1 /* Array translation routines
2 Copyright (C) 2002-2019 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
129 #define DIMENSION_FIELD 4
130 #define CAF_TOKEN_FIELD 5
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc
)
144 type
= TREE_TYPE (desc
);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
147 field
= TYPE_FIELDS (type
);
148 gcc_assert (DATA_FIELD
== 0);
150 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
152 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
157 /* This provides WRITE access to the data field.
159 TUPLES_P is true if we are generating tuples.
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
166 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
170 type
= TREE_TYPE (desc
);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
173 field
= TYPE_FIELDS (type
);
174 gcc_assert (DATA_FIELD
== 0);
176 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
178 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc
)
190 type
= TREE_TYPE (desc
);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
193 field
= TYPE_FIELDS (type
);
194 gcc_assert (DATA_FIELD
== 0);
196 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
198 return gfc_build_addr_expr (NULL_TREE
, t
);
202 gfc_conv_descriptor_offset (tree desc
)
207 type
= TREE_TYPE (desc
);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
210 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
211 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
213 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
214 desc
, field
, NULL_TREE
);
218 gfc_conv_descriptor_offset_get (tree desc
)
220 return gfc_conv_descriptor_offset (desc
);
224 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
227 tree t
= gfc_conv_descriptor_offset (desc
);
228 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
233 gfc_conv_descriptor_dtype (tree desc
)
238 type
= TREE_TYPE (desc
);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
241 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
242 gcc_assert (field
!= NULL_TREE
243 && TREE_TYPE (field
) == get_dtype_type_node ());
245 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
246 desc
, field
, NULL_TREE
);
250 gfc_conv_descriptor_span (tree desc
)
255 type
= TREE_TYPE (desc
);
256 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
258 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
259 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
261 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
262 desc
, field
, NULL_TREE
);
266 gfc_conv_descriptor_span_get (tree desc
)
268 return gfc_conv_descriptor_span (desc
);
272 gfc_conv_descriptor_span_set (stmtblock_t
*block
, tree desc
,
275 tree t
= gfc_conv_descriptor_span (desc
);
276 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
281 gfc_conv_descriptor_rank (tree desc
)
286 dtype
= gfc_conv_descriptor_dtype (desc
);
287 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)), GFC_DTYPE_RANK
);
288 gcc_assert (tmp
!= NULL_TREE
289 && TREE_TYPE (tmp
) == signed_char_type_node
);
290 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
291 dtype
, tmp
, NULL_TREE
);
295 /* Return the element length from the descriptor dtype field. */
298 gfc_conv_descriptor_elem_len (tree desc
)
303 dtype
= gfc_conv_descriptor_dtype (desc
);
304 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
306 gcc_assert (tmp
!= NULL_TREE
307 && TREE_TYPE (tmp
) == size_type_node
);
308 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
309 dtype
, tmp
, NULL_TREE
);
314 gfc_conv_descriptor_attribute (tree desc
)
319 dtype
= gfc_conv_descriptor_dtype (desc
);
320 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
321 GFC_DTYPE_ATTRIBUTE
);
322 gcc_assert (tmp
!= NULL_TREE
323 && TREE_TYPE (tmp
) == short_integer_type_node
);
324 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
325 dtype
, tmp
, NULL_TREE
);
330 gfc_get_descriptor_dimension (tree desc
)
334 type
= TREE_TYPE (desc
);
335 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
337 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
338 gcc_assert (field
!= NULL_TREE
339 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
340 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
342 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
343 desc
, field
, NULL_TREE
);
348 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
352 tmp
= gfc_get_descriptor_dimension (desc
);
354 return gfc_build_array_ref (tmp
, dim
, NULL
);
359 gfc_conv_descriptor_token (tree desc
)
364 type
= TREE_TYPE (desc
);
365 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
366 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
367 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
369 /* Should be a restricted pointer - except in the finalization wrapper. */
370 gcc_assert (field
!= NULL_TREE
371 && (TREE_TYPE (field
) == prvoid_type_node
372 || TREE_TYPE (field
) == pvoid_type_node
));
374 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
375 desc
, field
, NULL_TREE
);
380 gfc_conv_descriptor_stride (tree desc
, tree dim
)
385 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
386 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
387 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
388 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
390 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
391 tmp
, field
, NULL_TREE
);
396 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
398 tree type
= TREE_TYPE (desc
);
399 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
400 if (integer_zerop (dim
)
401 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
402 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
403 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
404 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
405 return gfc_index_one_node
;
407 return gfc_conv_descriptor_stride (desc
, dim
);
411 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
412 tree dim
, tree value
)
414 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
415 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
419 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
424 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
425 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
426 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
427 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
429 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
430 tmp
, field
, NULL_TREE
);
435 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
437 return gfc_conv_descriptor_lbound (desc
, dim
);
441 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
442 tree dim
, tree value
)
444 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
445 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
449 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
454 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
455 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
456 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
457 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
459 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
460 tmp
, field
, NULL_TREE
);
465 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
467 return gfc_conv_descriptor_ubound (desc
, dim
);
471 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
472 tree dim
, tree value
)
474 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
475 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
478 /* Build a null array descriptor constructor. */
481 gfc_build_null_descriptor (tree type
)
486 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
487 gcc_assert (DATA_FIELD
== 0);
488 field
= TYPE_FIELDS (type
);
490 /* Set a NULL data pointer. */
491 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
492 TREE_CONSTANT (tmp
) = 1;
493 /* All other fields are ignored. */
499 /* Modify a descriptor such that the lbound of a given dimension is the value
500 specified. This also updates ubound and offset accordingly. */
503 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
504 int dim
, tree new_lbound
)
506 tree offs
, ubound
, lbound
, stride
;
507 tree diff
, offs_diff
;
509 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
511 offs
= gfc_conv_descriptor_offset_get (desc
);
512 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
513 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
514 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
516 /* Get difference (new - old) by which to shift stuff. */
517 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
520 /* Shift ubound and offset accordingly. This has to be done before
521 updating the lbound, as they depend on the lbound expression! */
522 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
524 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
525 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
527 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
529 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
531 /* Finally set lbound to value we want. */
532 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
536 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
539 gfc_get_descriptor_offsets_for_info (const_tree desc_type
, tree
*data_off
,
540 tree
*dtype_off
, tree
*dim_off
,
541 tree
*dim_size
, tree
*stride_suboff
,
542 tree
*lower_suboff
, tree
*upper_suboff
)
547 type
= TYPE_MAIN_VARIANT (desc_type
);
548 field
= gfc_advance_chain (TYPE_FIELDS (type
), DATA_FIELD
);
549 *data_off
= byte_position (field
);
550 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
551 *dtype_off
= byte_position (field
);
552 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
553 *dim_off
= byte_position (field
);
554 type
= TREE_TYPE (TREE_TYPE (field
));
555 *dim_size
= TYPE_SIZE_UNIT (type
);
556 field
= gfc_advance_chain (TYPE_FIELDS (type
), STRIDE_SUBFIELD
);
557 *stride_suboff
= byte_position (field
);
558 field
= gfc_advance_chain (TYPE_FIELDS (type
), LBOUND_SUBFIELD
);
559 *lower_suboff
= byte_position (field
);
560 field
= gfc_advance_chain (TYPE_FIELDS (type
), UBOUND_SUBFIELD
);
561 *upper_suboff
= byte_position (field
);
565 /* Cleanup those #defines. */
571 #undef DIMENSION_FIELD
572 #undef CAF_TOKEN_FIELD
573 #undef STRIDE_SUBFIELD
574 #undef LBOUND_SUBFIELD
575 #undef UBOUND_SUBFIELD
578 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
579 flags & 1 = Main loop body.
580 flags & 2 = temp copy loop. */
583 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
585 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
586 ss
->info
->useflags
= flags
;
590 /* Free a gfc_ss chain. */
593 gfc_free_ss_chain (gfc_ss
* ss
)
597 while (ss
!= gfc_ss_terminator
)
599 gcc_assert (ss
!= NULL
);
608 free_ss_info (gfc_ss_info
*ss_info
)
613 if (ss_info
->refcount
> 0)
616 gcc_assert (ss_info
->refcount
== 0);
618 switch (ss_info
->type
)
621 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
622 if (ss_info
->data
.array
.subscript
[n
])
623 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
637 gfc_free_ss (gfc_ss
* ss
)
639 free_ss_info (ss
->info
);
644 /* Creates and initializes an array type gfc_ss struct. */
647 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
650 gfc_ss_info
*ss_info
;
653 ss_info
= gfc_get_ss_info ();
655 ss_info
->type
= type
;
656 ss_info
->expr
= expr
;
662 for (i
= 0; i
< ss
->dimen
; i
++)
669 /* Creates and initializes a temporary type gfc_ss struct. */
672 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
675 gfc_ss_info
*ss_info
;
678 ss_info
= gfc_get_ss_info ();
680 ss_info
->type
= GFC_SS_TEMP
;
681 ss_info
->string_length
= string_length
;
682 ss_info
->data
.temp
.type
= type
;
686 ss
->next
= gfc_ss_terminator
;
688 for (i
= 0; i
< ss
->dimen
; i
++)
695 /* Creates and initializes a scalar type gfc_ss struct. */
698 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
701 gfc_ss_info
*ss_info
;
703 ss_info
= gfc_get_ss_info ();
705 ss_info
->type
= GFC_SS_SCALAR
;
706 ss_info
->expr
= expr
;
716 /* Free all the SS associated with a loop. */
719 gfc_cleanup_loop (gfc_loopinfo
* loop
)
721 gfc_loopinfo
*loop_next
, **ploop
;
726 while (ss
!= gfc_ss_terminator
)
728 gcc_assert (ss
!= NULL
);
729 next
= ss
->loop_chain
;
734 /* Remove reference to self in the parent loop. */
736 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
743 /* Free non-freed nested loops. */
744 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
746 loop_next
= loop
->next
;
747 gfc_cleanup_loop (loop
);
754 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
758 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
762 if (ss
->info
->type
== GFC_SS_SCALAR
763 || ss
->info
->type
== GFC_SS_REFERENCE
764 || ss
->info
->type
== GFC_SS_TEMP
)
767 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
768 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
769 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
774 /* Associate a SS chain with a loop. */
777 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
780 gfc_loopinfo
*nested_loop
;
782 if (head
== gfc_ss_terminator
)
785 set_ss_loop (head
, loop
);
788 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
792 nested_loop
= ss
->nested_ss
->loop
;
794 /* More than one ss can belong to the same loop. Hence, we add the
795 loop to the chain only if it is different from the previously
796 added one, to avoid duplicate nested loops. */
797 if (nested_loop
!= loop
->nested
)
799 gcc_assert (nested_loop
->parent
== NULL
);
800 nested_loop
->parent
= loop
;
802 gcc_assert (nested_loop
->next
== NULL
);
803 nested_loop
->next
= loop
->nested
;
804 loop
->nested
= nested_loop
;
807 gcc_assert (nested_loop
->parent
== loop
);
810 if (ss
->next
== gfc_ss_terminator
)
811 ss
->loop_chain
= loop
->ss
;
813 ss
->loop_chain
= ss
->next
;
815 gcc_assert (ss
== gfc_ss_terminator
);
820 /* Returns true if the expression is an array pointer. */
823 is_pointer_array (tree expr
)
825 if (expr
== NULL_TREE
826 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr
))
827 || GFC_CLASS_TYPE_P (TREE_TYPE (expr
)))
830 if (TREE_CODE (expr
) == VAR_DECL
831 && GFC_DECL_PTR_ARRAY_P (expr
))
834 if (TREE_CODE (expr
) == PARM_DECL
835 && GFC_DECL_PTR_ARRAY_P (expr
))
838 if (TREE_CODE (expr
) == INDIRECT_REF
839 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 0)))
842 /* The field declaration is marked as an pointer array. */
843 if (TREE_CODE (expr
) == COMPONENT_REF
844 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 1))
845 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr
, 1))))
852 /* If the symbol or expression reference a CFI descriptor, return the
853 pointer to the converted gfc descriptor. If an array reference is
854 present as the last argument, check that it is the one applied to
855 the CFI descriptor in the expression. Note that the CFI object is
856 always the symbol in the expression! */
859 get_CFI_desc (gfc_symbol
*sym
, gfc_expr
*expr
,
860 tree
*desc
, gfc_array_ref
*ar
)
864 if (!is_CFI_desc (sym
, expr
))
869 if (!(expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
870 || (&expr
->ref
->u
.ar
!= ar
))
875 tmp
= expr
->symtree
->n
.sym
->backend_decl
;
877 tmp
= sym
->backend_decl
;
879 if (tmp
&& DECL_LANG_SPECIFIC (tmp
))
880 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
887 /* Return the span of an array. */
890 gfc_get_array_span (tree desc
, gfc_expr
*expr
)
894 if (is_pointer_array (desc
) || get_CFI_desc (NULL
, expr
, &desc
, NULL
))
896 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
897 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
899 /* This will have the span field set. */
900 tmp
= gfc_conv_descriptor_span_get (desc
);
902 else if (TREE_CODE (desc
) == COMPONENT_REF
903 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
904 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
906 /* The descriptor is a class _data field and so use the vtable
907 size for the receiving span field. */
908 tmp
= gfc_get_vptr_from_expr (desc
);
909 tmp
= gfc_vptr_size_get (tmp
);
911 else if (expr
&& expr
->expr_type
== EXPR_VARIABLE
912 && expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
913 && expr
->ref
->type
== REF_COMPONENT
914 && expr
->ref
->next
->type
== REF_ARRAY
915 && expr
->ref
->next
->next
== NULL
916 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.dimension
)
918 /* Dummys come in sometimes with the descriptor detached from
919 the class field or declaration. */
920 tmp
= gfc_class_vptr_get (expr
->symtree
->n
.sym
->backend_decl
);
921 tmp
= gfc_vptr_size_get (tmp
);
925 /* If none of the fancy stuff works, the span is the element
926 size of the array. Attempt to deal with unbounded character
927 types if possible. Otherwise, return NULL_TREE. */
928 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
929 if (tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
930 && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) == NULL_TREE
931 || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)))))
933 if (expr
->expr_type
== EXPR_VARIABLE
934 && expr
->ts
.type
== BT_CHARACTER
)
935 tmp
= fold_convert (gfc_array_index_type
,
936 gfc_get_expr_charlen (expr
));
941 tmp
= fold_convert (gfc_array_index_type
,
942 size_in_bytes (tmp
));
948 /* Generate an initializer for a static pointer or allocatable array. */
951 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
955 gcc_assert (TREE_STATIC (sym
->backend_decl
));
956 /* Just zero the data member. */
957 type
= TREE_TYPE (sym
->backend_decl
);
958 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
962 /* If the bounds of SE's loop have not yet been set, see if they can be
963 determined from array spec AS, which is the array spec of a called
964 function. MAPPING maps the callee's dummy arguments to the values
965 that the caller is passing. Add any initialization and finalization
969 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
970 gfc_se
* se
, gfc_array_spec
* as
)
972 int n
, dim
, total_dim
;
981 if (!as
|| as
->type
!= AS_EXPLICIT
)
984 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
986 total_dim
+= ss
->loop
->dimen
;
987 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
989 /* The bound is known, nothing to do. */
990 if (ss
->loop
->to
[n
] != NULL_TREE
)
994 gcc_assert (dim
< as
->rank
);
995 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
997 /* Evaluate the lower bound. */
998 gfc_init_se (&tmpse
, NULL
);
999 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
1000 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
1001 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
1002 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
1004 /* ...and the upper bound. */
1005 gfc_init_se (&tmpse
, NULL
);
1006 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
1007 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
1008 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
1009 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
1011 /* Set the upper bound of the loop to UPPER - LOWER. */
1012 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1013 gfc_array_index_type
, upper
, lower
);
1014 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1015 ss
->loop
->to
[n
] = tmp
;
1019 gcc_assert (total_dim
== as
->rank
);
1023 /* Generate code to allocate an array temporary, or create a variable to
1024 hold the data. If size is NULL, zero the descriptor so that the
1025 callee will allocate the array. If DEALLOC is true, also generate code to
1026 free the array afterwards.
1028 If INITIAL is not NULL, it is packed using internal_pack and the result used
1029 as data instead of allocating a fresh, unitialized area of memory.
1031 Initialization code is added to PRE and finalization code to POST.
1032 DYNAMIC is true if the caller may want to extend the array later
1033 using realloc. This prevents us from putting the array on the stack. */
1036 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
1037 gfc_array_info
* info
, tree size
, tree nelem
,
1038 tree initial
, bool dynamic
, bool dealloc
)
1044 desc
= info
->descriptor
;
1045 info
->offset
= gfc_index_zero_node
;
1046 if (size
== NULL_TREE
|| integer_zerop (size
))
1048 /* A callee allocated array. */
1049 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
1054 /* Allocate the temporary. */
1055 onstack
= !dynamic
&& initial
== NULL_TREE
1056 && (flag_stack_arrays
1057 || gfc_can_put_var_on_stack (size
));
1061 /* Make a temporary variable to hold the data. */
1062 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
1063 nelem
, gfc_index_one_node
);
1064 tmp
= gfc_evaluate_now (tmp
, pre
);
1065 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1067 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
1069 tmp
= gfc_create_var (tmp
, "A");
1070 /* If we're here only because of -fstack-arrays we have to
1071 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1072 if (!gfc_can_put_var_on_stack (size
))
1073 gfc_add_expr_to_block (pre
,
1074 fold_build1_loc (input_location
,
1075 DECL_EXPR
, TREE_TYPE (tmp
),
1077 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1078 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1082 /* Allocate memory to hold the data or call internal_pack. */
1083 if (initial
== NULL_TREE
)
1085 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1086 tmp
= gfc_evaluate_now (tmp
, pre
);
1093 stmtblock_t do_copying
;
1095 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1096 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1097 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1098 tmp
= gfc_get_element_type (tmp
);
1099 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1100 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1102 tmp
= build_call_expr_loc (input_location
,
1103 gfor_fndecl_in_pack
, 1, initial
);
1104 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1105 gfc_add_modify (pre
, packed
, tmp
);
1107 tmp
= build_fold_indirect_ref_loc (input_location
,
1109 source_data
= gfc_conv_descriptor_data_get (tmp
);
1111 /* internal_pack may return source->data without any allocation
1112 or copying if it is already packed. If that's the case, we
1113 need to allocate and copy manually. */
1115 gfc_start_block (&do_copying
);
1116 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1117 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1118 gfc_add_modify (&do_copying
, packed
, tmp
);
1119 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1120 gfc_add_expr_to_block (&do_copying
, tmp
);
1122 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1123 logical_type_node
, packed
,
1125 tmp
= gfc_finish_block (&do_copying
);
1126 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1127 build_empty_stmt (input_location
));
1128 gfc_add_expr_to_block (pre
, tmp
);
1130 tmp
= fold_convert (pvoid_type_node
, packed
);
1133 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1136 info
->data
= gfc_conv_descriptor_data_get (desc
);
1138 /* The offset is zero because we create temporaries with a zero
1140 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1142 if (dealloc
&& !onstack
)
1144 /* Free the temporary. */
1145 tmp
= gfc_conv_descriptor_data_get (desc
);
1146 tmp
= gfc_call_free (tmp
);
1147 gfc_add_expr_to_block (post
, tmp
);
1152 /* Get the scalarizer array dimension corresponding to actual array dimension
1155 For example, if SS represents the array ref a(1,:,:,1), it is a
1156 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1157 and 1 for ARRAY_DIM=2.
1158 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1159 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1161 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1162 array. If called on the inner ss, the result would be respectively 0,1,2 for
1163 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1164 for ARRAY_DIM=1,2. */
1167 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1174 for (; ss
; ss
= ss
->parent
)
1175 for (n
= 0; n
< ss
->dimen
; n
++)
1176 if (ss
->dim
[n
] < array_dim
)
1179 return array_ref_dim
;
1184 innermost_ss (gfc_ss
*ss
)
1186 while (ss
->nested_ss
!= NULL
)
1194 /* Get the array reference dimension corresponding to the given loop dimension.
1195 It is different from the true array dimension given by the dim array in
1196 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1197 It is different from the loop dimension in the case of a transposed array.
1201 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1203 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1208 /* Generate code to create and initialize the descriptor for a temporary
1209 array. This is used for both temporaries needed by the scalarizer, and
1210 functions returning arrays. Adjusts the loop variables to be
1211 zero-based, and calculates the loop bounds for callee allocated arrays.
1212 Allocate the array unless it's callee allocated (we have a callee
1213 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1214 NULL_TREE for any n). Also fills in the descriptor, data and offset
1215 fields of info if known. Returns the size of the array, or NULL for a
1216 callee allocated array.
1218 'eltype' == NULL signals that the temporary should be a class object.
1219 The 'initial' expression is used to obtain the size of the dynamic
1220 type; otherwise the allocation and initialization proceeds as for any
1223 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1224 gfc_trans_allocate_array_storage. */
1227 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1228 tree eltype
, tree initial
, bool dynamic
,
1229 bool dealloc
, bool callee_alloc
, locus
* where
)
1233 gfc_array_info
*info
;
1234 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1243 tree class_expr
= NULL_TREE
;
1244 int n
, dim
, tmp_dim
;
1247 /* This signals a class array for which we need the size of the
1248 dynamic type. Generate an eltype and then the class expression. */
1249 if (eltype
== NULL_TREE
&& initial
)
1251 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1252 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1253 eltype
= TREE_TYPE (class_expr
);
1254 eltype
= gfc_get_element_type (eltype
);
1255 /* Obtain the structure (class) expression. */
1256 class_expr
= TREE_OPERAND (class_expr
, 0);
1257 gcc_assert (class_expr
);
1260 memset (from
, 0, sizeof (from
));
1261 memset (to
, 0, sizeof (to
));
1263 info
= &ss
->info
->data
.array
;
1265 gcc_assert (ss
->dimen
> 0);
1266 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1268 if (warn_array_temporaries
&& where
)
1269 gfc_warning (OPT_Warray_temporaries
,
1270 "Creating array temporary at %L", where
);
1272 /* Set the lower bound to zero. */
1273 for (s
= ss
; s
; s
= s
->parent
)
1277 total_dim
+= loop
->dimen
;
1278 for (n
= 0; n
< loop
->dimen
; n
++)
1282 /* Callee allocated arrays may not have a known bound yet. */
1284 loop
->to
[n
] = gfc_evaluate_now (
1285 fold_build2_loc (input_location
, MINUS_EXPR
,
1286 gfc_array_index_type
,
1287 loop
->to
[n
], loop
->from
[n
]),
1289 loop
->from
[n
] = gfc_index_zero_node
;
1291 /* We have just changed the loop bounds, we must clear the
1292 corresponding specloop, so that delta calculation is not skipped
1293 later in gfc_set_delta. */
1294 loop
->specloop
[n
] = NULL
;
1296 /* We are constructing the temporary's descriptor based on the loop
1297 dimensions. As the dimensions may be accessed in arbitrary order
1298 (think of transpose) the size taken from the n'th loop may not map
1299 to the n'th dimension of the array. We need to reconstruct loop
1300 infos in the right order before using it to set the descriptor
1302 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1303 from
[tmp_dim
] = loop
->from
[n
];
1304 to
[tmp_dim
] = loop
->to
[n
];
1306 info
->delta
[dim
] = gfc_index_zero_node
;
1307 info
->start
[dim
] = gfc_index_zero_node
;
1308 info
->end
[dim
] = gfc_index_zero_node
;
1309 info
->stride
[dim
] = gfc_index_one_node
;
1313 /* Initialize the descriptor. */
1315 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1316 GFC_ARRAY_UNKNOWN
, true);
1317 desc
= gfc_create_var (type
, "atmp");
1318 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1320 info
->descriptor
= desc
;
1321 size
= gfc_index_one_node
;
1323 /* Emit a DECL_EXPR for the variable sized array type in
1324 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1325 sizes works correctly. */
1326 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1327 if (! TYPE_NAME (arraytype
))
1328 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1329 NULL_TREE
, arraytype
);
1330 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1331 arraytype
, TYPE_NAME (arraytype
)));
1333 /* Fill in the array dtype. */
1334 tmp
= gfc_conv_descriptor_dtype (desc
);
1335 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1338 Fill in the bounds and stride. This is a packed array, so:
1341 for (n = 0; n < rank; n++)
1344 delta = ubound[n] + 1 - lbound[n];
1345 size = size * delta;
1347 size = size * sizeof(element);
1350 or_expr
= NULL_TREE
;
1352 /* If there is at least one null loop->to[n], it is a callee allocated
1354 for (n
= 0; n
< total_dim
; n
++)
1355 if (to
[n
] == NULL_TREE
)
1361 if (size
== NULL_TREE
)
1362 for (s
= ss
; s
; s
= s
->parent
)
1363 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1365 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1367 /* For a callee allocated array express the loop bounds in terms
1368 of the descriptor fields. */
1369 tmp
= fold_build2_loc (input_location
,
1370 MINUS_EXPR
, gfc_array_index_type
,
1371 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1372 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1373 s
->loop
->to
[n
] = tmp
;
1377 for (n
= 0; n
< total_dim
; n
++)
1379 /* Store the stride and bound components in the descriptor. */
1380 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1382 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1383 gfc_index_zero_node
);
1385 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1387 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1388 gfc_array_index_type
,
1389 to
[n
], gfc_index_one_node
);
1391 /* Check whether the size for this dimension is negative. */
1392 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1393 tmp
, gfc_index_zero_node
);
1394 cond
= gfc_evaluate_now (cond
, pre
);
1399 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1400 logical_type_node
, or_expr
, cond
);
1402 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1403 gfc_array_index_type
, size
, tmp
);
1404 size
= gfc_evaluate_now (size
, pre
);
1408 if (class_expr
== NULL_TREE
)
1409 elemsize
= fold_convert (gfc_array_index_type
,
1410 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1412 elemsize
= gfc_class_vtab_size_get (class_expr
);
1414 /* Get the size of the array. */
1415 if (size
&& !callee_alloc
)
1417 /* If or_expr is true, then the extent in at least one
1418 dimension is zero and the size is set to zero. */
1419 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1420 or_expr
, gfc_index_zero_node
, size
);
1423 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1433 tmp
= fold_convert (gfc_array_index_type
, elemsize
);
1434 gfc_conv_descriptor_span_set (pre
, desc
, tmp
);
1436 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1442 if (ss
->dimen
> ss
->loop
->temp_dim
)
1443 ss
->loop
->temp_dim
= ss
->dimen
;
1449 /* Return the number of iterations in a loop that starts at START,
1450 ends at END, and has step STEP. */
1453 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1458 type
= TREE_TYPE (step
);
1459 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1460 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1461 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1462 build_int_cst (type
, 1));
1463 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1464 build_int_cst (type
, 0));
1465 return fold_convert (gfc_array_index_type
, tmp
);
1469 /* Extend the data in array DESC by EXTRA elements. */
1472 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1479 if (integer_zerop (extra
))
1482 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1484 /* Add EXTRA to the upper bound. */
1485 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1487 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1489 /* Get the value of the current data pointer. */
1490 arg0
= gfc_conv_descriptor_data_get (desc
);
1492 /* Calculate the new array size. */
1493 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1494 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1495 ubound
, gfc_index_one_node
);
1496 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1497 fold_convert (size_type_node
, tmp
),
1498 fold_convert (size_type_node
, size
));
1500 /* Call the realloc() function. */
1501 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1502 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1506 /* Return true if the bounds of iterator I can only be determined
1510 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1512 return (i
->start
->expr_type
!= EXPR_CONSTANT
1513 || i
->end
->expr_type
!= EXPR_CONSTANT
1514 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1518 /* Split the size of constructor element EXPR into the sum of two terms,
1519 one of which can be determined at compile time and one of which must
1520 be calculated at run time. Set *SIZE to the former and return true
1521 if the latter might be nonzero. */
1524 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1526 if (expr
->expr_type
== EXPR_ARRAY
)
1527 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1528 else if (expr
->rank
> 0)
1530 /* Calculate everything at run time. */
1531 mpz_set_ui (*size
, 0);
1536 /* A single element. */
1537 mpz_set_ui (*size
, 1);
1543 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1544 of array constructor C. */
1547 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1555 mpz_set_ui (*size
, 0);
1560 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1563 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1567 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1570 /* Multiply the static part of the element size by the
1571 number of iterations. */
1572 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1573 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1574 mpz_add_ui (val
, val
, 1);
1575 if (mpz_sgn (val
) > 0)
1576 mpz_mul (len
, len
, val
);
1578 mpz_set_ui (len
, 0);
1580 mpz_add (*size
, *size
, len
);
1589 /* Make sure offset is a variable. */
1592 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1595 /* We should have already created the offset variable. We cannot
1596 create it here because we may be in an inner scope. */
1597 gcc_assert (*offsetvar
!= NULL_TREE
);
1598 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1599 *poffset
= *offsetvar
;
1600 TREE_USED (*offsetvar
) = 1;
1604 /* Variables needed for bounds-checking. */
1605 static bool first_len
;
1606 static tree first_len_val
;
1607 static bool typespec_chararray_ctor
;
1610 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1611 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1615 gfc_conv_expr (se
, expr
);
1617 /* Store the value. */
1618 tmp
= build_fold_indirect_ref_loc (input_location
,
1619 gfc_conv_descriptor_data_get (desc
));
1620 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1622 if (expr
->ts
.type
== BT_CHARACTER
)
1624 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1627 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1628 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1629 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1630 TREE_TYPE (esize
), esize
,
1631 build_int_cst (TREE_TYPE (esize
),
1632 gfc_character_kinds
[i
].bit_size
/ 8));
1634 gfc_conv_string_parameter (se
);
1635 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1637 /* The temporary is an array of pointers. */
1638 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1639 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1643 /* The temporary is an array of string values. */
1644 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1645 /* We know the temporary and the value will be the same length,
1646 so can use memcpy. */
1647 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1648 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1650 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1654 gfc_add_modify (&se
->pre
, first_len_val
,
1655 fold_convert (TREE_TYPE (first_len_val
),
1656 se
->string_length
));
1661 /* Verify that all constructor elements are of the same
1663 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1665 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1666 logical_type_node
, first_len_val
,
1668 gfc_trans_runtime_check
1669 (true, false, cond
, &se
->pre
, &expr
->where
,
1670 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1671 fold_convert (long_integer_type_node
, first_len_val
),
1672 fold_convert (long_integer_type_node
, se
->string_length
));
1676 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1677 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1679 /* Assignment of a CLASS array constructor to a derived type array. */
1680 if (expr
->expr_type
== EXPR_FUNCTION
)
1681 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1682 se
->expr
= gfc_class_data_get (se
->expr
);
1683 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1684 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1685 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1689 /* TODO: Should the frontend already have done this conversion? */
1690 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1691 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1694 gfc_add_block_to_block (pblock
, &se
->pre
);
1695 gfc_add_block_to_block (pblock
, &se
->post
);
1699 /* Add the contents of an array to the constructor. DYNAMIC is as for
1700 gfc_trans_array_constructor_value. */
1703 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1704 tree type ATTRIBUTE_UNUSED
,
1705 tree desc
, gfc_expr
* expr
,
1706 tree
* poffset
, tree
* offsetvar
,
1717 /* We need this to be a variable so we can increment it. */
1718 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1720 gfc_init_se (&se
, NULL
);
1722 /* Walk the array expression. */
1723 ss
= gfc_walk_expr (expr
);
1724 gcc_assert (ss
!= gfc_ss_terminator
);
1726 /* Initialize the scalarizer. */
1727 gfc_init_loopinfo (&loop
);
1728 gfc_add_ss_to_loop (&loop
, ss
);
1730 /* Initialize the loop. */
1731 gfc_conv_ss_startstride (&loop
);
1732 gfc_conv_loop_setup (&loop
, &expr
->where
);
1734 /* Make sure the constructed array has room for the new data. */
1737 /* Set SIZE to the total number of elements in the subarray. */
1738 size
= gfc_index_one_node
;
1739 for (n
= 0; n
< loop
.dimen
; n
++)
1741 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1742 gfc_index_one_node
);
1743 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1744 gfc_array_index_type
, size
, tmp
);
1747 /* Grow the constructed array by SIZE elements. */
1748 gfc_grow_array (&loop
.pre
, desc
, size
);
1751 /* Make the loop body. */
1752 gfc_mark_ss_chain_used (ss
, 1);
1753 gfc_start_scalarized_body (&loop
, &body
);
1754 gfc_copy_loopinfo_to_se (&se
, &loop
);
1757 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1758 gcc_assert (se
.ss
== gfc_ss_terminator
);
1760 /* Increment the offset. */
1761 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1762 *poffset
, gfc_index_one_node
);
1763 gfc_add_modify (&body
, *poffset
, tmp
);
1765 /* Finish the loop. */
1766 gfc_trans_scalarizing_loops (&loop
, &body
);
1767 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1768 tmp
= gfc_finish_block (&loop
.pre
);
1769 gfc_add_expr_to_block (pblock
, tmp
);
1771 gfc_cleanup_loop (&loop
);
1775 /* Assign the values to the elements of an array constructor. DYNAMIC
1776 is true if descriptor DESC only contains enough data for the static
1777 size calculated by gfc_get_array_constructor_size. When true, memory
1778 for the dynamic parts must be allocated using realloc. */
1781 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1782 tree desc
, gfc_constructor_base base
,
1783 tree
* poffset
, tree
* offsetvar
,
1787 tree start
= NULL_TREE
;
1788 tree end
= NULL_TREE
;
1789 tree step
= NULL_TREE
;
1795 tree shadow_loopvar
= NULL_TREE
;
1796 gfc_saved_var saved_loopvar
;
1799 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1801 /* If this is an iterator or an array, the offset must be a variable. */
1802 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1803 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1805 /* Shadowing the iterator avoids changing its value and saves us from
1806 keeping track of it. Further, it makes sure that there's always a
1807 backend-decl for the symbol, even if there wasn't one before,
1808 e.g. in the case of an iterator that appears in a specification
1809 expression in an interface mapping. */
1815 /* Evaluate loop bounds before substituting the loop variable
1816 in case they depend on it. Such a case is invalid, but it is
1817 not more expensive to do the right thing here.
1819 gfc_init_se (&se
, NULL
);
1820 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1821 gfc_add_block_to_block (pblock
, &se
.pre
);
1822 start
= gfc_evaluate_now (se
.expr
, pblock
);
1824 gfc_init_se (&se
, NULL
);
1825 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1826 gfc_add_block_to_block (pblock
, &se
.pre
);
1827 end
= gfc_evaluate_now (se
.expr
, pblock
);
1829 gfc_init_se (&se
, NULL
);
1830 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1831 gfc_add_block_to_block (pblock
, &se
.pre
);
1832 step
= gfc_evaluate_now (se
.expr
, pblock
);
1834 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1835 type
= gfc_typenode_for_spec (&sym
->ts
);
1837 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1838 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1841 gfc_start_block (&body
);
1843 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1845 /* Array constructors can be nested. */
1846 gfc_trans_array_constructor_value (&body
, type
, desc
,
1847 c
->expr
->value
.constructor
,
1848 poffset
, offsetvar
, dynamic
);
1850 else if (c
->expr
->rank
> 0)
1852 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1853 poffset
, offsetvar
, dynamic
);
1857 /* This code really upsets the gimplifier so don't bother for now. */
1864 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1866 p
= gfc_constructor_next (p
);
1871 /* Scalar values. */
1872 gfc_init_se (&se
, NULL
);
1873 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1876 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1877 gfc_array_index_type
,
1878 *poffset
, gfc_index_one_node
);
1882 /* Collect multiple scalar constants into a constructor. */
1883 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1887 HOST_WIDE_INT idx
= 0;
1890 /* Count the number of consecutive scalar constants. */
1891 while (p
&& !(p
->iterator
1892 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1894 gfc_init_se (&se
, NULL
);
1895 gfc_conv_constant (&se
, p
->expr
);
1897 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1898 se
.expr
= fold_convert (type
, se
.expr
);
1899 /* For constant character array constructors we build
1900 an array of pointers. */
1901 else if (POINTER_TYPE_P (type
))
1902 se
.expr
= gfc_build_addr_expr
1903 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1906 CONSTRUCTOR_APPEND_ELT (v
,
1907 build_int_cst (gfc_array_index_type
,
1911 p
= gfc_constructor_next (p
);
1914 bound
= size_int (n
- 1);
1915 /* Create an array type to hold them. */
1916 tmptype
= build_range_type (gfc_array_index_type
,
1917 gfc_index_zero_node
, bound
);
1918 tmptype
= build_array_type (type
, tmptype
);
1920 init
= build_constructor (tmptype
, v
);
1921 TREE_CONSTANT (init
) = 1;
1922 TREE_STATIC (init
) = 1;
1923 /* Create a static variable to hold the data. */
1924 tmp
= gfc_create_var (tmptype
, "data");
1925 TREE_STATIC (tmp
) = 1;
1926 TREE_CONSTANT (tmp
) = 1;
1927 TREE_READONLY (tmp
) = 1;
1928 DECL_INITIAL (tmp
) = init
;
1931 /* Use BUILTIN_MEMCPY to assign the values. */
1932 tmp
= gfc_conv_descriptor_data_get (desc
);
1933 tmp
= build_fold_indirect_ref_loc (input_location
,
1935 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1936 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1937 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1939 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1940 bound
= build_int_cst (size_type_node
, n
* size
);
1941 tmp
= build_call_expr_loc (input_location
,
1942 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1943 3, tmp
, init
, bound
);
1944 gfc_add_expr_to_block (&body
, tmp
);
1946 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1947 gfc_array_index_type
, *poffset
,
1948 build_int_cst (gfc_array_index_type
, n
));
1950 if (!INTEGER_CST_P (*poffset
))
1952 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1953 *poffset
= *offsetvar
;
1957 /* The frontend should already have done any expansions
1961 /* Pass the code as is. */
1962 tmp
= gfc_finish_block (&body
);
1963 gfc_add_expr_to_block (pblock
, tmp
);
1967 /* Build the implied do-loop. */
1968 stmtblock_t implied_do_block
;
1974 loopbody
= gfc_finish_block (&body
);
1976 /* Create a new block that holds the implied-do loop. A temporary
1977 loop-variable is used. */
1978 gfc_start_block(&implied_do_block
);
1980 /* Initialize the loop. */
1981 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1983 /* If this array expands dynamically, and the number of iterations
1984 is not constant, we won't have allocated space for the static
1985 part of C->EXPR's size. Do that now. */
1986 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1988 /* Get the number of iterations. */
1989 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1991 /* Get the static part of C->EXPR's size. */
1992 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1993 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1995 /* Grow the array by TMP * TMP2 elements. */
1996 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1997 gfc_array_index_type
, tmp
, tmp2
);
1998 gfc_grow_array (&implied_do_block
, desc
, tmp
);
2001 /* Generate the loop body. */
2002 exit_label
= gfc_build_label_decl (NULL_TREE
);
2003 gfc_start_block (&body
);
2005 /* Generate the exit condition. Depending on the sign of
2006 the step variable we have to generate the correct
2008 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2009 step
, build_int_cst (TREE_TYPE (step
), 0));
2010 cond
= fold_build3_loc (input_location
, COND_EXPR
,
2011 logical_type_node
, tmp
,
2012 fold_build2_loc (input_location
, GT_EXPR
,
2013 logical_type_node
, shadow_loopvar
, end
),
2014 fold_build2_loc (input_location
, LT_EXPR
,
2015 logical_type_node
, shadow_loopvar
, end
));
2016 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2017 TREE_USED (exit_label
) = 1;
2018 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2019 build_empty_stmt (input_location
));
2020 gfc_add_expr_to_block (&body
, tmp
);
2022 /* The main loop body. */
2023 gfc_add_expr_to_block (&body
, loopbody
);
2025 /* Increase loop variable by step. */
2026 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2027 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
2029 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
2031 /* Finish the loop. */
2032 tmp
= gfc_finish_block (&body
);
2033 tmp
= build1_v (LOOP_EXPR
, tmp
);
2034 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2036 /* Add the exit label. */
2037 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2038 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2040 /* Finish the implied-do loop. */
2041 tmp
= gfc_finish_block(&implied_do_block
);
2042 gfc_add_expr_to_block(pblock
, tmp
);
2044 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
2051 /* The array constructor code can create a string length with an operand
2052 in the form of a temporary variable. This variable will retain its
2053 context (current_function_decl). If we store this length tree in a
2054 gfc_charlen structure which is shared by a variable in another
2055 context, the resulting gfc_charlen structure with a variable in a
2056 different context, we could trip the assertion in expand_expr_real_1
2057 when it sees that a variable has been created in one context and
2058 referenced in another.
2060 If this might be the case, we create a new gfc_charlen structure and
2061 link it into the current namespace. */
2064 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
2068 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
2071 (*clp
)->backend_decl
= len
;
2074 /* A catch-all to obtain the string length for anything that is not
2075 a substring of non-constant length, a constant, array or variable. */
2078 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2082 /* Don't bother if we already know the length is a constant. */
2083 if (*len
&& INTEGER_CST_P (*len
))
2086 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2087 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2090 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2091 *len
= e
->ts
.u
.cl
->backend_decl
;
2095 /* Otherwise, be brutal even if inefficient. */
2096 gfc_init_se (&se
, NULL
);
2098 /* No function call, in case of side effects. */
2099 se
.no_function_call
= 1;
2101 gfc_conv_expr (&se
, e
);
2103 gfc_conv_expr_descriptor (&se
, e
);
2105 /* Fix the value. */
2106 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2108 gfc_add_block_to_block (block
, &se
.pre
);
2109 gfc_add_block_to_block (block
, &se
.post
);
2111 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2116 /* Figure out the string length of a variable reference expression.
2117 Used by get_array_ctor_strlen. */
2120 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2126 /* Don't bother if we already know the length is a constant. */
2127 if (*len
&& INTEGER_CST_P (*len
))
2130 ts
= &expr
->symtree
->n
.sym
->ts
;
2131 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2136 /* Array references don't change the string length. */
2138 get_array_ctor_all_strlen (block
, expr
, len
);
2142 /* Use the length of the component. */
2143 ts
= &ref
->u
.c
.component
->ts
;
2147 if (ref
->u
.ss
.end
== NULL
2148 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2149 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2151 /* Note that this might evaluate expr. */
2152 get_array_ctor_all_strlen (block
, expr
, len
);
2155 mpz_init_set_ui (char_len
, 1);
2156 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2157 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2158 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2159 mpz_clear (char_len
);
2170 *len
= ts
->u
.cl
->backend_decl
;
2174 /* Figure out the string length of a character array constructor.
2175 If len is NULL, don't calculate the length; this happens for recursive calls
2176 when a sub-array-constructor is an element but not at the first position,
2177 so when we're not interested in the length.
2178 Returns TRUE if all elements are character constants. */
2181 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2188 if (gfc_constructor_first (base
) == NULL
)
2191 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2195 /* Loop over all constructor elements to find out is_const, but in len we
2196 want to store the length of the first, not the last, element. We can
2197 of course exit the loop as soon as is_const is found to be false. */
2198 for (c
= gfc_constructor_first (base
);
2199 c
&& is_const
; c
= gfc_constructor_next (c
))
2201 switch (c
->expr
->expr_type
)
2204 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2205 *len
= build_int_cstu (gfc_charlen_type_node
,
2206 c
->expr
->value
.character
.length
);
2210 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2217 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2223 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2227 /* After the first iteration, we don't want the length modified. */
2234 /* Check whether the array constructor C consists entirely of constant
2235 elements, and if so returns the number of those elements, otherwise
2236 return zero. Note, an empty or NULL array constructor returns zero. */
2238 unsigned HOST_WIDE_INT
2239 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2241 unsigned HOST_WIDE_INT nelem
= 0;
2243 gfc_constructor
*c
= gfc_constructor_first (base
);
2247 || c
->expr
->rank
> 0
2248 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2250 c
= gfc_constructor_next (c
);
2257 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2258 and the tree type of it's elements, TYPE, return a static constant
2259 variable that is compile-time initialized. */
2262 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2264 tree tmptype
, init
, tmp
;
2265 HOST_WIDE_INT nelem
;
2270 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2272 /* First traverse the constructor list, converting the constants
2273 to tree to build an initializer. */
2275 c
= gfc_constructor_first (expr
->value
.constructor
);
2278 gfc_init_se (&se
, NULL
);
2279 gfc_conv_constant (&se
, c
->expr
);
2280 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2281 se
.expr
= fold_convert (type
, se
.expr
);
2282 else if (POINTER_TYPE_P (type
))
2283 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2285 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2287 c
= gfc_constructor_next (c
);
2291 /* Next determine the tree type for the array. We use the gfortran
2292 front-end's gfc_get_nodesc_array_type in order to create a suitable
2293 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2295 memset (&as
, 0, sizeof (gfc_array_spec
));
2297 as
.rank
= expr
->rank
;
2298 as
.type
= AS_EXPLICIT
;
2301 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2302 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2306 for (i
= 0; i
< expr
->rank
; i
++)
2308 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2309 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2310 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2314 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2316 /* as is not needed anymore. */
2317 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2319 gfc_free_expr (as
.lower
[i
]);
2320 gfc_free_expr (as
.upper
[i
]);
2323 init
= build_constructor (tmptype
, v
);
2325 TREE_CONSTANT (init
) = 1;
2326 TREE_STATIC (init
) = 1;
2328 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2330 DECL_ARTIFICIAL (tmp
) = 1;
2331 DECL_IGNORED_P (tmp
) = 1;
2332 TREE_STATIC (tmp
) = 1;
2333 TREE_CONSTANT (tmp
) = 1;
2334 TREE_READONLY (tmp
) = 1;
2335 DECL_INITIAL (tmp
) = init
;
2342 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2343 This mostly initializes the scalarizer state info structure with the
2344 appropriate values to directly use the array created by the function
2345 gfc_build_constant_array_constructor. */
2348 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2350 gfc_array_info
*info
;
2354 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2356 info
= &ss
->info
->data
.array
;
2358 info
->descriptor
= tmp
;
2359 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2360 info
->offset
= gfc_index_zero_node
;
2362 for (i
= 0; i
< ss
->dimen
; i
++)
2364 info
->delta
[i
] = gfc_index_zero_node
;
2365 info
->start
[i
] = gfc_index_zero_node
;
2366 info
->end
[i
] = gfc_index_zero_node
;
2367 info
->stride
[i
] = gfc_index_one_node
;
2373 get_rank (gfc_loopinfo
*loop
)
2378 for (; loop
; loop
= loop
->parent
)
2379 rank
+= loop
->dimen
;
2385 /* Helper routine of gfc_trans_array_constructor to determine if the
2386 bounds of the loop specified by LOOP are constant and simple enough
2387 to use with trans_constant_array_constructor. Returns the
2388 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2391 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2394 tree size
= gfc_index_one_node
;
2398 total_dim
= get_rank (l
);
2400 for (loop
= l
; loop
; loop
= loop
->parent
)
2402 for (i
= 0; i
< loop
->dimen
; i
++)
2404 /* If the bounds aren't constant, return NULL_TREE. */
2405 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2407 if (!integer_zerop (loop
->from
[i
]))
2409 /* Only allow nonzero "from" in one-dimensional arrays. */
2412 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2413 gfc_array_index_type
,
2414 loop
->to
[i
], loop
->from
[i
]);
2418 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2419 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2420 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2421 gfc_array_index_type
, size
, tmp
);
2430 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2435 gcc_assert (array
->nested_ss
== NULL
);
2437 for (ss
= array
; ss
; ss
= ss
->parent
)
2438 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2439 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2440 return &(ss
->loop
->to
[n
]);
2446 static gfc_loopinfo
*
2447 outermost_loop (gfc_loopinfo
* loop
)
2449 while (loop
->parent
!= NULL
)
2450 loop
= loop
->parent
;
2456 /* Array constructors are handled by constructing a temporary, then using that
2457 within the scalarization loop. This is not optimal, but seems by far the
2461 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2463 gfc_constructor_base c
;
2471 bool old_first_len
, old_typespec_chararray_ctor
;
2472 tree old_first_len_val
;
2473 gfc_loopinfo
*loop
, *outer_loop
;
2474 gfc_ss_info
*ss_info
;
2480 /* Save the old values for nested checking. */
2481 old_first_len
= first_len
;
2482 old_first_len_val
= first_len_val
;
2483 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2486 outer_loop
= outermost_loop (loop
);
2488 expr
= ss_info
->expr
;
2490 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2491 typespec was given for the array constructor. */
2492 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2494 && expr
->ts
.u
.cl
->length_from_typespec
);
2496 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2497 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2499 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2503 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2505 c
= expr
->value
.constructor
;
2506 if (expr
->ts
.type
== BT_CHARACTER
)
2509 bool force_new_cl
= false;
2511 /* get_array_ctor_strlen walks the elements of the constructor, if a
2512 typespec was given, we already know the string length and want the one
2514 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2515 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2519 const_string
= false;
2520 gfc_init_se (&length_se
, NULL
);
2521 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2522 gfc_charlen_type_node
);
2523 ss_info
->string_length
= length_se
.expr
;
2525 /* Check if the character length is negative. If it is, then
2527 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2528 logical_type_node
, ss_info
->string_length
,
2529 build_zero_cst (TREE_TYPE
2530 (ss_info
->string_length
)));
2531 /* Print a warning if bounds checking is enabled. */
2532 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2534 msg
= xasprintf ("Negative character length treated as LEN = 0");
2535 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2540 ss_info
->string_length
2541 = fold_build3_loc (input_location
, COND_EXPR
,
2542 gfc_charlen_type_node
, neg_len
,
2544 (TREE_TYPE (ss_info
->string_length
)),
2545 ss_info
->string_length
);
2546 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2548 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2549 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2553 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2554 &ss_info
->string_length
);
2555 force_new_cl
= true;
2558 /* Complex character array constructors should have been taken care of
2559 and not end up here. */
2560 gcc_assert (ss_info
->string_length
);
2562 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2564 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2566 type
= build_pointer_type (type
);
2569 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2570 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2572 /* See if the constructor determines the loop bounds. */
2575 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2577 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2579 /* We have a multidimensional parameter. */
2580 for (s
= ss
; s
; s
= s
->parent
)
2583 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2585 s
->loop
->from
[n
] = gfc_index_zero_node
;
2586 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2587 gfc_index_integer_kind
);
2588 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2589 gfc_array_index_type
,
2591 gfc_index_one_node
);
2596 if (*loop_ubound0
== NULL_TREE
)
2600 /* We should have a 1-dimensional, zero-based loop. */
2601 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2602 gcc_assert (loop
->dimen
== 1);
2603 gcc_assert (integer_zerop (loop
->from
[0]));
2605 /* Split the constructor size into a static part and a dynamic part.
2606 Allocate the static size up-front and record whether the dynamic
2607 size might be nonzero. */
2609 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2610 mpz_sub_ui (size
, size
, 1);
2611 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2615 /* Special case constant array constructors. */
2618 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2621 tree size
= constant_array_constructor_loop_size (loop
);
2622 if (size
&& compare_tree_int (size
, nelem
) == 0)
2624 trans_constant_array_constructor (ss
, type
);
2630 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2631 NULL_TREE
, dynamic
, true, false, where
);
2633 desc
= ss_info
->data
.array
.descriptor
;
2634 offset
= gfc_index_zero_node
;
2635 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2636 TREE_NO_WARNING (offsetvar
) = 1;
2637 TREE_USED (offsetvar
) = 0;
2638 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2639 &offset
, &offsetvar
, dynamic
);
2641 /* If the array grows dynamically, the upper bound of the loop variable
2642 is determined by the array's final upper bound. */
2645 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2646 gfc_array_index_type
,
2647 offsetvar
, gfc_index_one_node
);
2648 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2649 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2650 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2651 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2653 *loop_ubound0
= tmp
;
2656 if (TREE_USED (offsetvar
))
2657 pushdecl (offsetvar
);
2659 gcc_assert (INTEGER_CST_P (offset
));
2662 /* Disable bound checking for now because it's probably broken. */
2663 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2670 /* Restore old values of globals. */
2671 first_len
= old_first_len
;
2672 first_len_val
= old_first_len_val
;
2673 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2677 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2678 called after evaluating all of INFO's vector dimensions. Go through
2679 each such vector dimension and see if we can now fill in any missing
2683 set_vector_loop_bounds (gfc_ss
* ss
)
2685 gfc_loopinfo
*loop
, *outer_loop
;
2686 gfc_array_info
*info
;
2694 outer_loop
= outermost_loop (ss
->loop
);
2696 info
= &ss
->info
->data
.array
;
2698 for (; ss
; ss
= ss
->parent
)
2702 for (n
= 0; n
< loop
->dimen
; n
++)
2705 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2706 || loop
->to
[n
] != NULL
)
2709 /* Loop variable N indexes vector dimension DIM, and we don't
2710 yet know the upper bound of loop variable N. Set it to the
2711 difference between the vector's upper and lower bounds. */
2712 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2713 gcc_assert (info
->subscript
[dim
]
2714 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2716 gfc_init_se (&se
, NULL
);
2717 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2718 zero
= gfc_rank_cst
[0];
2719 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2720 gfc_array_index_type
,
2721 gfc_conv_descriptor_ubound_get (desc
, zero
),
2722 gfc_conv_descriptor_lbound_get (desc
, zero
));
2723 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2730 /* Tells whether a scalar argument to an elemental procedure is saved out
2731 of a scalarization loop as a value or as a reference. */
2734 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2736 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2739 if (ss_info
->data
.scalar
.needs_temporary
)
2742 /* If the actual argument can be absent (in other words, it can
2743 be a NULL reference), don't try to evaluate it; pass instead
2744 the reference directly. */
2745 if (ss_info
->can_be_null_ref
)
2748 /* If the expression is of polymorphic type, it's actual size is not known,
2749 so we avoid copying it anywhere. */
2750 if (ss_info
->data
.scalar
.dummy_arg
2751 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2752 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2755 /* If the expression is a data reference of aggregate type,
2756 and the data reference is not used on the left hand side,
2757 avoid a copy by saving a reference to the content. */
2758 if (!ss_info
->data
.scalar
.needs_temporary
2759 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2760 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2761 && gfc_expr_is_variable (ss_info
->expr
))
2764 /* Otherwise the expression is evaluated to a temporary variable before the
2765 scalarization loop. */
2770 /* Add the pre and post chains for all the scalar expressions in a SS chain
2771 to loop. This is called after the loop parameters have been calculated,
2772 but before the actual scalarizing loops. */
2775 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2778 gfc_loopinfo
*nested_loop
, *outer_loop
;
2780 gfc_ss_info
*ss_info
;
2781 gfc_array_info
*info
;
2785 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2786 arguments could get evaluated multiple times. */
2787 if (ss
->is_alloc_lhs
)
2790 outer_loop
= outermost_loop (loop
);
2792 /* TODO: This can generate bad code if there are ordering dependencies,
2793 e.g., a callee allocated function and an unknown size constructor. */
2794 gcc_assert (ss
!= NULL
);
2796 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2800 /* Cross loop arrays are handled from within the most nested loop. */
2801 if (ss
->nested_ss
!= NULL
)
2805 expr
= ss_info
->expr
;
2806 info
= &ss_info
->data
.array
;
2808 switch (ss_info
->type
)
2811 /* Scalar expression. Evaluate this now. This includes elemental
2812 dimension indices, but not array section bounds. */
2813 gfc_init_se (&se
, NULL
);
2814 gfc_conv_expr (&se
, expr
);
2815 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2817 if (expr
->ts
.type
!= BT_CHARACTER
2818 && !gfc_is_alloc_class_scalar_function (expr
))
2820 /* Move the evaluation of scalar expressions outside the
2821 scalarization loop, except for WHERE assignments. */
2823 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2824 if (!ss_info
->where
)
2825 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2826 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2829 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2831 ss_info
->data
.scalar
.value
= se
.expr
;
2832 ss_info
->string_length
= se
.string_length
;
2835 case GFC_SS_REFERENCE
:
2836 /* Scalar argument to elemental procedure. */
2837 gfc_init_se (&se
, NULL
);
2838 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2839 gfc_conv_expr_reference (&se
, expr
);
2842 /* Evaluate the argument outside the loop and pass
2843 a reference to the value. */
2844 gfc_conv_expr (&se
, expr
);
2847 /* Ensure that a pointer to the string is stored. */
2848 if (expr
->ts
.type
== BT_CHARACTER
)
2849 gfc_conv_string_parameter (&se
);
2851 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2852 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2853 if (gfc_is_class_scalar_expr (expr
))
2854 /* This is necessary because the dynamic type will always be
2855 large than the declared type. In consequence, assigning
2856 the value to a temporary could segfault.
2857 OOP-TODO: see if this is generally correct or is the value
2858 has to be written to an allocated temporary, whose address
2859 is passed via ss_info. */
2860 ss_info
->data
.scalar
.value
= se
.expr
;
2862 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2865 ss_info
->string_length
= se
.string_length
;
2868 case GFC_SS_SECTION
:
2869 /* Add the expressions for scalar and vector subscripts. */
2870 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2871 if (info
->subscript
[n
])
2872 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2874 set_vector_loop_bounds (ss
);
2878 /* Get the vector's descriptor and store it in SS. */
2879 gfc_init_se (&se
, NULL
);
2880 gfc_conv_expr_descriptor (&se
, expr
);
2881 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2882 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2883 info
->descriptor
= se
.expr
;
2886 case GFC_SS_INTRINSIC
:
2887 gfc_add_intrinsic_ss_code (loop
, ss
);
2890 case GFC_SS_FUNCTION
:
2891 /* Array function return value. We call the function and save its
2892 result in a temporary for use inside the loop. */
2893 gfc_init_se (&se
, NULL
);
2896 if (gfc_is_class_array_function (expr
))
2897 expr
->must_finalize
= 1;
2898 gfc_conv_expr (&se
, expr
);
2899 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2900 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2901 ss_info
->string_length
= se
.string_length
;
2904 case GFC_SS_CONSTRUCTOR
:
2905 if (expr
->ts
.type
== BT_CHARACTER
2906 && ss_info
->string_length
== NULL
2908 && expr
->ts
.u
.cl
->length
2909 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2911 gfc_init_se (&se
, NULL
);
2912 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2913 gfc_charlen_type_node
);
2914 ss_info
->string_length
= se
.expr
;
2915 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2916 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2918 trans_array_constructor (ss
, where
);
2922 case GFC_SS_COMPONENT
:
2923 /* Do nothing. These are handled elsewhere. */
2932 for (nested_loop
= loop
->nested
; nested_loop
;
2933 nested_loop
= nested_loop
->next
)
2934 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2938 /* Translate expressions for the descriptor and data pointer of a SS. */
2942 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2945 gfc_ss_info
*ss_info
;
2946 gfc_array_info
*info
;
2950 info
= &ss_info
->data
.array
;
2952 /* Get the descriptor for the array to be scalarized. */
2953 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2954 gfc_init_se (&se
, NULL
);
2955 se
.descriptor_only
= 1;
2956 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2957 gfc_add_block_to_block (block
, &se
.pre
);
2958 info
->descriptor
= se
.expr
;
2959 ss_info
->string_length
= se
.string_length
;
2963 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2964 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2966 /* Emit a DECL_EXPR for the variable sized array type in
2967 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2968 sizes works correctly. */
2969 tree arraytype
= TREE_TYPE (
2970 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2971 if (! TYPE_NAME (arraytype
))
2972 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2973 NULL_TREE
, arraytype
);
2974 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2975 TYPE_NAME (arraytype
)));
2977 /* Also the data pointer. */
2978 tmp
= gfc_conv_array_data (se
.expr
);
2979 /* If this is a variable or address of a variable we use it directly.
2980 Otherwise we must evaluate it now to avoid breaking dependency
2981 analysis by pulling the expressions for elemental array indices
2984 || (TREE_CODE (tmp
) == ADDR_EXPR
2985 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2986 tmp
= gfc_evaluate_now (tmp
, block
);
2989 tmp
= gfc_conv_array_offset (se
.expr
);
2990 info
->offset
= gfc_evaluate_now (tmp
, block
);
2992 /* Make absolutely sure that the saved_offset is indeed saved
2993 so that the variable is still accessible after the loops
2995 info
->saved_offset
= info
->offset
;
3000 /* Initialize a gfc_loopinfo structure. */
3003 gfc_init_loopinfo (gfc_loopinfo
* loop
)
3007 memset (loop
, 0, sizeof (gfc_loopinfo
));
3008 gfc_init_block (&loop
->pre
);
3009 gfc_init_block (&loop
->post
);
3011 /* Initially scalarize in order and default to no loop reversal. */
3012 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
3015 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
3018 loop
->ss
= gfc_ss_terminator
;
3022 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3026 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
3032 /* Return an expression for the data pointer of an array. */
3035 gfc_conv_array_data (tree descriptor
)
3039 type
= TREE_TYPE (descriptor
);
3040 if (GFC_ARRAY_TYPE_P (type
))
3042 if (TREE_CODE (type
) == POINTER_TYPE
)
3046 /* Descriptorless arrays. */
3047 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
3051 return gfc_conv_descriptor_data_get (descriptor
);
3055 /* Return an expression for the base offset of an array. */
3058 gfc_conv_array_offset (tree descriptor
)
3062 type
= TREE_TYPE (descriptor
);
3063 if (GFC_ARRAY_TYPE_P (type
))
3064 return GFC_TYPE_ARRAY_OFFSET (type
);
3066 return gfc_conv_descriptor_offset_get (descriptor
);
3070 /* Get an expression for the array stride. */
3073 gfc_conv_array_stride (tree descriptor
, int dim
)
3078 type
= TREE_TYPE (descriptor
);
3080 /* For descriptorless arrays use the array size. */
3081 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
3082 if (tmp
!= NULL_TREE
)
3085 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3090 /* Like gfc_conv_array_stride, but for the lower bound. */
3093 gfc_conv_array_lbound (tree descriptor
, int dim
)
3098 type
= TREE_TYPE (descriptor
);
3100 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3101 if (tmp
!= NULL_TREE
)
3104 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3109 /* Like gfc_conv_array_stride, but for the upper bound. */
3112 gfc_conv_array_ubound (tree descriptor
, int dim
)
3117 type
= TREE_TYPE (descriptor
);
3119 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3120 if (tmp
!= NULL_TREE
)
3123 /* This should only ever happen when passing an assumed shape array
3124 as an actual parameter. The value will never be used. */
3125 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3126 return gfc_index_zero_node
;
3128 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3133 /* Generate code to perform an array index bound check. */
3136 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3137 locus
* where
, bool check_upper
)
3140 tree tmp_lo
, tmp_up
;
3143 const char * name
= NULL
;
3145 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3148 descriptor
= ss
->info
->data
.array
.descriptor
;
3150 index
= gfc_evaluate_now (index
, &se
->pre
);
3152 /* We find a name for the error message. */
3153 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3154 gcc_assert (name
!= NULL
);
3156 if (VAR_P (descriptor
))
3157 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3159 /* If upper bound is present, include both bounds in the error message. */
3162 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3163 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3166 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3167 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3169 msg
= xasprintf ("Index '%%ld' of dimension %d "
3170 "outside of expected range (%%ld:%%ld)", n
+1);
3172 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3174 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3175 fold_convert (long_integer_type_node
, index
),
3176 fold_convert (long_integer_type_node
, tmp_lo
),
3177 fold_convert (long_integer_type_node
, tmp_up
));
3178 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3180 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3181 fold_convert (long_integer_type_node
, index
),
3182 fold_convert (long_integer_type_node
, tmp_lo
),
3183 fold_convert (long_integer_type_node
, tmp_up
));
3188 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3191 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3192 "below lower bound of %%ld", n
+1, name
);
3194 msg
= xasprintf ("Index '%%ld' of dimension %d "
3195 "below lower bound of %%ld", n
+1);
3197 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3199 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3200 fold_convert (long_integer_type_node
, index
),
3201 fold_convert (long_integer_type_node
, tmp_lo
));
3209 /* Return the offset for an index. Performs bound checking for elemental
3210 dimensions. Single element references are processed separately.
3211 DIM is the array dimension, I is the loop dimension. */
3214 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3215 gfc_array_ref
* ar
, tree stride
)
3217 gfc_array_info
*info
;
3222 info
= &ss
->info
->data
.array
;
3224 /* Get the index into the array for this dimension. */
3227 gcc_assert (ar
->type
!= AR_ELEMENT
);
3228 switch (ar
->dimen_type
[dim
])
3230 case DIMEN_THIS_IMAGE
:
3234 /* Elemental dimension. */
3235 gcc_assert (info
->subscript
[dim
]
3236 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3237 /* We've already translated this value outside the loop. */
3238 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3240 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3241 ar
->as
->type
!= AS_ASSUMED_SIZE
3242 || dim
< ar
->dimen
- 1);
3246 gcc_assert (info
&& se
->loop
);
3247 gcc_assert (info
->subscript
[dim
]
3248 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3249 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3251 /* Get a zero-based index into the vector. */
3252 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3253 gfc_array_index_type
,
3254 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3256 /* Multiply the index by the stride. */
3257 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3258 gfc_array_index_type
,
3259 index
, gfc_conv_array_stride (desc
, 0));
3261 /* Read the vector to get an index into info->descriptor. */
3262 data
= build_fold_indirect_ref_loc (input_location
,
3263 gfc_conv_array_data (desc
));
3264 index
= gfc_build_array_ref (data
, index
, NULL
);
3265 index
= gfc_evaluate_now (index
, &se
->pre
);
3266 index
= fold_convert (gfc_array_index_type
, index
);
3268 /* Do any bounds checking on the final info->descriptor index. */
3269 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3270 ar
->as
->type
!= AS_ASSUMED_SIZE
3271 || dim
< ar
->dimen
- 1);
3275 /* Scalarized dimension. */
3276 gcc_assert (info
&& se
->loop
);
3278 /* Multiply the loop variable by the stride and delta. */
3279 index
= se
->loop
->loopvar
[i
];
3280 if (!integer_onep (info
->stride
[dim
]))
3281 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3282 gfc_array_index_type
, index
,
3284 if (!integer_zerop (info
->delta
[dim
]))
3285 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3286 gfc_array_index_type
, index
,
3296 /* Temporary array or derived type component. */
3297 gcc_assert (se
->loop
);
3298 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3300 /* Pointer functions can have stride[0] different from unity.
3301 Use the stride returned by the function call and stored in
3302 the descriptor for the temporary. */
3303 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3304 && se
->ss
->info
->expr
3305 && se
->ss
->info
->expr
->symtree
3306 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3307 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3308 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3311 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3312 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3313 gfc_array_index_type
, index
, info
->delta
[dim
]);
3316 /* Multiply by the stride. */
3317 if (stride
!= NULL
&& !integer_onep (stride
))
3318 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3325 /* Build a scalarized array reference using the vptr 'size'. */
3328 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3333 tree decl
= NULL_TREE
;
3335 gfc_expr
*expr
= se
->ss
->info
->expr
;
3337 gfc_ref
*class_ref
= NULL
;
3340 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3341 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3342 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3347 || (expr
->ts
.type
!= BT_CLASS
3348 && !gfc_is_class_array_function (expr
)
3349 && !gfc_is_class_array_ref (expr
, NULL
)))
3352 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3353 ts
= &expr
->symtree
->n
.sym
->ts
;
3357 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3359 if (ref
->type
== REF_COMPONENT
3360 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3361 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3362 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3364 && ref
->next
->next
->type
== REF_ARRAY
3365 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3367 ts
= &ref
->u
.c
.component
->ts
;
3377 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3378 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3379 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3381 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3383 else if (expr
&& gfc_is_class_array_function (expr
))
3387 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3390 type
= TREE_TYPE (tmp
);
3393 if (GFC_CLASS_TYPE_P (type
))
3395 if (type
!= TYPE_CANONICAL (type
))
3396 type
= TYPE_CANONICAL (type
);
3404 if (decl
== NULL_TREE
)
3407 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3409 else if (class_ref
== NULL
)
3411 if (decl
== NULL_TREE
)
3412 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3413 /* For class arrays the tree containing the class is stored in
3414 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3415 For all others it's sym's backend_decl directly. */
3416 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3417 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3421 /* Remove everything after the last class reference, convert the
3422 expression and then recover its tailend once more. */
3424 ref
= class_ref
->next
;
3425 class_ref
->next
= NULL
;
3426 gfc_init_se (&tmpse
, NULL
);
3427 gfc_conv_expr (&tmpse
, expr
);
3428 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3430 class_ref
->next
= ref
;
3433 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3434 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3436 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3439 size
= gfc_class_vtab_size_get (decl
);
3441 /* For unlimited polymorphic entities then _len component needs to be
3442 multiplied with the size. If no _len component is present, then
3443 gfc_class_len_or_zero_get () return a zero_node. */
3444 tmp
= gfc_class_len_or_zero_get (decl
);
3445 if (!integer_zerop (tmp
))
3446 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3447 fold_convert (TREE_TYPE (index
), size
),
3448 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3449 fold_convert (TREE_TYPE (index
), tmp
),
3450 fold_convert (TREE_TYPE (index
),
3451 integer_one_node
)));
3453 size
= fold_convert (TREE_TYPE (index
), size
);
3455 /* Build the address of the element. */
3456 type
= TREE_TYPE (TREE_TYPE (base
));
3457 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3458 gfc_array_index_type
,
3460 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3461 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3462 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3464 /* Return the element in the se expression. */
3465 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3470 /* Build a scalarized reference to an array. */
3473 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3475 gfc_array_info
*info
;
3476 tree decl
= NULL_TREE
;
3484 expr
= ss
->info
->expr
;
3485 info
= &ss
->info
->data
.array
;
3487 n
= se
->loop
->order
[0];
3491 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3492 /* Add the offset for this dimension to the stored offset for all other
3494 if (info
->offset
&& !integer_zerop (info
->offset
))
3495 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3496 index
, info
->offset
);
3498 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3500 /* Use the vptr 'size' field to access the element of a class array. */
3501 if (build_class_array_ref (se
, base
, index
))
3504 if (get_CFI_desc (NULL
, expr
, &decl
, ar
))
3505 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3507 /* A pointer array component can be detected from its field decl. Fix
3508 the descriptor, mark the resulting variable decl and pass it to
3509 gfc_build_array_ref. */
3510 if (is_pointer_array (info
->descriptor
)
3511 || (expr
&& expr
->ts
.deferred
&& info
->descriptor
3512 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
))))
3514 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3515 decl
= info
->descriptor
;
3516 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3517 decl
= TREE_OPERAND (info
->descriptor
, 0);
3519 if (decl
== NULL_TREE
)
3520 decl
= info
->descriptor
;
3523 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3527 /* Translate access of temporary array. */
3530 gfc_conv_tmp_array_ref (gfc_se
* se
)
3532 se
->string_length
= se
->ss
->info
->string_length
;
3533 gfc_conv_scalarized_array_ref (se
, NULL
);
3534 gfc_advance_se_ss_chain (se
);
3537 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3540 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3542 if (TREE_CODE (t
) == INTEGER_CST
)
3543 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3546 if (!integer_zerop (*offset
))
3547 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3548 gfc_array_index_type
, *offset
, t
);
3556 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3562 /* For class arrays the class declaration is stored in the saved
3564 if (INDIRECT_REF_P (desc
)
3565 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3566 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3567 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3568 TREE_OPERAND (desc
, 0)));
3572 /* Class container types do not always have the GFC_CLASS_TYPE_P
3573 but the canonical type does. */
3574 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3575 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3577 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3578 if (TYPE_CANONICAL (type
)
3579 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3580 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3583 tmp
= gfc_conv_array_data (desc
);
3584 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3585 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3590 /* Build an array reference. se->expr already holds the array descriptor.
3591 This should be either a variable, indirect variable reference or component
3592 reference. For arrays which do not have a descriptor, se->expr will be
3594 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3597 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3601 tree offset
, cst_offset
;
3604 tree decl
= NULL_TREE
;
3607 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3608 char *var_name
= NULL
;
3612 gcc_assert (ar
->codimen
|| sym
->attr
.select_rank_temporary
);
3614 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3615 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3618 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3619 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3620 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3622 /* Use the actual tree type and not the wrapped coarray. */
3623 if (!se
->want_pointer
)
3624 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3631 /* Handle scalarized references separately. */
3632 if (ar
->type
!= AR_ELEMENT
)
3634 gfc_conv_scalarized_array_ref (se
, ar
);
3635 gfc_advance_se_ss_chain (se
);
3639 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3644 len
= strlen (sym
->name
) + 1;
3645 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3647 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3649 if (ref
->type
== REF_COMPONENT
)
3650 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3653 var_name
= XALLOCAVEC (char, len
);
3654 strcpy (var_name
, sym
->name
);
3656 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3658 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3660 if (ref
->type
== REF_COMPONENT
)
3662 strcat (var_name
, "%%");
3663 strcat (var_name
, ref
->u
.c
.component
->name
);
3668 cst_offset
= offset
= gfc_index_zero_node
;
3669 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3671 /* Calculate the offsets from all the dimensions. Make sure to associate
3672 the final offset so that we form a chain of loop invariant summands. */
3673 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3675 /* Calculate the index for this dimension. */
3676 gfc_init_se (&indexse
, se
);
3677 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3678 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3680 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3682 /* Check array bounds. */
3686 /* Evaluate the indexse.expr only once. */
3687 indexse
.expr
= save_expr (indexse
.expr
);
3690 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3691 if (sym
->attr
.temporary
)
3693 gfc_init_se (&tmpse
, se
);
3694 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3695 gfc_array_index_type
);
3696 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3700 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3702 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3703 "below lower bound of %%ld", n
+1, var_name
);
3704 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3705 fold_convert (long_integer_type_node
,
3707 fold_convert (long_integer_type_node
, tmp
));
3710 /* Upper bound, but not for the last dimension of assumed-size
3712 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3714 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3715 if (sym
->attr
.temporary
)
3717 gfc_init_se (&tmpse
, se
);
3718 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3719 gfc_array_index_type
);
3720 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3724 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3725 logical_type_node
, indexse
.expr
, tmp
);
3726 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3727 "above upper bound of %%ld", n
+1, var_name
);
3728 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3729 fold_convert (long_integer_type_node
,
3731 fold_convert (long_integer_type_node
, tmp
));
3736 /* Multiply the index by the stride. */
3737 stride
= gfc_conv_array_stride (se
->expr
, n
);
3738 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3739 indexse
.expr
, stride
);
3741 /* And add it to the total. */
3742 add_to_offset (&cst_offset
, &offset
, tmp
);
3745 if (!integer_zerop (cst_offset
))
3746 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3747 gfc_array_index_type
, offset
, cst_offset
);
3749 /* A pointer array component can be detected from its field decl. Fix
3750 the descriptor, mark the resulting variable decl and pass it to
3752 if (get_CFI_desc (sym
, expr
, &decl
, ar
))
3753 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3754 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3755 && is_pointer_array (se
->expr
))
3757 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3759 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3760 decl
= TREE_OPERAND (se
->expr
, 0);
3764 else if (expr
->ts
.deferred
3765 || (sym
->ts
.type
== BT_CHARACTER
3766 && sym
->attr
.select_type_temporary
))
3768 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3771 if (TREE_CODE (decl
) == INDIRECT_REF
)
3772 decl
= TREE_OPERAND (decl
, 0);
3775 decl
= sym
->backend_decl
;
3777 else if (sym
->ts
.type
== BT_CLASS
)
3780 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3784 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3785 LOOP_DIM dimension (if any) to array's offset. */
3788 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3789 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3792 gfc_array_info
*info
;
3795 info
= &ss
->info
->data
.array
;
3797 gfc_init_se (&se
, NULL
);
3799 se
.expr
= info
->descriptor
;
3800 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3801 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3802 gfc_add_block_to_block (pblock
, &se
.pre
);
3804 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3805 gfc_array_index_type
,
3806 info
->offset
, index
);
3807 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3811 /* Generate the code to be executed immediately before entering a
3812 scalarization loop. */
3815 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3816 stmtblock_t
* pblock
)
3819 gfc_ss_info
*ss_info
;
3820 gfc_array_info
*info
;
3821 gfc_ss_type ss_type
;
3823 gfc_loopinfo
*ploop
;
3827 /* This code will be executed before entering the scalarization loop
3828 for this dimension. */
3829 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3833 if ((ss_info
->useflags
& flag
) == 0)
3836 ss_type
= ss_info
->type
;
3837 if (ss_type
!= GFC_SS_SECTION
3838 && ss_type
!= GFC_SS_FUNCTION
3839 && ss_type
!= GFC_SS_CONSTRUCTOR
3840 && ss_type
!= GFC_SS_COMPONENT
)
3843 info
= &ss_info
->data
.array
;
3845 gcc_assert (dim
< ss
->dimen
);
3846 gcc_assert (ss
->dimen
== loop
->dimen
);
3849 ar
= &info
->ref
->u
.ar
;
3853 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3855 /* If we are in the outermost dimension of this loop, the previous
3856 dimension shall be in the parent loop. */
3857 gcc_assert (ss
->parent
!= NULL
);
3860 ploop
= loop
->parent
;
3862 /* ss and ss->parent are about the same array. */
3863 gcc_assert (ss_info
== pss
->info
);
3871 if (dim
== loop
->dimen
- 1)
3876 /* For the time being, there is no loop reordering. */
3877 gcc_assert (i
== ploop
->order
[i
]);
3878 i
= ploop
->order
[i
];
3880 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3882 stride
= gfc_conv_array_stride (info
->descriptor
,
3883 innermost_ss (ss
)->dim
[i
]);
3885 /* Calculate the stride of the innermost loop. Hopefully this will
3886 allow the backend optimizers to do their stuff more effectively.
3888 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3890 /* For the outermost loop calculate the offset due to any
3891 elemental dimensions. It will have been initialized with the
3892 base offset of the array. */
3895 for (i
= 0; i
< ar
->dimen
; i
++)
3897 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3900 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3905 /* Add the offset for the previous loop dimension. */
3906 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3908 /* Remember this offset for the second loop. */
3909 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3910 info
->saved_offset
= info
->offset
;
3915 /* Start a scalarized expression. Creates a scope and declares loop
3919 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3925 gcc_assert (!loop
->array_parameter
);
3927 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3929 n
= loop
->order
[dim
];
3931 gfc_start_block (&loop
->code
[n
]);
3933 /* Create the loop variable. */
3934 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3936 if (dim
< loop
->temp_dim
)
3940 /* Calculate values that will be constant within this loop. */
3941 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3943 gfc_start_block (pbody
);
3947 /* Generates the actual loop code for a scalarization loop. */
3950 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3951 stmtblock_t
* pbody
)
3962 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3963 | OMPWS_SCALARIZER_BODY
))
3964 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3965 && n
== loop
->dimen
- 1)
3967 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3968 init
= make_tree_vec (1);
3969 cond
= make_tree_vec (1);
3970 incr
= make_tree_vec (1);
3972 /* Cycle statement is implemented with a goto. Exit statement must not
3973 be present for this loop. */
3974 exit_label
= gfc_build_label_decl (NULL_TREE
);
3975 TREE_USED (exit_label
) = 1;
3977 /* Label for cycle statements (if needed). */
3978 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3979 gfc_add_expr_to_block (pbody
, tmp
);
3981 stmt
= make_node (OMP_FOR
);
3983 TREE_TYPE (stmt
) = void_type_node
;
3984 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3986 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3987 OMP_CLAUSE_SCHEDULE
);
3988 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3989 = OMP_CLAUSE_SCHEDULE_STATIC
;
3990 if (ompws_flags
& OMPWS_NOWAIT
)
3991 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3992 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3994 /* Initialize the loopvar. */
3995 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3997 OMP_FOR_INIT (stmt
) = init
;
3998 /* The exit condition. */
3999 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
4001 loop
->loopvar
[n
], loop
->to
[n
]);
4002 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
4003 OMP_FOR_COND (stmt
) = cond
;
4004 /* Increment the loopvar. */
4005 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4006 loop
->loopvar
[n
], gfc_index_one_node
);
4007 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
4008 void_type_node
, loop
->loopvar
[n
], tmp
);
4009 OMP_FOR_INCR (stmt
) = incr
;
4011 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
4012 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
4016 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
4017 && (loop
->temp_ss
== NULL
);
4019 loopbody
= gfc_finish_block (pbody
);
4022 std::swap (loop
->from
[n
], loop
->to
[n
]);
4024 /* Initialize the loopvar. */
4025 if (loop
->loopvar
[n
] != loop
->from
[n
])
4026 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
4028 exit_label
= gfc_build_label_decl (NULL_TREE
);
4030 /* Generate the loop body. */
4031 gfc_init_block (&block
);
4033 /* The exit condition. */
4034 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
4035 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
4036 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4037 TREE_USED (exit_label
) = 1;
4038 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4039 gfc_add_expr_to_block (&block
, tmp
);
4041 /* The main body. */
4042 gfc_add_expr_to_block (&block
, loopbody
);
4044 /* Increment the loopvar. */
4045 tmp
= fold_build2_loc (input_location
,
4046 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
4047 gfc_array_index_type
, loop
->loopvar
[n
],
4048 gfc_index_one_node
);
4050 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
4052 /* Build the loop. */
4053 tmp
= gfc_finish_block (&block
);
4054 tmp
= build1_v (LOOP_EXPR
, tmp
);
4055 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4057 /* Add the exit label. */
4058 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4059 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4065 /* Finishes and generates the loops for a scalarized expression. */
4068 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4073 stmtblock_t
*pblock
;
4077 /* Generate the loops. */
4078 for (dim
= 0; dim
< loop
->dimen
; dim
++)
4080 n
= loop
->order
[dim
];
4081 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4082 loop
->loopvar
[n
] = NULL_TREE
;
4083 pblock
= &loop
->code
[n
];
4086 tmp
= gfc_finish_block (pblock
);
4087 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4089 /* Clear all the used flags. */
4090 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4091 if (ss
->parent
== NULL
)
4092 ss
->info
->useflags
= 0;
4096 /* Finish the main body of a scalarized expression, and start the secondary
4100 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4104 stmtblock_t
*pblock
;
4108 /* We finish as many loops as are used by the temporary. */
4109 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4111 n
= loop
->order
[dim
];
4112 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4113 loop
->loopvar
[n
] = NULL_TREE
;
4114 pblock
= &loop
->code
[n
];
4117 /* We don't want to finish the outermost loop entirely. */
4118 n
= loop
->order
[loop
->temp_dim
- 1];
4119 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4121 /* Restore the initial offsets. */
4122 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4124 gfc_ss_type ss_type
;
4125 gfc_ss_info
*ss_info
;
4129 if ((ss_info
->useflags
& 2) == 0)
4132 ss_type
= ss_info
->type
;
4133 if (ss_type
!= GFC_SS_SECTION
4134 && ss_type
!= GFC_SS_FUNCTION
4135 && ss_type
!= GFC_SS_CONSTRUCTOR
4136 && ss_type
!= GFC_SS_COMPONENT
)
4139 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4142 /* Restart all the inner loops we just finished. */
4143 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4145 n
= loop
->order
[dim
];
4147 gfc_start_block (&loop
->code
[n
]);
4149 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4151 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4154 /* Start a block for the secondary copying code. */
4155 gfc_start_block (body
);
4159 /* Precalculate (either lower or upper) bound of an array section.
4160 BLOCK: Block in which the (pre)calculation code will go.
4161 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4162 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4163 DESC: Array descriptor from which the bound will be picked if unspecified
4164 (either lower or upper bound according to LBOUND). */
4167 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4168 tree desc
, int dim
, bool lbound
, bool deferred
)
4171 gfc_expr
* input_val
= values
[dim
];
4172 tree
*output
= &bounds
[dim
];
4177 /* Specified section bound. */
4178 gfc_init_se (&se
, NULL
);
4179 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4180 gfc_add_block_to_block (block
, &se
.pre
);
4183 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4185 /* The gfc_conv_array_lbound () routine returns a constant zero for
4186 deferred length arrays, which in the scalarizer wreaks havoc, when
4187 copying to a (newly allocated) one-based array.
4188 Keep returning the actual result in sync for both bounds. */
4189 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4191 gfc_conv_descriptor_ubound_get (desc
,
4196 /* No specific bound specified so use the bound of the array. */
4197 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4198 gfc_conv_array_ubound (desc
, dim
);
4200 *output
= gfc_evaluate_now (*output
, block
);
4204 /* Calculate the lower bound of an array section. */
4207 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4209 gfc_expr
*stride
= NULL
;
4212 gfc_array_info
*info
;
4215 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4217 info
= &ss
->info
->data
.array
;
4218 ar
= &info
->ref
->u
.ar
;
4220 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4222 /* We use a zero-based index to access the vector. */
4223 info
->start
[dim
] = gfc_index_zero_node
;
4224 info
->end
[dim
] = NULL
;
4225 info
->stride
[dim
] = gfc_index_one_node
;
4229 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4230 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4231 desc
= info
->descriptor
;
4232 stride
= ar
->stride
[dim
];
4235 /* Calculate the start of the range. For vector subscripts this will
4236 be the range of the vector. */
4237 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4238 ar
->as
->type
== AS_DEFERRED
);
4240 /* Similarly calculate the end. Although this is not used in the
4241 scalarizer, it is needed when checking bounds and where the end
4242 is an expression with side-effects. */
4243 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4244 ar
->as
->type
== AS_DEFERRED
);
4247 /* Calculate the stride. */
4249 info
->stride
[dim
] = gfc_index_one_node
;
4252 gfc_init_se (&se
, NULL
);
4253 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4254 gfc_add_block_to_block (block
, &se
.pre
);
4255 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4260 /* Calculates the range start and stride for a SS chain. Also gets the
4261 descriptor and data pointer. The range of vector subscripts is the size
4262 of the vector. Array bounds are also checked. */
4265 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4272 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4275 /* Determine the rank of the loop. */
4276 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4278 switch (ss
->info
->type
)
4280 case GFC_SS_SECTION
:
4281 case GFC_SS_CONSTRUCTOR
:
4282 case GFC_SS_FUNCTION
:
4283 case GFC_SS_COMPONENT
:
4284 loop
->dimen
= ss
->dimen
;
4287 /* As usual, lbound and ubound are exceptions!. */
4288 case GFC_SS_INTRINSIC
:
4289 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4291 case GFC_ISYM_LBOUND
:
4292 case GFC_ISYM_UBOUND
:
4293 case GFC_ISYM_LCOBOUND
:
4294 case GFC_ISYM_UCOBOUND
:
4295 case GFC_ISYM_THIS_IMAGE
:
4296 loop
->dimen
= ss
->dimen
;
4308 /* We should have determined the rank of the expression by now. If
4309 not, that's bad news. */
4313 /* Loop over all the SS in the chain. */
4314 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4316 gfc_ss_info
*ss_info
;
4317 gfc_array_info
*info
;
4321 expr
= ss_info
->expr
;
4322 info
= &ss_info
->data
.array
;
4324 if (expr
&& expr
->shape
&& !info
->shape
)
4325 info
->shape
= expr
->shape
;
4327 switch (ss_info
->type
)
4329 case GFC_SS_SECTION
:
4330 /* Get the descriptor for the array. If it is a cross loops array,
4331 we got the descriptor already in the outermost loop. */
4332 if (ss
->parent
== NULL
)
4333 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4334 !loop
->array_parameter
);
4336 for (n
= 0; n
< ss
->dimen
; n
++)
4337 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4340 case GFC_SS_INTRINSIC
:
4341 switch (expr
->value
.function
.isym
->id
)
4343 /* Fall through to supply start and stride. */
4344 case GFC_ISYM_LBOUND
:
4345 case GFC_ISYM_UBOUND
:
4349 /* This is the variant without DIM=... */
4350 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4352 arg
= expr
->value
.function
.actual
->expr
;
4353 if (arg
->rank
== -1)
4358 /* The rank (hence the return value's shape) is unknown,
4359 we have to retrieve it. */
4360 gfc_init_se (&se
, NULL
);
4361 se
.descriptor_only
= 1;
4362 gfc_conv_expr (&se
, arg
);
4363 /* This is a bare variable, so there is no preliminary
4365 gcc_assert (se
.pre
.head
== NULL_TREE
4366 && se
.post
.head
== NULL_TREE
);
4367 rank
= gfc_conv_descriptor_rank (se
.expr
);
4368 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4369 gfc_array_index_type
,
4370 fold_convert (gfc_array_index_type
,
4372 gfc_index_one_node
);
4373 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4374 info
->start
[0] = gfc_index_zero_node
;
4375 info
->stride
[0] = gfc_index_one_node
;
4378 /* Otherwise fall through GFC_SS_FUNCTION. */
4381 case GFC_ISYM_LCOBOUND
:
4382 case GFC_ISYM_UCOBOUND
:
4383 case GFC_ISYM_THIS_IMAGE
:
4391 case GFC_SS_CONSTRUCTOR
:
4392 case GFC_SS_FUNCTION
:
4393 for (n
= 0; n
< ss
->dimen
; n
++)
4395 int dim
= ss
->dim
[n
];
4397 info
->start
[dim
] = gfc_index_zero_node
;
4398 info
->end
[dim
] = gfc_index_zero_node
;
4399 info
->stride
[dim
] = gfc_index_one_node
;
4408 /* The rest is just runtime bounds checking. */
4409 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4412 tree lbound
, ubound
;
4414 tree size
[GFC_MAX_DIMENSIONS
];
4415 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4416 gfc_array_info
*info
;
4420 gfc_start_block (&block
);
4422 for (n
= 0; n
< loop
->dimen
; n
++)
4423 size
[n
] = NULL_TREE
;
4425 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4428 gfc_ss_info
*ss_info
;
4431 const char *expr_name
;
4434 if (ss_info
->type
!= GFC_SS_SECTION
)
4437 /* Catch allocatable lhs in f2003. */
4438 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4441 expr
= ss_info
->expr
;
4442 expr_loc
= &expr
->where
;
4443 expr_name
= expr
->symtree
->name
;
4445 gfc_start_block (&inner
);
4447 /* TODO: range checking for mapped dimensions. */
4448 info
= &ss_info
->data
.array
;
4450 /* This code only checks ranges. Elemental and vector
4451 dimensions are checked later. */
4452 for (n
= 0; n
< loop
->dimen
; n
++)
4457 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4460 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4461 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4462 check_upper
= false;
4466 /* Zero stride is not allowed. */
4467 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4468 info
->stride
[dim
], gfc_index_zero_node
);
4469 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4470 "of array '%s'", dim
+ 1, expr_name
);
4471 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4475 desc
= info
->descriptor
;
4477 /* This is the run-time equivalent of resolve.c's
4478 check_dimension(). The logical is more readable there
4479 than it is here, with all the trees. */
4480 lbound
= gfc_conv_array_lbound (desc
, dim
);
4481 end
= info
->end
[dim
];
4483 ubound
= gfc_conv_array_ubound (desc
, dim
);
4487 /* non_zerosized is true when the selected range is not
4489 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4490 logical_type_node
, info
->stride
[dim
],
4491 gfc_index_zero_node
);
4492 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4493 info
->start
[dim
], end
);
4494 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4495 logical_type_node
, stride_pos
, tmp
);
4497 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4499 info
->stride
[dim
], gfc_index_zero_node
);
4500 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4501 info
->start
[dim
], end
);
4502 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4505 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4507 stride_pos
, stride_neg
);
4509 /* Check the start of the range against the lower and upper
4510 bounds of the array, if the range is not empty.
4511 If upper bound is present, include both bounds in the
4515 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4517 info
->start
[dim
], lbound
);
4518 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4520 non_zerosized
, tmp
);
4521 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4523 info
->start
[dim
], ubound
);
4524 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4526 non_zerosized
, tmp2
);
4527 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4528 "outside of expected range (%%ld:%%ld)",
4529 dim
+ 1, expr_name
);
4530 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4532 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4533 fold_convert (long_integer_type_node
, lbound
),
4534 fold_convert (long_integer_type_node
, ubound
));
4535 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4537 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4538 fold_convert (long_integer_type_node
, lbound
),
4539 fold_convert (long_integer_type_node
, ubound
));
4544 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4546 info
->start
[dim
], lbound
);
4547 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4548 logical_type_node
, non_zerosized
, tmp
);
4549 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4550 "below lower bound of %%ld",
4551 dim
+ 1, expr_name
);
4552 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4554 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4555 fold_convert (long_integer_type_node
, lbound
));
4559 /* Compute the last element of the range, which is not
4560 necessarily "end" (think 0:5:3, which doesn't contain 5)
4561 and check it against both lower and upper bounds. */
4563 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4564 gfc_array_index_type
, end
,
4566 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4567 gfc_array_index_type
, tmp
,
4569 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4570 gfc_array_index_type
, end
, tmp
);
4571 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4572 logical_type_node
, tmp
, lbound
);
4573 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4574 logical_type_node
, non_zerosized
, tmp2
);
4577 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4578 logical_type_node
, tmp
, ubound
);
4579 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4580 logical_type_node
, non_zerosized
, tmp3
);
4581 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4582 "outside of expected range (%%ld:%%ld)",
4583 dim
+ 1, expr_name
);
4584 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4586 fold_convert (long_integer_type_node
, tmp
),
4587 fold_convert (long_integer_type_node
, ubound
),
4588 fold_convert (long_integer_type_node
, lbound
));
4589 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4591 fold_convert (long_integer_type_node
, tmp
),
4592 fold_convert (long_integer_type_node
, ubound
),
4593 fold_convert (long_integer_type_node
, lbound
));
4598 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4599 "below lower bound of %%ld",
4600 dim
+ 1, expr_name
);
4601 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4603 fold_convert (long_integer_type_node
, tmp
),
4604 fold_convert (long_integer_type_node
, lbound
));
4608 /* Check the section sizes match. */
4609 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4610 gfc_array_index_type
, end
,
4612 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4613 gfc_array_index_type
, tmp
,
4615 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4616 gfc_array_index_type
,
4617 gfc_index_one_node
, tmp
);
4618 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4619 gfc_array_index_type
, tmp
,
4620 build_int_cst (gfc_array_index_type
, 0));
4621 /* We remember the size of the first section, and check all the
4622 others against this. */
4625 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4626 logical_type_node
, tmp
, size
[n
]);
4627 msg
= xasprintf ("Array bound mismatch for dimension %d "
4628 "of array '%s' (%%ld/%%ld)",
4629 dim
+ 1, expr_name
);
4631 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4633 fold_convert (long_integer_type_node
, tmp
),
4634 fold_convert (long_integer_type_node
, size
[n
]));
4639 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4642 tmp
= gfc_finish_block (&inner
);
4644 /* For optional arguments, only check bounds if the argument is
4646 if (expr
->symtree
->n
.sym
->attr
.optional
4647 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4648 tmp
= build3_v (COND_EXPR
,
4649 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4650 tmp
, build_empty_stmt (input_location
));
4652 gfc_add_expr_to_block (&block
, tmp
);
4656 tmp
= gfc_finish_block (&block
);
4657 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4660 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4661 gfc_conv_ss_startstride (loop
);
4664 /* Return true if both symbols could refer to the same data object. Does
4665 not take account of aliasing due to equivalence statements. */
4668 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4669 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4671 /* Aliasing isn't possible if the symbols have different base types. */
4672 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4675 /* Pointers can point to other pointers and target objects. */
4677 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4678 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4681 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4682 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4684 if (lsym_target
&& rsym_target
4685 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4686 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4687 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4688 && (!rsym
->attr
.dimension
4689 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4696 /* Return true if the two SS could be aliased, i.e. both point to the same data
4698 /* TODO: resolve aliases based on frontend expressions. */
4701 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4705 gfc_expr
*lexpr
, *rexpr
;
4708 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4710 lexpr
= lss
->info
->expr
;
4711 rexpr
= rss
->info
->expr
;
4713 lsym
= lexpr
->symtree
->n
.sym
;
4714 rsym
= rexpr
->symtree
->n
.sym
;
4716 lsym_pointer
= lsym
->attr
.pointer
;
4717 lsym_target
= lsym
->attr
.target
;
4718 rsym_pointer
= rsym
->attr
.pointer
;
4719 rsym_target
= rsym
->attr
.target
;
4721 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4722 rsym_pointer
, rsym_target
))
4725 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4726 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4729 /* For derived types we must check all the component types. We can ignore
4730 array references as these will have the same base type as the previous
4732 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4734 if (lref
->type
!= REF_COMPONENT
)
4737 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4738 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4740 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4741 rsym_pointer
, rsym_target
))
4744 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4745 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4747 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4752 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4755 if (rref
->type
!= REF_COMPONENT
)
4758 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4759 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4761 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4762 lsym_pointer
, lsym_target
,
4763 rsym_pointer
, rsym_target
))
4766 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4767 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4769 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4770 &rref
->u
.c
.sym
->ts
))
4772 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4773 &rref
->u
.c
.component
->ts
))
4775 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4776 &rref
->u
.c
.component
->ts
))
4782 lsym_pointer
= lsym
->attr
.pointer
;
4783 lsym_target
= lsym
->attr
.target
;
4785 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4787 if (rref
->type
!= REF_COMPONENT
)
4790 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4791 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4793 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4794 lsym_pointer
, lsym_target
,
4795 rsym_pointer
, rsym_target
))
4798 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4799 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4801 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4810 /* Resolve array data dependencies. Creates a temporary if required. */
4811 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4815 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4821 gfc_ss_info
*ss_info
;
4822 gfc_expr
*dest_expr
;
4827 loop
->temp_ss
= NULL
;
4828 dest_expr
= dest
->info
->expr
;
4830 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4833 ss_expr
= ss_info
->expr
;
4835 if (ss_info
->array_outer_dependency
)
4841 if (ss_info
->type
!= GFC_SS_SECTION
)
4843 if (flag_realloc_lhs
4844 && dest_expr
!= ss_expr
4845 && gfc_is_reallocatable_lhs (dest_expr
)
4847 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4849 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4850 if (!nDepend
&& dest_expr
->rank
> 0
4851 && dest_expr
->ts
.type
== BT_CHARACTER
4852 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4854 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4856 if (ss_info
->type
== GFC_SS_REFERENCE
4857 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4858 ss_info
->data
.scalar
.needs_temporary
= 1;
4866 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4868 if (gfc_could_be_alias (dest
, ss
)
4869 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4877 lref
= dest_expr
->ref
;
4878 rref
= ss_expr
->ref
;
4880 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4885 for (i
= 0; i
< dest
->dimen
; i
++)
4886 for (j
= 0; j
< ss
->dimen
; j
++)
4888 && dest
->dim
[i
] == ss
->dim
[j
])
4890 /* If we don't access array elements in the same order,
4891 there is a dependency. */
4896 /* TODO : loop shifting. */
4899 /* Mark the dimensions for LOOP SHIFTING */
4900 for (n
= 0; n
< loop
->dimen
; n
++)
4902 int dim
= dest
->data
.info
.dim
[n
];
4904 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4906 else if (! gfc_is_same_range (&lref
->u
.ar
,
4907 &rref
->u
.ar
, dim
, 0))
4911 /* Put all the dimensions with dependencies in the
4914 for (n
= 0; n
< loop
->dimen
; n
++)
4916 gcc_assert (loop
->order
[n
] == n
);
4918 loop
->order
[dim
++] = n
;
4920 for (n
= 0; n
< loop
->dimen
; n
++)
4923 loop
->order
[dim
++] = n
;
4926 gcc_assert (dim
== loop
->dimen
);
4937 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4938 if (GFC_ARRAY_TYPE_P (base_type
)
4939 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4940 base_type
= gfc_get_element_type (base_type
);
4941 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4943 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4946 loop
->temp_ss
= NULL
;
4950 /* Browse through each array's information from the scalarizer and set the loop
4951 bounds according to the "best" one (per dimension), i.e. the one which
4952 provides the most information (constant bounds, shape, etc.). */
4955 set_loop_bounds (gfc_loopinfo
*loop
)
4957 int n
, dim
, spec_dim
;
4958 gfc_array_info
*info
;
4959 gfc_array_info
*specinfo
;
4963 bool dynamic
[GFC_MAX_DIMENSIONS
];
4966 bool nonoptional_arr
;
4968 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4970 loopspec
= loop
->specloop
;
4973 for (n
= 0; n
< loop
->dimen
; n
++)
4978 /* If there are both optional and nonoptional array arguments, scalarize
4979 over the nonoptional; otherwise, it does not matter as then all
4980 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4982 nonoptional_arr
= false;
4984 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4985 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4986 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4988 nonoptional_arr
= true;
4992 /* We use one SS term, and use that to determine the bounds of the
4993 loop for this dimension. We try to pick the simplest term. */
4994 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4996 gfc_ss_type ss_type
;
4998 ss_type
= ss
->info
->type
;
4999 if (ss_type
== GFC_SS_SCALAR
5000 || ss_type
== GFC_SS_TEMP
5001 || ss_type
== GFC_SS_REFERENCE
5002 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
5005 info
= &ss
->info
->data
.array
;
5008 if (loopspec
[n
] != NULL
)
5010 specinfo
= &loopspec
[n
]->info
->data
.array
;
5011 spec_dim
= loopspec
[n
]->dim
[n
];
5015 /* Silence uninitialized warnings. */
5022 gcc_assert (info
->shape
[dim
]);
5023 /* The frontend has worked out the size for us. */
5026 || !integer_zerop (specinfo
->start
[spec_dim
]))
5027 /* Prefer zero-based descriptors if possible. */
5032 if (ss_type
== GFC_SS_CONSTRUCTOR
)
5034 gfc_constructor_base base
;
5035 /* An unknown size constructor will always be rank one.
5036 Higher rank constructors will either have known shape,
5037 or still be wrapped in a call to reshape. */
5038 gcc_assert (loop
->dimen
== 1);
5040 /* Always prefer to use the constructor bounds if the size
5041 can be determined at compile time. Prefer not to otherwise,
5042 since the general case involves realloc, and it's better to
5043 avoid that overhead if possible. */
5044 base
= ss
->info
->expr
->value
.constructor
;
5045 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
5046 if (!dynamic
[n
] || !loopspec
[n
])
5051 /* Avoid using an allocatable lhs in an assignment, since
5052 there might be a reallocation coming. */
5053 if (loopspec
[n
] && ss
->is_alloc_lhs
)
5058 /* Criteria for choosing a loop specifier (most important first):
5059 doesn't need realloc
5065 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
5067 else if (integer_onep (info
->stride
[dim
])
5068 && !integer_onep (specinfo
->stride
[spec_dim
]))
5070 else if (INTEGER_CST_P (info
->stride
[dim
])
5071 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5073 else if (INTEGER_CST_P (info
->start
[dim
])
5074 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
5075 && integer_onep (info
->stride
[dim
])
5076 == integer_onep (specinfo
->stride
[spec_dim
])
5077 && INTEGER_CST_P (info
->stride
[dim
])
5078 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5080 /* We don't work out the upper bound.
5081 else if (INTEGER_CST_P (info->finish[n])
5082 && ! INTEGER_CST_P (specinfo->finish[n]))
5083 loopspec[n] = ss; */
5086 /* We should have found the scalarization loop specifier. If not,
5088 gcc_assert (loopspec
[n
]);
5090 info
= &loopspec
[n
]->info
->data
.array
;
5091 dim
= loopspec
[n
]->dim
[n
];
5093 /* Set the extents of this range. */
5094 cshape
= info
->shape
;
5095 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5096 && INTEGER_CST_P (info
->stride
[dim
]))
5098 loop
->from
[n
] = info
->start
[dim
];
5099 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5100 mpz_sub_ui (i
, i
, 1);
5101 /* To = from + (size - 1) * stride. */
5102 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5103 if (!integer_onep (info
->stride
[dim
]))
5104 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5105 gfc_array_index_type
, tmp
,
5107 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5108 gfc_array_index_type
,
5109 loop
->from
[n
], tmp
);
5113 loop
->from
[n
] = info
->start
[dim
];
5114 switch (loopspec
[n
]->info
->type
)
5116 case GFC_SS_CONSTRUCTOR
:
5117 /* The upper bound is calculated when we expand the
5119 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5122 case GFC_SS_SECTION
:
5123 /* Use the end expression if it exists and is not constant,
5124 so that it is only evaluated once. */
5125 loop
->to
[n
] = info
->end
[dim
];
5128 case GFC_SS_FUNCTION
:
5129 /* The loop bound will be set when we generate the call. */
5130 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5133 case GFC_SS_INTRINSIC
:
5135 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5137 /* The {l,u}bound of an assumed rank. */
5138 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5139 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5140 && expr
->value
.function
.actual
->next
->expr
== NULL
5141 && expr
->value
.function
.actual
->expr
->rank
== -1);
5143 loop
->to
[n
] = info
->end
[dim
];
5147 case GFC_SS_COMPONENT
:
5149 if (info
->end
[dim
] != NULL_TREE
)
5151 loop
->to
[n
] = info
->end
[dim
];
5163 /* Transform everything so we have a simple incrementing variable. */
5164 if (integer_onep (info
->stride
[dim
]))
5165 info
->delta
[dim
] = gfc_index_zero_node
;
5168 /* Set the delta for this section. */
5169 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5170 /* Number of iterations is (end - start + step) / step.
5171 with start = 0, this simplifies to
5173 for (i = 0; i<=last; i++){...}; */
5174 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5175 gfc_array_index_type
, loop
->to
[n
],
5177 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5178 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5179 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5180 tmp
, build_int_cst (gfc_array_index_type
, -1));
5181 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5182 /* Make the loop variable start at 0. */
5183 loop
->from
[n
] = gfc_index_zero_node
;
5188 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5189 set_loop_bounds (loop
);
5193 /* Initialize the scalarization loop. Creates the loop variables. Determines
5194 the range of the loop variables. Creates a temporary if required.
5195 Also generates code for scalar expressions which have been
5196 moved outside the loop. */
5199 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5204 set_loop_bounds (loop
);
5206 /* Add all the scalar code that can be taken out of the loops.
5207 This may include calculating the loop bounds, so do it before
5208 allocating the temporary. */
5209 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5211 tmp_ss
= loop
->temp_ss
;
5212 /* If we want a temporary then create it. */
5215 gfc_ss_info
*tmp_ss_info
;
5217 tmp_ss_info
= tmp_ss
->info
;
5218 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5219 gcc_assert (loop
->parent
== NULL
);
5221 /* Make absolutely sure that this is a complete type. */
5222 if (tmp_ss_info
->string_length
)
5223 tmp_ss_info
->data
.temp
.type
5224 = gfc_get_character_type_len_for_eltype
5225 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5226 tmp_ss_info
->string_length
);
5228 tmp
= tmp_ss_info
->data
.temp
.type
;
5229 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5230 tmp_ss_info
->type
= GFC_SS_SECTION
;
5232 gcc_assert (tmp_ss
->dimen
!= 0);
5234 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5235 NULL_TREE
, false, true, false, where
);
5238 /* For array parameters we don't have loop variables, so don't calculate the
5240 if (!loop
->array_parameter
)
5241 gfc_set_delta (loop
);
5245 /* Calculates how to transform from loop variables to array indices for each
5246 array: once loop bounds are chosen, sets the difference (DELTA field) between
5247 loop bounds and array reference bounds, for each array info. */
5250 gfc_set_delta (gfc_loopinfo
*loop
)
5252 gfc_ss
*ss
, **loopspec
;
5253 gfc_array_info
*info
;
5257 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5259 loopspec
= loop
->specloop
;
5261 /* Calculate the translation from loop variables to array indices. */
5262 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5264 gfc_ss_type ss_type
;
5266 ss_type
= ss
->info
->type
;
5267 if (ss_type
!= GFC_SS_SECTION
5268 && ss_type
!= GFC_SS_COMPONENT
5269 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5272 info
= &ss
->info
->data
.array
;
5274 for (n
= 0; n
< ss
->dimen
; n
++)
5276 /* If we are specifying the range the delta is already set. */
5277 if (loopspec
[n
] != ss
)
5281 /* Calculate the offset relative to the loop variable.
5282 First multiply by the stride. */
5283 tmp
= loop
->from
[n
];
5284 if (!integer_onep (info
->stride
[dim
]))
5285 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5286 gfc_array_index_type
,
5287 tmp
, info
->stride
[dim
]);
5289 /* Then subtract this from our starting value. */
5290 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5291 gfc_array_index_type
,
5292 info
->start
[dim
], tmp
);
5294 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5299 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5300 gfc_set_delta (loop
);
5304 /* Calculate the size of a given array dimension from the bounds. This
5305 is simply (ubound - lbound + 1) if this expression is positive
5306 or 0 if it is negative (pick either one if it is zero). Optionally
5307 (if or_expr is present) OR the (expression != 0) condition to it. */
5310 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5315 /* Calculate (ubound - lbound + 1). */
5316 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5318 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5319 gfc_index_one_node
);
5321 /* Check whether the size for this dimension is negative. */
5322 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5323 gfc_index_zero_node
);
5324 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5325 gfc_index_zero_node
, res
);
5327 /* Build OR expression. */
5329 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5330 logical_type_node
, *or_expr
, cond
);
5336 /* For an array descriptor, get the total number of elements. This is just
5337 the product of the extents along from_dim to to_dim. */
5340 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5345 res
= gfc_index_one_node
;
5347 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5353 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5354 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5356 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5357 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5365 /* Full size of an array. */
5368 gfc_conv_descriptor_size (tree desc
, int rank
)
5370 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5374 /* Size of a coarray for all dimensions but the last. */
5377 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5379 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5383 /* Fills in an array descriptor, and returns the size of the array.
5384 The size will be a simple_val, ie a variable or a constant. Also
5385 calculates the offset of the base. The pointer argument overflow,
5386 which should be of integer type, will increase in value if overflow
5387 occurs during the size calculation. Returns the size of the array.
5391 for (n = 0; n < rank; n++)
5393 a.lbound[n] = specified_lower_bound;
5394 offset = offset + a.lbond[n] * stride;
5396 a.ubound[n] = specified_upper_bound;
5397 a.stride[n] = stride;
5398 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5399 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5400 stride = stride * size;
5402 for (n = rank; n < rank+corank; n++)
5403 (Set lcobound/ucobound as above.)
5404 element_size = sizeof (array element);
5407 stride = (size_t) stride;
5408 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5409 stride = stride * element_size;
5415 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5416 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5417 stmtblock_t
* descriptor_block
, tree
* overflow
,
5418 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5419 tree expr3_desc
, bool e3_has_nodescriptor
, gfc_expr
*expr
,
5432 stmtblock_t thenblock
;
5433 stmtblock_t elseblock
;
5438 type
= TREE_TYPE (descriptor
);
5440 stride
= gfc_index_one_node
;
5441 offset
= gfc_index_zero_node
;
5443 /* Set the dtype before the alloc, because registration of coarrays needs
5445 if (expr
->ts
.type
== BT_CHARACTER
5446 && expr
->ts
.deferred
5447 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5449 type
= gfc_typenode_for_spec (&expr
->ts
);
5450 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5451 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5453 else if (expr
->ts
.type
== BT_CHARACTER
5454 && expr
->ts
.deferred
5455 && TREE_CODE (descriptor
) == COMPONENT_REF
)
5457 /* Deferred character components have their string length tucked away
5458 in a hidden field of the derived type. Obtain that and use it to
5459 set the dtype. The charlen backend decl is zero because the field
5460 type is zero length. */
5463 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5464 if (ref
->type
== REF_COMPONENT
5465 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
5467 gcc_assert (tmp
!= NULL_TREE
);
5468 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
5469 TREE_OPERAND (descriptor
, 0), tmp
, NULL_TREE
);
5470 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
5471 type
= gfc_get_character_type_len (expr
->ts
.kind
, tmp
);
5472 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5473 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5477 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5478 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5481 or_expr
= logical_false_node
;
5483 for (n
= 0; n
< rank
; n
++)
5488 /* We have 3 possibilities for determining the size of the array:
5489 lower == NULL => lbound = 1, ubound = upper[n]
5490 upper[n] = NULL => lbound = 1, ubound = lower[n]
5491 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5494 /* Set lower bound. */
5495 gfc_init_se (&se
, NULL
);
5496 if (expr3_desc
!= NULL_TREE
)
5498 if (e3_has_nodescriptor
)
5499 /* The lbound of nondescriptor arrays like array constructors,
5500 nonallocatable/nonpointer function results/variables,
5501 start at zero, but when allocating it, the standard expects
5502 the array to start at one. */
5503 se
.expr
= gfc_index_one_node
;
5505 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5508 else if (lower
== NULL
)
5509 se
.expr
= gfc_index_one_node
;
5512 gcc_assert (lower
[n
]);
5515 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5516 gfc_add_block_to_block (pblock
, &se
.pre
);
5520 se
.expr
= gfc_index_one_node
;
5524 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5525 gfc_rank_cst
[n
], se
.expr
);
5526 conv_lbound
= se
.expr
;
5528 /* Work out the offset for this component. */
5529 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5531 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5532 gfc_array_index_type
, offset
, tmp
);
5534 /* Set upper bound. */
5535 gfc_init_se (&se
, NULL
);
5536 if (expr3_desc
!= NULL_TREE
)
5538 if (e3_has_nodescriptor
)
5540 /* The lbound of nondescriptor arrays like array constructors,
5541 nonallocatable/nonpointer function results/variables,
5542 start at zero, but when allocating it, the standard expects
5543 the array to start at one. Therefore fix the upper bound to be
5544 (desc.ubound - desc.lbound) + 1. */
5545 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5546 gfc_array_index_type
,
5547 gfc_conv_descriptor_ubound_get (
5548 expr3_desc
, gfc_rank_cst
[n
]),
5549 gfc_conv_descriptor_lbound_get (
5550 expr3_desc
, gfc_rank_cst
[n
]));
5551 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5552 gfc_array_index_type
, tmp
,
5553 gfc_index_one_node
);
5554 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5557 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5562 gcc_assert (ubound
);
5563 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5564 gfc_add_block_to_block (pblock
, &se
.pre
);
5565 if (ubound
->expr_type
== EXPR_FUNCTION
)
5566 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5568 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5569 gfc_rank_cst
[n
], se
.expr
);
5570 conv_ubound
= se
.expr
;
5572 /* Store the stride. */
5573 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5574 gfc_rank_cst
[n
], stride
);
5576 /* Calculate size and check whether extent is negative. */
5577 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5578 size
= gfc_evaluate_now (size
, pblock
);
5580 /* Check whether multiplying the stride by the number of
5581 elements in this dimension would overflow. We must also check
5582 whether the current dimension has zero size in order to avoid
5585 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5586 gfc_array_index_type
,
5587 fold_convert (gfc_array_index_type
,
5588 TYPE_MAX_VALUE (gfc_array_index_type
)),
5590 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5591 logical_type_node
, tmp
, stride
),
5592 PRED_FORTRAN_OVERFLOW
);
5593 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5594 integer_one_node
, integer_zero_node
);
5595 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5596 logical_type_node
, size
,
5597 gfc_index_zero_node
),
5598 PRED_FORTRAN_SIZE_ZERO
);
5599 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5600 integer_zero_node
, tmp
);
5601 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5603 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5605 /* Multiply the stride by the number of elements in this dimension. */
5606 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5607 gfc_array_index_type
, stride
, size
);
5608 stride
= gfc_evaluate_now (stride
, pblock
);
5611 for (n
= rank
; n
< rank
+ corank
; n
++)
5615 /* Set lower bound. */
5616 gfc_init_se (&se
, NULL
);
5617 if (lower
== NULL
|| lower
[n
] == NULL
)
5619 gcc_assert (n
== rank
+ corank
- 1);
5620 se
.expr
= gfc_index_one_node
;
5624 if (ubound
|| n
== rank
+ corank
- 1)
5626 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5627 gfc_add_block_to_block (pblock
, &se
.pre
);
5631 se
.expr
= gfc_index_one_node
;
5635 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5636 gfc_rank_cst
[n
], se
.expr
);
5638 if (n
< rank
+ corank
- 1)
5640 gfc_init_se (&se
, NULL
);
5641 gcc_assert (ubound
);
5642 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5643 gfc_add_block_to_block (pblock
, &se
.pre
);
5644 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5645 gfc_rank_cst
[n
], se
.expr
);
5649 /* The stride is the number of elements in the array, so multiply by the
5650 size of an element to get the total size. Obviously, if there is a
5651 SOURCE expression (expr3) we must use its element size. */
5652 if (expr3_elem_size
!= NULL_TREE
)
5653 tmp
= expr3_elem_size
;
5654 else if (expr3
!= NULL
)
5656 if (expr3
->ts
.type
== BT_CLASS
)
5659 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5660 gfc_add_vptr_component (sz
);
5661 gfc_add_size_component (sz
);
5662 gfc_init_se (&se_sz
, NULL
);
5663 gfc_conv_expr (&se_sz
, sz
);
5669 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5670 tmp
= TYPE_SIZE_UNIT (tmp
);
5674 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5676 /* Convert to size_t. */
5677 *element_size
= fold_convert (size_type_node
, tmp
);
5680 return *element_size
;
5682 *nelems
= gfc_evaluate_now (stride
, pblock
);
5683 stride
= fold_convert (size_type_node
, stride
);
5685 /* First check for overflow. Since an array of type character can
5686 have zero element_size, we must check for that before
5688 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5690 TYPE_MAX_VALUE (size_type_node
), *element_size
);
5691 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5692 logical_type_node
, tmp
, stride
),
5693 PRED_FORTRAN_OVERFLOW
);
5694 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5695 integer_one_node
, integer_zero_node
);
5696 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5697 logical_type_node
, *element_size
,
5698 build_int_cst (size_type_node
, 0)),
5699 PRED_FORTRAN_SIZE_ZERO
);
5700 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5701 integer_zero_node
, tmp
);
5702 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5704 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5706 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5707 stride
, *element_size
);
5709 if (poffset
!= NULL
)
5711 offset
= gfc_evaluate_now (offset
, pblock
);
5715 if (integer_zerop (or_expr
))
5717 if (integer_onep (or_expr
))
5718 return build_int_cst (size_type_node
, 0);
5720 var
= gfc_create_var (TREE_TYPE (size
), "size");
5721 gfc_start_block (&thenblock
);
5722 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5723 thencase
= gfc_finish_block (&thenblock
);
5725 gfc_start_block (&elseblock
);
5726 gfc_add_modify (&elseblock
, var
, size
);
5727 elsecase
= gfc_finish_block (&elseblock
);
5729 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5730 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5731 gfc_add_expr_to_block (pblock
, tmp
);
5737 /* Retrieve the last ref from the chain. This routine is specific to
5738 gfc_array_allocate ()'s needs. */
5741 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5743 gfc_ref
*ref
, *prev_ref
;
5746 /* Prevent warnings for uninitialized variables. */
5747 prev_ref
= *prev_ref_in
;
5748 while (ref
&& ref
->next
!= NULL
)
5750 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5751 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5756 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5760 *prev_ref_in
= prev_ref
;
5764 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5765 the work for an ALLOCATE statement. */
5769 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5770 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5771 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5772 bool e3_has_nodescriptor
)
5776 tree offset
= NULL_TREE
;
5777 tree token
= NULL_TREE
;
5780 tree error
= NULL_TREE
;
5781 tree overflow
; /* Boolean storing whether size calculation overflows. */
5782 tree var_overflow
= NULL_TREE
;
5784 tree set_descriptor
;
5785 tree not_prev_allocated
= NULL_TREE
;
5786 tree element_size
= NULL_TREE
;
5787 stmtblock_t set_descriptor_block
;
5788 stmtblock_t elseblock
;
5791 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5792 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5793 non_ulimate_coarray_ptr_comp
;
5797 /* Find the last reference in the chain. */
5798 if (!retrieve_last_ref (&ref
, &prev_ref
))
5801 /* Take the allocatable and coarray properties solely from the expr-ref's
5802 attributes and not from source=-expression. */
5805 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5806 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5807 non_ulimate_coarray_ptr_comp
= false;
5811 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5812 /* Pointer components in coarrayed derived types must be treated
5813 specially in that they are registered without a check if the are
5814 already associated. This does not hold for ultimate coarray
5816 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5817 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5818 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5821 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5822 a coarray. In this case it does not matter whether we are on this_image
5825 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5826 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5833 gcc_assert (coarray
);
5835 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5837 gfc_ref
*old_ref
= ref
;
5838 /* F08:C633: Array shape from expr3. */
5841 /* Find the last reference in the chain. */
5842 if (!retrieve_last_ref (&ref
, &prev_ref
))
5844 if (expr3
->expr_type
== EXPR_FUNCTION
5845 && gfc_expr_attr (expr3
).dimension
)
5850 alloc_w_e3_arr_spec
= true;
5853 /* Figure out the size of the array. */
5854 switch (ref
->u
.ar
.type
)
5860 upper
= ref
->u
.ar
.start
;
5866 lower
= ref
->u
.ar
.start
;
5867 upper
= ref
->u
.ar
.end
;
5871 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5872 || alloc_w_e3_arr_spec
);
5874 lower
= ref
->u
.ar
.as
->lower
;
5875 upper
= ref
->u
.ar
.as
->upper
;
5883 overflow
= integer_zero_node
;
5885 if (expr
->ts
.type
== BT_CHARACTER
5886 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5887 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
5888 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5889 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5890 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5891 se
->string_length
));
5893 gfc_init_block (&set_descriptor_block
);
5894 /* Take the corank only from the actual ref and not from the coref. The
5895 later will mislead the generation of the array dimensions for allocatable/
5896 pointer components in derived types. */
5897 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5898 : ref
->u
.ar
.as
->rank
,
5899 coarray
? ref
->u
.ar
.as
->corank
: 0,
5900 &offset
, lower
, upper
,
5901 &se
->pre
, &set_descriptor_block
, &overflow
,
5902 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5903 e3_has_nodescriptor
, expr
, &element_size
);
5907 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5908 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5910 if (status
== NULL_TREE
)
5912 /* Generate the block of code handling overflow. */
5913 msg
= gfc_build_addr_expr (pchar_type_node
,
5914 gfc_build_localized_cstring_const
5915 ("Integer overflow when calculating the amount of "
5916 "memory to allocate"));
5917 error
= build_call_expr_loc (input_location
,
5918 gfor_fndecl_runtime_error
, 1, msg
);
5922 tree status_type
= TREE_TYPE (status
);
5923 stmtblock_t set_status_block
;
5925 gfc_start_block (&set_status_block
);
5926 gfc_add_modify (&set_status_block
, status
,
5927 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5928 error
= gfc_finish_block (&set_status_block
);
5932 /* Allocate memory to store the data. */
5933 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5934 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5936 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5938 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5939 : gfc_conv_descriptor_data_get (se
->expr
);
5940 token
= gfc_conv_descriptor_token (se
->expr
);
5941 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5944 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5945 STRIP_NOPS (pointer
);
5949 not_prev_allocated
= gfc_create_var (logical_type_node
,
5950 "not_prev_allocated");
5951 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5952 logical_type_node
, pointer
,
5953 build_int_cst (TREE_TYPE (pointer
), 0));
5955 gfc_add_modify (&se
->pre
, not_prev_allocated
, tmp
);
5958 gfc_start_block (&elseblock
);
5960 /* The allocatable variant takes the old pointer as first argument. */
5962 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5963 status
, errmsg
, errlen
, label_finish
, expr
,
5964 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5965 else if (non_ulimate_coarray_ptr_comp
&& token
)
5966 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5967 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5969 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5971 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5975 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5976 logical_type_node
, var_overflow
, integer_zero_node
),
5977 PRED_FORTRAN_OVERFLOW
);
5978 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5979 error
, gfc_finish_block (&elseblock
));
5982 tmp
= gfc_finish_block (&elseblock
);
5984 gfc_add_expr_to_block (&se
->pre
, tmp
);
5986 /* Update the array descriptor with the offset and the span. */
5989 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5990 tmp
= fold_convert (gfc_array_index_type
, element_size
);
5991 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5994 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5995 if (status
!= NULL_TREE
)
5997 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5998 logical_type_node
, status
,
5999 build_int_cst (TREE_TYPE (status
), 0));
6001 if (not_prev_allocated
!= NULL_TREE
)
6002 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6003 logical_type_node
, cond
, not_prev_allocated
);
6005 gfc_add_expr_to_block (&se
->pre
,
6006 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6009 build_empty_stmt (input_location
)));
6012 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
6018 /* Create an array constructor from an initialization expression.
6019 We assume the frontend already did any expansions and conversions. */
6022 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
6028 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6030 if (expr
->expr_type
== EXPR_VARIABLE
6031 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6032 && expr
->symtree
->n
.sym
->value
)
6033 expr
= expr
->symtree
->n
.sym
->value
;
6035 switch (expr
->expr_type
)
6038 case EXPR_STRUCTURE
:
6039 /* A single scalar or derived type value. Create an array with all
6040 elements equal to that value. */
6041 gfc_init_se (&se
, NULL
);
6043 if (expr
->expr_type
== EXPR_CONSTANT
)
6044 gfc_conv_constant (&se
, expr
);
6046 gfc_conv_structure (&se
, expr
, 1);
6048 CONSTRUCTOR_APPEND_ELT (v
, build2 (RANGE_EXPR
, gfc_array_index_type
,
6049 TYPE_MIN_VALUE (TYPE_DOMAIN (type
)),
6050 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))),
6055 /* Create a vector of all the elements. */
6056 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6057 c
; c
= gfc_constructor_next (c
))
6061 /* Problems occur when we get something like
6062 integer :: a(lots) = (/(i, i=1, lots)/) */
6063 gfc_fatal_error ("The number of elements in the array "
6064 "constructor at %L requires an increase of "
6065 "the allowed %d upper limit. See "
6066 "%<-fmax-array-constructor%> option",
6067 &expr
->where
, flag_max_array_constructor
);
6070 if (mpz_cmp_si (c
->offset
, 0) != 0)
6071 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6075 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6081 mpz_add (maxval
, c
->offset
, c
->repeat
);
6082 mpz_sub_ui (maxval
, maxval
, 1);
6083 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6084 if (mpz_cmp_si (c
->offset
, 0) != 0)
6086 mpz_add_ui (maxval
, c
->offset
, 1);
6087 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6090 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6092 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6098 gfc_init_se (&se
, NULL
);
6099 switch (c
->expr
->expr_type
)
6102 gfc_conv_constant (&se
, c
->expr
);
6104 /* See gfortran.dg/charlen_15.f90 for instance. */
6105 if (TREE_CODE (se
.expr
) == STRING_CST
6106 && TREE_CODE (type
) == ARRAY_TYPE
)
6109 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6110 atype
= TREE_TYPE (atype
);
6111 if (TREE_CODE (TREE_TYPE (atype
)) == INTEGER_TYPE
6112 && tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6113 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6115 unsigned HOST_WIDE_INT size
6116 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6117 const char *p
= TREE_STRING_POINTER (se
.expr
);
6119 se
.expr
= build_string (size
, p
);
6120 TREE_TYPE (se
.expr
) = atype
;
6125 case EXPR_STRUCTURE
:
6126 gfc_conv_structure (&se
, c
->expr
, 1);
6130 /* Catch those occasional beasts that do not simplify
6131 for one reason or another, assuming that if they are
6132 standard defying the frontend will catch them. */
6133 gfc_conv_expr (&se
, c
->expr
);
6137 if (range
== NULL_TREE
)
6138 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6141 if (index
!= NULL_TREE
)
6142 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6143 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6149 return gfc_build_null_descriptor (type
);
6155 /* Create a constructor from the list of elements. */
6156 tmp
= build_constructor (type
, v
);
6157 TREE_CONSTANT (tmp
) = 1;
6162 /* Generate code to evaluate non-constant coarray cobounds. */
6165 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6166 const gfc_symbol
*sym
)
6174 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6176 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6178 /* Evaluate non-constant array bound expressions. */
6179 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6180 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6182 gfc_init_se (&se
, NULL
);
6183 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6184 gfc_add_block_to_block (pblock
, &se
.pre
);
6185 gfc_add_modify (pblock
, lbound
, se
.expr
);
6187 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6188 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6190 gfc_init_se (&se
, NULL
);
6191 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6192 gfc_add_block_to_block (pblock
, &se
.pre
);
6193 gfc_add_modify (pblock
, ubound
, se
.expr
);
6199 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6200 returns the size (in elements) of the array. */
6203 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6204 stmtblock_t
* pblock
)
6217 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6219 size
= gfc_index_one_node
;
6220 offset
= gfc_index_zero_node
;
6221 for (dim
= 0; dim
< as
->rank
; dim
++)
6223 /* Evaluate non-constant array bound expressions. */
6224 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6225 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6227 gfc_init_se (&se
, NULL
);
6228 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6229 gfc_add_block_to_block (pblock
, &se
.pre
);
6230 gfc_add_modify (pblock
, lbound
, se
.expr
);
6232 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6233 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6235 gfc_init_se (&se
, NULL
);
6236 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6237 gfc_add_block_to_block (pblock
, &se
.pre
);
6238 gfc_add_modify (pblock
, ubound
, se
.expr
);
6240 /* The offset of this dimension. offset = offset - lbound * stride. */
6241 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6243 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6246 /* The size of this dimension, and the stride of the next. */
6247 if (dim
+ 1 < as
->rank
)
6248 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6250 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6252 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6254 /* Calculate stride = size * (ubound + 1 - lbound). */
6255 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6256 gfc_array_index_type
,
6257 gfc_index_one_node
, lbound
);
6258 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6259 gfc_array_index_type
, ubound
, tmp
);
6260 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6261 gfc_array_index_type
, size
, tmp
);
6263 gfc_add_modify (pblock
, stride
, tmp
);
6265 stride
= gfc_evaluate_now (tmp
, pblock
);
6267 /* Make sure that negative size arrays are translated
6268 to being zero size. */
6269 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6270 stride
, gfc_index_zero_node
);
6271 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6272 gfc_array_index_type
, tmp
,
6273 stride
, gfc_index_zero_node
);
6274 gfc_add_modify (pblock
, stride
, tmp
);
6280 gfc_trans_array_cobounds (type
, pblock
, sym
);
6281 gfc_trans_vla_type_sizes (sym
, pblock
);
6288 /* Generate code to initialize/allocate an array variable. */
6291 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6292 gfc_wrapped_block
* block
)
6296 tree tmp
= NULL_TREE
;
6303 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6305 /* Do nothing for USEd variables. */
6306 if (sym
->attr
.use_assoc
)
6309 type
= TREE_TYPE (decl
);
6310 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6311 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6313 gfc_init_block (&init
);
6315 /* Evaluate character string length. */
6316 if (sym
->ts
.type
== BT_CHARACTER
6317 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6319 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6321 gfc_trans_vla_type_sizes (sym
, &init
);
6323 /* Emit a DECL_EXPR for this variable, which will cause the
6324 gimplifier to allocate storage, and all that good stuff. */
6325 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6326 gfc_add_expr_to_block (&init
, tmp
);
6331 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6335 type
= TREE_TYPE (type
);
6337 gcc_assert (!sym
->attr
.use_assoc
);
6338 gcc_assert (!TREE_STATIC (decl
));
6339 gcc_assert (!sym
->module
);
6341 if (sym
->ts
.type
== BT_CHARACTER
6342 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6343 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6345 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6347 /* Don't actually allocate space for Cray Pointees. */
6348 if (sym
->attr
.cray_pointee
)
6350 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6351 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6353 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6357 if (flag_stack_arrays
)
6359 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6360 space
= build_decl (sym
->declared_at
.lb
->location
,
6361 VAR_DECL
, create_tmp_var_name ("A"),
6362 TREE_TYPE (TREE_TYPE (decl
)));
6363 gfc_trans_vla_type_sizes (sym
, &init
);
6367 /* The size is the number of elements in the array, so multiply by the
6368 size of an element to get the total size. */
6369 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6370 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6371 size
, fold_convert (gfc_array_index_type
, tmp
));
6373 /* Allocate memory to hold the data. */
6374 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6375 gfc_add_modify (&init
, decl
, tmp
);
6377 /* Free the temporary. */
6378 tmp
= gfc_call_free (decl
);
6382 /* Set offset of the array. */
6383 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6384 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6386 /* Automatic arrays should not have initializers. */
6387 gcc_assert (!sym
->value
);
6389 inittree
= gfc_finish_block (&init
);
6396 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6397 where also space is located. */
6398 gfc_init_block (&init
);
6399 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6400 TREE_TYPE (space
), space
);
6401 gfc_add_expr_to_block (&init
, tmp
);
6402 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6403 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6404 gfc_add_modify (&init
, decl
, addr
);
6405 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6408 gfc_add_init_cleanup (block
, inittree
, tmp
);
6412 /* Generate entry and exit code for g77 calling convention arrays. */
6415 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6425 gfc_save_backend_locus (&loc
);
6426 gfc_set_backend_locus (&sym
->declared_at
);
6428 /* Descriptor type. */
6429 parm
= sym
->backend_decl
;
6430 type
= TREE_TYPE (parm
);
6431 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6433 gfc_start_block (&init
);
6435 if (sym
->ts
.type
== BT_CHARACTER
6436 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6437 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6439 /* Evaluate the bounds of the array. */
6440 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6442 /* Set the offset. */
6443 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6444 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6446 /* Set the pointer itself if we aren't using the parameter directly. */
6447 if (TREE_CODE (parm
) != PARM_DECL
)
6449 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6450 gfc_add_modify (&init
, parm
, tmp
);
6452 stmt
= gfc_finish_block (&init
);
6454 gfc_restore_backend_locus (&loc
);
6456 /* Add the initialization code to the start of the function. */
6458 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6460 tmp
= gfc_conv_expr_present (sym
);
6461 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6464 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6468 /* Modify the descriptor of an array parameter so that it has the
6469 correct lower bound. Also move the upper bound accordingly.
6470 If the array is not packed, it will be copied into a temporary.
6471 For each dimension we set the new lower and upper bounds. Then we copy the
6472 stride and calculate the offset for this dimension. We also work out
6473 what the stride of a packed array would be, and see it the two match.
6474 If the array need repacking, we set the stride to the values we just
6475 calculated, recalculate the offset and copy the array data.
6476 Code is also added to copy the data back at the end of the function.
6480 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6481 gfc_wrapped_block
* block
)
6488 tree stmtInit
, stmtCleanup
;
6495 tree stride
, stride2
;
6505 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6507 /* Do nothing for pointer and allocatable arrays. */
6508 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6509 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6510 || sym
->attr
.allocatable
6511 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6514 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6516 gfc_trans_g77_array (sym
, block
);
6521 gfc_save_backend_locus (&loc
);
6522 /* loc.nextc is not set by save_backend_locus but the location routines
6524 if (loc
.nextc
== NULL
)
6525 loc
.nextc
= loc
.lb
->line
;
6526 gfc_set_backend_locus (&sym
->declared_at
);
6528 /* Descriptor type. */
6529 type
= TREE_TYPE (tmpdesc
);
6530 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6531 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6533 /* For a class array the dummy array descriptor is in the _class
6535 dumdesc
= gfc_class_data_get (dumdesc
);
6537 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6538 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6539 gfc_start_block (&init
);
6541 if (sym
->ts
.type
== BT_CHARACTER
6542 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6543 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6545 checkparm
= (as
->type
== AS_EXPLICIT
6546 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6548 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6549 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6551 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6553 /* For non-constant shape arrays we only check if the first dimension
6554 is contiguous. Repacking higher dimensions wouldn't gain us
6555 anything as we still don't know the array stride. */
6556 partial
= gfc_create_var (logical_type_node
, "partial");
6557 TREE_USED (partial
) = 1;
6558 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6559 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6560 gfc_index_one_node
);
6561 gfc_add_modify (&init
, partial
, tmp
);
6564 partial
= NULL_TREE
;
6566 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6567 here, however I think it does the right thing. */
6570 /* Set the first stride. */
6571 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6572 stride
= gfc_evaluate_now (stride
, &init
);
6574 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6575 stride
, gfc_index_zero_node
);
6576 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6577 tmp
, gfc_index_one_node
, stride
);
6578 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6579 gfc_add_modify (&init
, stride
, tmp
);
6581 /* Allow the user to disable array repacking. */
6582 stmt_unpacked
= NULL_TREE
;
6586 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6587 /* A library call to repack the array if necessary. */
6588 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6589 stmt_unpacked
= build_call_expr_loc (input_location
,
6590 gfor_fndecl_in_pack
, 1, tmp
);
6592 stride
= gfc_index_one_node
;
6594 if (warn_array_temporaries
)
6595 gfc_warning (OPT_Warray_temporaries
,
6596 "Creating array temporary at %L", &loc
);
6599 /* This is for the case where the array data is used directly without
6600 calling the repack function. */
6601 if (no_repack
|| partial
!= NULL_TREE
)
6602 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6604 stmt_packed
= NULL_TREE
;
6606 /* Assign the data pointer. */
6607 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6609 /* Don't repack unknown shape arrays when the first stride is 1. */
6610 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6611 partial
, stmt_packed
, stmt_unpacked
);
6614 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6615 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6617 offset
= gfc_index_zero_node
;
6618 size
= gfc_index_one_node
;
6620 /* Evaluate the bounds of the array. */
6621 for (n
= 0; n
< as
->rank
; n
++)
6623 if (checkparm
|| !as
->upper
[n
])
6625 /* Get the bounds of the actual parameter. */
6626 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6627 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6631 dubound
= NULL_TREE
;
6632 dlbound
= NULL_TREE
;
6635 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6636 if (!INTEGER_CST_P (lbound
))
6638 gfc_init_se (&se
, NULL
);
6639 gfc_conv_expr_type (&se
, as
->lower
[n
],
6640 gfc_array_index_type
);
6641 gfc_add_block_to_block (&init
, &se
.pre
);
6642 gfc_add_modify (&init
, lbound
, se
.expr
);
6645 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6646 /* Set the desired upper bound. */
6649 /* We know what we want the upper bound to be. */
6650 if (!INTEGER_CST_P (ubound
))
6652 gfc_init_se (&se
, NULL
);
6653 gfc_conv_expr_type (&se
, as
->upper
[n
],
6654 gfc_array_index_type
);
6655 gfc_add_block_to_block (&init
, &se
.pre
);
6656 gfc_add_modify (&init
, ubound
, se
.expr
);
6659 /* Check the sizes match. */
6662 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6666 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6667 gfc_array_index_type
, ubound
, lbound
);
6668 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6669 gfc_array_index_type
,
6670 gfc_index_one_node
, temp
);
6671 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6672 gfc_array_index_type
, dubound
,
6674 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6675 gfc_array_index_type
,
6676 gfc_index_one_node
, stride2
);
6677 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6678 gfc_array_index_type
, temp
, stride2
);
6679 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6680 "%%ld instead of %%ld", n
+1, sym
->name
);
6682 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6683 fold_convert (long_integer_type_node
, temp
),
6684 fold_convert (long_integer_type_node
, stride2
));
6691 /* For assumed shape arrays move the upper bound by the same amount
6692 as the lower bound. */
6693 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6694 gfc_array_index_type
, dubound
, dlbound
);
6695 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6696 gfc_array_index_type
, tmp
, lbound
);
6697 gfc_add_modify (&init
, ubound
, tmp
);
6699 /* The offset of this dimension. offset = offset - lbound * stride. */
6700 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6702 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6703 gfc_array_index_type
, offset
, tmp
);
6705 /* The size of this dimension, and the stride of the next. */
6706 if (n
+ 1 < as
->rank
)
6708 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6710 if (no_repack
|| partial
!= NULL_TREE
)
6712 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6714 /* Figure out the stride if not a known constant. */
6715 if (!INTEGER_CST_P (stride
))
6718 stmt_packed
= NULL_TREE
;
6721 /* Calculate stride = size * (ubound + 1 - lbound). */
6722 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6723 gfc_array_index_type
,
6724 gfc_index_one_node
, lbound
);
6725 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6726 gfc_array_index_type
, ubound
, tmp
);
6727 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6728 gfc_array_index_type
, size
, tmp
);
6732 /* Assign the stride. */
6733 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6734 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6735 gfc_array_index_type
, partial
,
6736 stmt_unpacked
, stmt_packed
);
6738 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6739 gfc_add_modify (&init
, stride
, tmp
);
6744 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6746 if (stride
&& !INTEGER_CST_P (stride
))
6748 /* Calculate size = stride * (ubound + 1 - lbound). */
6749 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6750 gfc_array_index_type
,
6751 gfc_index_one_node
, lbound
);
6752 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6753 gfc_array_index_type
,
6755 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6756 gfc_array_index_type
,
6757 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6758 gfc_add_modify (&init
, stride
, tmp
);
6763 gfc_trans_array_cobounds (type
, &init
, sym
);
6765 /* Set the offset. */
6766 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6767 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6769 gfc_trans_vla_type_sizes (sym
, &init
);
6771 stmtInit
= gfc_finish_block (&init
);
6773 /* Only do the entry/initialization code if the arg is present. */
6774 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6775 optional_arg
= (sym
->attr
.optional
6776 || (sym
->ns
->proc_name
->attr
.entry_master
6777 && sym
->attr
.dummy
));
6780 tmp
= gfc_conv_expr_present (sym
);
6781 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6782 build_empty_stmt (input_location
));
6787 stmtCleanup
= NULL_TREE
;
6790 stmtblock_t cleanup
;
6791 gfc_start_block (&cleanup
);
6793 if (sym
->attr
.intent
!= INTENT_IN
)
6795 /* Copy the data back. */
6796 tmp
= build_call_expr_loc (input_location
,
6797 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6798 gfc_add_expr_to_block (&cleanup
, tmp
);
6801 /* Free the temporary. */
6802 tmp
= gfc_call_free (tmpdesc
);
6803 gfc_add_expr_to_block (&cleanup
, tmp
);
6805 stmtCleanup
= gfc_finish_block (&cleanup
);
6807 /* Only do the cleanup if the array was repacked. */
6809 /* For a class array the dummy array descriptor is in the _class
6811 tmp
= gfc_class_data_get (dumdesc
);
6813 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6814 tmp
= gfc_conv_descriptor_data_get (tmp
);
6815 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6817 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6818 build_empty_stmt (input_location
));
6822 tmp
= gfc_conv_expr_present (sym
);
6823 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6824 build_empty_stmt (input_location
));
6828 /* We don't need to free any memory allocated by internal_pack as it will
6829 be freed at the end of the function by pop_context. */
6830 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6832 gfc_restore_backend_locus (&loc
);
6836 /* Calculate the overall offset, including subreferences. */
6838 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6839 bool subref
, gfc_expr
*expr
)
6849 /* If offset is NULL and this is not a subreferenced array, there is
6851 if (offset
== NULL_TREE
)
6854 offset
= gfc_index_zero_node
;
6859 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6861 /* Offset the data pointer for pointer assignments from arrays with
6862 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6865 /* Go past the array reference. */
6866 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6867 if (ref
->type
== REF_ARRAY
&&
6868 ref
->u
.ar
.type
!= AR_ELEMENT
)
6874 /* Calculate the offset for each subsequent subreference. */
6875 for (; ref
; ref
= ref
->next
)
6880 field
= ref
->u
.c
.component
->backend_decl
;
6881 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6882 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6884 tmp
, field
, NULL_TREE
);
6888 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6889 gfc_init_se (&start
, NULL
);
6890 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6891 gfc_add_block_to_block (block
, &start
.pre
);
6892 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6896 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6897 && ref
->u
.ar
.type
== AR_ELEMENT
);
6899 /* TODO - Add bounds checking. */
6900 stride
= gfc_index_one_node
;
6901 index
= gfc_index_zero_node
;
6902 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6907 /* Update the index. */
6908 gfc_init_se (&start
, NULL
);
6909 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6910 itmp
= gfc_evaluate_now (start
.expr
, block
);
6911 gfc_init_se (&start
, NULL
);
6912 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6913 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6914 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6915 gfc_array_index_type
, itmp
, jtmp
);
6916 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6917 gfc_array_index_type
, itmp
, stride
);
6918 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6919 gfc_array_index_type
, itmp
, index
);
6920 index
= gfc_evaluate_now (index
, block
);
6922 /* Update the stride. */
6923 gfc_init_se (&start
, NULL
);
6924 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6925 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6926 gfc_array_index_type
, start
.expr
,
6928 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6929 gfc_array_index_type
,
6930 gfc_index_one_node
, itmp
);
6931 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6932 gfc_array_index_type
, stride
, itmp
);
6933 stride
= gfc_evaluate_now (stride
, block
);
6936 /* Apply the index to obtain the array element. */
6937 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6947 /* Set the target data pointer. */
6948 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6949 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6953 /* gfc_conv_expr_descriptor needs the string length an expression
6954 so that the size of the temporary can be obtained. This is done
6955 by adding up the string lengths of all the elements in the
6956 expression. Function with non-constant expressions have their
6957 string lengths mapped onto the actual arguments using the
6958 interface mapping machinery in trans-expr.c. */
6960 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6962 gfc_interface_mapping mapping
;
6963 gfc_formal_arglist
*formal
;
6964 gfc_actual_arglist
*arg
;
6968 if (expr
->ts
.u
.cl
->length
6969 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6971 if (!expr
->ts
.u
.cl
->backend_decl
)
6972 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6976 switch (expr
->expr_type
)
6980 /* This is somewhat brutal. The expression for the first
6981 element of the array is evaluated and assigned to a
6982 new string length for the original expression. */
6983 e
= gfc_constructor_first (expr
->value
.constructor
)->expr
;
6985 gfc_init_se (&tse
, NULL
);
6987 gfc_conv_expr_descriptor (&tse
, e
);
6989 gfc_conv_expr (&tse
, e
);
6991 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6992 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6994 if (!expr
->ts
.u
.cl
->backend_decl
|| !VAR_P (expr
->ts
.u
.cl
->backend_decl
))
6996 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
6997 expr
->ts
.u
.cl
->backend_decl
=
6998 gfc_create_var (gfc_charlen_type_node
, "sln");
7001 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7007 get_array_charlen (expr
->value
.op
.op1
, se
);
7009 /* For parentheses the expression ts.u.cl is identical. */
7010 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
7013 expr
->ts
.u
.cl
->backend_decl
=
7014 gfc_create_var (gfc_charlen_type_node
, "sln");
7016 if (expr
->value
.op
.op2
)
7018 get_array_charlen (expr
->value
.op
.op2
, se
);
7020 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
7022 /* Add the string lengths and assign them to the expression
7023 string length backend declaration. */
7024 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7025 fold_build2_loc (input_location
, PLUS_EXPR
,
7026 gfc_charlen_type_node
,
7027 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
7028 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
7031 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7032 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
7036 if (expr
->value
.function
.esym
== NULL
7037 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7039 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7043 /* Map expressions involving the dummy arguments onto the actual
7044 argument expressions. */
7045 gfc_init_interface_mapping (&mapping
);
7046 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
7047 arg
= expr
->value
.function
.actual
;
7049 /* Set se = NULL in the calls to the interface mapping, to suppress any
7051 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
7056 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
7059 gfc_init_se (&tse
, NULL
);
7061 /* Build the expression for the character length and convert it. */
7062 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
7064 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7065 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7066 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
7067 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7068 TREE_TYPE (tse
.expr
), tse
.expr
,
7069 build_zero_cst (TREE_TYPE (tse
.expr
)));
7070 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
7071 gfc_free_interface_mapping (&mapping
);
7075 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7081 /* Helper function to check dimensions. */
7083 transposed_dims (gfc_ss
*ss
)
7087 for (n
= 0; n
< ss
->dimen
; n
++)
7088 if (ss
->dim
[n
] != n
)
7094 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7095 AR_FULL, suitable for the scalarizer. */
7098 walk_coarray (gfc_expr
*e
)
7102 gcc_assert (gfc_get_corank (e
) > 0);
7104 ss
= gfc_walk_expr (e
);
7106 /* Fix scalar coarray. */
7107 if (ss
== gfc_ss_terminator
)
7114 if (ref
->type
== REF_ARRAY
7115 && ref
->u
.ar
.codimen
> 0)
7121 gcc_assert (ref
!= NULL
);
7122 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7123 ref
->u
.ar
.type
= AR_SECTION
;
7124 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7131 /* Convert an array for passing as an actual argument. Expressions and
7132 vector subscripts are evaluated and stored in a temporary, which is then
7133 passed. For whole arrays the descriptor is passed. For array sections
7134 a modified copy of the descriptor is passed, but using the original data.
7136 This function is also used for array pointer assignments, and there
7139 - se->want_pointer && !se->direct_byref
7140 EXPR is an actual argument. On exit, se->expr contains a
7141 pointer to the array descriptor.
7143 - !se->want_pointer && !se->direct_byref
7144 EXPR is an actual argument to an intrinsic function or the
7145 left-hand side of a pointer assignment. On exit, se->expr
7146 contains the descriptor for EXPR.
7148 - !se->want_pointer && se->direct_byref
7149 EXPR is the right-hand side of a pointer assignment and
7150 se->expr is the descriptor for the previously-evaluated
7151 left-hand side. The function creates an assignment from
7155 The se->force_tmp flag disables the non-copying descriptor optimization
7156 that is used for transpose. It may be used in cases where there is an
7157 alias between the transpose argument and another argument in the same
7161 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7164 gfc_ss_type ss_type
;
7165 gfc_ss_info
*ss_info
;
7167 gfc_array_info
*info
;
7176 bool subref_array_target
= false;
7177 bool deferred_array_component
= false;
7178 gfc_expr
*arg
, *ss_expr
;
7180 if (se
->want_coarray
)
7181 ss
= walk_coarray (expr
);
7183 ss
= gfc_walk_expr (expr
);
7185 gcc_assert (ss
!= NULL
);
7186 gcc_assert (ss
!= gfc_ss_terminator
);
7189 ss_type
= ss_info
->type
;
7190 ss_expr
= ss_info
->expr
;
7192 /* Special case: TRANSPOSE which needs no temporary. */
7193 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7194 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7196 /* This is a call to transpose which has already been handled by the
7197 scalarizer, so that we just need to get its argument's descriptor. */
7198 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7199 expr
= expr
->value
.function
.actual
->expr
;
7202 /* Special case things we know we can pass easily. */
7203 switch (expr
->expr_type
)
7206 /* If we have a linear array section, we can pass it directly.
7207 Otherwise we need to copy it into a temporary. */
7209 gcc_assert (ss_type
== GFC_SS_SECTION
);
7210 gcc_assert (ss_expr
== expr
);
7211 info
= &ss_info
->data
.array
;
7213 /* Get the descriptor for the array. */
7214 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7215 desc
= info
->descriptor
;
7217 /* The charlen backend decl for deferred character components cannot
7218 be used because it is fixed at zero. Instead, the hidden string
7219 length component is used. */
7220 if (expr
->ts
.type
== BT_CHARACTER
7221 && expr
->ts
.deferred
7222 && TREE_CODE (desc
) == COMPONENT_REF
)
7223 deferred_array_component
= true;
7225 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7226 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7227 && !subref_array_target
;
7231 else if (se
->force_no_tmp
)
7236 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7238 /* Create a new descriptor if the array doesn't have one. */
7241 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7243 else if (se
->direct_byref
)
7246 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7248 if (full
&& !transposed_dims (ss
))
7250 if (se
->direct_byref
&& !se
->byref_noassign
)
7252 /* Copy the descriptor for pointer assignments. */
7253 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7255 /* Add any offsets from subreferences. */
7256 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7257 subref_array_target
, expr
);
7259 /* ....and set the span field. */
7260 tmp
= gfc_get_array_span (desc
, expr
);
7261 if (tmp
!= NULL_TREE
&& !integer_zerop (tmp
))
7262 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7264 else if (se
->want_pointer
)
7266 /* We pass full arrays directly. This means that pointers and
7267 allocatable arrays should also work. */
7268 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7275 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7276 se
->string_length
= gfc_get_expr_charlen (expr
);
7277 /* The ss_info string length is returned set to the value of the
7278 hidden string length component. */
7279 else if (deferred_array_component
)
7280 se
->string_length
= ss_info
->string_length
;
7282 gfc_free_ss_chain (ss
);
7288 /* A transformational function return value will be a temporary
7289 array descriptor. We still need to go through the scalarizer
7290 to create the descriptor. Elemental functions are handled as
7291 arbitrary expressions, i.e. copy to a temporary. */
7293 if (se
->direct_byref
)
7295 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7297 /* For pointer assignments pass the descriptor directly. */
7301 gcc_assert (se
->ss
== ss
);
7303 if (!is_pointer_array (se
->expr
))
7305 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7306 tmp
= fold_convert (gfc_array_index_type
,
7307 size_in_bytes (tmp
));
7308 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7311 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7312 gfc_conv_expr (se
, expr
);
7314 gfc_free_ss_chain (ss
);
7318 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7320 if (ss_expr
!= expr
)
7321 /* Elemental function. */
7322 gcc_assert ((expr
->value
.function
.esym
!= NULL
7323 && expr
->value
.function
.esym
->attr
.elemental
)
7324 || (expr
->value
.function
.isym
!= NULL
7325 && expr
->value
.function
.isym
->elemental
)
7326 || gfc_inline_intrinsic_function_p (expr
));
7328 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7331 if (expr
->ts
.type
== BT_CHARACTER
7332 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7333 get_array_charlen (expr
, se
);
7339 /* Transformational function. */
7340 info
= &ss_info
->data
.array
;
7346 /* Constant array constructors don't need a temporary. */
7347 if (ss_type
== GFC_SS_CONSTRUCTOR
7348 && expr
->ts
.type
!= BT_CHARACTER
7349 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7352 info
= &ss_info
->data
.array
;
7362 /* Something complicated. Copy it into a temporary. */
7368 /* If we are creating a temporary, we don't need to bother about aliases
7373 gfc_init_loopinfo (&loop
);
7375 /* Associate the SS with the loop. */
7376 gfc_add_ss_to_loop (&loop
, ss
);
7378 /* Tell the scalarizer not to bother creating loop variables, etc. */
7380 loop
.array_parameter
= 1;
7382 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7383 gcc_assert (!se
->direct_byref
);
7385 /* Do we need bounds checking or not? */
7386 ss
->no_bounds_check
= expr
->no_bounds_check
;
7388 /* Setup the scalarizing loops and bounds. */
7389 gfc_conv_ss_startstride (&loop
);
7393 if (expr
->ts
.type
== BT_CHARACTER
7394 && (!expr
->ts
.u
.cl
->backend_decl
|| expr
->expr_type
== EXPR_ARRAY
))
7395 get_array_charlen (expr
, se
);
7397 /* Tell the scalarizer to make a temporary. */
7398 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7399 ((expr
->ts
.type
== BT_CHARACTER
)
7400 ? expr
->ts
.u
.cl
->backend_decl
7404 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7405 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7406 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7409 gfc_conv_loop_setup (&loop
, & expr
->where
);
7413 /* Copy into a temporary and pass that. We don't need to copy the data
7414 back because expressions and vector subscripts must be INTENT_IN. */
7415 /* TODO: Optimize passing function return values. */
7420 /* Start the copying loops. */
7421 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7422 gfc_mark_ss_chain_used (ss
, 1);
7423 gfc_start_scalarized_body (&loop
, &block
);
7425 /* Copy each data element. */
7426 gfc_init_se (&lse
, NULL
);
7427 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7428 gfc_init_se (&rse
, NULL
);
7429 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7431 lse
.ss
= loop
.temp_ss
;
7434 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7435 if (expr
->ts
.type
== BT_CHARACTER
)
7437 gfc_conv_expr (&rse
, expr
);
7438 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7439 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7443 gfc_conv_expr_val (&rse
, expr
);
7445 gfc_add_block_to_block (&block
, &rse
.pre
);
7446 gfc_add_block_to_block (&block
, &lse
.pre
);
7448 lse
.string_length
= rse
.string_length
;
7450 deep_copy
= !se
->data_not_needed
7451 && (expr
->expr_type
== EXPR_VARIABLE
7452 || expr
->expr_type
== EXPR_ARRAY
);
7453 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7455 gfc_add_expr_to_block (&block
, tmp
);
7457 /* Finish the copying loops. */
7458 gfc_trans_scalarizing_loops (&loop
, &block
);
7460 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7462 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7464 desc
= info
->descriptor
;
7465 se
->string_length
= ss_info
->string_length
;
7469 /* We pass sections without copying to a temporary. Make a new
7470 descriptor and point it at the section we want. The loop variable
7471 limits will be the limits of the section.
7472 A function may decide to repack the array to speed up access, but
7473 we're not bothered about that here. */
7474 int dim
, ndim
, codim
;
7481 bool onebased
= false, rank_remap
;
7483 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7484 rank_remap
= ss
->dimen
< ndim
;
7486 if (se
->want_coarray
)
7488 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7490 codim
= gfc_get_corank (expr
);
7491 for (n
= 0; n
< codim
- 1; n
++)
7493 /* Make sure we are not lost somehow. */
7494 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7496 /* Make sure the call to gfc_conv_section_startstride won't
7497 generate unnecessary code to calculate stride. */
7498 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7500 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7501 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7502 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7505 gcc_assert (n
== codim
- 1);
7506 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7507 info
->descriptor
, n
+ ndim
, true,
7508 ar
->as
->type
== AS_DEFERRED
);
7509 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7514 /* Set the string_length for a character array. */
7515 if (expr
->ts
.type
== BT_CHARACTER
)
7517 se
->string_length
= gfc_get_expr_charlen (expr
);
7518 if (VAR_P (se
->string_length
)
7519 && expr
->ts
.u
.cl
->backend_decl
== se
->string_length
)
7520 tmp
= ss_info
->string_length
;
7522 tmp
= se
->string_length
;
7524 if (expr
->ts
.deferred
)
7525 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
, tmp
);
7528 /* If we have an array section or are assigning make sure that
7529 the lower bound is 1. References to the full
7530 array should otherwise keep the original bounds. */
7531 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7532 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7533 if (!integer_onep (loop
.from
[dim
]))
7535 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7536 gfc_array_index_type
, gfc_index_one_node
,
7538 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7539 gfc_array_index_type
,
7541 loop
.from
[dim
] = gfc_index_one_node
;
7544 desc
= info
->descriptor
;
7545 if (se
->direct_byref
&& !se
->byref_noassign
)
7547 /* For pointer assignments we fill in the destination. */
7549 parmtype
= TREE_TYPE (parm
);
7553 /* Otherwise make a new one. */
7554 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7555 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7557 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7559 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7560 loop
.from
, loop
.to
, 0,
7561 GFC_ARRAY_UNKNOWN
, false);
7562 parm
= gfc_create_var (parmtype
, "parm");
7564 /* When expression is a class object, then add the class' handle to
7566 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7568 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7571 /* class_expr can be NULL, when no _class ref is in expr.
7572 We must not fix this here with a gfc_fix_class_ref (). */
7575 gfc_init_se (&classse
, NULL
);
7576 gfc_conv_expr (&classse
, class_expr
);
7577 gfc_free_expr (class_expr
);
7579 gcc_assert (classse
.pre
.head
== NULL_TREE
7580 && classse
.post
.head
== NULL_TREE
);
7581 gfc_allocate_lang_decl (parm
);
7582 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7587 /* Set the span field. */
7588 if (expr
->ts
.type
== BT_CHARACTER
&& ss_info
->string_length
)
7589 tmp
= ss_info
->string_length
;
7591 tmp
= gfc_get_array_span (desc
, expr
);
7592 if (tmp
!= NULL_TREE
)
7593 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7595 offset
= gfc_index_zero_node
;
7597 /* The following can be somewhat confusing. We have two
7598 descriptors, a new one and the original array.
7599 {parm, parmtype, dim} refer to the new one.
7600 {desc, type, n, loop} refer to the original, which maybe
7601 a descriptorless array.
7602 The bounds of the scalarization are the bounds of the section.
7603 We don't have to worry about numeric overflows when calculating
7604 the offsets because all elements are within the array data. */
7606 /* Set the dtype. */
7607 tmp
= gfc_conv_descriptor_dtype (parm
);
7608 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7610 /* Set offset for assignments to pointer only to zero if it is not
7612 if ((se
->direct_byref
|| se
->use_offset
)
7613 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7614 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7615 base
= gfc_index_zero_node
;
7616 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7617 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7621 for (n
= 0; n
< ndim
; n
++)
7623 stride
= gfc_conv_array_stride (desc
, n
);
7625 /* Work out the offset. */
7627 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7629 gcc_assert (info
->subscript
[n
]
7630 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7631 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7635 /* Evaluate and remember the start of the section. */
7636 start
= info
->start
[n
];
7637 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7640 tmp
= gfc_conv_array_lbound (desc
, n
);
7641 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7643 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7645 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7649 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7651 /* For elemental dimensions, we only need the offset. */
7655 /* Vector subscripts need copying and are handled elsewhere. */
7657 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7659 /* look for the corresponding scalarizer dimension: dim. */
7660 for (dim
= 0; dim
< ndim
; dim
++)
7661 if (ss
->dim
[dim
] == n
)
7664 /* loop exited early: the DIM being looked for has been found. */
7665 gcc_assert (dim
< ndim
);
7667 /* Set the new lower bound. */
7668 from
= loop
.from
[dim
];
7671 onebased
= integer_onep (from
);
7672 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7673 gfc_rank_cst
[dim
], from
);
7675 /* Set the new upper bound. */
7676 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7677 gfc_rank_cst
[dim
], to
);
7679 /* Multiply the stride by the section stride to get the
7681 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7682 gfc_array_index_type
,
7683 stride
, info
->stride
[n
]);
7685 if ((se
->direct_byref
|| se
->use_offset
)
7686 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7687 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7689 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7690 TREE_TYPE (base
), base
, stride
);
7692 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7695 tmp
= gfc_conv_array_lbound (desc
, n
);
7696 toonebased
= integer_onep (tmp
);
7697 // lb(arr) - from (- start + 1)
7698 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7699 TREE_TYPE (base
), tmp
, from
);
7700 if (onebased
&& toonebased
)
7702 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7703 TREE_TYPE (base
), tmp
, start
);
7704 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7705 TREE_TYPE (base
), tmp
,
7706 gfc_index_one_node
);
7708 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7709 TREE_TYPE (base
), tmp
,
7710 gfc_conv_array_stride (desc
, n
));
7711 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7712 TREE_TYPE (base
), tmp
, base
);
7715 /* Store the new stride. */
7716 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7717 gfc_rank_cst
[dim
], stride
);
7720 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7722 from
= loop
.from
[n
];
7724 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7725 gfc_rank_cst
[n
], from
);
7726 if (n
< loop
.dimen
+ codim
- 1)
7727 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7728 gfc_rank_cst
[n
], to
);
7731 if (se
->data_not_needed
)
7732 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7733 gfc_index_zero_node
);
7735 /* Point the data pointer at the 1st element in the section. */
7736 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7737 subref_array_target
, expr
);
7739 /* Force the offset to be -1, when the lower bound of the highest
7740 dimension is one and the symbol is present and is not a
7741 pointer/allocatable or associated. */
7742 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7743 && !se
->data_not_needed
)
7744 || (se
->use_offset
&& base
!= NULL_TREE
))
7746 /* Set the offset depending on base. */
7747 tmp
= rank_remap
&& !se
->direct_byref
?
7748 fold_build2_loc (input_location
, PLUS_EXPR
,
7749 gfc_array_index_type
, base
,
7752 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7754 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7755 && !se
->data_not_needed
7756 && (!rank_remap
|| se
->use_offset
))
7758 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7759 gfc_conv_descriptor_offset_get (desc
));
7761 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7762 && !se
->data_not_needed
7763 && gfc_expr_attr (expr
).select_rank_temporary
)
7765 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7767 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7769 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7770 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7771 && !expr
->symtree
->n
.sym
->attr
.allocatable
7772 && !expr
->symtree
->n
.sym
->attr
.pointer
7773 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7774 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7776 /* Set the offset to -1. */
7778 mpz_init_set_si (minus_one
, -1);
7779 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7780 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7784 /* Only the callee knows what the correct offset it, so just set
7786 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7791 /* For class arrays add the class tree into the saved descriptor to
7792 enable getting of _vptr and the like. */
7793 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7794 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7796 gfc_allocate_lang_decl (desc
);
7797 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7798 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7799 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7800 : expr
->symtree
->n
.sym
->backend_decl
;
7802 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7803 && IS_CLASS_ARRAY (expr
))
7806 gfc_allocate_lang_decl (desc
);
7807 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7808 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7809 vtype
= gfc_class_vptr_get (tmp
);
7810 gfc_add_modify (&se
->pre
, vtype
,
7811 gfc_build_addr_expr (TREE_TYPE (vtype
),
7812 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7814 if (!se
->direct_byref
|| se
->byref_noassign
)
7816 /* Get a pointer to the new descriptor. */
7817 if (se
->want_pointer
)
7818 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7823 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7824 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7826 /* Cleanup the scalarizer. */
7827 gfc_cleanup_loop (&loop
);
7830 /* Helper function for gfc_conv_array_parameter if array size needs to be
7834 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7837 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7838 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7839 else if (expr
->rank
> 1)
7840 *size
= build_call_expr_loc (input_location
,
7841 gfor_fndecl_size0
, 1,
7842 gfc_build_addr_expr (NULL
, desc
));
7845 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7846 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7848 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7849 gfc_array_index_type
, ubound
, lbound
);
7850 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7851 *size
, gfc_index_one_node
);
7852 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7853 *size
, gfc_index_zero_node
);
7855 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7856 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7857 *size
, fold_convert (gfc_array_index_type
, elem
));
7860 /* Helper function - return true if the argument is a pointer. */
7863 is_pointer (gfc_expr
*e
)
7867 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->symtree
== NULL
)
7870 sym
= e
->symtree
->n
.sym
;
7874 return sym
->attr
.pointer
|| sym
->attr
.proc_pointer
;
7877 /* Convert an array for passing as an actual parameter. */
7880 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7881 const gfc_symbol
*fsym
, const char *proc_name
,
7886 tree tmp
= NULL_TREE
;
7888 tree parent
= DECL_CONTEXT (current_function_decl
);
7889 bool full_array_var
;
7890 bool this_array_result
;
7893 bool array_constructor
;
7894 bool good_allocatable
;
7895 bool ultimate_ptr_comp
;
7896 bool ultimate_alloc_comp
;
7901 ultimate_ptr_comp
= false;
7902 ultimate_alloc_comp
= false;
7904 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7906 if (ref
->next
== NULL
)
7909 if (ref
->type
== REF_COMPONENT
)
7911 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7912 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7916 full_array_var
= false;
7919 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7920 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7922 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7924 /* The symbol should have an array specification. */
7925 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7927 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7929 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7930 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7931 se
->string_length
= tmp
;
7934 /* Is this the result of the enclosing procedure? */
7935 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7936 if (this_array_result
7937 && (sym
->backend_decl
!= current_function_decl
)
7938 && (sym
->backend_decl
!= parent
))
7939 this_array_result
= false;
7941 /* Passing address of the array if it is not pointer or assumed-shape. */
7942 if (full_array_var
&& g77
&& !this_array_result
7943 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7945 tmp
= gfc_get_symbol_decl (sym
);
7947 if (sym
->ts
.type
== BT_CHARACTER
)
7948 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7950 if (!sym
->attr
.pointer
7952 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7953 && sym
->as
->type
!= AS_DEFERRED
7954 && sym
->as
->type
!= AS_ASSUMED_RANK
7955 && !sym
->attr
.allocatable
)
7957 /* Some variables are declared directly, others are declared as
7958 pointers and allocated on the heap. */
7959 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7962 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7964 array_parameter_size (tmp
, expr
, size
);
7968 if (sym
->attr
.allocatable
)
7970 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7972 gfc_conv_expr_descriptor (se
, expr
);
7976 array_parameter_size (tmp
, expr
, size
);
7977 se
->expr
= gfc_conv_array_data (tmp
);
7982 /* A convenient reduction in scope. */
7983 contiguous
= g77
&& !this_array_result
&& contiguous
;
7985 /* There is no need to pack and unpack the array, if it is contiguous
7986 and not a deferred- or assumed-shape array, or if it is simply
7988 no_pack
= ((sym
&& sym
->as
7989 && !sym
->attr
.pointer
7990 && sym
->as
->type
!= AS_DEFERRED
7991 && sym
->as
->type
!= AS_ASSUMED_RANK
7992 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7994 (ref
&& ref
->u
.ar
.as
7995 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7996 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7997 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7999 gfc_is_simply_contiguous (expr
, false, true));
8001 no_pack
= contiguous
&& no_pack
;
8003 /* If we have an EXPR_OP or a function returning an explicit-shaped
8004 or allocatable array, an array temporary will be generated which
8005 does not need to be packed / unpacked if passed to an
8006 explicit-shape dummy array. */
8010 if (expr
->expr_type
== EXPR_OP
)
8012 else if (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.esym
)
8014 gfc_symbol
*result
= expr
->value
.function
.esym
->result
;
8015 if (result
->attr
.dimension
8016 && (result
->as
->type
== AS_EXPLICIT
8017 || result
->attr
.allocatable
8018 || result
->attr
.contiguous
))
8023 /* Array constructors are always contiguous and do not need packing. */
8024 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
8026 /* Same is true of contiguous sections from allocatable variables. */
8027 good_allocatable
= contiguous
8029 && expr
->symtree
->n
.sym
->attr
.allocatable
;
8031 /* Or ultimate allocatable components. */
8032 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
8034 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
8036 gfc_conv_expr_descriptor (se
, expr
);
8037 /* Deallocate the allocatable components of structures that are
8039 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8040 && expr
->ts
.u
.derived
->attr
.alloc_comp
8041 && expr
->expr_type
!= EXPR_VARIABLE
)
8043 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
8045 /* The components shall be deallocated before their containing entity. */
8046 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8048 if (expr
->ts
.type
== BT_CHARACTER
)
8049 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
8051 array_parameter_size (se
->expr
, expr
, size
);
8052 se
->expr
= gfc_conv_array_data (se
->expr
);
8056 if (this_array_result
)
8058 /* Result of the enclosing function. */
8059 gfc_conv_expr_descriptor (se
, expr
);
8061 array_parameter_size (se
->expr
, expr
, size
);
8062 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8064 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
8065 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
8066 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
8073 /* Every other type of array. */
8074 se
->want_pointer
= 1;
8075 gfc_conv_expr_descriptor (se
, expr
);
8078 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
8083 /* Deallocate the allocatable components of structures that are
8084 not variable, for descriptorless arguments.
8085 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8086 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8087 && expr
->ts
.u
.derived
->attr
.alloc_comp
8088 && expr
->expr_type
!= EXPR_VARIABLE
)
8090 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8091 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
8093 /* The components shall be deallocated before their containing entity. */
8094 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8097 if (g77
|| (fsym
&& fsym
->attr
.contiguous
8098 && !gfc_is_simply_contiguous (expr
, false, true)))
8100 tree origptr
= NULL_TREE
;
8104 /* For contiguous arrays, save the original value of the descriptor. */
8107 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
8108 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8109 tmp
= gfc_conv_array_data (tmp
);
8110 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8111 TREE_TYPE (origptr
), origptr
,
8112 fold_convert (TREE_TYPE (origptr
), tmp
));
8113 gfc_add_expr_to_block (&se
->pre
, tmp
);
8116 /* Repack the array. */
8117 if (warn_array_temporaries
)
8120 gfc_warning (OPT_Warray_temporaries
,
8121 "Creating array temporary at %L for argument %qs",
8122 &expr
->where
, fsym
->name
);
8124 gfc_warning (OPT_Warray_temporaries
,
8125 "Creating array temporary at %L", &expr
->where
);
8128 /* When optmizing, we can use gfc_conv_subref_array_arg for
8129 making the packing and unpacking operation visible to the
8132 if (g77
&& optimize
&& !optimize_size
&& expr
->expr_type
== EXPR_VARIABLE
8133 && !is_pointer (expr
) && ! gfc_has_dimen_vector_ref (expr
)
8134 && (fsym
== NULL
|| fsym
->ts
.type
!= BT_ASSUMED
))
8136 gfc_conv_subref_array_arg (se
, expr
, g77
,
8137 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
8138 false, fsym
, proc_name
, sym
, true);
8142 ptr
= build_call_expr_loc (input_location
,
8143 gfor_fndecl_in_pack
, 1, desc
);
8145 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8147 tmp
= gfc_conv_expr_present (sym
);
8148 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
8149 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
8150 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
8153 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
8155 /* Use the packed data for the actual argument, except for contiguous arrays,
8156 where the descriptor's data component is set. */
8161 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8163 gfc_ss
* ss
= gfc_walk_expr (expr
);
8164 if (!transposed_dims (ss
))
8165 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
8168 tree old_field
, new_field
;
8170 /* The original descriptor has transposed dims so we can't reuse
8171 it directly; we have to create a new one. */
8172 tree old_desc
= tmp
;
8173 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8175 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8176 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8177 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8179 old_field
= gfc_conv_descriptor_offset (old_desc
);
8180 new_field
= gfc_conv_descriptor_offset (new_desc
);
8181 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8183 for (int i
= 0; i
< expr
->rank
; i
++)
8185 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8186 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8187 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8189 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8192 if (flag_coarray
== GFC_FCOARRAY_LIB
8193 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8194 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8195 == GFC_ARRAY_ALLOCATABLE
)
8197 old_field
= gfc_conv_descriptor_token (old_desc
);
8198 new_field
= gfc_conv_descriptor_token (new_desc
);
8199 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8202 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8203 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8208 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8212 if (fsym
&& proc_name
)
8213 msg
= xasprintf ("An array temporary was created for argument "
8214 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8216 msg
= xasprintf ("An array temporary was created");
8218 tmp
= build_fold_indirect_ref_loc (input_location
,
8220 tmp
= gfc_conv_array_data (tmp
);
8221 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8222 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8224 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8225 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8227 gfc_conv_expr_present (sym
), tmp
);
8229 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8234 gfc_start_block (&block
);
8236 /* Copy the data back. */
8237 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8239 tmp
= build_call_expr_loc (input_location
,
8240 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8241 gfc_add_expr_to_block (&block
, tmp
);
8244 /* Free the temporary. */
8245 tmp
= gfc_call_free (ptr
);
8246 gfc_add_expr_to_block (&block
, tmp
);
8248 stmt
= gfc_finish_block (&block
);
8250 gfc_init_block (&block
);
8251 /* Only if it was repacked. This code needs to be executed before the
8252 loop cleanup code. */
8253 tmp
= build_fold_indirect_ref_loc (input_location
,
8255 tmp
= gfc_conv_array_data (tmp
);
8256 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8257 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8259 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8260 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8262 gfc_conv_expr_present (sym
), tmp
);
8264 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8266 gfc_add_expr_to_block (&block
, tmp
);
8267 gfc_add_block_to_block (&block
, &se
->post
);
8269 gfc_init_block (&se
->post
);
8271 /* Reset the descriptor pointer. */
8274 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8275 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8278 gfc_add_block_to_block (&se
->post
, &block
);
8283 /* This helper function calculates the size in words of a full array. */
8286 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8291 idx
= gfc_rank_cst
[rank
- 1];
8292 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8293 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8294 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8296 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8297 tmp
, gfc_index_one_node
);
8298 tmp
= gfc_evaluate_now (tmp
, block
);
8300 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8301 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8303 return gfc_evaluate_now (tmp
, block
);
8307 /* Allocate dest to the same size as src, and copy src -> dest.
8308 If no_malloc is set, only the copy is done. */
8311 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8312 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8313 tree add_when_allocated
)
8322 /* If the source is null, set the destination to null. Then,
8323 allocate memory to the destination. */
8324 gfc_init_block (&block
);
8326 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8328 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8329 null_data
= gfc_finish_block (&block
);
8331 gfc_init_block (&block
);
8332 if (str_sz
!= NULL_TREE
)
8335 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8339 tmp
= gfc_call_malloc (&block
, type
, size
);
8340 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8345 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8346 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8347 fold_convert (size_type_node
, size
));
8348 gfc_add_expr_to_block (&block
, tmp
);
8353 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8354 null_data
= gfc_finish_block (&block
);
8356 gfc_init_block (&block
);
8358 nelems
= gfc_full_array_size (&block
, src
, rank
);
8360 nelems
= gfc_index_one_node
;
8362 if (str_sz
!= NULL_TREE
)
8363 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8365 tmp
= fold_convert (gfc_array_index_type
,
8366 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8367 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8371 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8372 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8373 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8376 /* We know the temporary and the value will be the same length,
8377 so can use memcpy. */
8380 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8381 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8382 gfc_conv_descriptor_data_get (dest
),
8383 gfc_conv_descriptor_data_get (src
),
8384 fold_convert (size_type_node
, size
));
8385 gfc_add_expr_to_block (&block
, tmp
);
8389 gfc_add_expr_to_block (&block
, add_when_allocated
);
8390 tmp
= gfc_finish_block (&block
);
8392 /* Null the destination if the source is null; otherwise do
8393 the allocate and copy. */
8394 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8397 null_cond
= gfc_conv_descriptor_data_get (src
);
8399 null_cond
= convert (pvoid_type_node
, null_cond
);
8400 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8401 null_cond
, null_pointer_node
);
8402 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8406 /* Allocate dest to the same size as src, and copy data src -> dest. */
8409 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8410 tree add_when_allocated
)
8412 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8413 NULL_TREE
, add_when_allocated
);
8417 /* Copy data src -> dest. */
8420 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8422 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8423 NULL_TREE
, NULL_TREE
);
8426 /* Allocate dest to the same size as src, but don't copy anything. */
8429 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8431 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8432 NULL_TREE
, NULL_TREE
);
8437 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8438 tree type
, int rank
)
8445 stmtblock_t block
, globalblock
;
8447 /* If the source is null, set the destination to null. Then,
8448 allocate memory to the destination. */
8449 gfc_init_block (&block
);
8450 gfc_init_block (&globalblock
);
8452 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8455 symbol_attribute attr
;
8458 gfc_init_se (&se
, NULL
);
8459 gfc_clear_attr (&attr
);
8460 attr
.allocatable
= 1;
8461 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8462 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8463 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8465 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8466 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8467 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8468 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8469 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8470 null_data
= gfc_finish_block (&block
);
8472 gfc_init_block (&block
);
8474 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8475 fold_convert (size_type_node
, size
),
8476 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8477 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8478 GFC_CAF_COARRAY_ALLOC
);
8480 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8481 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8482 fold_convert (size_type_node
, size
));
8483 gfc_add_expr_to_block (&block
, tmp
);
8487 /* Set the rank or unitialized memory access may be reported. */
8488 tmp
= gfc_conv_descriptor_rank (dest
);
8489 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8492 nelems
= gfc_full_array_size (&block
, src
, rank
);
8494 nelems
= integer_one_node
;
8496 tmp
= fold_convert (size_type_node
,
8497 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8498 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8499 fold_convert (size_type_node
, nelems
), tmp
);
8501 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8502 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8504 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8505 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8506 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8507 null_data
= gfc_finish_block (&block
);
8509 gfc_init_block (&block
);
8510 gfc_allocate_using_caf_lib (&block
, dest
,
8511 fold_convert (size_type_node
, size
),
8512 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8513 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8514 GFC_CAF_COARRAY_ALLOC
);
8516 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8517 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8518 gfc_conv_descriptor_data_get (dest
),
8519 gfc_conv_descriptor_data_get (src
),
8520 fold_convert (size_type_node
, size
));
8521 gfc_add_expr_to_block (&block
, tmp
);
8524 tmp
= gfc_finish_block (&block
);
8526 /* Null the destination if the source is null; otherwise do
8527 the register and copy. */
8528 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8531 null_cond
= gfc_conv_descriptor_data_get (src
);
8533 null_cond
= convert (pvoid_type_node
, null_cond
);
8534 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8535 null_cond
, null_pointer_node
);
8536 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8538 return gfc_finish_block (&globalblock
);
8542 /* Helper function to abstract whether coarray processing is enabled. */
8545 caf_enabled (int caf_mode
)
8547 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8548 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8552 /* Helper function to abstract whether coarray processing is enabled
8553 and we are in a derived type coarray. */
8556 caf_in_coarray (int caf_mode
)
8558 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8559 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8560 return (caf_mode
& pat
) == pat
;
8564 /* Helper function to abstract whether coarray is to deallocate only. */
8567 gfc_caf_is_dealloc_only (int caf_mode
)
8569 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8570 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8574 /* Recursively traverse an object of derived type, generating code to
8575 deallocate, nullify or copy allocatable components. This is the work horse
8576 function for the functions named in this enum. */
8578 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8579 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8580 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8582 static gfc_actual_arglist
*pdt_param_list
;
8585 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8586 tree dest
, int rank
, int purpose
, int caf_mode
)
8590 stmtblock_t fnblock
;
8591 stmtblock_t loopbody
;
8592 stmtblock_t tmpblock
;
8603 tree null_cond
= NULL_TREE
;
8604 tree add_when_allocated
;
8605 tree dealloc_fndecl
;
8609 symbol_attribute
*attr
;
8610 bool deallocate_called
;
8612 gfc_init_block (&fnblock
);
8614 decl_type
= TREE_TYPE (decl
);
8616 if ((POINTER_TYPE_P (decl_type
))
8617 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8619 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8620 /* Deref dest in sync with decl, but only when it is not NULL. */
8622 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8624 /* Update the decl_type because it got dereferenced. */
8625 decl_type
= TREE_TYPE (decl
);
8628 /* If this is an array of derived types with allocatable components
8629 build a loop and recursively call this function. */
8630 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8631 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8633 tmp
= gfc_conv_array_data (decl
);
8634 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8636 /* Get the number of elements - 1 and set the counter. */
8637 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8639 /* Use the descriptor for an allocatable array. Since this
8640 is a full array reference, we only need the descriptor
8641 information from dimension = rank. */
8642 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8643 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8644 gfc_array_index_type
, tmp
,
8645 gfc_index_one_node
);
8647 null_cond
= gfc_conv_descriptor_data_get (decl
);
8648 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8649 logical_type_node
, null_cond
,
8650 build_int_cst (TREE_TYPE (null_cond
), 0));
8654 /* Otherwise use the TYPE_DOMAIN information. */
8655 tmp
= array_type_nelts (decl_type
);
8656 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8659 /* Remember that this is, in fact, the no. of elements - 1. */
8660 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8661 index
= gfc_create_var (gfc_array_index_type
, "S");
8663 /* Build the body of the loop. */
8664 gfc_init_block (&loopbody
);
8666 vref
= gfc_build_array_ref (var
, index
, NULL
);
8668 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8669 && !caf_enabled (caf_mode
))
8671 tmp
= build_fold_indirect_ref_loc (input_location
,
8672 gfc_conv_array_data (dest
));
8673 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8674 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8675 COPY_ALLOC_COMP
, 0);
8678 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8681 gfc_add_expr_to_block (&loopbody
, tmp
);
8683 /* Build the loop and return. */
8684 gfc_init_loopinfo (&loop
);
8686 loop
.from
[0] = gfc_index_zero_node
;
8687 loop
.loopvar
[0] = index
;
8688 loop
.to
[0] = nelems
;
8689 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8690 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8692 tmp
= gfc_finish_block (&fnblock
);
8693 /* When copying allocateable components, the above implements the
8694 deep copy. Nevertheless is a deep copy only allowed, when the current
8695 component is allocated, for which code will be generated in
8696 gfc_duplicate_allocatable (), where the deep copy code is just added
8697 into the if's body, by adding tmp (the deep copy code) as last
8698 argument to gfc_duplicate_allocatable (). */
8699 if (purpose
== COPY_ALLOC_COMP
8700 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8701 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8703 else if (null_cond
!= NULL_TREE
)
8704 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8705 build_empty_stmt (input_location
));
8710 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8712 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8713 DEALLOCATE_PDT_COMP
, 0);
8714 gfc_add_expr_to_block (&fnblock
, tmp
);
8716 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8718 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8719 NULLIFY_ALLOC_COMP
, 0);
8720 gfc_add_expr_to_block (&fnblock
, tmp
);
8723 /* Otherwise, act on the components or recursively call self to
8724 act on a chain of components. */
8725 for (c
= der_type
->components
; c
; c
= c
->next
)
8727 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8728 || c
->ts
.type
== BT_CLASS
)
8729 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8730 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8731 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8733 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8734 && c
->ts
.u
.derived
->attr
.pdt_type
;
8736 cdecl = c
->backend_decl
;
8737 ctype
= TREE_TYPE (cdecl);
8741 case DEALLOCATE_ALLOC_COMP
:
8743 gfc_init_block (&tmpblock
);
8745 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8746 decl
, cdecl, NULL_TREE
);
8748 /* Shortcut to get the attributes of the component. */
8749 if (c
->ts
.type
== BT_CLASS
)
8751 attr
= &CLASS_DATA (c
)->attr
;
8752 if (attr
->class_pointer
)
8762 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8763 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8764 /* Call the finalizer, which will free the memory and nullify the
8765 pointer of an array. */
8766 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8767 caf_enabled (caf_mode
))
8770 deallocate_called
= false;
8772 /* Add the _class ref for classes. */
8773 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8774 comp
= gfc_class_data_get (comp
);
8776 add_when_allocated
= NULL_TREE
;
8777 if (cmp_has_alloc_comps
8778 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8780 && !deallocate_called
)
8782 /* Add checked deallocation of the components. This code is
8783 obviously added because the finalizer is not trusted to free
8785 if (c
->ts
.type
== BT_CLASS
)
8787 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8789 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8790 comp
, NULL_TREE
, rank
, purpose
,
8795 rank
= c
->as
? c
->as
->rank
: 0;
8796 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8803 if (attr
->allocatable
&& !same_type
8804 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8806 /* Handle all types of components besides components of the
8807 same_type as the current one, because those would create an
8810 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8811 ? (gfc_caf_is_dealloc_only (caf_mode
)
8812 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8813 : GFC_CAF_COARRAY_DEREGISTER
)
8814 : GFC_CAF_COARRAY_NOCOARRAY
;
8816 caf_token
= NULL_TREE
;
8817 /* Coarray components are handled directly by
8818 deallocate_with_status. */
8819 if (!attr
->codimension
8820 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8823 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8824 TREE_TYPE (c
->caf_token
),
8825 decl
, c
->caf_token
, NULL_TREE
);
8826 else if (attr
->dimension
&& !attr
->proc_pointer
)
8827 caf_token
= gfc_conv_descriptor_token (comp
);
8829 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8830 /* When this is an array but not in conjunction with a coarray
8831 then add the data-ref. For coarray'ed arrays the data-ref
8832 is added by deallocate_with_status. */
8833 comp
= gfc_conv_descriptor_data_get (comp
);
8835 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8836 NULL_TREE
, NULL_TREE
, true,
8837 NULL
, caf_dereg_mode
,
8838 add_when_allocated
, caf_token
);
8840 gfc_add_expr_to_block (&tmpblock
, tmp
);
8842 else if (attr
->allocatable
&& !attr
->codimension
8843 && !deallocate_called
)
8845 /* Case of recursive allocatable derived types. */
8849 stmtblock_t dealloc_block
;
8851 gfc_init_block (&dealloc_block
);
8852 if (add_when_allocated
)
8853 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8855 /* Convert the component into a rank 1 descriptor type. */
8856 if (attr
->dimension
)
8858 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8859 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8860 c
->ts
.type
== BT_CLASS
8861 ? CLASS_DATA (c
)->as
->rank
8866 tmp
= TREE_TYPE (comp
);
8867 ubound
= build_int_cst (gfc_array_index_type
, 1);
8870 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8872 GFC_ARRAY_ALLOCATABLE
, false);
8874 cdesc
= gfc_create_var (cdesc
, "cdesc");
8875 DECL_ARTIFICIAL (cdesc
) = 1;
8877 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8878 gfc_get_dtype_rank_type (1, tmp
));
8879 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8880 gfc_index_zero_node
,
8881 gfc_index_one_node
);
8882 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8883 gfc_index_zero_node
,
8884 gfc_index_one_node
);
8885 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8886 gfc_index_zero_node
, ubound
);
8888 if (attr
->dimension
)
8889 comp
= gfc_conv_descriptor_data_get (comp
);
8891 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8893 /* Now call the deallocator. */
8894 vtab
= gfc_find_vtab (&c
->ts
);
8895 if (vtab
->backend_decl
== NULL
)
8896 gfc_get_symbol_decl (vtab
);
8897 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8898 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8899 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8901 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8902 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8903 logical_type_node
, tmp
,
8905 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8907 tmp
= build_call_expr_loc (input_location
,
8910 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8912 tmp
= gfc_finish_block (&dealloc_block
);
8914 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8915 void_type_node
, is_allocated
, tmp
,
8916 build_empty_stmt (input_location
));
8918 gfc_add_expr_to_block (&tmpblock
, tmp
);
8920 else if (add_when_allocated
)
8921 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8923 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8924 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8926 /* Finally, reset the vptr to the declared type vtable and, if
8927 necessary reset the _len field.
8929 First recover the reference to the component and obtain
8931 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8932 decl
, cdecl, NULL_TREE
);
8933 tmp
= gfc_class_vptr_get (comp
);
8935 if (UNLIMITED_POLY (c
))
8937 /* Both vptr and _len field should be nulled. */
8938 gfc_add_modify (&tmpblock
, tmp
,
8939 build_int_cst (TREE_TYPE (tmp
), 0));
8940 tmp
= gfc_class_len_get (comp
);
8941 gfc_add_modify (&tmpblock
, tmp
,
8942 build_int_cst (TREE_TYPE (tmp
), 0));
8946 /* Build the vtable address and set the vptr with it. */
8949 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8950 vtab
= vtable
->backend_decl
;
8951 if (vtab
== NULL_TREE
)
8952 vtab
= gfc_get_symbol_decl (vtable
);
8953 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8954 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8955 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8959 /* Now add the deallocation of this component. */
8960 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8963 case NULLIFY_ALLOC_COMP
:
8965 - allocatable components (regular or in class)
8966 - components that have allocatable components
8967 - pointer components when in a coarray.
8968 Skip everything else especially proc_pointers, which may come
8969 coupled with the regular pointer attribute. */
8970 if (c
->attr
.proc_pointer
8971 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8972 && CLASS_DATA (c
)->attr
.allocatable
)
8973 || (cmp_has_alloc_comps
8974 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8975 || (c
->ts
.type
== BT_CLASS
8976 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8977 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8980 /* Process class components first, because they always have the
8981 pointer-attribute set which would be caught wrong else. */
8982 if (c
->ts
.type
== BT_CLASS
8983 && (CLASS_DATA (c
)->attr
.allocatable
8984 || CLASS_DATA (c
)->attr
.class_pointer
))
8986 /* Allocatable CLASS components. */
8987 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8988 decl
, cdecl, NULL_TREE
);
8990 comp
= gfc_class_data_get (comp
);
8991 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8992 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8996 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8997 void_type_node
, comp
,
8998 build_int_cst (TREE_TYPE (comp
), 0));
8999 gfc_add_expr_to_block (&fnblock
, tmp
);
9001 cmp_has_alloc_comps
= false;
9003 /* Coarrays need the component to be nulled before the api-call
9005 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
9007 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9008 decl
, cdecl, NULL_TREE
);
9009 if (c
->attr
.dimension
|| c
->attr
.codimension
)
9010 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9013 gfc_add_modify (&fnblock
, comp
,
9014 build_int_cst (TREE_TYPE (comp
), 0));
9015 if (gfc_deferred_strlen (c
, &comp
))
9017 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9019 decl
, comp
, NULL_TREE
);
9020 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9021 TREE_TYPE (comp
), comp
,
9022 build_int_cst (TREE_TYPE (comp
), 0));
9023 gfc_add_expr_to_block (&fnblock
, tmp
);
9025 cmp_has_alloc_comps
= false;
9028 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
9030 /* Register a component of a derived type coarray with the
9031 coarray library. Do not register ultimate component
9032 coarrays here. They are treated like regular coarrays and
9033 are either allocated on all images or on none. */
9036 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9037 decl
, cdecl, NULL_TREE
);
9038 if (c
->attr
.dimension
)
9040 /* Set the dtype, because caf_register needs it. */
9041 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
9042 gfc_get_dtype (TREE_TYPE (comp
)));
9043 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9044 decl
, cdecl, NULL_TREE
);
9045 token
= gfc_conv_descriptor_token (tmp
);
9051 gfc_init_se (&se
, NULL
);
9052 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9053 pvoid_type_node
, decl
, c
->caf_token
,
9055 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
9056 c
->ts
.type
== BT_CLASS
9057 ? CLASS_DATA (c
)->attr
9059 gfc_add_block_to_block (&fnblock
, &se
.pre
);
9062 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
9063 gfc_build_addr_expr (NULL_TREE
,
9065 NULL_TREE
, NULL_TREE
, NULL_TREE
,
9066 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
9069 if (cmp_has_alloc_comps
)
9071 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9072 decl
, cdecl, NULL_TREE
);
9073 rank
= c
->as
? c
->as
->rank
: 0;
9074 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
9075 rank
, purpose
, caf_mode
);
9076 gfc_add_expr_to_block (&fnblock
, tmp
);
9080 case REASSIGN_CAF_COMP
:
9081 if (caf_enabled (caf_mode
)
9082 && (c
->attr
.codimension
9083 || (c
->ts
.type
== BT_CLASS
9084 && (CLASS_DATA (c
)->attr
.coarray_comp
9085 || caf_in_coarray (caf_mode
)))
9086 || (c
->ts
.type
== BT_DERIVED
9087 && (c
->ts
.u
.derived
->attr
.coarray_comp
9088 || caf_in_coarray (caf_mode
))))
9091 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9092 decl
, cdecl, NULL_TREE
);
9093 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9094 dest
, cdecl, NULL_TREE
);
9096 if (c
->attr
.codimension
)
9098 if (c
->ts
.type
== BT_CLASS
)
9100 comp
= gfc_class_data_get (comp
);
9101 dcmp
= gfc_class_data_get (dcmp
);
9103 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
9104 gfc_conv_descriptor_data_get (comp
));
9108 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
9109 rank
, purpose
, caf_mode
9110 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
9111 gfc_add_expr_to_block (&fnblock
, tmp
);
9116 case COPY_ALLOC_COMP
:
9117 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
9120 /* We need source and destination components. */
9121 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
9123 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
9125 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
9127 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
9135 dst_data
= gfc_class_data_get (dcmp
);
9136 src_data
= gfc_class_data_get (comp
);
9137 size
= fold_convert (size_type_node
,
9138 gfc_class_vtab_size_get (comp
));
9140 if (CLASS_DATA (c
)->attr
.dimension
)
9142 nelems
= gfc_conv_descriptor_size (src_data
,
9143 CLASS_DATA (c
)->as
->rank
);
9144 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9145 size_type_node
, size
,
9146 fold_convert (size_type_node
,
9150 nelems
= build_int_cst (size_type_node
, 1);
9152 if (CLASS_DATA (c
)->attr
.dimension
9153 || CLASS_DATA (c
)->attr
.codimension
)
9155 src_data
= gfc_conv_descriptor_data_get (src_data
);
9156 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
9159 gfc_init_block (&tmpblock
);
9161 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
9162 gfc_class_vptr_get (comp
));
9164 /* Copy the unlimited '_len' field. If it is greater than zero
9165 (ie. a character(_len)), multiply it by size and use this
9166 for the malloc call. */
9167 if (UNLIMITED_POLY (c
))
9170 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
9171 gfc_class_len_get (comp
));
9173 size
= gfc_evaluate_now (size
, &tmpblock
);
9174 tmp
= gfc_class_len_get (comp
);
9175 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9176 size_type_node
, size
,
9177 fold_convert (size_type_node
, tmp
));
9178 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9179 logical_type_node
, tmp
,
9180 build_zero_cst (TREE_TYPE (tmp
)));
9181 size
= fold_build3_loc (input_location
, COND_EXPR
,
9182 size_type_node
, tmp
, ctmp
, size
);
9183 size
= gfc_evaluate_now (size
, &tmpblock
);
9186 /* Coarray component have to have the same allocation status and
9187 shape/type-parameter/effective-type on the LHS and RHS of an
9188 intrinsic assignment. Hence, we did not deallocated them - and
9189 do not allocate them here. */
9190 if (!CLASS_DATA (c
)->attr
.codimension
)
9192 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9193 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9194 gfc_add_modify (&tmpblock
, dst_data
,
9195 fold_convert (TREE_TYPE (dst_data
), tmp
));
9198 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9199 UNLIMITED_POLY (c
));
9200 gfc_add_expr_to_block (&tmpblock
, tmp
);
9201 tmp
= gfc_finish_block (&tmpblock
);
9203 gfc_init_block (&tmpblock
);
9204 gfc_add_modify (&tmpblock
, dst_data
,
9205 fold_convert (TREE_TYPE (dst_data
),
9206 null_pointer_node
));
9207 null_data
= gfc_finish_block (&tmpblock
);
9209 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9210 logical_type_node
, src_data
,
9213 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9218 /* To implement guarded deep copy, i.e., deep copy only allocatable
9219 components that are really allocated, the deep copy code has to
9220 be generated first and then added to the if-block in
9221 gfc_duplicate_allocatable (). */
9222 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9224 rank
= c
->as
? c
->as
->rank
: 0;
9225 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9226 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9227 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9233 add_when_allocated
= NULL_TREE
;
9235 if (gfc_deferred_strlen (c
, &tmp
))
9239 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9241 decl
, len
, NULL_TREE
);
9242 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9244 dest
, len
, NULL_TREE
);
9245 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9246 TREE_TYPE (len
), len
, tmp
);
9247 gfc_add_expr_to_block (&fnblock
, tmp
);
9248 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9249 /* This component cannot have allocatable components,
9250 therefore add_when_allocated of duplicate_allocatable ()
9252 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9253 false, false, size
, NULL_TREE
);
9254 gfc_add_expr_to_block (&fnblock
, tmp
);
9256 else if (c
->attr
.pdt_array
)
9258 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9259 c
->as
? c
->as
->rank
: 0,
9260 false, false, NULL_TREE
, NULL_TREE
);
9261 gfc_add_expr_to_block (&fnblock
, tmp
);
9263 else if ((c
->attr
.allocatable
)
9264 && !c
->attr
.proc_pointer
&& !same_type
9265 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9266 || caf_in_coarray (caf_mode
)))
9268 rank
= c
->as
? c
->as
->rank
: 0;
9269 if (c
->attr
.codimension
)
9270 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9271 else if (flag_coarray
== GFC_FCOARRAY_LIB
9272 && caf_in_coarray (caf_mode
))
9274 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
9275 : fold_build3_loc (input_location
,
9277 pvoid_type_node
, dest
,
9280 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9284 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9285 add_when_allocated
);
9286 gfc_add_expr_to_block (&fnblock
, tmp
);
9289 if (cmp_has_alloc_comps
|| is_pdt_type
)
9290 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9294 case ALLOCATE_PDT_COMP
:
9296 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9297 decl
, cdecl, NULL_TREE
);
9299 /* Set the PDT KIND and LEN fields. */
9300 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9303 gfc_expr
*c_expr
= NULL
;
9304 gfc_actual_arglist
*param
= pdt_param_list
;
9305 gfc_init_se (&tse
, NULL
);
9306 for (; param
; param
= param
->next
)
9307 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9308 c_expr
= param
->expr
;
9311 c_expr
= c
->initializer
;
9315 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9316 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9320 if (c
->attr
.pdt_string
)
9323 gfc_init_se (&tse
, NULL
);
9324 tree strlen
= NULL_TREE
;
9325 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9326 /* Convert the parameterized string length to its value. The
9327 string length is stored in a hidden field in the same way as
9328 deferred string lengths. */
9329 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9330 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9332 gfc_conv_expr_type (&tse
, e
,
9333 TREE_TYPE (strlen
));
9334 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9336 decl
, strlen
, NULL_TREE
);
9337 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9338 c
->ts
.u
.cl
->backend_decl
= strlen
;
9342 /* Scalar parameterized strings can be allocated now. */
9345 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9346 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9347 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9348 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9349 gfc_add_modify (&fnblock
, comp
, tmp
);
9353 /* Allocate parameterized arrays of parameterized derived types. */
9354 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9355 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9356 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9359 if (c
->ts
.type
== BT_CLASS
)
9360 comp
= gfc_class_data_get (comp
);
9362 if (c
->attr
.pdt_array
)
9366 tree size
= gfc_index_one_node
;
9367 tree offset
= gfc_index_zero_node
;
9371 /* This chunk takes the expressions for 'lower' and 'upper'
9372 in the arrayspec and substitutes in the expressions for
9373 the parameters from 'pdt_param_list'. The descriptor
9374 fields can then be filled from the values so obtained. */
9375 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9376 for (i
= 0; i
< c
->as
->rank
; i
++)
9378 gfc_init_se (&tse
, NULL
);
9379 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9380 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9381 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9384 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9387 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9388 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9389 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9392 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9395 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9398 size
= gfc_evaluate_now (size
, &fnblock
);
9399 offset
= fold_build2_loc (input_location
,
9401 gfc_array_index_type
,
9403 offset
= gfc_evaluate_now (offset
, &fnblock
);
9404 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9405 gfc_array_index_type
,
9407 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9408 gfc_array_index_type
,
9409 tmp
, gfc_index_one_node
);
9410 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9411 gfc_array_index_type
, size
, tmp
);
9413 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9414 if (c
->ts
.type
== BT_CLASS
)
9416 tmp
= gfc_get_vptr_from_expr (comp
);
9417 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9418 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9419 tmp
= gfc_vptr_size_get (tmp
);
9422 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9423 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9424 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9425 gfc_array_index_type
, size
, tmp
);
9426 size
= gfc_evaluate_now (size
, &fnblock
);
9427 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9428 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9429 tmp
= gfc_conv_descriptor_dtype (comp
);
9430 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9432 if (c
->initializer
&& c
->initializer
->rank
)
9434 gfc_init_se (&tse
, NULL
);
9435 e
= gfc_copy_expr (c
->initializer
);
9436 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9437 gfc_conv_expr_descriptor (&tse
, e
);
9438 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9440 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9441 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9442 gfc_conv_descriptor_data_get (comp
),
9443 gfc_conv_descriptor_data_get (tse
.expr
),
9444 fold_convert (size_type_node
, size
));
9445 gfc_add_expr_to_block (&fnblock
, tmp
);
9446 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9450 /* Recurse in to PDT components. */
9451 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9452 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9453 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9455 bool is_deferred
= false;
9456 gfc_actual_arglist
*tail
= c
->param_list
;
9458 for (; tail
; tail
= tail
->next
)
9462 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9463 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9464 c
->as
? c
->as
->rank
: 0,
9466 gfc_add_expr_to_block (&fnblock
, tmp
);
9471 case DEALLOCATE_PDT_COMP
:
9472 /* Deallocate array or parameterized string length components
9473 of parameterized derived types. */
9474 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9475 && !c
->attr
.pdt_string
9476 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9477 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9480 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9481 decl
, cdecl, NULL_TREE
);
9482 if (c
->ts
.type
== BT_CLASS
)
9483 comp
= gfc_class_data_get (comp
);
9485 /* Recurse in to PDT components. */
9486 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9487 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9488 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9490 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9491 c
->as
? c
->as
->rank
: 0);
9492 gfc_add_expr_to_block (&fnblock
, tmp
);
9495 if (c
->attr
.pdt_array
)
9497 tmp
= gfc_conv_descriptor_data_get (comp
);
9498 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9499 logical_type_node
, tmp
,
9500 build_int_cst (TREE_TYPE (tmp
), 0));
9501 tmp
= gfc_call_free (tmp
);
9502 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9503 build_empty_stmt (input_location
));
9504 gfc_add_expr_to_block (&fnblock
, tmp
);
9505 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9507 else if (c
->attr
.pdt_string
)
9509 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9510 logical_type_node
, comp
,
9511 build_int_cst (TREE_TYPE (comp
), 0));
9512 tmp
= gfc_call_free (comp
);
9513 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9514 build_empty_stmt (input_location
));
9515 gfc_add_expr_to_block (&fnblock
, tmp
);
9516 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9517 gfc_add_modify (&fnblock
, comp
, tmp
);
9522 case CHECK_PDT_DUMMY
:
9524 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9525 decl
, cdecl, NULL_TREE
);
9526 if (c
->ts
.type
== BT_CLASS
)
9527 comp
= gfc_class_data_get (comp
);
9529 /* Recurse in to PDT components. */
9530 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9531 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9533 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9534 c
->as
? c
->as
->rank
: 0,
9536 gfc_add_expr_to_block (&fnblock
, tmp
);
9539 if (!c
->attr
.pdt_len
)
9544 gfc_expr
*c_expr
= NULL
;
9545 gfc_actual_arglist
*param
= pdt_param_list
;
9547 gfc_init_se (&tse
, NULL
);
9548 for (; param
; param
= param
->next
)
9549 if (!strcmp (c
->name
, param
->name
)
9550 && param
->spec_type
== SPEC_EXPLICIT
)
9551 c_expr
= param
->expr
;
9555 tree error
, cond
, cname
;
9556 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9557 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9560 cname
= gfc_build_cstring_const (c
->name
);
9561 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9562 error
= gfc_trans_runtime_error (true, NULL
,
9563 "The value of the PDT LEN "
9564 "parameter '%s' does not "
9565 "agree with that in the "
9566 "dummy declaration",
9568 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9569 void_type_node
, cond
, error
,
9570 build_empty_stmt (input_location
));
9571 gfc_add_expr_to_block (&fnblock
, tmp
);
9582 return gfc_finish_block (&fnblock
);
9585 /* Recursively traverse an object of derived type, generating code to
9586 nullify allocatable components. */
9589 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9592 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9594 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9598 /* Recursively traverse an object of derived type, generating code to
9599 deallocate allocatable components. */
9602 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9605 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9606 DEALLOCATE_ALLOC_COMP
,
9607 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9611 /* Recursively traverse an object of derived type, generating code to
9612 deallocate allocatable components. But do not deallocate coarrays.
9613 To be used for intrinsic assignment, which may not change the allocation
9614 status of coarrays. */
9617 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9619 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9620 DEALLOCATE_ALLOC_COMP
, 0);
9625 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9627 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9628 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9632 /* Recursively traverse an object of derived type, generating code to
9633 copy it and its allocatable components. */
9636 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9639 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9644 /* Recursively traverse an object of derived type, generating code to
9645 copy only its allocatable components. */
9648 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9650 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9651 COPY_ONLY_ALLOC_COMP
, 0);
9655 /* Recursively traverse an object of paramterized derived type, generating
9656 code to allocate parameterized components. */
9659 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9660 gfc_actual_arglist
*param_list
)
9663 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9664 pdt_param_list
= param_list
;
9665 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9666 ALLOCATE_PDT_COMP
, 0);
9667 pdt_param_list
= old_param_list
;
9671 /* Recursively traverse an object of paramterized derived type, generating
9672 code to deallocate parameterized components. */
9675 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9677 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9678 DEALLOCATE_PDT_COMP
, 0);
9682 /* Recursively traverse a dummy of paramterized derived type to check the
9683 values of LEN parameters. */
9686 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9687 gfc_actual_arglist
*param_list
)
9690 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9691 pdt_param_list
= param_list
;
9692 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9693 CHECK_PDT_DUMMY
, 0);
9694 pdt_param_list
= old_param_list
;
9699 /* Returns the value of LBOUND for an expression. This could be broken out
9700 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9701 called by gfc_alloc_allocatable_for_assignment. */
9703 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9708 tree cond
, cond1
, cond3
, cond4
;
9712 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9714 tmp
= gfc_rank_cst
[dim
];
9715 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9716 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9717 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9718 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9720 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9721 stride
, gfc_index_zero_node
);
9722 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9723 logical_type_node
, cond3
, cond1
);
9724 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9725 stride
, gfc_index_zero_node
);
9727 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9728 tmp
, build_int_cst (gfc_array_index_type
,
9731 cond
= logical_false_node
;
9733 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9734 logical_type_node
, cond3
, cond4
);
9735 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9736 logical_type_node
, cond
, cond1
);
9738 return fold_build3_loc (input_location
, COND_EXPR
,
9739 gfc_array_index_type
, cond
,
9740 lbound
, gfc_index_one_node
);
9743 if (expr
->expr_type
== EXPR_FUNCTION
)
9745 /* A conversion function, so use the argument. */
9746 gcc_assert (expr
->value
.function
.isym
9747 && expr
->value
.function
.isym
->conversion
);
9748 expr
= expr
->value
.function
.actual
->expr
;
9751 if (expr
->expr_type
== EXPR_VARIABLE
)
9753 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9754 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9756 if (ref
->type
== REF_COMPONENT
9757 && ref
->u
.c
.component
->as
9759 && ref
->next
->u
.ar
.type
== AR_FULL
)
9760 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9762 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9765 return gfc_index_one_node
;
9769 /* Returns true if an expression represents an lhs that can be reallocated
9773 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9781 sym
= expr
->symtree
->n
.sym
;
9783 if (sym
->attr
.associate_var
&& !expr
->ref
)
9786 /* An allocatable class variable with no reference. */
9787 if (sym
->ts
.type
== BT_CLASS
9788 && !sym
->attr
.associate_var
9789 && CLASS_DATA (sym
)->attr
.allocatable
9791 && ((expr
->ref
->type
== REF_ARRAY
&& expr
->ref
->u
.ar
.type
== AR_FULL
9792 && expr
->ref
->next
== NULL
)
9793 || (expr
->ref
->type
== REF_COMPONENT
9794 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9795 && (expr
->ref
->next
== NULL
9796 || (expr
->ref
->next
->type
== REF_ARRAY
9797 && expr
->ref
->next
->u
.ar
.type
== AR_FULL
9798 && expr
->ref
->next
->next
== NULL
)))))
9801 /* An allocatable variable. */
9802 if (sym
->attr
.allocatable
9803 && !sym
->attr
.associate_var
9805 && expr
->ref
->type
== REF_ARRAY
9806 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9809 /* All that can be left are allocatable components. */
9810 if ((sym
->ts
.type
!= BT_DERIVED
9811 && sym
->ts
.type
!= BT_CLASS
)
9812 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9815 /* Find a component ref followed by an array reference. */
9816 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9818 && ref
->type
== REF_COMPONENT
9819 && ref
->next
->type
== REF_ARRAY
9820 && !ref
->next
->next
)
9826 /* Return true if valid reallocatable lhs. */
9827 if (ref
->u
.c
.component
->attr
.allocatable
9828 && ref
->next
->u
.ar
.type
== AR_FULL
)
9836 concat_str_length (gfc_expr
* expr
)
9843 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9844 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9845 if (len1
== NULL_TREE
)
9847 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9848 len1
= concat_str_length (expr
->value
.op
.op1
);
9849 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9850 len1
= build_int_cst (gfc_charlen_type_node
,
9851 expr
->value
.op
.op1
->value
.character
.length
);
9852 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9854 gfc_init_se (&se
, NULL
);
9855 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9861 gfc_init_se (&se
, NULL
);
9862 se
.want_pointer
= 1;
9863 se
.descriptor_only
= 1;
9864 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9865 len1
= se
.string_length
;
9869 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9870 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9871 if (len2
== NULL_TREE
)
9873 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9874 len2
= concat_str_length (expr
->value
.op
.op2
);
9875 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9876 len2
= build_int_cst (gfc_charlen_type_node
,
9877 expr
->value
.op
.op2
->value
.character
.length
);
9878 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9880 gfc_init_se (&se
, NULL
);
9881 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9887 gfc_init_se (&se
, NULL
);
9888 se
.want_pointer
= 1;
9889 se
.descriptor_only
= 1;
9890 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9891 len2
= se
.string_length
;
9895 gcc_assert(len1
&& len2
);
9896 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9897 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9899 return fold_build2_loc (input_location
, PLUS_EXPR
,
9900 gfc_charlen_type_node
, len1
, len2
);
9904 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9908 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9912 stmtblock_t realloc_block
;
9913 stmtblock_t alloc_block
;
9917 gfc_array_info
*linfo
;
9939 gfc_array_spec
* as
;
9940 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9941 && gfc_caf_attr (expr1
, true).codimension
);
9945 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9946 Find the lhs expression in the loop chain and set expr1 and
9947 expr2 accordingly. */
9948 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9951 /* Find the ss for the lhs. */
9953 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9954 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9956 if (lss
== gfc_ss_terminator
)
9958 expr1
= lss
->info
->expr
;
9961 /* Bail out if this is not a valid allocate on assignment. */
9962 if (!gfc_is_reallocatable_lhs (expr1
)
9963 || (expr2
&& !expr2
->rank
))
9966 /* Find the ss for the lhs. */
9968 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9969 if (lss
->info
->expr
== expr1
)
9972 if (lss
== gfc_ss_terminator
)
9975 linfo
= &lss
->info
->data
.array
;
9977 /* Find an ss for the rhs. For operator expressions, we see the
9978 ss's for the operands. Any one of these will do. */
9980 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9981 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9984 if (expr2
&& rss
== gfc_ss_terminator
)
9987 /* Ensure that the string length from the current scope is used. */
9988 if (expr2
->ts
.type
== BT_CHARACTER
9989 && expr2
->expr_type
== EXPR_FUNCTION
9990 && !expr2
->value
.function
.isym
)
9991 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
9993 gfc_start_block (&fblock
);
9995 /* Since the lhs is allocatable, this must be a descriptor type.
9996 Get the data and array size. */
9997 desc
= linfo
->descriptor
;
9998 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9999 array1
= gfc_conv_descriptor_data_get (desc
);
10001 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
10002 deallocated if expr is an array of different shape or any of the
10003 corresponding length type parameter values of variable and expr
10004 differ." This assures F95 compatibility. */
10005 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10006 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10008 /* Allocate if data is NULL. */
10009 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10010 array1
, build_int_cst (TREE_TYPE (array1
), 0));
10012 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10014 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10016 lss
->info
->string_length
,
10017 rss
->info
->string_length
);
10018 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10019 logical_type_node
, tmp
, cond_null
);
10022 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10024 tmp
= build3_v (COND_EXPR
, cond_null
,
10025 build1_v (GOTO_EXPR
, jump_label1
),
10026 build_empty_stmt (input_location
));
10027 gfc_add_expr_to_block (&fblock
, tmp
);
10029 /* Get arrayspec if expr is a full array. */
10030 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
10031 && expr2
->value
.function
.isym
10032 && expr2
->value
.function
.isym
->conversion
)
10034 /* For conversion functions, take the arg. */
10035 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
10036 as
= gfc_get_full_arrayspec_from_expr (arg
);
10039 as
= gfc_get_full_arrayspec_from_expr (expr2
);
10043 /* If the lhs shape is not the same as the rhs jump to setting the
10044 bounds and doing the reallocation....... */
10045 for (n
= 0; n
< expr1
->rank
; n
++)
10047 /* Check the shape. */
10048 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10049 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10050 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10051 gfc_array_index_type
,
10052 loop
->to
[n
], loop
->from
[n
]);
10053 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10054 gfc_array_index_type
,
10056 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10057 gfc_array_index_type
,
10059 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10061 tmp
, gfc_index_zero_node
);
10062 tmp
= build3_v (COND_EXPR
, cond
,
10063 build1_v (GOTO_EXPR
, jump_label1
),
10064 build_empty_stmt (input_location
));
10065 gfc_add_expr_to_block (&fblock
, tmp
);
10068 /* ....else jump past the (re)alloc code. */
10069 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10070 gfc_add_expr_to_block (&fblock
, tmp
);
10072 /* Add the label to start automatic (re)allocation. */
10073 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10074 gfc_add_expr_to_block (&fblock
, tmp
);
10076 /* If the lhs has not been allocated, its bounds will not have been
10077 initialized and so its size is set to zero. */
10078 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
10079 gfc_init_block (&alloc_block
);
10080 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
10081 gfc_init_block (&realloc_block
);
10082 gfc_add_modify (&realloc_block
, size1
,
10083 gfc_conv_descriptor_size (desc
, expr1
->rank
));
10084 tmp
= build3_v (COND_EXPR
, cond_null
,
10085 gfc_finish_block (&alloc_block
),
10086 gfc_finish_block (&realloc_block
));
10087 gfc_add_expr_to_block (&fblock
, tmp
);
10089 /* Get the rhs size and fix it. */
10091 desc2
= rss
->info
->data
.array
.descriptor
;
10095 size2
= gfc_index_one_node
;
10096 for (n
= 0; n
< expr2
->rank
; n
++)
10098 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10099 gfc_array_index_type
,
10100 loop
->to
[n
], loop
->from
[n
]);
10101 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10102 gfc_array_index_type
,
10103 tmp
, gfc_index_one_node
);
10104 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10105 gfc_array_index_type
,
10108 size2
= gfc_evaluate_now (size2
, &fblock
);
10110 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10113 /* If the lhs is deferred length, assume that the element size
10114 changes and force a reallocation. */
10115 if (expr1
->ts
.deferred
)
10116 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
10118 neq_size
= gfc_evaluate_now (cond
, &fblock
);
10120 /* Deallocation of allocatable components will have to occur on
10121 reallocation. Fix the old descriptor now. */
10122 if ((expr1
->ts
.type
== BT_DERIVED
)
10123 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10124 old_desc
= gfc_evaluate_now (desc
, &fblock
);
10126 old_desc
= NULL_TREE
;
10128 /* Now modify the lhs descriptor and the associated scalarizer
10129 variables. F2003 7.4.1.3: "If variable is or becomes an
10130 unallocated allocatable variable, then it is allocated with each
10131 deferred type parameter equal to the corresponding type parameters
10132 of expr , with the shape of expr , and with each lower bound equal
10133 to the corresponding element of LBOUND(expr)."
10134 Reuse size1 to keep a dimension-by-dimension track of the
10135 stride of the new array. */
10136 size1
= gfc_index_one_node
;
10137 offset
= gfc_index_zero_node
;
10139 for (n
= 0; n
< expr2
->rank
; n
++)
10141 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10142 gfc_array_index_type
,
10143 loop
->to
[n
], loop
->from
[n
]);
10144 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10145 gfc_array_index_type
,
10146 tmp
, gfc_index_one_node
);
10148 lbound
= gfc_index_one_node
;
10153 lbd
= get_std_lbound (expr2
, desc2
, n
,
10154 as
->type
== AS_ASSUMED_SIZE
);
10155 ubound
= fold_build2_loc (input_location
,
10157 gfc_array_index_type
,
10159 ubound
= fold_build2_loc (input_location
,
10161 gfc_array_index_type
,
10166 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
10169 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
10172 gfc_conv_descriptor_stride_set (&fblock
, desc
,
10175 lbound
= gfc_conv_descriptor_lbound_get (desc
,
10177 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
10178 gfc_array_index_type
,
10180 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10181 gfc_array_index_type
,
10183 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10184 gfc_array_index_type
,
10188 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10189 the array offset is saved and the info.offset is used for a
10190 running offset. Use the saved_offset instead. */
10191 tmp
= gfc_conv_descriptor_offset (desc
);
10192 gfc_add_modify (&fblock
, tmp
, offset
);
10193 if (linfo
->saved_offset
10194 && VAR_P (linfo
->saved_offset
))
10195 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10197 /* Now set the deltas for the lhs. */
10198 for (n
= 0; n
< expr1
->rank
; n
++)
10200 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10202 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10203 gfc_array_index_type
, tmp
,
10205 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10206 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10209 /* Get the new lhs size in bytes. */
10210 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10212 if (expr2
->ts
.deferred
)
10214 if (expr2
->ts
.u
.cl
->backend_decl
10215 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10216 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10218 tmp
= rss
->info
->string_length
;
10222 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10223 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10224 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10226 tmp
= concat_str_length (expr2
);
10227 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10229 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10232 gfc_init_se (&tmpse
, NULL
);
10233 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10234 gfc_charlen_type_node
);
10236 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10238 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10241 if (expr1
->ts
.u
.cl
->backend_decl
10242 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10243 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10245 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10247 if (expr1
->ts
.kind
> 1)
10248 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10250 tmp
, build_int_cst (TREE_TYPE (tmp
),
10253 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10255 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10256 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10257 gfc_array_index_type
, tmp
,
10258 expr1
->ts
.u
.cl
->backend_decl
);
10260 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10261 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10263 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10264 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10266 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10267 gfc_conv_descriptor_span_set (&fblock
, desc
, tmp
);
10269 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10270 gfc_array_index_type
,
10272 size2
= fold_convert (size_type_node
, size2
);
10273 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10274 size2
, size_one_node
);
10275 size2
= gfc_evaluate_now (size2
, &fblock
);
10277 /* For deferred character length, the 'size' field of the dtype might
10278 have changed so set the dtype. */
10279 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10280 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10283 tmp
= gfc_conv_descriptor_dtype (desc
);
10284 if (expr2
->ts
.u
.cl
->backend_decl
)
10285 type
= gfc_typenode_for_spec (&expr2
->ts
);
10287 type
= gfc_typenode_for_spec (&expr1
->ts
);
10289 gfc_add_modify (&fblock
, tmp
,
10290 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10292 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10295 tmp
= gfc_conv_descriptor_dtype (desc
);
10296 type
= gfc_typenode_for_spec (&expr2
->ts
);
10297 gfc_add_modify (&fblock
, tmp
,
10298 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10299 /* Set the _len field as well... */
10300 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10301 if (expr2
->ts
.type
== BT_CHARACTER
)
10302 gfc_add_modify (&fblock
, tmp
,
10303 fold_convert (TREE_TYPE (tmp
),
10304 TYPE_SIZE_UNIT (type
)));
10306 gfc_add_modify (&fblock
, tmp
,
10307 build_int_cst (TREE_TYPE (tmp
), 0));
10308 /* ...and the vptr. */
10309 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10310 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10311 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10312 gfc_add_modify (&fblock
, tmp
, tmp2
);
10314 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10316 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10317 gfc_get_dtype (TREE_TYPE (desc
)));
10320 /* Realloc expression. Note that the scalarizer uses desc.data
10321 in the array reference - (*desc.data)[<element>]. */
10322 gfc_init_block (&realloc_block
);
10323 gfc_init_se (&caf_se
, NULL
);
10327 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10328 if (token
== NULL_TREE
)
10330 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10331 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10332 tmp
= build_fold_indirect_ref (tmp
);
10333 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10335 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10338 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10340 if ((expr1
->ts
.type
== BT_DERIVED
)
10341 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10343 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10345 gfc_add_expr_to_block (&realloc_block
, tmp
);
10350 tmp
= build_call_expr_loc (input_location
,
10351 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10352 fold_convert (pvoid_type_node
, array1
),
10354 gfc_conv_descriptor_data_set (&realloc_block
,
10359 tmp
= build_call_expr_loc (input_location
,
10360 gfor_fndecl_caf_deregister
, 5, token
,
10361 build_int_cst (integer_type_node
,
10362 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10363 null_pointer_node
, null_pointer_node
,
10364 integer_zero_node
);
10365 gfc_add_expr_to_block (&realloc_block
, tmp
);
10366 tmp
= build_call_expr_loc (input_location
,
10367 gfor_fndecl_caf_register
,
10369 build_int_cst (integer_type_node
,
10370 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10371 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10372 null_pointer_node
, null_pointer_node
,
10373 integer_zero_node
);
10374 gfc_add_expr_to_block (&realloc_block
, tmp
);
10377 if ((expr1
->ts
.type
== BT_DERIVED
)
10378 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10380 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10382 gfc_add_expr_to_block (&realloc_block
, tmp
);
10385 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10386 realloc_expr
= gfc_finish_block (&realloc_block
);
10388 /* Only reallocate if sizes are different. */
10389 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10390 build_empty_stmt (input_location
));
10391 realloc_expr
= tmp
;
10394 /* Malloc expression. */
10395 gfc_init_block (&alloc_block
);
10398 tmp
= build_call_expr_loc (input_location
,
10399 builtin_decl_explicit (BUILT_IN_MALLOC
),
10401 gfc_conv_descriptor_data_set (&alloc_block
,
10406 tmp
= build_call_expr_loc (input_location
,
10407 gfor_fndecl_caf_register
,
10409 build_int_cst (integer_type_node
,
10410 GFC_CAF_COARRAY_ALLOC
),
10411 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10412 null_pointer_node
, null_pointer_node
,
10413 integer_zero_node
);
10414 gfc_add_expr_to_block (&alloc_block
, tmp
);
10418 /* We already set the dtype in the case of deferred character
10419 length arrays and unlimited polymorphic arrays. */
10420 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10421 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10423 && !UNLIMITED_POLY (expr1
))
10425 tmp
= gfc_conv_descriptor_dtype (desc
);
10426 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10429 if ((expr1
->ts
.type
== BT_DERIVED
)
10430 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10432 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10434 gfc_add_expr_to_block (&alloc_block
, tmp
);
10436 alloc_expr
= gfc_finish_block (&alloc_block
);
10438 /* Malloc if not allocated; realloc otherwise. */
10439 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10440 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10443 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10444 gfc_add_expr_to_block (&fblock
, tmp
);
10446 /* Make sure that the scalarizer data pointer is updated. */
10447 if (linfo
->data
&& VAR_P (linfo
->data
))
10449 tmp
= gfc_conv_descriptor_data_get (desc
);
10450 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10453 /* Add the exit label. */
10454 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10455 gfc_add_expr_to_block (&fblock
, tmp
);
10457 return gfc_finish_block (&fblock
);
10461 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10462 Do likewise, recursively if necessary, with the allocatable components of
10466 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10472 stmtblock_t cleanup
;
10475 bool sym_has_alloc_comp
, has_finalizer
;
10477 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10478 || sym
->ts
.type
== BT_CLASS
)
10479 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10480 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10481 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10483 /* Make sure the frontend gets these right. */
10484 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10487 gfc_save_backend_locus (&loc
);
10488 gfc_set_backend_locus (&sym
->declared_at
);
10489 gfc_init_block (&init
);
10491 gcc_assert (VAR_P (sym
->backend_decl
)
10492 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10494 if (sym
->ts
.type
== BT_CHARACTER
10495 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10497 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10498 gfc_trans_vla_type_sizes (sym
, &init
);
10501 /* Dummy, use associated and result variables don't need anything special. */
10502 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10504 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10505 gfc_restore_backend_locus (&loc
);
10509 descriptor
= sym
->backend_decl
;
10511 /* Although static, derived types with default initializers and
10512 allocatable components must not be nulled wholesale; instead they
10513 are treated component by component. */
10514 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10516 /* SAVEd variables are not freed on exit. */
10517 gfc_trans_static_array_pointer (sym
);
10519 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10520 gfc_restore_backend_locus (&loc
);
10524 /* Get the descriptor type. */
10525 type
= TREE_TYPE (sym
->backend_decl
);
10527 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10528 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10530 if (!sym
->attr
.save
10531 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10533 if (sym
->value
== NULL
10534 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10536 rank
= sym
->as
? sym
->as
->rank
: 0;
10537 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10539 gfc_add_expr_to_block (&init
, tmp
);
10542 gfc_init_default_dt (sym
, &init
, false);
10545 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10547 /* If the backend_decl is not a descriptor, we must have a pointer
10549 descriptor
= build_fold_indirect_ref_loc (input_location
,
10550 sym
->backend_decl
);
10551 type
= TREE_TYPE (descriptor
);
10554 /* NULLIFY the data pointer, for non-saved allocatables. */
10555 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10557 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10558 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10560 /* Declare the variable static so its array descriptor stays present
10561 after leaving the scope. It may still be accessed through another
10562 image. This may happen, for example, with the caf_mpi
10564 TREE_STATIC (descriptor
) = 1;
10565 tmp
= gfc_conv_descriptor_token (descriptor
);
10566 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10567 null_pointer_node
));
10571 gfc_restore_backend_locus (&loc
);
10572 gfc_init_block (&cleanup
);
10574 /* Allocatable arrays need to be freed when they go out of scope.
10575 The allocatable components of pointers must not be touched. */
10576 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10577 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10578 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10581 sym
->attr
.referenced
= 1;
10582 e
= gfc_lval_expr_from_sym (sym
);
10583 gfc_add_finalizer_call (&cleanup
, e
);
10586 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10587 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10588 && !sym
->attr
.pointer
&& !sym
->attr
.save
10589 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10592 rank
= sym
->as
? sym
->as
->rank
: 0;
10593 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10594 gfc_add_expr_to_block (&cleanup
, tmp
);
10597 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10598 && !sym
->attr
.save
&& !sym
->attr
.result
10599 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10602 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10603 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10604 NULL_TREE
, NULL_TREE
, true, e
,
10605 sym
->attr
.codimension
10606 ? GFC_CAF_COARRAY_DEREGISTER
10607 : GFC_CAF_COARRAY_NOCOARRAY
);
10610 gfc_add_expr_to_block (&cleanup
, tmp
);
10613 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10614 gfc_finish_block (&cleanup
));
10617 /************ Expression Walking Functions ******************/
10619 /* Walk a variable reference.
10621 Possible extension - multiple component subscripts.
10622 x(:,:) = foo%a(:)%b(:)
10624 forall (i=..., j=...)
10625 x(i,j) = foo%a(j)%b(i)
10627 This adds a fair amount of complexity because you need to deal with more
10628 than one ref. Maybe handle in a similar manner to vector subscripts.
10629 Maybe not worth the effort. */
10633 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10637 gfc_fix_class_refs (expr
);
10639 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10640 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10643 return gfc_walk_array_ref (ss
, expr
, ref
);
10648 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10654 for (; ref
; ref
= ref
->next
)
10656 if (ref
->type
== REF_SUBSTRING
)
10658 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10659 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10662 /* We're only interested in array sections from now on. */
10663 if (ref
->type
!= REF_ARRAY
)
10671 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10672 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10676 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10677 newss
->info
->data
.array
.ref
= ref
;
10679 /* Make sure array is the same as array(:,:), this way
10680 we don't need to special case all the time. */
10681 ar
->dimen
= ar
->as
->rank
;
10682 for (n
= 0; n
< ar
->dimen
; n
++)
10684 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10686 gcc_assert (ar
->start
[n
] == NULL
);
10687 gcc_assert (ar
->end
[n
] == NULL
);
10688 gcc_assert (ar
->stride
[n
] == NULL
);
10694 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10695 newss
->info
->data
.array
.ref
= ref
;
10697 /* We add SS chains for all the subscripts in the section. */
10698 for (n
= 0; n
< ar
->dimen
; n
++)
10702 switch (ar
->dimen_type
[n
])
10704 case DIMEN_ELEMENT
:
10705 /* Add SS for elemental (scalar) subscripts. */
10706 gcc_assert (ar
->start
[n
]);
10707 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10708 indexss
->loop_chain
= gfc_ss_terminator
;
10709 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10713 /* We don't add anything for sections, just remember this
10714 dimension for later. */
10715 newss
->dim
[newss
->dimen
] = n
;
10720 /* Create a GFC_SS_VECTOR index in which we can store
10721 the vector's descriptor. */
10722 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10724 indexss
->loop_chain
= gfc_ss_terminator
;
10725 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10726 newss
->dim
[newss
->dimen
] = n
;
10731 /* We should know what sort of section it is by now. */
10732 gcc_unreachable ();
10735 /* We should have at least one non-elemental dimension,
10736 unless we are creating a descriptor for a (scalar) coarray. */
10737 gcc_assert (newss
->dimen
> 0
10738 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10743 /* We should know what sort of section it is by now. */
10744 gcc_unreachable ();
10752 /* Walk an expression operator. If only one operand of a binary expression is
10753 scalar, we must also add the scalar term to the SS chain. */
10756 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10761 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10762 if (expr
->value
.op
.op2
== NULL
)
10765 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10767 /* All operands are scalar. Pass back and let the caller deal with it. */
10771 /* All operands require scalarization. */
10772 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10775 /* One of the operands needs scalarization, the other is scalar.
10776 Create a gfc_ss for the scalar expression. */
10779 /* First operand is scalar. We build the chain in reverse order, so
10780 add the scalar SS after the second operand. */
10782 while (head
&& head
->next
!= ss
)
10784 /* Check we haven't somehow broken the chain. */
10786 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10788 else /* head2 == head */
10790 gcc_assert (head2
== head
);
10791 /* Second operand is scalar. */
10792 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10799 /* Reverse a SS chain. */
10802 gfc_reverse_ss (gfc_ss
* ss
)
10807 gcc_assert (ss
!= NULL
);
10809 head
= gfc_ss_terminator
;
10810 while (ss
!= gfc_ss_terminator
)
10813 /* Check we didn't somehow break the chain. */
10814 gcc_assert (next
!= NULL
);
10824 /* Given an expression referring to a procedure, return the symbol of its
10825 interface. We can't get the procedure symbol directly as we have to handle
10826 the case of (deferred) type-bound procedures. */
10829 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10834 if (procedure_ref
== NULL
)
10837 /* Normal procedure case. */
10838 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10839 && procedure_ref
->value
.function
.esym
)
10840 sym
= procedure_ref
->value
.function
.esym
;
10842 sym
= procedure_ref
->symtree
->n
.sym
;
10844 /* Typebound procedure case. */
10845 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10847 if (ref
->type
== REF_COMPONENT
10848 && ref
->u
.c
.component
->attr
.proc_pointer
)
10849 sym
= ref
->u
.c
.component
->ts
.interface
;
10858 /* Walk the arguments of an elemental function.
10859 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10860 it is NULL, we don't do the check and the argument is assumed to be present.
10864 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10865 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10867 gfc_formal_arglist
*dummy_arg
;
10873 head
= gfc_ss_terminator
;
10877 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10882 for (; arg
; arg
= arg
->next
)
10884 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10885 goto loop_continue
;
10887 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10890 /* Scalar argument. */
10891 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10892 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10893 newss
->info
->type
= type
;
10895 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10900 if (dummy_arg
!= NULL
10901 && dummy_arg
->sym
->attr
.optional
10902 && arg
->expr
->expr_type
== EXPR_VARIABLE
10903 && (gfc_expr_attr (arg
->expr
).optional
10904 || gfc_expr_attr (arg
->expr
).allocatable
10905 || gfc_expr_attr (arg
->expr
).pointer
))
10906 newss
->info
->can_be_null_ref
= true;
10912 while (tail
->next
!= gfc_ss_terminator
)
10917 if (dummy_arg
!= NULL
)
10918 dummy_arg
= dummy_arg
->next
;
10923 /* If all the arguments are scalar we don't need the argument SS. */
10924 gfc_free_ss_chain (head
);
10925 /* Pass it back. */
10929 /* Add it onto the existing chain. */
10935 /* Walk a function call. Scalar functions are passed back, and taken out of
10936 scalarization loops. For elemental functions we walk their arguments.
10937 The result of functions returning arrays is stored in a temporary outside
10938 the loop, so that the function is only called once. Hence we do not need
10939 to walk their arguments. */
10942 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10944 gfc_intrinsic_sym
*isym
;
10946 gfc_component
*comp
= NULL
;
10948 isym
= expr
->value
.function
.isym
;
10950 /* Handle intrinsic functions separately. */
10952 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10954 sym
= expr
->value
.function
.esym
;
10956 sym
= expr
->symtree
->n
.sym
;
10958 if (gfc_is_class_array_function (expr
))
10959 return gfc_get_array_ss (ss
, expr
,
10960 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10963 /* A function that returns arrays. */
10964 comp
= gfc_get_proc_ptr_comp (expr
);
10965 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10966 || (comp
&& comp
->attr
.dimension
))
10967 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10969 /* Walk the parameters of an elemental function. For now we always pass
10971 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10973 gfc_ss
*old_ss
= ss
;
10975 ss
= gfc_walk_elemental_function_args (old_ss
,
10976 expr
->value
.function
.actual
,
10977 gfc_get_proc_ifc_for_expr (expr
),
10981 || sym
->attr
.proc_pointer
10982 || sym
->attr
.if_source
!= IFSRC_DECL
10983 || sym
->attr
.array_outer_dependency
))
10984 ss
->info
->array_outer_dependency
= 1;
10987 /* Scalar functions are OK as these are evaluated outside the scalarization
10988 loop. Pass back and let the caller deal with it. */
10993 /* An array temporary is constructed for array constructors. */
10996 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10998 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
11002 /* Walk an expression. Add walked expressions to the head of the SS chain.
11003 A wholly scalar expression will not be added. */
11006 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
11010 switch (expr
->expr_type
)
11012 case EXPR_VARIABLE
:
11013 head
= gfc_walk_variable_expr (ss
, expr
);
11017 head
= gfc_walk_op_expr (ss
, expr
);
11020 case EXPR_FUNCTION
:
11021 head
= gfc_walk_function_expr (ss
, expr
);
11024 case EXPR_CONSTANT
:
11026 case EXPR_STRUCTURE
:
11027 /* Pass back and let the caller deal with it. */
11031 head
= gfc_walk_array_constructor (ss
, expr
);
11034 case EXPR_SUBSTRING
:
11035 /* Pass back and let the caller deal with it. */
11039 gfc_internal_error ("bad expression type during walk (%d)",
11046 /* Entry point for expression walking.
11047 A return value equal to the passed chain means this is
11048 a scalar expression. It is up to the caller to take whatever action is
11049 necessary to translate these. */
11052 gfc_walk_expr (gfc_expr
* expr
)
11056 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
11057 return gfc_reverse_ss (res
);