1 /* Array translation routines
2 Copyright (C) 2002-2020 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 if (TREE_CODE (type
) == REFERENCE_TYPE
)
146 type
= TREE_TYPE (type
);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
150 field
= TYPE_FIELDS (type
);
151 gcc_assert (DATA_FIELD
== 0);
153 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
155 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
160 /* This provides WRITE access to the data field.
162 TUPLES_P is true if we are generating tuples.
164 This function gets called through the following macros:
165 gfc_conv_descriptor_data_set
166 gfc_conv_descriptor_data_set. */
169 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
173 type
= TREE_TYPE (desc
);
174 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
176 field
= TYPE_FIELDS (type
);
177 gcc_assert (DATA_FIELD
== 0);
179 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
181 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
185 /* This provides address access to the data field. This should only be
186 used by array allocation, passing this on to the runtime. */
189 gfc_conv_descriptor_data_addr (tree desc
)
193 type
= TREE_TYPE (desc
);
194 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
196 field
= TYPE_FIELDS (type
);
197 gcc_assert (DATA_FIELD
== 0);
199 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
201 return gfc_build_addr_expr (NULL_TREE
, t
);
205 gfc_conv_descriptor_offset (tree desc
)
210 type
= TREE_TYPE (desc
);
211 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
213 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
214 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
216 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
217 desc
, field
, NULL_TREE
);
221 gfc_conv_descriptor_offset_get (tree desc
)
223 return gfc_conv_descriptor_offset (desc
);
227 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
230 tree t
= gfc_conv_descriptor_offset (desc
);
231 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
236 gfc_conv_descriptor_dtype (tree desc
)
241 type
= TREE_TYPE (desc
);
242 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
244 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
245 gcc_assert (field
!= NULL_TREE
246 && TREE_TYPE (field
) == get_dtype_type_node ());
248 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
249 desc
, field
, NULL_TREE
);
253 gfc_conv_descriptor_span (tree desc
)
258 type
= TREE_TYPE (desc
);
259 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
261 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
262 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
264 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
265 desc
, field
, NULL_TREE
);
269 gfc_conv_descriptor_span_get (tree desc
)
271 return gfc_conv_descriptor_span (desc
);
275 gfc_conv_descriptor_span_set (stmtblock_t
*block
, tree desc
,
278 tree t
= gfc_conv_descriptor_span (desc
);
279 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
284 gfc_conv_descriptor_rank (tree desc
)
289 dtype
= gfc_conv_descriptor_dtype (desc
);
290 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)), GFC_DTYPE_RANK
);
291 gcc_assert (tmp
!= NULL_TREE
292 && TREE_TYPE (tmp
) == signed_char_type_node
);
293 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
294 dtype
, tmp
, NULL_TREE
);
298 /* Return the element length from the descriptor dtype field. */
301 gfc_conv_descriptor_elem_len (tree desc
)
306 dtype
= gfc_conv_descriptor_dtype (desc
);
307 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
309 gcc_assert (tmp
!= NULL_TREE
310 && TREE_TYPE (tmp
) == size_type_node
);
311 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
312 dtype
, tmp
, NULL_TREE
);
317 gfc_conv_descriptor_attribute (tree desc
)
322 dtype
= gfc_conv_descriptor_dtype (desc
);
323 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
324 GFC_DTYPE_ATTRIBUTE
);
325 gcc_assert (tmp
!= NULL_TREE
326 && TREE_TYPE (tmp
) == short_integer_type_node
);
327 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
328 dtype
, tmp
, NULL_TREE
);
333 gfc_get_descriptor_dimension (tree desc
)
337 type
= TREE_TYPE (desc
);
338 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
340 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
341 gcc_assert (field
!= NULL_TREE
342 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
343 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
345 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
346 desc
, field
, NULL_TREE
);
351 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
355 tmp
= gfc_get_descriptor_dimension (desc
);
357 return gfc_build_array_ref (tmp
, dim
, NULL
);
362 gfc_conv_descriptor_token (tree desc
)
367 type
= TREE_TYPE (desc
);
368 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
369 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
370 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
372 /* Should be a restricted pointer - except in the finalization wrapper. */
373 gcc_assert (field
!= NULL_TREE
374 && (TREE_TYPE (field
) == prvoid_type_node
375 || TREE_TYPE (field
) == pvoid_type_node
));
377 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
378 desc
, field
, NULL_TREE
);
383 gfc_conv_descriptor_stride (tree desc
, tree dim
)
388 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
389 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
390 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
391 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
393 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
394 tmp
, field
, NULL_TREE
);
399 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
401 tree type
= TREE_TYPE (desc
);
402 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
403 if (integer_zerop (dim
)
404 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
405 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
406 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
407 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
408 return gfc_index_one_node
;
410 return gfc_conv_descriptor_stride (desc
, dim
);
414 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
415 tree dim
, tree value
)
417 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
418 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
422 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
427 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
428 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
429 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
430 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
432 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
433 tmp
, field
, NULL_TREE
);
438 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
440 return gfc_conv_descriptor_lbound (desc
, dim
);
444 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
445 tree dim
, tree value
)
447 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
448 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
452 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
457 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
458 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
459 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
460 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
462 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
463 tmp
, field
, NULL_TREE
);
468 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
470 return gfc_conv_descriptor_ubound (desc
, dim
);
474 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
475 tree dim
, tree value
)
477 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
478 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
481 /* Build a null array descriptor constructor. */
484 gfc_build_null_descriptor (tree type
)
489 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
490 gcc_assert (DATA_FIELD
== 0);
491 field
= TYPE_FIELDS (type
);
493 /* Set a NULL data pointer. */
494 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
495 TREE_CONSTANT (tmp
) = 1;
496 /* All other fields are ignored. */
502 /* Modify a descriptor such that the lbound of a given dimension is the value
503 specified. This also updates ubound and offset accordingly. */
506 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
507 int dim
, tree new_lbound
)
509 tree offs
, ubound
, lbound
, stride
;
510 tree diff
, offs_diff
;
512 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
514 offs
= gfc_conv_descriptor_offset_get (desc
);
515 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
516 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
517 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
519 /* Get difference (new - old) by which to shift stuff. */
520 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
523 /* Shift ubound and offset accordingly. This has to be done before
524 updating the lbound, as they depend on the lbound expression! */
525 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
527 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
528 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
530 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
532 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
534 /* Finally set lbound to value we want. */
535 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
539 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
542 gfc_get_descriptor_offsets_for_info (const_tree desc_type
, tree
*data_off
,
543 tree
*dtype_off
, tree
*span_off
,
544 tree
*dim_off
, tree
*dim_size
,
545 tree
*stride_suboff
, tree
*lower_suboff
,
551 type
= TYPE_MAIN_VARIANT (desc_type
);
552 field
= gfc_advance_chain (TYPE_FIELDS (type
), DATA_FIELD
);
553 *data_off
= byte_position (field
);
554 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
555 *dtype_off
= byte_position (field
);
556 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
557 *span_off
= byte_position (field
);
558 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
559 *dim_off
= byte_position (field
);
560 type
= TREE_TYPE (TREE_TYPE (field
));
561 *dim_size
= TYPE_SIZE_UNIT (type
);
562 field
= gfc_advance_chain (TYPE_FIELDS (type
), STRIDE_SUBFIELD
);
563 *stride_suboff
= byte_position (field
);
564 field
= gfc_advance_chain (TYPE_FIELDS (type
), LBOUND_SUBFIELD
);
565 *lower_suboff
= byte_position (field
);
566 field
= gfc_advance_chain (TYPE_FIELDS (type
), UBOUND_SUBFIELD
);
567 *upper_suboff
= byte_position (field
);
571 /* Cleanup those #defines. */
577 #undef DIMENSION_FIELD
578 #undef CAF_TOKEN_FIELD
579 #undef STRIDE_SUBFIELD
580 #undef LBOUND_SUBFIELD
581 #undef UBOUND_SUBFIELD
584 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
585 flags & 1 = Main loop body.
586 flags & 2 = temp copy loop. */
589 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
591 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
592 ss
->info
->useflags
= flags
;
596 /* Free a gfc_ss chain. */
599 gfc_free_ss_chain (gfc_ss
* ss
)
603 while (ss
!= gfc_ss_terminator
)
605 gcc_assert (ss
!= NULL
);
614 free_ss_info (gfc_ss_info
*ss_info
)
619 if (ss_info
->refcount
> 0)
622 gcc_assert (ss_info
->refcount
== 0);
624 switch (ss_info
->type
)
627 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
628 if (ss_info
->data
.array
.subscript
[n
])
629 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
643 gfc_free_ss (gfc_ss
* ss
)
645 free_ss_info (ss
->info
);
650 /* Creates and initializes an array type gfc_ss struct. */
653 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
656 gfc_ss_info
*ss_info
;
659 ss_info
= gfc_get_ss_info ();
661 ss_info
->type
= type
;
662 ss_info
->expr
= expr
;
668 for (i
= 0; i
< ss
->dimen
; i
++)
675 /* Creates and initializes a temporary type gfc_ss struct. */
678 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
681 gfc_ss_info
*ss_info
;
684 ss_info
= gfc_get_ss_info ();
686 ss_info
->type
= GFC_SS_TEMP
;
687 ss_info
->string_length
= string_length
;
688 ss_info
->data
.temp
.type
= type
;
692 ss
->next
= gfc_ss_terminator
;
694 for (i
= 0; i
< ss
->dimen
; i
++)
701 /* Creates and initializes a scalar type gfc_ss struct. */
704 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
707 gfc_ss_info
*ss_info
;
709 ss_info
= gfc_get_ss_info ();
711 ss_info
->type
= GFC_SS_SCALAR
;
712 ss_info
->expr
= expr
;
722 /* Free all the SS associated with a loop. */
725 gfc_cleanup_loop (gfc_loopinfo
* loop
)
727 gfc_loopinfo
*loop_next
, **ploop
;
732 while (ss
!= gfc_ss_terminator
)
734 gcc_assert (ss
!= NULL
);
735 next
= ss
->loop_chain
;
740 /* Remove reference to self in the parent loop. */
742 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
749 /* Free non-freed nested loops. */
750 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
752 loop_next
= loop
->next
;
753 gfc_cleanup_loop (loop
);
760 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
764 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
768 if (ss
->info
->type
== GFC_SS_SCALAR
769 || ss
->info
->type
== GFC_SS_REFERENCE
770 || ss
->info
->type
== GFC_SS_TEMP
)
773 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
774 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
775 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
780 /* Associate a SS chain with a loop. */
783 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
786 gfc_loopinfo
*nested_loop
;
788 if (head
== gfc_ss_terminator
)
791 set_ss_loop (head
, loop
);
794 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
798 nested_loop
= ss
->nested_ss
->loop
;
800 /* More than one ss can belong to the same loop. Hence, we add the
801 loop to the chain only if it is different from the previously
802 added one, to avoid duplicate nested loops. */
803 if (nested_loop
!= loop
->nested
)
805 gcc_assert (nested_loop
->parent
== NULL
);
806 nested_loop
->parent
= loop
;
808 gcc_assert (nested_loop
->next
== NULL
);
809 nested_loop
->next
= loop
->nested
;
810 loop
->nested
= nested_loop
;
813 gcc_assert (nested_loop
->parent
== loop
);
816 if (ss
->next
== gfc_ss_terminator
)
817 ss
->loop_chain
= loop
->ss
;
819 ss
->loop_chain
= ss
->next
;
821 gcc_assert (ss
== gfc_ss_terminator
);
826 /* Returns true if the expression is an array pointer. */
829 is_pointer_array (tree expr
)
831 if (expr
== NULL_TREE
832 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr
))
833 || GFC_CLASS_TYPE_P (TREE_TYPE (expr
)))
836 if (TREE_CODE (expr
) == VAR_DECL
837 && GFC_DECL_PTR_ARRAY_P (expr
))
840 if (TREE_CODE (expr
) == PARM_DECL
841 && GFC_DECL_PTR_ARRAY_P (expr
))
844 if (TREE_CODE (expr
) == INDIRECT_REF
845 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 0)))
848 /* The field declaration is marked as an pointer array. */
849 if (TREE_CODE (expr
) == COMPONENT_REF
850 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 1))
851 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr
, 1))))
858 /* If the symbol or expression reference a CFI descriptor, return the
859 pointer to the converted gfc descriptor. If an array reference is
860 present as the last argument, check that it is the one applied to
861 the CFI descriptor in the expression. Note that the CFI object is
862 always the symbol in the expression! */
865 get_CFI_desc (gfc_symbol
*sym
, gfc_expr
*expr
,
866 tree
*desc
, gfc_array_ref
*ar
)
870 if (!is_CFI_desc (sym
, expr
))
875 if (!(expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
876 || (&expr
->ref
->u
.ar
!= ar
))
881 tmp
= expr
->symtree
->n
.sym
->backend_decl
;
883 tmp
= sym
->backend_decl
;
885 if (tmp
&& DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
886 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
893 /* Return the span of an array. */
896 gfc_get_array_span (tree desc
, gfc_expr
*expr
)
900 if (is_pointer_array (desc
) || get_CFI_desc (NULL
, expr
, &desc
, NULL
))
902 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
903 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
905 /* This will have the span field set. */
906 tmp
= gfc_conv_descriptor_span_get (desc
);
908 else if (TREE_CODE (desc
) == COMPONENT_REF
909 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
910 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
912 /* The descriptor is a class _data field and so use the vtable
913 size for the receiving span field. */
914 tmp
= gfc_get_vptr_from_expr (desc
);
915 tmp
= gfc_vptr_size_get (tmp
);
917 else if (expr
&& expr
->expr_type
== EXPR_VARIABLE
918 && expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
919 && expr
->ref
->type
== REF_COMPONENT
920 && expr
->ref
->next
->type
== REF_ARRAY
921 && expr
->ref
->next
->next
== NULL
922 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.dimension
)
924 /* Dummys come in sometimes with the descriptor detached from
925 the class field or declaration. */
926 tmp
= gfc_class_vptr_get (expr
->symtree
->n
.sym
->backend_decl
);
927 tmp
= gfc_vptr_size_get (tmp
);
931 /* If none of the fancy stuff works, the span is the element
932 size of the array. Attempt to deal with unbounded character
933 types if possible. Otherwise, return NULL_TREE. */
934 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
935 if (tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
936 && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) == NULL_TREE
937 || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)))))
939 if (expr
->expr_type
== EXPR_VARIABLE
940 && expr
->ts
.type
== BT_CHARACTER
)
941 tmp
= fold_convert (gfc_array_index_type
,
942 gfc_get_expr_charlen (expr
));
947 tmp
= fold_convert (gfc_array_index_type
,
948 size_in_bytes (tmp
));
954 /* Generate an initializer for a static pointer or allocatable array. */
957 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
961 gcc_assert (TREE_STATIC (sym
->backend_decl
));
962 /* Just zero the data member. */
963 type
= TREE_TYPE (sym
->backend_decl
);
964 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
968 /* If the bounds of SE's loop have not yet been set, see if they can be
969 determined from array spec AS, which is the array spec of a called
970 function. MAPPING maps the callee's dummy arguments to the values
971 that the caller is passing. Add any initialization and finalization
975 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
976 gfc_se
* se
, gfc_array_spec
* as
)
978 int n
, dim
, total_dim
;
987 if (!as
|| as
->type
!= AS_EXPLICIT
)
990 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
992 total_dim
+= ss
->loop
->dimen
;
993 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
995 /* The bound is known, nothing to do. */
996 if (ss
->loop
->to
[n
] != NULL_TREE
)
1000 gcc_assert (dim
< as
->rank
);
1001 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
1003 /* Evaluate the lower bound. */
1004 gfc_init_se (&tmpse
, NULL
);
1005 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
1006 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
1007 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
1008 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
1010 /* ...and the upper bound. */
1011 gfc_init_se (&tmpse
, NULL
);
1012 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
1013 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
1014 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
1015 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
1017 /* Set the upper bound of the loop to UPPER - LOWER. */
1018 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1019 gfc_array_index_type
, upper
, lower
);
1020 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1021 ss
->loop
->to
[n
] = tmp
;
1025 gcc_assert (total_dim
== as
->rank
);
1029 /* Generate code to allocate an array temporary, or create a variable to
1030 hold the data. If size is NULL, zero the descriptor so that the
1031 callee will allocate the array. If DEALLOC is true, also generate code to
1032 free the array afterwards.
1034 If INITIAL is not NULL, it is packed using internal_pack and the result used
1035 as data instead of allocating a fresh, unitialized area of memory.
1037 Initialization code is added to PRE and finalization code to POST.
1038 DYNAMIC is true if the caller may want to extend the array later
1039 using realloc. This prevents us from putting the array on the stack. */
1042 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
1043 gfc_array_info
* info
, tree size
, tree nelem
,
1044 tree initial
, bool dynamic
, bool dealloc
)
1050 desc
= info
->descriptor
;
1051 info
->offset
= gfc_index_zero_node
;
1052 if (size
== NULL_TREE
|| integer_zerop (size
))
1054 /* A callee allocated array. */
1055 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
1060 /* Allocate the temporary. */
1061 onstack
= !dynamic
&& initial
== NULL_TREE
1062 && (flag_stack_arrays
1063 || gfc_can_put_var_on_stack (size
));
1067 /* Make a temporary variable to hold the data. */
1068 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
1069 nelem
, gfc_index_one_node
);
1070 tmp
= gfc_evaluate_now (tmp
, pre
);
1071 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1073 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
1075 tmp
= gfc_create_var (tmp
, "A");
1076 /* If we're here only because of -fstack-arrays we have to
1077 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1078 if (!gfc_can_put_var_on_stack (size
))
1079 gfc_add_expr_to_block (pre
,
1080 fold_build1_loc (input_location
,
1081 DECL_EXPR
, TREE_TYPE (tmp
),
1083 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1084 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1088 /* Allocate memory to hold the data or call internal_pack. */
1089 if (initial
== NULL_TREE
)
1091 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1092 tmp
= gfc_evaluate_now (tmp
, pre
);
1099 stmtblock_t do_copying
;
1101 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1102 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1103 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1104 tmp
= gfc_get_element_type (tmp
);
1105 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1106 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1108 tmp
= build_call_expr_loc (input_location
,
1109 gfor_fndecl_in_pack
, 1, initial
);
1110 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1111 gfc_add_modify (pre
, packed
, tmp
);
1113 tmp
= build_fold_indirect_ref_loc (input_location
,
1115 source_data
= gfc_conv_descriptor_data_get (tmp
);
1117 /* internal_pack may return source->data without any allocation
1118 or copying if it is already packed. If that's the case, we
1119 need to allocate and copy manually. */
1121 gfc_start_block (&do_copying
);
1122 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1123 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1124 gfc_add_modify (&do_copying
, packed
, tmp
);
1125 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1126 gfc_add_expr_to_block (&do_copying
, tmp
);
1128 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1129 logical_type_node
, packed
,
1131 tmp
= gfc_finish_block (&do_copying
);
1132 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1133 build_empty_stmt (input_location
));
1134 gfc_add_expr_to_block (pre
, tmp
);
1136 tmp
= fold_convert (pvoid_type_node
, packed
);
1139 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1142 info
->data
= gfc_conv_descriptor_data_get (desc
);
1144 /* The offset is zero because we create temporaries with a zero
1146 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1148 if (dealloc
&& !onstack
)
1150 /* Free the temporary. */
1151 tmp
= gfc_conv_descriptor_data_get (desc
);
1152 tmp
= gfc_call_free (tmp
);
1153 gfc_add_expr_to_block (post
, tmp
);
1158 /* Get the scalarizer array dimension corresponding to actual array dimension
1161 For example, if SS represents the array ref a(1,:,:,1), it is a
1162 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1163 and 1 for ARRAY_DIM=2.
1164 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1165 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1167 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1168 array. If called on the inner ss, the result would be respectively 0,1,2 for
1169 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1170 for ARRAY_DIM=1,2. */
1173 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1180 for (; ss
; ss
= ss
->parent
)
1181 for (n
= 0; n
< ss
->dimen
; n
++)
1182 if (ss
->dim
[n
] < array_dim
)
1185 return array_ref_dim
;
1190 innermost_ss (gfc_ss
*ss
)
1192 while (ss
->nested_ss
!= NULL
)
1200 /* Get the array reference dimension corresponding to the given loop dimension.
1201 It is different from the true array dimension given by the dim array in
1202 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1203 It is different from the loop dimension in the case of a transposed array.
1207 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1209 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1214 /* Generate code to create and initialize the descriptor for a temporary
1215 array. This is used for both temporaries needed by the scalarizer, and
1216 functions returning arrays. Adjusts the loop variables to be
1217 zero-based, and calculates the loop bounds for callee allocated arrays.
1218 Allocate the array unless it's callee allocated (we have a callee
1219 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1220 NULL_TREE for any n). Also fills in the descriptor, data and offset
1221 fields of info if known. Returns the size of the array, or NULL for a
1222 callee allocated array.
1224 'eltype' == NULL signals that the temporary should be a class object.
1225 The 'initial' expression is used to obtain the size of the dynamic
1226 type; otherwise the allocation and initialization proceeds as for any
1229 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1230 gfc_trans_allocate_array_storage. */
1233 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1234 tree eltype
, tree initial
, bool dynamic
,
1235 bool dealloc
, bool callee_alloc
, locus
* where
)
1239 gfc_array_info
*info
;
1240 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1249 tree class_expr
= NULL_TREE
;
1250 int n
, dim
, tmp_dim
;
1253 /* This signals a class array for which we need the size of the
1254 dynamic type. Generate an eltype and then the class expression. */
1255 if (eltype
== NULL_TREE
&& initial
)
1257 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1258 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1259 eltype
= TREE_TYPE (class_expr
);
1260 eltype
= gfc_get_element_type (eltype
);
1261 /* Obtain the structure (class) expression. */
1262 class_expr
= TREE_OPERAND (class_expr
, 0);
1263 gcc_assert (class_expr
);
1266 memset (from
, 0, sizeof (from
));
1267 memset (to
, 0, sizeof (to
));
1269 info
= &ss
->info
->data
.array
;
1271 gcc_assert (ss
->dimen
> 0);
1272 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1274 if (warn_array_temporaries
&& where
)
1275 gfc_warning (OPT_Warray_temporaries
,
1276 "Creating array temporary at %L", where
);
1278 /* Set the lower bound to zero. */
1279 for (s
= ss
; s
; s
= s
->parent
)
1283 total_dim
+= loop
->dimen
;
1284 for (n
= 0; n
< loop
->dimen
; n
++)
1288 /* Callee allocated arrays may not have a known bound yet. */
1290 loop
->to
[n
] = gfc_evaluate_now (
1291 fold_build2_loc (input_location
, MINUS_EXPR
,
1292 gfc_array_index_type
,
1293 loop
->to
[n
], loop
->from
[n
]),
1295 loop
->from
[n
] = gfc_index_zero_node
;
1297 /* We have just changed the loop bounds, we must clear the
1298 corresponding specloop, so that delta calculation is not skipped
1299 later in gfc_set_delta. */
1300 loop
->specloop
[n
] = NULL
;
1302 /* We are constructing the temporary's descriptor based on the loop
1303 dimensions. As the dimensions may be accessed in arbitrary order
1304 (think of transpose) the size taken from the n'th loop may not map
1305 to the n'th dimension of the array. We need to reconstruct loop
1306 infos in the right order before using it to set the descriptor
1308 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1309 from
[tmp_dim
] = loop
->from
[n
];
1310 to
[tmp_dim
] = loop
->to
[n
];
1312 info
->delta
[dim
] = gfc_index_zero_node
;
1313 info
->start
[dim
] = gfc_index_zero_node
;
1314 info
->end
[dim
] = gfc_index_zero_node
;
1315 info
->stride
[dim
] = gfc_index_one_node
;
1319 /* Initialize the descriptor. */
1321 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1322 GFC_ARRAY_UNKNOWN
, true);
1323 desc
= gfc_create_var (type
, "atmp");
1324 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1326 info
->descriptor
= desc
;
1327 size
= gfc_index_one_node
;
1329 /* Emit a DECL_EXPR for the variable sized array type in
1330 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1331 sizes works correctly. */
1332 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1333 if (! TYPE_NAME (arraytype
))
1334 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1335 NULL_TREE
, arraytype
);
1336 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1337 arraytype
, TYPE_NAME (arraytype
)));
1339 /* Fill in the array dtype. */
1340 tmp
= gfc_conv_descriptor_dtype (desc
);
1341 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1344 Fill in the bounds and stride. This is a packed array, so:
1347 for (n = 0; n < rank; n++)
1350 delta = ubound[n] + 1 - lbound[n];
1351 size = size * delta;
1353 size = size * sizeof(element);
1356 or_expr
= NULL_TREE
;
1358 /* If there is at least one null loop->to[n], it is a callee allocated
1360 for (n
= 0; n
< total_dim
; n
++)
1361 if (to
[n
] == NULL_TREE
)
1367 if (size
== NULL_TREE
)
1368 for (s
= ss
; s
; s
= s
->parent
)
1369 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1371 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1373 /* For a callee allocated array express the loop bounds in terms
1374 of the descriptor fields. */
1375 tmp
= fold_build2_loc (input_location
,
1376 MINUS_EXPR
, gfc_array_index_type
,
1377 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1378 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1379 s
->loop
->to
[n
] = tmp
;
1383 for (n
= 0; n
< total_dim
; n
++)
1385 /* Store the stride and bound components in the descriptor. */
1386 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1388 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1389 gfc_index_zero_node
);
1391 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1393 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1394 gfc_array_index_type
,
1395 to
[n
], gfc_index_one_node
);
1397 /* Check whether the size for this dimension is negative. */
1398 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1399 tmp
, gfc_index_zero_node
);
1400 cond
= gfc_evaluate_now (cond
, pre
);
1405 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1406 logical_type_node
, or_expr
, cond
);
1408 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1409 gfc_array_index_type
, size
, tmp
);
1410 size
= gfc_evaluate_now (size
, pre
);
1414 if (class_expr
== NULL_TREE
)
1415 elemsize
= fold_convert (gfc_array_index_type
,
1416 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1418 elemsize
= gfc_class_vtab_size_get (class_expr
);
1420 /* Get the size of the array. */
1421 if (size
&& !callee_alloc
)
1423 /* If or_expr is true, then the extent in at least one
1424 dimension is zero and the size is set to zero. */
1425 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1426 or_expr
, gfc_index_zero_node
, size
);
1429 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1439 tmp
= fold_convert (gfc_array_index_type
, elemsize
);
1440 gfc_conv_descriptor_span_set (pre
, desc
, tmp
);
1442 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1448 if (ss
->dimen
> ss
->loop
->temp_dim
)
1449 ss
->loop
->temp_dim
= ss
->dimen
;
1455 /* Return the number of iterations in a loop that starts at START,
1456 ends at END, and has step STEP. */
1459 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1464 type
= TREE_TYPE (step
);
1465 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1466 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1467 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1468 build_int_cst (type
, 1));
1469 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1470 build_int_cst (type
, 0));
1471 return fold_convert (gfc_array_index_type
, tmp
);
1475 /* Extend the data in array DESC by EXTRA elements. */
1478 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1485 if (integer_zerop (extra
))
1488 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1490 /* Add EXTRA to the upper bound. */
1491 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1493 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1495 /* Get the value of the current data pointer. */
1496 arg0
= gfc_conv_descriptor_data_get (desc
);
1498 /* Calculate the new array size. */
1499 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1500 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1501 ubound
, gfc_index_one_node
);
1502 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1503 fold_convert (size_type_node
, tmp
),
1504 fold_convert (size_type_node
, size
));
1506 /* Call the realloc() function. */
1507 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1508 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1512 /* Return true if the bounds of iterator I can only be determined
1516 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1518 return (i
->start
->expr_type
!= EXPR_CONSTANT
1519 || i
->end
->expr_type
!= EXPR_CONSTANT
1520 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1524 /* Split the size of constructor element EXPR into the sum of two terms,
1525 one of which can be determined at compile time and one of which must
1526 be calculated at run time. Set *SIZE to the former and return true
1527 if the latter might be nonzero. */
1530 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1532 if (expr
->expr_type
== EXPR_ARRAY
)
1533 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1534 else if (expr
->rank
> 0)
1536 /* Calculate everything at run time. */
1537 mpz_set_ui (*size
, 0);
1542 /* A single element. */
1543 mpz_set_ui (*size
, 1);
1549 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1550 of array constructor C. */
1553 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1561 mpz_set_ui (*size
, 0);
1566 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1569 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1573 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1576 /* Multiply the static part of the element size by the
1577 number of iterations. */
1578 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1579 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1580 mpz_add_ui (val
, val
, 1);
1581 if (mpz_sgn (val
) > 0)
1582 mpz_mul (len
, len
, val
);
1584 mpz_set_ui (len
, 0);
1586 mpz_add (*size
, *size
, len
);
1595 /* Make sure offset is a variable. */
1598 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1601 /* We should have already created the offset variable. We cannot
1602 create it here because we may be in an inner scope. */
1603 gcc_assert (*offsetvar
!= NULL_TREE
);
1604 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1605 *poffset
= *offsetvar
;
1606 TREE_USED (*offsetvar
) = 1;
1610 /* Variables needed for bounds-checking. */
1611 static bool first_len
;
1612 static tree first_len_val
;
1613 static bool typespec_chararray_ctor
;
1616 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1617 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1621 gfc_conv_expr (se
, expr
);
1623 /* Store the value. */
1624 tmp
= build_fold_indirect_ref_loc (input_location
,
1625 gfc_conv_descriptor_data_get (desc
));
1626 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1628 if (expr
->ts
.type
== BT_CHARACTER
)
1630 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1633 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1634 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1635 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1636 TREE_TYPE (esize
), esize
,
1637 build_int_cst (TREE_TYPE (esize
),
1638 gfc_character_kinds
[i
].bit_size
/ 8));
1640 gfc_conv_string_parameter (se
);
1641 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1643 /* The temporary is an array of pointers. */
1644 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1645 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1649 /* The temporary is an array of string values. */
1650 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1651 /* We know the temporary and the value will be the same length,
1652 so can use memcpy. */
1653 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1654 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1656 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1660 gfc_add_modify (&se
->pre
, first_len_val
,
1661 fold_convert (TREE_TYPE (first_len_val
),
1662 se
->string_length
));
1667 /* Verify that all constructor elements are of the same
1669 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1671 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1672 logical_type_node
, first_len_val
,
1674 gfc_trans_runtime_check
1675 (true, false, cond
, &se
->pre
, &expr
->where
,
1676 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1677 fold_convert (long_integer_type_node
, first_len_val
),
1678 fold_convert (long_integer_type_node
, se
->string_length
));
1682 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1683 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1685 /* Assignment of a CLASS array constructor to a derived type array. */
1686 if (expr
->expr_type
== EXPR_FUNCTION
)
1687 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1688 se
->expr
= gfc_class_data_get (se
->expr
);
1689 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1690 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1691 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1695 /* TODO: Should the frontend already have done this conversion? */
1696 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1697 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1700 gfc_add_block_to_block (pblock
, &se
->pre
);
1701 gfc_add_block_to_block (pblock
, &se
->post
);
1705 /* Add the contents of an array to the constructor. DYNAMIC is as for
1706 gfc_trans_array_constructor_value. */
1709 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1710 tree type ATTRIBUTE_UNUSED
,
1711 tree desc
, gfc_expr
* expr
,
1712 tree
* poffset
, tree
* offsetvar
,
1723 /* We need this to be a variable so we can increment it. */
1724 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1726 gfc_init_se (&se
, NULL
);
1728 /* Walk the array expression. */
1729 ss
= gfc_walk_expr (expr
);
1730 gcc_assert (ss
!= gfc_ss_terminator
);
1732 /* Initialize the scalarizer. */
1733 gfc_init_loopinfo (&loop
);
1734 gfc_add_ss_to_loop (&loop
, ss
);
1736 /* Initialize the loop. */
1737 gfc_conv_ss_startstride (&loop
);
1738 gfc_conv_loop_setup (&loop
, &expr
->where
);
1740 /* Make sure the constructed array has room for the new data. */
1743 /* Set SIZE to the total number of elements in the subarray. */
1744 size
= gfc_index_one_node
;
1745 for (n
= 0; n
< loop
.dimen
; n
++)
1747 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1748 gfc_index_one_node
);
1749 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1750 gfc_array_index_type
, size
, tmp
);
1753 /* Grow the constructed array by SIZE elements. */
1754 gfc_grow_array (&loop
.pre
, desc
, size
);
1757 /* Make the loop body. */
1758 gfc_mark_ss_chain_used (ss
, 1);
1759 gfc_start_scalarized_body (&loop
, &body
);
1760 gfc_copy_loopinfo_to_se (&se
, &loop
);
1763 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1764 gcc_assert (se
.ss
== gfc_ss_terminator
);
1766 /* Increment the offset. */
1767 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1768 *poffset
, gfc_index_one_node
);
1769 gfc_add_modify (&body
, *poffset
, tmp
);
1771 /* Finish the loop. */
1772 gfc_trans_scalarizing_loops (&loop
, &body
);
1773 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1774 tmp
= gfc_finish_block (&loop
.pre
);
1775 gfc_add_expr_to_block (pblock
, tmp
);
1777 gfc_cleanup_loop (&loop
);
1781 /* Assign the values to the elements of an array constructor. DYNAMIC
1782 is true if descriptor DESC only contains enough data for the static
1783 size calculated by gfc_get_array_constructor_size. When true, memory
1784 for the dynamic parts must be allocated using realloc. */
1787 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1788 tree desc
, gfc_constructor_base base
,
1789 tree
* poffset
, tree
* offsetvar
,
1793 tree start
= NULL_TREE
;
1794 tree end
= NULL_TREE
;
1795 tree step
= NULL_TREE
;
1801 tree shadow_loopvar
= NULL_TREE
;
1802 gfc_saved_var saved_loopvar
;
1805 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1807 /* If this is an iterator or an array, the offset must be a variable. */
1808 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1809 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1811 /* Shadowing the iterator avoids changing its value and saves us from
1812 keeping track of it. Further, it makes sure that there's always a
1813 backend-decl for the symbol, even if there wasn't one before,
1814 e.g. in the case of an iterator that appears in a specification
1815 expression in an interface mapping. */
1821 /* Evaluate loop bounds before substituting the loop variable
1822 in case they depend on it. Such a case is invalid, but it is
1823 not more expensive to do the right thing here.
1825 gfc_init_se (&se
, NULL
);
1826 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1827 gfc_add_block_to_block (pblock
, &se
.pre
);
1828 start
= gfc_evaluate_now (se
.expr
, pblock
);
1830 gfc_init_se (&se
, NULL
);
1831 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1832 gfc_add_block_to_block (pblock
, &se
.pre
);
1833 end
= gfc_evaluate_now (se
.expr
, pblock
);
1835 gfc_init_se (&se
, NULL
);
1836 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1837 gfc_add_block_to_block (pblock
, &se
.pre
);
1838 step
= gfc_evaluate_now (se
.expr
, pblock
);
1840 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1841 type
= gfc_typenode_for_spec (&sym
->ts
);
1843 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1844 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1847 gfc_start_block (&body
);
1849 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1851 /* Array constructors can be nested. */
1852 gfc_trans_array_constructor_value (&body
, type
, desc
,
1853 c
->expr
->value
.constructor
,
1854 poffset
, offsetvar
, dynamic
);
1856 else if (c
->expr
->rank
> 0)
1858 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1859 poffset
, offsetvar
, dynamic
);
1863 /* This code really upsets the gimplifier so don't bother for now. */
1870 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1872 p
= gfc_constructor_next (p
);
1877 /* Scalar values. */
1878 gfc_init_se (&se
, NULL
);
1879 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1882 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1883 gfc_array_index_type
,
1884 *poffset
, gfc_index_one_node
);
1888 /* Collect multiple scalar constants into a constructor. */
1889 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1893 HOST_WIDE_INT idx
= 0;
1896 /* Count the number of consecutive scalar constants. */
1897 while (p
&& !(p
->iterator
1898 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1900 gfc_init_se (&se
, NULL
);
1901 gfc_conv_constant (&se
, p
->expr
);
1903 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1904 se
.expr
= fold_convert (type
, se
.expr
);
1905 /* For constant character array constructors we build
1906 an array of pointers. */
1907 else if (POINTER_TYPE_P (type
))
1908 se
.expr
= gfc_build_addr_expr
1909 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1912 CONSTRUCTOR_APPEND_ELT (v
,
1913 build_int_cst (gfc_array_index_type
,
1917 p
= gfc_constructor_next (p
);
1920 bound
= size_int (n
- 1);
1921 /* Create an array type to hold them. */
1922 tmptype
= build_range_type (gfc_array_index_type
,
1923 gfc_index_zero_node
, bound
);
1924 tmptype
= build_array_type (type
, tmptype
);
1926 init
= build_constructor (tmptype
, v
);
1927 TREE_CONSTANT (init
) = 1;
1928 TREE_STATIC (init
) = 1;
1929 /* Create a static variable to hold the data. */
1930 tmp
= gfc_create_var (tmptype
, "data");
1931 TREE_STATIC (tmp
) = 1;
1932 TREE_CONSTANT (tmp
) = 1;
1933 TREE_READONLY (tmp
) = 1;
1934 DECL_INITIAL (tmp
) = init
;
1937 /* Use BUILTIN_MEMCPY to assign the values. */
1938 tmp
= gfc_conv_descriptor_data_get (desc
);
1939 tmp
= build_fold_indirect_ref_loc (input_location
,
1941 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1942 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1943 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1945 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1946 bound
= build_int_cst (size_type_node
, n
* size
);
1947 tmp
= build_call_expr_loc (input_location
,
1948 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1949 3, tmp
, init
, bound
);
1950 gfc_add_expr_to_block (&body
, tmp
);
1952 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1953 gfc_array_index_type
, *poffset
,
1954 build_int_cst (gfc_array_index_type
, n
));
1956 if (!INTEGER_CST_P (*poffset
))
1958 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1959 *poffset
= *offsetvar
;
1963 /* The frontend should already have done any expansions
1967 /* Pass the code as is. */
1968 tmp
= gfc_finish_block (&body
);
1969 gfc_add_expr_to_block (pblock
, tmp
);
1973 /* Build the implied do-loop. */
1974 stmtblock_t implied_do_block
;
1980 loopbody
= gfc_finish_block (&body
);
1982 /* Create a new block that holds the implied-do loop. A temporary
1983 loop-variable is used. */
1984 gfc_start_block(&implied_do_block
);
1986 /* Initialize the loop. */
1987 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1989 /* If this array expands dynamically, and the number of iterations
1990 is not constant, we won't have allocated space for the static
1991 part of C->EXPR's size. Do that now. */
1992 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1994 /* Get the number of iterations. */
1995 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1997 /* Get the static part of C->EXPR's size. */
1998 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1999 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2001 /* Grow the array by TMP * TMP2 elements. */
2002 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
2003 gfc_array_index_type
, tmp
, tmp2
);
2004 gfc_grow_array (&implied_do_block
, desc
, tmp
);
2007 /* Generate the loop body. */
2008 exit_label
= gfc_build_label_decl (NULL_TREE
);
2009 gfc_start_block (&body
);
2011 /* Generate the exit condition. Depending on the sign of
2012 the step variable we have to generate the correct
2014 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2015 step
, build_int_cst (TREE_TYPE (step
), 0));
2016 cond
= fold_build3_loc (input_location
, COND_EXPR
,
2017 logical_type_node
, tmp
,
2018 fold_build2_loc (input_location
, GT_EXPR
,
2019 logical_type_node
, shadow_loopvar
, end
),
2020 fold_build2_loc (input_location
, LT_EXPR
,
2021 logical_type_node
, shadow_loopvar
, end
));
2022 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2023 TREE_USED (exit_label
) = 1;
2024 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2025 build_empty_stmt (input_location
));
2026 gfc_add_expr_to_block (&body
, tmp
);
2028 /* The main loop body. */
2029 gfc_add_expr_to_block (&body
, loopbody
);
2031 /* Increase loop variable by step. */
2032 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2033 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
2035 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
2037 /* Finish the loop. */
2038 tmp
= gfc_finish_block (&body
);
2039 tmp
= build1_v (LOOP_EXPR
, tmp
);
2040 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2042 /* Add the exit label. */
2043 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2044 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2046 /* Finish the implied-do loop. */
2047 tmp
= gfc_finish_block(&implied_do_block
);
2048 gfc_add_expr_to_block(pblock
, tmp
);
2050 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
2057 /* The array constructor code can create a string length with an operand
2058 in the form of a temporary variable. This variable will retain its
2059 context (current_function_decl). If we store this length tree in a
2060 gfc_charlen structure which is shared by a variable in another
2061 context, the resulting gfc_charlen structure with a variable in a
2062 different context, we could trip the assertion in expand_expr_real_1
2063 when it sees that a variable has been created in one context and
2064 referenced in another.
2066 If this might be the case, we create a new gfc_charlen structure and
2067 link it into the current namespace. */
2070 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
2074 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
2077 (*clp
)->backend_decl
= len
;
2080 /* A catch-all to obtain the string length for anything that is not
2081 a substring of non-constant length, a constant, array or variable. */
2084 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2088 /* Don't bother if we already know the length is a constant. */
2089 if (*len
&& INTEGER_CST_P (*len
))
2092 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2093 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2096 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2097 *len
= e
->ts
.u
.cl
->backend_decl
;
2101 /* Otherwise, be brutal even if inefficient. */
2102 gfc_init_se (&se
, NULL
);
2104 /* No function call, in case of side effects. */
2105 se
.no_function_call
= 1;
2107 gfc_conv_expr (&se
, e
);
2109 gfc_conv_expr_descriptor (&se
, e
);
2111 /* Fix the value. */
2112 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2114 gfc_add_block_to_block (block
, &se
.pre
);
2115 gfc_add_block_to_block (block
, &se
.post
);
2117 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2122 /* Figure out the string length of a variable reference expression.
2123 Used by get_array_ctor_strlen. */
2126 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2132 /* Don't bother if we already know the length is a constant. */
2133 if (*len
&& INTEGER_CST_P (*len
))
2136 ts
= &expr
->symtree
->n
.sym
->ts
;
2137 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2142 /* Array references don't change the string length. */
2144 get_array_ctor_all_strlen (block
, expr
, len
);
2148 /* Use the length of the component. */
2149 ts
= &ref
->u
.c
.component
->ts
;
2153 if (ref
->u
.ss
.end
== NULL
2154 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2155 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2157 /* Note that this might evaluate expr. */
2158 get_array_ctor_all_strlen (block
, expr
, len
);
2161 mpz_init_set_ui (char_len
, 1);
2162 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2163 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2164 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2165 mpz_clear (char_len
);
2176 *len
= ts
->u
.cl
->backend_decl
;
2180 /* Figure out the string length of a character array constructor.
2181 If len is NULL, don't calculate the length; this happens for recursive calls
2182 when a sub-array-constructor is an element but not at the first position,
2183 so when we're not interested in the length.
2184 Returns TRUE if all elements are character constants. */
2187 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2194 if (gfc_constructor_first (base
) == NULL
)
2197 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2201 /* Loop over all constructor elements to find out is_const, but in len we
2202 want to store the length of the first, not the last, element. We can
2203 of course exit the loop as soon as is_const is found to be false. */
2204 for (c
= gfc_constructor_first (base
);
2205 c
&& is_const
; c
= gfc_constructor_next (c
))
2207 switch (c
->expr
->expr_type
)
2210 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2211 *len
= build_int_cstu (gfc_charlen_type_node
,
2212 c
->expr
->value
.character
.length
);
2216 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2223 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2229 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2233 /* After the first iteration, we don't want the length modified. */
2240 /* Check whether the array constructor C consists entirely of constant
2241 elements, and if so returns the number of those elements, otherwise
2242 return zero. Note, an empty or NULL array constructor returns zero. */
2244 unsigned HOST_WIDE_INT
2245 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2247 unsigned HOST_WIDE_INT nelem
= 0;
2249 gfc_constructor
*c
= gfc_constructor_first (base
);
2253 || c
->expr
->rank
> 0
2254 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2256 c
= gfc_constructor_next (c
);
2263 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2264 and the tree type of it's elements, TYPE, return a static constant
2265 variable that is compile-time initialized. */
2268 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2270 tree tmptype
, init
, tmp
;
2271 HOST_WIDE_INT nelem
;
2276 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2278 /* First traverse the constructor list, converting the constants
2279 to tree to build an initializer. */
2281 c
= gfc_constructor_first (expr
->value
.constructor
);
2284 gfc_init_se (&se
, NULL
);
2285 gfc_conv_constant (&se
, c
->expr
);
2286 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2287 se
.expr
= fold_convert (type
, se
.expr
);
2288 else if (POINTER_TYPE_P (type
))
2289 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2291 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2293 c
= gfc_constructor_next (c
);
2297 /* Next determine the tree type for the array. We use the gfortran
2298 front-end's gfc_get_nodesc_array_type in order to create a suitable
2299 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2301 memset (&as
, 0, sizeof (gfc_array_spec
));
2303 as
.rank
= expr
->rank
;
2304 as
.type
= AS_EXPLICIT
;
2307 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2308 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2312 for (i
= 0; i
< expr
->rank
; i
++)
2314 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2315 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2316 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2320 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2322 /* as is not needed anymore. */
2323 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2325 gfc_free_expr (as
.lower
[i
]);
2326 gfc_free_expr (as
.upper
[i
]);
2329 init
= build_constructor (tmptype
, v
);
2331 TREE_CONSTANT (init
) = 1;
2332 TREE_STATIC (init
) = 1;
2334 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2336 DECL_ARTIFICIAL (tmp
) = 1;
2337 DECL_IGNORED_P (tmp
) = 1;
2338 TREE_STATIC (tmp
) = 1;
2339 TREE_CONSTANT (tmp
) = 1;
2340 TREE_READONLY (tmp
) = 1;
2341 DECL_INITIAL (tmp
) = init
;
2348 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2349 This mostly initializes the scalarizer state info structure with the
2350 appropriate values to directly use the array created by the function
2351 gfc_build_constant_array_constructor. */
2354 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2356 gfc_array_info
*info
;
2360 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2362 info
= &ss
->info
->data
.array
;
2364 info
->descriptor
= tmp
;
2365 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2366 info
->offset
= gfc_index_zero_node
;
2368 for (i
= 0; i
< ss
->dimen
; i
++)
2370 info
->delta
[i
] = gfc_index_zero_node
;
2371 info
->start
[i
] = gfc_index_zero_node
;
2372 info
->end
[i
] = gfc_index_zero_node
;
2373 info
->stride
[i
] = gfc_index_one_node
;
2379 get_rank (gfc_loopinfo
*loop
)
2384 for (; loop
; loop
= loop
->parent
)
2385 rank
+= loop
->dimen
;
2391 /* Helper routine of gfc_trans_array_constructor to determine if the
2392 bounds of the loop specified by LOOP are constant and simple enough
2393 to use with trans_constant_array_constructor. Returns the
2394 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2397 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2400 tree size
= gfc_index_one_node
;
2404 total_dim
= get_rank (l
);
2406 for (loop
= l
; loop
; loop
= loop
->parent
)
2408 for (i
= 0; i
< loop
->dimen
; i
++)
2410 /* If the bounds aren't constant, return NULL_TREE. */
2411 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2413 if (!integer_zerop (loop
->from
[i
]))
2415 /* Only allow nonzero "from" in one-dimensional arrays. */
2418 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2419 gfc_array_index_type
,
2420 loop
->to
[i
], loop
->from
[i
]);
2424 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2425 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2426 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2427 gfc_array_index_type
, size
, tmp
);
2436 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2441 gcc_assert (array
->nested_ss
== NULL
);
2443 for (ss
= array
; ss
; ss
= ss
->parent
)
2444 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2445 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2446 return &(ss
->loop
->to
[n
]);
2452 static gfc_loopinfo
*
2453 outermost_loop (gfc_loopinfo
* loop
)
2455 while (loop
->parent
!= NULL
)
2456 loop
= loop
->parent
;
2462 /* Array constructors are handled by constructing a temporary, then using that
2463 within the scalarization loop. This is not optimal, but seems by far the
2467 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2469 gfc_constructor_base c
;
2477 bool old_first_len
, old_typespec_chararray_ctor
;
2478 tree old_first_len_val
;
2479 gfc_loopinfo
*loop
, *outer_loop
;
2480 gfc_ss_info
*ss_info
;
2486 /* Save the old values for nested checking. */
2487 old_first_len
= first_len
;
2488 old_first_len_val
= first_len_val
;
2489 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2492 outer_loop
= outermost_loop (loop
);
2494 expr
= ss_info
->expr
;
2496 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2497 typespec was given for the array constructor. */
2498 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2500 && expr
->ts
.u
.cl
->length_from_typespec
);
2502 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2503 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2505 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2509 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2511 c
= expr
->value
.constructor
;
2512 if (expr
->ts
.type
== BT_CHARACTER
)
2515 bool force_new_cl
= false;
2517 /* get_array_ctor_strlen walks the elements of the constructor, if a
2518 typespec was given, we already know the string length and want the one
2520 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2521 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2525 const_string
= false;
2526 gfc_init_se (&length_se
, NULL
);
2527 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2528 gfc_charlen_type_node
);
2529 ss_info
->string_length
= length_se
.expr
;
2531 /* Check if the character length is negative. If it is, then
2533 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2534 logical_type_node
, ss_info
->string_length
,
2535 build_zero_cst (TREE_TYPE
2536 (ss_info
->string_length
)));
2537 /* Print a warning if bounds checking is enabled. */
2538 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2540 msg
= xasprintf ("Negative character length treated as LEN = 0");
2541 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2546 ss_info
->string_length
2547 = fold_build3_loc (input_location
, COND_EXPR
,
2548 gfc_charlen_type_node
, neg_len
,
2550 (TREE_TYPE (ss_info
->string_length
)),
2551 ss_info
->string_length
);
2552 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2554 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2555 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2559 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2560 &ss_info
->string_length
);
2561 force_new_cl
= true;
2564 /* Complex character array constructors should have been taken care of
2565 and not end up here. */
2566 gcc_assert (ss_info
->string_length
);
2568 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2570 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2572 type
= build_pointer_type (type
);
2575 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2576 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2578 /* See if the constructor determines the loop bounds. */
2581 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2583 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2585 /* We have a multidimensional parameter. */
2586 for (s
= ss
; s
; s
= s
->parent
)
2589 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2591 s
->loop
->from
[n
] = gfc_index_zero_node
;
2592 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2593 gfc_index_integer_kind
);
2594 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2595 gfc_array_index_type
,
2597 gfc_index_one_node
);
2602 if (*loop_ubound0
== NULL_TREE
)
2606 /* We should have a 1-dimensional, zero-based loop. */
2607 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2608 gcc_assert (loop
->dimen
== 1);
2609 gcc_assert (integer_zerop (loop
->from
[0]));
2611 /* Split the constructor size into a static part and a dynamic part.
2612 Allocate the static size up-front and record whether the dynamic
2613 size might be nonzero. */
2615 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2616 mpz_sub_ui (size
, size
, 1);
2617 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2621 /* Special case constant array constructors. */
2624 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2627 tree size
= constant_array_constructor_loop_size (loop
);
2628 if (size
&& compare_tree_int (size
, nelem
) == 0)
2630 trans_constant_array_constructor (ss
, type
);
2636 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2637 NULL_TREE
, dynamic
, true, false, where
);
2639 desc
= ss_info
->data
.array
.descriptor
;
2640 offset
= gfc_index_zero_node
;
2641 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2642 TREE_NO_WARNING (offsetvar
) = 1;
2643 TREE_USED (offsetvar
) = 0;
2644 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2645 &offset
, &offsetvar
, dynamic
);
2647 /* If the array grows dynamically, the upper bound of the loop variable
2648 is determined by the array's final upper bound. */
2651 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2652 gfc_array_index_type
,
2653 offsetvar
, gfc_index_one_node
);
2654 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2655 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2656 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2657 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2659 *loop_ubound0
= tmp
;
2662 if (TREE_USED (offsetvar
))
2663 pushdecl (offsetvar
);
2665 gcc_assert (INTEGER_CST_P (offset
));
2668 /* Disable bound checking for now because it's probably broken. */
2669 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2676 /* Restore old values of globals. */
2677 first_len
= old_first_len
;
2678 first_len_val
= old_first_len_val
;
2679 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2683 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2684 called after evaluating all of INFO's vector dimensions. Go through
2685 each such vector dimension and see if we can now fill in any missing
2689 set_vector_loop_bounds (gfc_ss
* ss
)
2691 gfc_loopinfo
*loop
, *outer_loop
;
2692 gfc_array_info
*info
;
2700 outer_loop
= outermost_loop (ss
->loop
);
2702 info
= &ss
->info
->data
.array
;
2704 for (; ss
; ss
= ss
->parent
)
2708 for (n
= 0; n
< loop
->dimen
; n
++)
2711 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2712 || loop
->to
[n
] != NULL
)
2715 /* Loop variable N indexes vector dimension DIM, and we don't
2716 yet know the upper bound of loop variable N. Set it to the
2717 difference between the vector's upper and lower bounds. */
2718 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2719 gcc_assert (info
->subscript
[dim
]
2720 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2722 gfc_init_se (&se
, NULL
);
2723 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2724 zero
= gfc_rank_cst
[0];
2725 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2726 gfc_array_index_type
,
2727 gfc_conv_descriptor_ubound_get (desc
, zero
),
2728 gfc_conv_descriptor_lbound_get (desc
, zero
));
2729 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2736 /* Tells whether a scalar argument to an elemental procedure is saved out
2737 of a scalarization loop as a value or as a reference. */
2740 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2742 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2745 if (ss_info
->data
.scalar
.needs_temporary
)
2748 /* If the actual argument can be absent (in other words, it can
2749 be a NULL reference), don't try to evaluate it; pass instead
2750 the reference directly. */
2751 if (ss_info
->can_be_null_ref
)
2754 /* If the expression is of polymorphic type, it's actual size is not known,
2755 so we avoid copying it anywhere. */
2756 if (ss_info
->data
.scalar
.dummy_arg
2757 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2758 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2761 /* If the expression is a data reference of aggregate type,
2762 and the data reference is not used on the left hand side,
2763 avoid a copy by saving a reference to the content. */
2764 if (!ss_info
->data
.scalar
.needs_temporary
2765 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2766 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2767 && gfc_expr_is_variable (ss_info
->expr
))
2770 /* Otherwise the expression is evaluated to a temporary variable before the
2771 scalarization loop. */
2776 /* Add the pre and post chains for all the scalar expressions in a SS chain
2777 to loop. This is called after the loop parameters have been calculated,
2778 but before the actual scalarizing loops. */
2781 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2784 gfc_loopinfo
*nested_loop
, *outer_loop
;
2786 gfc_ss_info
*ss_info
;
2787 gfc_array_info
*info
;
2791 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2792 arguments could get evaluated multiple times. */
2793 if (ss
->is_alloc_lhs
)
2796 outer_loop
= outermost_loop (loop
);
2798 /* TODO: This can generate bad code if there are ordering dependencies,
2799 e.g., a callee allocated function and an unknown size constructor. */
2800 gcc_assert (ss
!= NULL
);
2802 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2806 /* Cross loop arrays are handled from within the most nested loop. */
2807 if (ss
->nested_ss
!= NULL
)
2811 expr
= ss_info
->expr
;
2812 info
= &ss_info
->data
.array
;
2814 switch (ss_info
->type
)
2817 /* Scalar expression. Evaluate this now. This includes elemental
2818 dimension indices, but not array section bounds. */
2819 gfc_init_se (&se
, NULL
);
2820 gfc_conv_expr (&se
, expr
);
2821 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2823 if (expr
->ts
.type
!= BT_CHARACTER
2824 && !gfc_is_alloc_class_scalar_function (expr
))
2826 /* Move the evaluation of scalar expressions outside the
2827 scalarization loop, except for WHERE assignments. */
2829 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2830 if (!ss_info
->where
)
2831 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2832 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2835 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2837 ss_info
->data
.scalar
.value
= se
.expr
;
2838 ss_info
->string_length
= se
.string_length
;
2841 case GFC_SS_REFERENCE
:
2842 /* Scalar argument to elemental procedure. */
2843 gfc_init_se (&se
, NULL
);
2844 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2845 gfc_conv_expr_reference (&se
, expr
);
2848 /* Evaluate the argument outside the loop and pass
2849 a reference to the value. */
2850 gfc_conv_expr (&se
, expr
);
2853 /* Ensure that a pointer to the string is stored. */
2854 if (expr
->ts
.type
== BT_CHARACTER
)
2855 gfc_conv_string_parameter (&se
);
2857 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2858 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2859 if (gfc_is_class_scalar_expr (expr
))
2860 /* This is necessary because the dynamic type will always be
2861 large than the declared type. In consequence, assigning
2862 the value to a temporary could segfault.
2863 OOP-TODO: see if this is generally correct or is the value
2864 has to be written to an allocated temporary, whose address
2865 is passed via ss_info. */
2866 ss_info
->data
.scalar
.value
= se
.expr
;
2868 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2871 ss_info
->string_length
= se
.string_length
;
2874 case GFC_SS_SECTION
:
2875 /* Add the expressions for scalar and vector subscripts. */
2876 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2877 if (info
->subscript
[n
])
2878 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2880 set_vector_loop_bounds (ss
);
2884 /* Get the vector's descriptor and store it in SS. */
2885 gfc_init_se (&se
, NULL
);
2886 gfc_conv_expr_descriptor (&se
, expr
);
2887 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2888 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2889 info
->descriptor
= se
.expr
;
2892 case GFC_SS_INTRINSIC
:
2893 gfc_add_intrinsic_ss_code (loop
, ss
);
2896 case GFC_SS_FUNCTION
:
2897 /* Array function return value. We call the function and save its
2898 result in a temporary for use inside the loop. */
2899 gfc_init_se (&se
, NULL
);
2902 if (gfc_is_class_array_function (expr
))
2903 expr
->must_finalize
= 1;
2904 gfc_conv_expr (&se
, expr
);
2905 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2906 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2907 ss_info
->string_length
= se
.string_length
;
2910 case GFC_SS_CONSTRUCTOR
:
2911 if (expr
->ts
.type
== BT_CHARACTER
2912 && ss_info
->string_length
== NULL
2914 && expr
->ts
.u
.cl
->length
2915 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2917 gfc_init_se (&se
, NULL
);
2918 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2919 gfc_charlen_type_node
);
2920 ss_info
->string_length
= se
.expr
;
2921 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2922 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2924 trans_array_constructor (ss
, where
);
2928 case GFC_SS_COMPONENT
:
2929 /* Do nothing. These are handled elsewhere. */
2938 for (nested_loop
= loop
->nested
; nested_loop
;
2939 nested_loop
= nested_loop
->next
)
2940 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2944 /* Translate expressions for the descriptor and data pointer of a SS. */
2948 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2951 gfc_ss_info
*ss_info
;
2952 gfc_array_info
*info
;
2956 info
= &ss_info
->data
.array
;
2958 /* Get the descriptor for the array to be scalarized. */
2959 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2960 gfc_init_se (&se
, NULL
);
2961 se
.descriptor_only
= 1;
2962 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2963 gfc_add_block_to_block (block
, &se
.pre
);
2964 info
->descriptor
= se
.expr
;
2965 ss_info
->string_length
= se
.string_length
;
2969 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2970 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2972 /* Emit a DECL_EXPR for the variable sized array type in
2973 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2974 sizes works correctly. */
2975 tree arraytype
= TREE_TYPE (
2976 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2977 if (! TYPE_NAME (arraytype
))
2978 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2979 NULL_TREE
, arraytype
);
2980 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2981 TYPE_NAME (arraytype
)));
2983 /* Also the data pointer. */
2984 tmp
= gfc_conv_array_data (se
.expr
);
2985 /* If this is a variable or address of a variable we use it directly.
2986 Otherwise we must evaluate it now to avoid breaking dependency
2987 analysis by pulling the expressions for elemental array indices
2990 || (TREE_CODE (tmp
) == ADDR_EXPR
2991 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2992 tmp
= gfc_evaluate_now (tmp
, block
);
2995 tmp
= gfc_conv_array_offset (se
.expr
);
2996 info
->offset
= gfc_evaluate_now (tmp
, block
);
2998 /* Make absolutely sure that the saved_offset is indeed saved
2999 so that the variable is still accessible after the loops
3001 info
->saved_offset
= info
->offset
;
3006 /* Initialize a gfc_loopinfo structure. */
3009 gfc_init_loopinfo (gfc_loopinfo
* loop
)
3013 memset (loop
, 0, sizeof (gfc_loopinfo
));
3014 gfc_init_block (&loop
->pre
);
3015 gfc_init_block (&loop
->post
);
3017 /* Initially scalarize in order and default to no loop reversal. */
3018 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
3021 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
3024 loop
->ss
= gfc_ss_terminator
;
3028 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3032 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
3038 /* Return an expression for the data pointer of an array. */
3041 gfc_conv_array_data (tree descriptor
)
3045 type
= TREE_TYPE (descriptor
);
3046 if (GFC_ARRAY_TYPE_P (type
))
3048 if (TREE_CODE (type
) == POINTER_TYPE
)
3052 /* Descriptorless arrays. */
3053 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
3057 return gfc_conv_descriptor_data_get (descriptor
);
3061 /* Return an expression for the base offset of an array. */
3064 gfc_conv_array_offset (tree descriptor
)
3068 type
= TREE_TYPE (descriptor
);
3069 if (GFC_ARRAY_TYPE_P (type
))
3070 return GFC_TYPE_ARRAY_OFFSET (type
);
3072 return gfc_conv_descriptor_offset_get (descriptor
);
3076 /* Get an expression for the array stride. */
3079 gfc_conv_array_stride (tree descriptor
, int dim
)
3084 type
= TREE_TYPE (descriptor
);
3086 /* For descriptorless arrays use the array size. */
3087 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
3088 if (tmp
!= NULL_TREE
)
3091 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3096 /* Like gfc_conv_array_stride, but for the lower bound. */
3099 gfc_conv_array_lbound (tree descriptor
, int dim
)
3104 type
= TREE_TYPE (descriptor
);
3106 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3107 if (tmp
!= NULL_TREE
)
3110 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3115 /* Like gfc_conv_array_stride, but for the upper bound. */
3118 gfc_conv_array_ubound (tree descriptor
, int dim
)
3123 type
= TREE_TYPE (descriptor
);
3125 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3126 if (tmp
!= NULL_TREE
)
3129 /* This should only ever happen when passing an assumed shape array
3130 as an actual parameter. The value will never be used. */
3131 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3132 return gfc_index_zero_node
;
3134 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3139 /* Generate code to perform an array index bound check. */
3142 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3143 locus
* where
, bool check_upper
)
3146 tree tmp_lo
, tmp_up
;
3149 const char * name
= NULL
;
3151 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3154 descriptor
= ss
->info
->data
.array
.descriptor
;
3156 index
= gfc_evaluate_now (index
, &se
->pre
);
3158 /* We find a name for the error message. */
3159 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3160 gcc_assert (name
!= NULL
);
3162 if (VAR_P (descriptor
))
3163 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3165 /* If upper bound is present, include both bounds in the error message. */
3168 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3169 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3172 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3173 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3175 msg
= xasprintf ("Index '%%ld' of dimension %d "
3176 "outside of expected range (%%ld:%%ld)", n
+1);
3178 fault
= fold_build2_loc (input_location
, LT_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
));
3184 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3186 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3187 fold_convert (long_integer_type_node
, index
),
3188 fold_convert (long_integer_type_node
, tmp_lo
),
3189 fold_convert (long_integer_type_node
, tmp_up
));
3194 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3197 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3198 "below lower bound of %%ld", n
+1, name
);
3200 msg
= xasprintf ("Index '%%ld' of dimension %d "
3201 "below lower bound of %%ld", n
+1);
3203 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3205 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3206 fold_convert (long_integer_type_node
, index
),
3207 fold_convert (long_integer_type_node
, tmp_lo
));
3215 /* Return the offset for an index. Performs bound checking for elemental
3216 dimensions. Single element references are processed separately.
3217 DIM is the array dimension, I is the loop dimension. */
3220 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3221 gfc_array_ref
* ar
, tree stride
)
3223 gfc_array_info
*info
;
3228 info
= &ss
->info
->data
.array
;
3230 /* Get the index into the array for this dimension. */
3233 gcc_assert (ar
->type
!= AR_ELEMENT
);
3234 switch (ar
->dimen_type
[dim
])
3236 case DIMEN_THIS_IMAGE
:
3240 /* Elemental dimension. */
3241 gcc_assert (info
->subscript
[dim
]
3242 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3243 /* We've already translated this value outside the loop. */
3244 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3246 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3247 ar
->as
->type
!= AS_ASSUMED_SIZE
3248 || dim
< ar
->dimen
- 1);
3252 gcc_assert (info
&& se
->loop
);
3253 gcc_assert (info
->subscript
[dim
]
3254 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3255 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3257 /* Get a zero-based index into the vector. */
3258 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3259 gfc_array_index_type
,
3260 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3262 /* Multiply the index by the stride. */
3263 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3264 gfc_array_index_type
,
3265 index
, gfc_conv_array_stride (desc
, 0));
3267 /* Read the vector to get an index into info->descriptor. */
3268 data
= build_fold_indirect_ref_loc (input_location
,
3269 gfc_conv_array_data (desc
));
3270 index
= gfc_build_array_ref (data
, index
, NULL
);
3271 index
= gfc_evaluate_now (index
, &se
->pre
);
3272 index
= fold_convert (gfc_array_index_type
, index
);
3274 /* Do any bounds checking on the final info->descriptor index. */
3275 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3276 ar
->as
->type
!= AS_ASSUMED_SIZE
3277 || dim
< ar
->dimen
- 1);
3281 /* Scalarized dimension. */
3282 gcc_assert (info
&& se
->loop
);
3284 /* Multiply the loop variable by the stride and delta. */
3285 index
= se
->loop
->loopvar
[i
];
3286 if (!integer_onep (info
->stride
[dim
]))
3287 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3288 gfc_array_index_type
, index
,
3290 if (!integer_zerop (info
->delta
[dim
]))
3291 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3292 gfc_array_index_type
, index
,
3302 /* Temporary array or derived type component. */
3303 gcc_assert (se
->loop
);
3304 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3306 /* Pointer functions can have stride[0] different from unity.
3307 Use the stride returned by the function call and stored in
3308 the descriptor for the temporary. */
3309 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3310 && se
->ss
->info
->expr
3311 && se
->ss
->info
->expr
->symtree
3312 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3313 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3314 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3317 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3318 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3319 gfc_array_index_type
, index
, info
->delta
[dim
]);
3322 /* Multiply by the stride. */
3323 if (stride
!= NULL
&& !integer_onep (stride
))
3324 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3331 /* Build a scalarized array reference using the vptr 'size'. */
3334 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3339 tree decl
= NULL_TREE
;
3341 gfc_expr
*expr
= se
->ss
->info
->expr
;
3343 gfc_ref
*class_ref
= NULL
;
3346 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3347 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3348 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3353 || (expr
->ts
.type
!= BT_CLASS
3354 && !gfc_is_class_array_function (expr
)
3355 && !gfc_is_class_array_ref (expr
, NULL
)))
3358 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3359 ts
= &expr
->symtree
->n
.sym
->ts
;
3363 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3365 if (ref
->type
== REF_COMPONENT
3366 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3367 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3368 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3370 && ref
->next
->next
->type
== REF_ARRAY
3371 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3373 ts
= &ref
->u
.c
.component
->ts
;
3383 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3384 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3385 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3387 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3389 else if (expr
&& gfc_is_class_array_function (expr
))
3393 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3396 type
= TREE_TYPE (tmp
);
3399 if (GFC_CLASS_TYPE_P (type
))
3401 if (type
!= TYPE_CANONICAL (type
))
3402 type
= TYPE_CANONICAL (type
);
3410 if (decl
== NULL_TREE
)
3413 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3415 else if (class_ref
== NULL
)
3417 if (decl
== NULL_TREE
)
3418 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3419 /* For class arrays the tree containing the class is stored in
3420 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3421 For all others it's sym's backend_decl directly. */
3422 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3423 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3427 /* Remove everything after the last class reference, convert the
3428 expression and then recover its tailend once more. */
3430 ref
= class_ref
->next
;
3431 class_ref
->next
= NULL
;
3432 gfc_init_se (&tmpse
, NULL
);
3433 gfc_conv_expr (&tmpse
, expr
);
3434 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3436 class_ref
->next
= ref
;
3439 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3440 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3442 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3445 size
= gfc_class_vtab_size_get (decl
);
3447 /* For unlimited polymorphic entities then _len component needs to be
3448 multiplied with the size. If no _len component is present, then
3449 gfc_class_len_or_zero_get () return a zero_node. */
3450 tmp
= gfc_class_len_or_zero_get (decl
);
3451 if (!integer_zerop (tmp
))
3452 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3453 fold_convert (TREE_TYPE (index
), size
),
3454 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3455 fold_convert (TREE_TYPE (index
), tmp
),
3456 fold_convert (TREE_TYPE (index
),
3457 integer_one_node
)));
3459 size
= fold_convert (TREE_TYPE (index
), size
);
3461 /* Build the address of the element. */
3462 type
= TREE_TYPE (TREE_TYPE (base
));
3463 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3464 gfc_array_index_type
,
3466 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3467 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3468 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3470 /* Return the element in the se expression. */
3471 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3476 /* Build a scalarized reference to an array. */
3479 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3481 gfc_array_info
*info
;
3482 tree decl
= NULL_TREE
;
3490 expr
= ss
->info
->expr
;
3491 info
= &ss
->info
->data
.array
;
3493 n
= se
->loop
->order
[0];
3497 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3498 /* Add the offset for this dimension to the stored offset for all other
3500 if (info
->offset
&& !integer_zerop (info
->offset
))
3501 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3502 index
, info
->offset
);
3504 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3506 /* Use the vptr 'size' field to access the element of a class array. */
3507 if (build_class_array_ref (se
, base
, index
))
3510 if (get_CFI_desc (NULL
, expr
, &decl
, ar
))
3511 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3513 /* A pointer array component can be detected from its field decl. Fix
3514 the descriptor, mark the resulting variable decl and pass it to
3515 gfc_build_array_ref. */
3516 if (is_pointer_array (info
->descriptor
)
3517 || (expr
&& expr
->ts
.deferred
&& info
->descriptor
3518 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
))))
3520 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3521 decl
= info
->descriptor
;
3522 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3523 decl
= TREE_OPERAND (info
->descriptor
, 0);
3525 if (decl
== NULL_TREE
)
3526 decl
= info
->descriptor
;
3529 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3533 /* Translate access of temporary array. */
3536 gfc_conv_tmp_array_ref (gfc_se
* se
)
3538 se
->string_length
= se
->ss
->info
->string_length
;
3539 gfc_conv_scalarized_array_ref (se
, NULL
);
3540 gfc_advance_se_ss_chain (se
);
3543 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3546 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3548 if (TREE_CODE (t
) == INTEGER_CST
)
3549 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3552 if (!integer_zerop (*offset
))
3553 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3554 gfc_array_index_type
, *offset
, t
);
3562 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3568 /* For class arrays the class declaration is stored in the saved
3570 if (INDIRECT_REF_P (desc
)
3571 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3572 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3573 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3574 TREE_OPERAND (desc
, 0)));
3578 /* Class container types do not always have the GFC_CLASS_TYPE_P
3579 but the canonical type does. */
3580 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3581 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3583 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3584 if (TYPE_CANONICAL (type
)
3585 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3586 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3589 tmp
= gfc_conv_array_data (desc
);
3590 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3591 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3596 /* Build an array reference. se->expr already holds the array descriptor.
3597 This should be either a variable, indirect variable reference or component
3598 reference. For arrays which do not have a descriptor, se->expr will be
3600 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3603 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3607 tree offset
, cst_offset
;
3610 tree decl
= NULL_TREE
;
3613 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3614 char *var_name
= NULL
;
3618 gcc_assert (ar
->codimen
|| sym
->attr
.select_rank_temporary
3619 || (ar
->as
&& ar
->as
->corank
));
3621 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3622 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3625 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3626 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3627 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3629 /* Use the actual tree type and not the wrapped coarray. */
3630 if (!se
->want_pointer
)
3631 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3638 /* Handle scalarized references separately. */
3639 if (ar
->type
!= AR_ELEMENT
)
3641 gfc_conv_scalarized_array_ref (se
, ar
);
3642 gfc_advance_se_ss_chain (se
);
3646 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3651 len
= strlen (sym
->name
) + 1;
3652 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3654 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3656 if (ref
->type
== REF_COMPONENT
)
3657 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3660 var_name
= XALLOCAVEC (char, len
);
3661 strcpy (var_name
, sym
->name
);
3663 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3665 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3667 if (ref
->type
== REF_COMPONENT
)
3669 strcat (var_name
, "%%");
3670 strcat (var_name
, ref
->u
.c
.component
->name
);
3676 if (IS_CLASS_ARRAY (sym
) && sym
->attr
.dummy
&& ar
->as
->type
!= AS_DEFERRED
)
3677 decl
= sym
->backend_decl
;
3679 cst_offset
= offset
= gfc_index_zero_node
;
3680 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (decl
));
3682 /* Calculate the offsets from all the dimensions. Make sure to associate
3683 the final offset so that we form a chain of loop invariant summands. */
3684 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3686 /* Calculate the index for this dimension. */
3687 gfc_init_se (&indexse
, se
);
3688 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3689 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3691 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3693 /* Check array bounds. */
3697 /* Evaluate the indexse.expr only once. */
3698 indexse
.expr
= save_expr (indexse
.expr
);
3701 tmp
= gfc_conv_array_lbound (decl
, n
);
3702 if (sym
->attr
.temporary
)
3704 gfc_init_se (&tmpse
, se
);
3705 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3706 gfc_array_index_type
);
3707 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3711 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3713 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3714 "below lower bound of %%ld", n
+1, var_name
);
3715 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3716 fold_convert (long_integer_type_node
,
3718 fold_convert (long_integer_type_node
, tmp
));
3721 /* Upper bound, but not for the last dimension of assumed-size
3723 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3725 tmp
= gfc_conv_array_ubound (decl
, n
);
3726 if (sym
->attr
.temporary
)
3728 gfc_init_se (&tmpse
, se
);
3729 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3730 gfc_array_index_type
);
3731 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3735 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3736 logical_type_node
, indexse
.expr
, tmp
);
3737 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3738 "above upper bound of %%ld", n
+1, var_name
);
3739 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3740 fold_convert (long_integer_type_node
,
3742 fold_convert (long_integer_type_node
, tmp
));
3747 /* Multiply the index by the stride. */
3748 stride
= gfc_conv_array_stride (decl
, n
);
3749 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3750 indexse
.expr
, stride
);
3752 /* And add it to the total. */
3753 add_to_offset (&cst_offset
, &offset
, tmp
);
3756 if (!integer_zerop (cst_offset
))
3757 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3758 gfc_array_index_type
, offset
, cst_offset
);
3760 /* A pointer array component can be detected from its field decl. Fix
3761 the descriptor, mark the resulting variable decl and pass it to
3764 if (get_CFI_desc (sym
, expr
, &decl
, ar
))
3765 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3766 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3767 && is_pointer_array (se
->expr
))
3769 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3771 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3772 decl
= TREE_OPERAND (se
->expr
, 0);
3776 else if (expr
->ts
.deferred
3777 || (sym
->ts
.type
== BT_CHARACTER
3778 && sym
->attr
.select_type_temporary
))
3780 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3783 if (TREE_CODE (decl
) == INDIRECT_REF
)
3784 decl
= TREE_OPERAND (decl
, 0);
3787 decl
= sym
->backend_decl
;
3789 else if (sym
->ts
.type
== BT_CLASS
)
3792 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3796 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3797 LOOP_DIM dimension (if any) to array's offset. */
3800 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3801 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3804 gfc_array_info
*info
;
3807 info
= &ss
->info
->data
.array
;
3809 gfc_init_se (&se
, NULL
);
3811 se
.expr
= info
->descriptor
;
3812 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3813 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3814 gfc_add_block_to_block (pblock
, &se
.pre
);
3816 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3817 gfc_array_index_type
,
3818 info
->offset
, index
);
3819 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3823 /* Generate the code to be executed immediately before entering a
3824 scalarization loop. */
3827 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3828 stmtblock_t
* pblock
)
3831 gfc_ss_info
*ss_info
;
3832 gfc_array_info
*info
;
3833 gfc_ss_type ss_type
;
3835 gfc_loopinfo
*ploop
;
3839 /* This code will be executed before entering the scalarization loop
3840 for this dimension. */
3841 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3845 if ((ss_info
->useflags
& flag
) == 0)
3848 ss_type
= ss_info
->type
;
3849 if (ss_type
!= GFC_SS_SECTION
3850 && ss_type
!= GFC_SS_FUNCTION
3851 && ss_type
!= GFC_SS_CONSTRUCTOR
3852 && ss_type
!= GFC_SS_COMPONENT
)
3855 info
= &ss_info
->data
.array
;
3857 gcc_assert (dim
< ss
->dimen
);
3858 gcc_assert (ss
->dimen
== loop
->dimen
);
3861 ar
= &info
->ref
->u
.ar
;
3865 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3867 /* If we are in the outermost dimension of this loop, the previous
3868 dimension shall be in the parent loop. */
3869 gcc_assert (ss
->parent
!= NULL
);
3872 ploop
= loop
->parent
;
3874 /* ss and ss->parent are about the same array. */
3875 gcc_assert (ss_info
== pss
->info
);
3883 if (dim
== loop
->dimen
- 1)
3888 /* For the time being, there is no loop reordering. */
3889 gcc_assert (i
== ploop
->order
[i
]);
3890 i
= ploop
->order
[i
];
3892 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3894 stride
= gfc_conv_array_stride (info
->descriptor
,
3895 innermost_ss (ss
)->dim
[i
]);
3897 /* Calculate the stride of the innermost loop. Hopefully this will
3898 allow the backend optimizers to do their stuff more effectively.
3900 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3902 /* For the outermost loop calculate the offset due to any
3903 elemental dimensions. It will have been initialized with the
3904 base offset of the array. */
3907 for (i
= 0; i
< ar
->dimen
; i
++)
3909 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3912 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3917 /* Add the offset for the previous loop dimension. */
3918 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3920 /* Remember this offset for the second loop. */
3921 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3922 info
->saved_offset
= info
->offset
;
3927 /* Start a scalarized expression. Creates a scope and declares loop
3931 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3937 gcc_assert (!loop
->array_parameter
);
3939 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3941 n
= loop
->order
[dim
];
3943 gfc_start_block (&loop
->code
[n
]);
3945 /* Create the loop variable. */
3946 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3948 if (dim
< loop
->temp_dim
)
3952 /* Calculate values that will be constant within this loop. */
3953 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3955 gfc_start_block (pbody
);
3959 /* Generates the actual loop code for a scalarization loop. */
3962 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3963 stmtblock_t
* pbody
)
3974 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3975 | OMPWS_SCALARIZER_BODY
))
3976 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3977 && n
== loop
->dimen
- 1)
3979 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3980 init
= make_tree_vec (1);
3981 cond
= make_tree_vec (1);
3982 incr
= make_tree_vec (1);
3984 /* Cycle statement is implemented with a goto. Exit statement must not
3985 be present for this loop. */
3986 exit_label
= gfc_build_label_decl (NULL_TREE
);
3987 TREE_USED (exit_label
) = 1;
3989 /* Label for cycle statements (if needed). */
3990 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3991 gfc_add_expr_to_block (pbody
, tmp
);
3993 stmt
= make_node (OMP_FOR
);
3995 TREE_TYPE (stmt
) = void_type_node
;
3996 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3998 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3999 OMP_CLAUSE_SCHEDULE
);
4000 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
4001 = OMP_CLAUSE_SCHEDULE_STATIC
;
4002 if (ompws_flags
& OMPWS_NOWAIT
)
4003 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
4004 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
4006 /* Initialize the loopvar. */
4007 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
4009 OMP_FOR_INIT (stmt
) = init
;
4010 /* The exit condition. */
4011 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
4013 loop
->loopvar
[n
], loop
->to
[n
]);
4014 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
4015 OMP_FOR_COND (stmt
) = cond
;
4016 /* Increment the loopvar. */
4017 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4018 loop
->loopvar
[n
], gfc_index_one_node
);
4019 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
4020 void_type_node
, loop
->loopvar
[n
], tmp
);
4021 OMP_FOR_INCR (stmt
) = incr
;
4023 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
4024 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
4028 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
4029 && (loop
->temp_ss
== NULL
);
4031 loopbody
= gfc_finish_block (pbody
);
4034 std::swap (loop
->from
[n
], loop
->to
[n
]);
4036 /* Initialize the loopvar. */
4037 if (loop
->loopvar
[n
] != loop
->from
[n
])
4038 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
4040 exit_label
= gfc_build_label_decl (NULL_TREE
);
4042 /* Generate the loop body. */
4043 gfc_init_block (&block
);
4045 /* The exit condition. */
4046 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
4047 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
4048 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4049 TREE_USED (exit_label
) = 1;
4050 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4051 gfc_add_expr_to_block (&block
, tmp
);
4053 /* The main body. */
4054 gfc_add_expr_to_block (&block
, loopbody
);
4056 /* Increment the loopvar. */
4057 tmp
= fold_build2_loc (input_location
,
4058 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
4059 gfc_array_index_type
, loop
->loopvar
[n
],
4060 gfc_index_one_node
);
4062 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
4064 /* Build the loop. */
4065 tmp
= gfc_finish_block (&block
);
4066 tmp
= build1_v (LOOP_EXPR
, tmp
);
4067 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4069 /* Add the exit label. */
4070 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4071 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4077 /* Finishes and generates the loops for a scalarized expression. */
4080 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4085 stmtblock_t
*pblock
;
4089 /* Generate the loops. */
4090 for (dim
= 0; dim
< loop
->dimen
; dim
++)
4092 n
= loop
->order
[dim
];
4093 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4094 loop
->loopvar
[n
] = NULL_TREE
;
4095 pblock
= &loop
->code
[n
];
4098 tmp
= gfc_finish_block (pblock
);
4099 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4101 /* Clear all the used flags. */
4102 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4103 if (ss
->parent
== NULL
)
4104 ss
->info
->useflags
= 0;
4108 /* Finish the main body of a scalarized expression, and start the secondary
4112 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4116 stmtblock_t
*pblock
;
4120 /* We finish as many loops as are used by the temporary. */
4121 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4123 n
= loop
->order
[dim
];
4124 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4125 loop
->loopvar
[n
] = NULL_TREE
;
4126 pblock
= &loop
->code
[n
];
4129 /* We don't want to finish the outermost loop entirely. */
4130 n
= loop
->order
[loop
->temp_dim
- 1];
4131 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4133 /* Restore the initial offsets. */
4134 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4136 gfc_ss_type ss_type
;
4137 gfc_ss_info
*ss_info
;
4141 if ((ss_info
->useflags
& 2) == 0)
4144 ss_type
= ss_info
->type
;
4145 if (ss_type
!= GFC_SS_SECTION
4146 && ss_type
!= GFC_SS_FUNCTION
4147 && ss_type
!= GFC_SS_CONSTRUCTOR
4148 && ss_type
!= GFC_SS_COMPONENT
)
4151 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4154 /* Restart all the inner loops we just finished. */
4155 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4157 n
= loop
->order
[dim
];
4159 gfc_start_block (&loop
->code
[n
]);
4161 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4163 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4166 /* Start a block for the secondary copying code. */
4167 gfc_start_block (body
);
4171 /* Precalculate (either lower or upper) bound of an array section.
4172 BLOCK: Block in which the (pre)calculation code will go.
4173 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4174 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4175 DESC: Array descriptor from which the bound will be picked if unspecified
4176 (either lower or upper bound according to LBOUND). */
4179 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4180 tree desc
, int dim
, bool lbound
, bool deferred
)
4183 gfc_expr
* input_val
= values
[dim
];
4184 tree
*output
= &bounds
[dim
];
4189 /* Specified section bound. */
4190 gfc_init_se (&se
, NULL
);
4191 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4192 gfc_add_block_to_block (block
, &se
.pre
);
4195 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4197 /* The gfc_conv_array_lbound () routine returns a constant zero for
4198 deferred length arrays, which in the scalarizer wreaks havoc, when
4199 copying to a (newly allocated) one-based array.
4200 Keep returning the actual result in sync for both bounds. */
4201 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4203 gfc_conv_descriptor_ubound_get (desc
,
4208 /* No specific bound specified so use the bound of the array. */
4209 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4210 gfc_conv_array_ubound (desc
, dim
);
4212 *output
= gfc_evaluate_now (*output
, block
);
4216 /* Calculate the lower bound of an array section. */
4219 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4221 gfc_expr
*stride
= NULL
;
4224 gfc_array_info
*info
;
4227 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4229 info
= &ss
->info
->data
.array
;
4230 ar
= &info
->ref
->u
.ar
;
4232 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4234 /* We use a zero-based index to access the vector. */
4235 info
->start
[dim
] = gfc_index_zero_node
;
4236 info
->end
[dim
] = NULL
;
4237 info
->stride
[dim
] = gfc_index_one_node
;
4241 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4242 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4243 desc
= info
->descriptor
;
4244 stride
= ar
->stride
[dim
];
4247 /* Calculate the start of the range. For vector subscripts this will
4248 be the range of the vector. */
4249 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4250 ar
->as
->type
== AS_DEFERRED
);
4252 /* Similarly calculate the end. Although this is not used in the
4253 scalarizer, it is needed when checking bounds and where the end
4254 is an expression with side-effects. */
4255 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4256 ar
->as
->type
== AS_DEFERRED
);
4259 /* Calculate the stride. */
4261 info
->stride
[dim
] = gfc_index_one_node
;
4264 gfc_init_se (&se
, NULL
);
4265 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4266 gfc_add_block_to_block (block
, &se
.pre
);
4267 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4272 /* Calculates the range start and stride for a SS chain. Also gets the
4273 descriptor and data pointer. The range of vector subscripts is the size
4274 of the vector. Array bounds are also checked. */
4277 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4284 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4287 /* Determine the rank of the loop. */
4288 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4290 switch (ss
->info
->type
)
4292 case GFC_SS_SECTION
:
4293 case GFC_SS_CONSTRUCTOR
:
4294 case GFC_SS_FUNCTION
:
4295 case GFC_SS_COMPONENT
:
4296 loop
->dimen
= ss
->dimen
;
4299 /* As usual, lbound and ubound are exceptions!. */
4300 case GFC_SS_INTRINSIC
:
4301 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4303 case GFC_ISYM_LBOUND
:
4304 case GFC_ISYM_UBOUND
:
4305 case GFC_ISYM_LCOBOUND
:
4306 case GFC_ISYM_UCOBOUND
:
4307 case GFC_ISYM_THIS_IMAGE
:
4308 loop
->dimen
= ss
->dimen
;
4320 /* We should have determined the rank of the expression by now. If
4321 not, that's bad news. */
4325 /* Loop over all the SS in the chain. */
4326 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4328 gfc_ss_info
*ss_info
;
4329 gfc_array_info
*info
;
4333 expr
= ss_info
->expr
;
4334 info
= &ss_info
->data
.array
;
4336 if (expr
&& expr
->shape
&& !info
->shape
)
4337 info
->shape
= expr
->shape
;
4339 switch (ss_info
->type
)
4341 case GFC_SS_SECTION
:
4342 /* Get the descriptor for the array. If it is a cross loops array,
4343 we got the descriptor already in the outermost loop. */
4344 if (ss
->parent
== NULL
)
4345 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4346 !loop
->array_parameter
);
4348 for (n
= 0; n
< ss
->dimen
; n
++)
4349 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4352 case GFC_SS_INTRINSIC
:
4353 switch (expr
->value
.function
.isym
->id
)
4355 /* Fall through to supply start and stride. */
4356 case GFC_ISYM_LBOUND
:
4357 case GFC_ISYM_UBOUND
:
4361 /* This is the variant without DIM=... */
4362 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4364 arg
= expr
->value
.function
.actual
->expr
;
4365 if (arg
->rank
== -1)
4370 /* The rank (hence the return value's shape) is unknown,
4371 we have to retrieve it. */
4372 gfc_init_se (&se
, NULL
);
4373 se
.descriptor_only
= 1;
4374 gfc_conv_expr (&se
, arg
);
4375 /* This is a bare variable, so there is no preliminary
4377 gcc_assert (se
.pre
.head
== NULL_TREE
4378 && se
.post
.head
== NULL_TREE
);
4379 rank
= gfc_conv_descriptor_rank (se
.expr
);
4380 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4381 gfc_array_index_type
,
4382 fold_convert (gfc_array_index_type
,
4384 gfc_index_one_node
);
4385 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4386 info
->start
[0] = gfc_index_zero_node
;
4387 info
->stride
[0] = gfc_index_one_node
;
4390 /* Otherwise fall through GFC_SS_FUNCTION. */
4393 case GFC_ISYM_LCOBOUND
:
4394 case GFC_ISYM_UCOBOUND
:
4395 case GFC_ISYM_THIS_IMAGE
:
4403 case GFC_SS_CONSTRUCTOR
:
4404 case GFC_SS_FUNCTION
:
4405 for (n
= 0; n
< ss
->dimen
; n
++)
4407 int dim
= ss
->dim
[n
];
4409 info
->start
[dim
] = gfc_index_zero_node
;
4410 info
->end
[dim
] = gfc_index_zero_node
;
4411 info
->stride
[dim
] = gfc_index_one_node
;
4420 /* The rest is just runtime bounds checking. */
4421 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4424 tree lbound
, ubound
;
4426 tree size
[GFC_MAX_DIMENSIONS
];
4427 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4428 gfc_array_info
*info
;
4432 gfc_start_block (&block
);
4434 for (n
= 0; n
< loop
->dimen
; n
++)
4435 size
[n
] = NULL_TREE
;
4437 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4440 gfc_ss_info
*ss_info
;
4443 const char *expr_name
;
4446 if (ss_info
->type
!= GFC_SS_SECTION
)
4449 /* Catch allocatable lhs in f2003. */
4450 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4453 expr
= ss_info
->expr
;
4454 expr_loc
= &expr
->where
;
4455 expr_name
= expr
->symtree
->name
;
4457 gfc_start_block (&inner
);
4459 /* TODO: range checking for mapped dimensions. */
4460 info
= &ss_info
->data
.array
;
4462 /* This code only checks ranges. Elemental and vector
4463 dimensions are checked later. */
4464 for (n
= 0; n
< loop
->dimen
; n
++)
4469 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4472 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4473 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4474 check_upper
= false;
4478 /* Zero stride is not allowed. */
4479 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4480 info
->stride
[dim
], gfc_index_zero_node
);
4481 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4482 "of array '%s'", dim
+ 1, expr_name
);
4483 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4487 desc
= info
->descriptor
;
4489 /* This is the run-time equivalent of resolve.c's
4490 check_dimension(). The logical is more readable there
4491 than it is here, with all the trees. */
4492 lbound
= gfc_conv_array_lbound (desc
, dim
);
4493 end
= info
->end
[dim
];
4495 ubound
= gfc_conv_array_ubound (desc
, dim
);
4499 /* non_zerosized is true when the selected range is not
4501 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4502 logical_type_node
, info
->stride
[dim
],
4503 gfc_index_zero_node
);
4504 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4505 info
->start
[dim
], end
);
4506 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4507 logical_type_node
, stride_pos
, tmp
);
4509 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4511 info
->stride
[dim
], gfc_index_zero_node
);
4512 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4513 info
->start
[dim
], end
);
4514 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4517 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4519 stride_pos
, stride_neg
);
4521 /* Check the start of the range against the lower and upper
4522 bounds of the array, if the range is not empty.
4523 If upper bound is present, include both bounds in the
4527 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4529 info
->start
[dim
], lbound
);
4530 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4532 non_zerosized
, tmp
);
4533 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4535 info
->start
[dim
], ubound
);
4536 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4538 non_zerosized
, tmp2
);
4539 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4540 "outside of expected range (%%ld:%%ld)",
4541 dim
+ 1, expr_name
);
4542 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4544 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4545 fold_convert (long_integer_type_node
, lbound
),
4546 fold_convert (long_integer_type_node
, ubound
));
4547 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4549 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4550 fold_convert (long_integer_type_node
, lbound
),
4551 fold_convert (long_integer_type_node
, ubound
));
4556 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4558 info
->start
[dim
], lbound
);
4559 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4560 logical_type_node
, non_zerosized
, tmp
);
4561 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4562 "below lower bound of %%ld",
4563 dim
+ 1, expr_name
);
4564 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4566 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4567 fold_convert (long_integer_type_node
, lbound
));
4571 /* Compute the last element of the range, which is not
4572 necessarily "end" (think 0:5:3, which doesn't contain 5)
4573 and check it against both lower and upper bounds. */
4575 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4576 gfc_array_index_type
, end
,
4578 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4579 gfc_array_index_type
, tmp
,
4581 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4582 gfc_array_index_type
, end
, tmp
);
4583 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4584 logical_type_node
, tmp
, lbound
);
4585 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4586 logical_type_node
, non_zerosized
, tmp2
);
4589 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4590 logical_type_node
, tmp
, ubound
);
4591 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4592 logical_type_node
, non_zerosized
, tmp3
);
4593 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4594 "outside of expected range (%%ld:%%ld)",
4595 dim
+ 1, expr_name
);
4596 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4598 fold_convert (long_integer_type_node
, tmp
),
4599 fold_convert (long_integer_type_node
, ubound
),
4600 fold_convert (long_integer_type_node
, lbound
));
4601 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4603 fold_convert (long_integer_type_node
, tmp
),
4604 fold_convert (long_integer_type_node
, ubound
),
4605 fold_convert (long_integer_type_node
, lbound
));
4610 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4611 "below lower bound of %%ld",
4612 dim
+ 1, expr_name
);
4613 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4615 fold_convert (long_integer_type_node
, tmp
),
4616 fold_convert (long_integer_type_node
, lbound
));
4620 /* Check the section sizes match. */
4621 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4622 gfc_array_index_type
, end
,
4624 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4625 gfc_array_index_type
, tmp
,
4627 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4628 gfc_array_index_type
,
4629 gfc_index_one_node
, tmp
);
4630 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4631 gfc_array_index_type
, tmp
,
4632 build_int_cst (gfc_array_index_type
, 0));
4633 /* We remember the size of the first section, and check all the
4634 others against this. */
4637 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4638 logical_type_node
, tmp
, size
[n
]);
4639 msg
= xasprintf ("Array bound mismatch for dimension %d "
4640 "of array '%s' (%%ld/%%ld)",
4641 dim
+ 1, expr_name
);
4643 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4645 fold_convert (long_integer_type_node
, tmp
),
4646 fold_convert (long_integer_type_node
, size
[n
]));
4651 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4654 tmp
= gfc_finish_block (&inner
);
4656 /* For optional arguments, only check bounds if the argument is
4658 if (expr
->symtree
->n
.sym
->attr
.optional
4659 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4660 tmp
= build3_v (COND_EXPR
,
4661 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4662 tmp
, build_empty_stmt (input_location
));
4664 gfc_add_expr_to_block (&block
, tmp
);
4668 tmp
= gfc_finish_block (&block
);
4669 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4672 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4673 gfc_conv_ss_startstride (loop
);
4676 /* Return true if both symbols could refer to the same data object. Does
4677 not take account of aliasing due to equivalence statements. */
4680 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4681 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4683 /* Aliasing isn't possible if the symbols have different base types. */
4684 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4687 /* Pointers can point to other pointers and target objects. */
4689 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4690 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4693 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4694 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4696 if (lsym_target
&& rsym_target
4697 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4698 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4699 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4700 && (!rsym
->attr
.dimension
4701 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4708 /* Return true if the two SS could be aliased, i.e. both point to the same data
4710 /* TODO: resolve aliases based on frontend expressions. */
4713 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4717 gfc_expr
*lexpr
, *rexpr
;
4720 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4722 lexpr
= lss
->info
->expr
;
4723 rexpr
= rss
->info
->expr
;
4725 lsym
= lexpr
->symtree
->n
.sym
;
4726 rsym
= rexpr
->symtree
->n
.sym
;
4728 lsym_pointer
= lsym
->attr
.pointer
;
4729 lsym_target
= lsym
->attr
.target
;
4730 rsym_pointer
= rsym
->attr
.pointer
;
4731 rsym_target
= rsym
->attr
.target
;
4733 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4734 rsym_pointer
, rsym_target
))
4737 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4738 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4741 /* For derived types we must check all the component types. We can ignore
4742 array references as these will have the same base type as the previous
4744 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4746 if (lref
->type
!= REF_COMPONENT
)
4749 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4750 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4752 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4753 rsym_pointer
, rsym_target
))
4756 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4757 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4759 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4764 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4767 if (rref
->type
!= REF_COMPONENT
)
4770 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4771 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4773 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4774 lsym_pointer
, lsym_target
,
4775 rsym_pointer
, rsym_target
))
4778 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4779 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4781 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4782 &rref
->u
.c
.sym
->ts
))
4784 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4785 &rref
->u
.c
.component
->ts
))
4787 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4788 &rref
->u
.c
.component
->ts
))
4794 lsym_pointer
= lsym
->attr
.pointer
;
4795 lsym_target
= lsym
->attr
.target
;
4797 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4799 if (rref
->type
!= REF_COMPONENT
)
4802 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4803 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4805 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4806 lsym_pointer
, lsym_target
,
4807 rsym_pointer
, rsym_target
))
4810 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4811 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4813 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4822 /* Resolve array data dependencies. Creates a temporary if required. */
4823 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4827 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4833 gfc_ss_info
*ss_info
;
4834 gfc_expr
*dest_expr
;
4839 loop
->temp_ss
= NULL
;
4840 dest_expr
= dest
->info
->expr
;
4842 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4845 ss_expr
= ss_info
->expr
;
4847 if (ss_info
->array_outer_dependency
)
4853 if (ss_info
->type
!= GFC_SS_SECTION
)
4855 if (flag_realloc_lhs
4856 && dest_expr
!= ss_expr
4857 && gfc_is_reallocatable_lhs (dest_expr
)
4859 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4861 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4862 if (!nDepend
&& dest_expr
->rank
> 0
4863 && dest_expr
->ts
.type
== BT_CHARACTER
4864 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4866 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4868 if (ss_info
->type
== GFC_SS_REFERENCE
4869 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4870 ss_info
->data
.scalar
.needs_temporary
= 1;
4878 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4880 if (gfc_could_be_alias (dest
, ss
)
4881 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4889 lref
= dest_expr
->ref
;
4890 rref
= ss_expr
->ref
;
4892 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4897 for (i
= 0; i
< dest
->dimen
; i
++)
4898 for (j
= 0; j
< ss
->dimen
; j
++)
4900 && dest
->dim
[i
] == ss
->dim
[j
])
4902 /* If we don't access array elements in the same order,
4903 there is a dependency. */
4908 /* TODO : loop shifting. */
4911 /* Mark the dimensions for LOOP SHIFTING */
4912 for (n
= 0; n
< loop
->dimen
; n
++)
4914 int dim
= dest
->data
.info
.dim
[n
];
4916 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4918 else if (! gfc_is_same_range (&lref
->u
.ar
,
4919 &rref
->u
.ar
, dim
, 0))
4923 /* Put all the dimensions with dependencies in the
4926 for (n
= 0; n
< loop
->dimen
; n
++)
4928 gcc_assert (loop
->order
[n
] == n
);
4930 loop
->order
[dim
++] = n
;
4932 for (n
= 0; n
< loop
->dimen
; n
++)
4935 loop
->order
[dim
++] = n
;
4938 gcc_assert (dim
== loop
->dimen
);
4949 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4950 if (GFC_ARRAY_TYPE_P (base_type
)
4951 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4952 base_type
= gfc_get_element_type (base_type
);
4953 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4955 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4958 loop
->temp_ss
= NULL
;
4962 /* Browse through each array's information from the scalarizer and set the loop
4963 bounds according to the "best" one (per dimension), i.e. the one which
4964 provides the most information (constant bounds, shape, etc.). */
4967 set_loop_bounds (gfc_loopinfo
*loop
)
4969 int n
, dim
, spec_dim
;
4970 gfc_array_info
*info
;
4971 gfc_array_info
*specinfo
;
4975 bool dynamic
[GFC_MAX_DIMENSIONS
];
4978 bool nonoptional_arr
;
4980 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4982 loopspec
= loop
->specloop
;
4985 for (n
= 0; n
< loop
->dimen
; n
++)
4990 /* If there are both optional and nonoptional array arguments, scalarize
4991 over the nonoptional; otherwise, it does not matter as then all
4992 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4994 nonoptional_arr
= false;
4996 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4997 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4998 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
5000 nonoptional_arr
= true;
5004 /* We use one SS term, and use that to determine the bounds of the
5005 loop for this dimension. We try to pick the simplest term. */
5006 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5008 gfc_ss_type ss_type
;
5010 ss_type
= ss
->info
->type
;
5011 if (ss_type
== GFC_SS_SCALAR
5012 || ss_type
== GFC_SS_TEMP
5013 || ss_type
== GFC_SS_REFERENCE
5014 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
5017 info
= &ss
->info
->data
.array
;
5020 if (loopspec
[n
] != NULL
)
5022 specinfo
= &loopspec
[n
]->info
->data
.array
;
5023 spec_dim
= loopspec
[n
]->dim
[n
];
5027 /* Silence uninitialized warnings. */
5034 gcc_assert (info
->shape
[dim
]);
5035 /* The frontend has worked out the size for us. */
5038 || !integer_zerop (specinfo
->start
[spec_dim
]))
5039 /* Prefer zero-based descriptors if possible. */
5044 if (ss_type
== GFC_SS_CONSTRUCTOR
)
5046 gfc_constructor_base base
;
5047 /* An unknown size constructor will always be rank one.
5048 Higher rank constructors will either have known shape,
5049 or still be wrapped in a call to reshape. */
5050 gcc_assert (loop
->dimen
== 1);
5052 /* Always prefer to use the constructor bounds if the size
5053 can be determined at compile time. Prefer not to otherwise,
5054 since the general case involves realloc, and it's better to
5055 avoid that overhead if possible. */
5056 base
= ss
->info
->expr
->value
.constructor
;
5057 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
5058 if (!dynamic
[n
] || !loopspec
[n
])
5063 /* Avoid using an allocatable lhs in an assignment, since
5064 there might be a reallocation coming. */
5065 if (loopspec
[n
] && ss
->is_alloc_lhs
)
5070 /* Criteria for choosing a loop specifier (most important first):
5071 doesn't need realloc
5077 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
5079 else if (integer_onep (info
->stride
[dim
])
5080 && !integer_onep (specinfo
->stride
[spec_dim
]))
5082 else if (INTEGER_CST_P (info
->stride
[dim
])
5083 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5085 else if (INTEGER_CST_P (info
->start
[dim
])
5086 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
5087 && integer_onep (info
->stride
[dim
])
5088 == integer_onep (specinfo
->stride
[spec_dim
])
5089 && INTEGER_CST_P (info
->stride
[dim
])
5090 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5092 /* We don't work out the upper bound.
5093 else if (INTEGER_CST_P (info->finish[n])
5094 && ! INTEGER_CST_P (specinfo->finish[n]))
5095 loopspec[n] = ss; */
5098 /* We should have found the scalarization loop specifier. If not,
5100 gcc_assert (loopspec
[n
]);
5102 info
= &loopspec
[n
]->info
->data
.array
;
5103 dim
= loopspec
[n
]->dim
[n
];
5105 /* Set the extents of this range. */
5106 cshape
= info
->shape
;
5107 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5108 && INTEGER_CST_P (info
->stride
[dim
]))
5110 loop
->from
[n
] = info
->start
[dim
];
5111 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5112 mpz_sub_ui (i
, i
, 1);
5113 /* To = from + (size - 1) * stride. */
5114 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5115 if (!integer_onep (info
->stride
[dim
]))
5116 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5117 gfc_array_index_type
, tmp
,
5119 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5120 gfc_array_index_type
,
5121 loop
->from
[n
], tmp
);
5125 loop
->from
[n
] = info
->start
[dim
];
5126 switch (loopspec
[n
]->info
->type
)
5128 case GFC_SS_CONSTRUCTOR
:
5129 /* The upper bound is calculated when we expand the
5131 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5134 case GFC_SS_SECTION
:
5135 /* Use the end expression if it exists and is not constant,
5136 so that it is only evaluated once. */
5137 loop
->to
[n
] = info
->end
[dim
];
5140 case GFC_SS_FUNCTION
:
5141 /* The loop bound will be set when we generate the call. */
5142 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5145 case GFC_SS_INTRINSIC
:
5147 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5149 /* The {l,u}bound of an assumed rank. */
5150 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5151 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5152 && expr
->value
.function
.actual
->next
->expr
== NULL
5153 && expr
->value
.function
.actual
->expr
->rank
== -1);
5155 loop
->to
[n
] = info
->end
[dim
];
5159 case GFC_SS_COMPONENT
:
5161 if (info
->end
[dim
] != NULL_TREE
)
5163 loop
->to
[n
] = info
->end
[dim
];
5175 /* Transform everything so we have a simple incrementing variable. */
5176 if (integer_onep (info
->stride
[dim
]))
5177 info
->delta
[dim
] = gfc_index_zero_node
;
5180 /* Set the delta for this section. */
5181 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5182 /* Number of iterations is (end - start + step) / step.
5183 with start = 0, this simplifies to
5185 for (i = 0; i<=last; i++){...}; */
5186 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5187 gfc_array_index_type
, loop
->to
[n
],
5189 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5190 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5191 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5192 tmp
, build_int_cst (gfc_array_index_type
, -1));
5193 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5194 /* Make the loop variable start at 0. */
5195 loop
->from
[n
] = gfc_index_zero_node
;
5200 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5201 set_loop_bounds (loop
);
5205 /* Initialize the scalarization loop. Creates the loop variables. Determines
5206 the range of the loop variables. Creates a temporary if required.
5207 Also generates code for scalar expressions which have been
5208 moved outside the loop. */
5211 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5216 set_loop_bounds (loop
);
5218 /* Add all the scalar code that can be taken out of the loops.
5219 This may include calculating the loop bounds, so do it before
5220 allocating the temporary. */
5221 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5223 tmp_ss
= loop
->temp_ss
;
5224 /* If we want a temporary then create it. */
5227 gfc_ss_info
*tmp_ss_info
;
5229 tmp_ss_info
= tmp_ss
->info
;
5230 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5231 gcc_assert (loop
->parent
== NULL
);
5233 /* Make absolutely sure that this is a complete type. */
5234 if (tmp_ss_info
->string_length
)
5235 tmp_ss_info
->data
.temp
.type
5236 = gfc_get_character_type_len_for_eltype
5237 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5238 tmp_ss_info
->string_length
);
5240 tmp
= tmp_ss_info
->data
.temp
.type
;
5241 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5242 tmp_ss_info
->type
= GFC_SS_SECTION
;
5244 gcc_assert (tmp_ss
->dimen
!= 0);
5246 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5247 NULL_TREE
, false, true, false, where
);
5250 /* For array parameters we don't have loop variables, so don't calculate the
5252 if (!loop
->array_parameter
)
5253 gfc_set_delta (loop
);
5257 /* Calculates how to transform from loop variables to array indices for each
5258 array: once loop bounds are chosen, sets the difference (DELTA field) between
5259 loop bounds and array reference bounds, for each array info. */
5262 gfc_set_delta (gfc_loopinfo
*loop
)
5264 gfc_ss
*ss
, **loopspec
;
5265 gfc_array_info
*info
;
5269 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5271 loopspec
= loop
->specloop
;
5273 /* Calculate the translation from loop variables to array indices. */
5274 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5276 gfc_ss_type ss_type
;
5278 ss_type
= ss
->info
->type
;
5279 if (ss_type
!= GFC_SS_SECTION
5280 && ss_type
!= GFC_SS_COMPONENT
5281 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5284 info
= &ss
->info
->data
.array
;
5286 for (n
= 0; n
< ss
->dimen
; n
++)
5288 /* If we are specifying the range the delta is already set. */
5289 if (loopspec
[n
] != ss
)
5293 /* Calculate the offset relative to the loop variable.
5294 First multiply by the stride. */
5295 tmp
= loop
->from
[n
];
5296 if (!integer_onep (info
->stride
[dim
]))
5297 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5298 gfc_array_index_type
,
5299 tmp
, info
->stride
[dim
]);
5301 /* Then subtract this from our starting value. */
5302 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5303 gfc_array_index_type
,
5304 info
->start
[dim
], tmp
);
5306 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5311 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5312 gfc_set_delta (loop
);
5316 /* Calculate the size of a given array dimension from the bounds. This
5317 is simply (ubound - lbound + 1) if this expression is positive
5318 or 0 if it is negative (pick either one if it is zero). Optionally
5319 (if or_expr is present) OR the (expression != 0) condition to it. */
5322 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5327 /* Calculate (ubound - lbound + 1). */
5328 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5330 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5331 gfc_index_one_node
);
5333 /* Check whether the size for this dimension is negative. */
5334 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5335 gfc_index_zero_node
);
5336 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5337 gfc_index_zero_node
, res
);
5339 /* Build OR expression. */
5341 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5342 logical_type_node
, *or_expr
, cond
);
5348 /* For an array descriptor, get the total number of elements. This is just
5349 the product of the extents along from_dim to to_dim. */
5352 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5357 res
= gfc_index_one_node
;
5359 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5365 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5366 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5368 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5369 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5377 /* Full size of an array. */
5380 gfc_conv_descriptor_size (tree desc
, int rank
)
5382 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5386 /* Size of a coarray for all dimensions but the last. */
5389 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5391 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5395 /* Fills in an array descriptor, and returns the size of the array.
5396 The size will be a simple_val, ie a variable or a constant. Also
5397 calculates the offset of the base. The pointer argument overflow,
5398 which should be of integer type, will increase in value if overflow
5399 occurs during the size calculation. Returns the size of the array.
5403 for (n = 0; n < rank; n++)
5405 a.lbound[n] = specified_lower_bound;
5406 offset = offset + a.lbond[n] * stride;
5408 a.ubound[n] = specified_upper_bound;
5409 a.stride[n] = stride;
5410 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5411 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5412 stride = stride * size;
5414 for (n = rank; n < rank+corank; n++)
5415 (Set lcobound/ucobound as above.)
5416 element_size = sizeof (array element);
5419 stride = (size_t) stride;
5420 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5421 stride = stride * element_size;
5427 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5428 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5429 stmtblock_t
* descriptor_block
, tree
* overflow
,
5430 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5431 tree expr3_desc
, bool e3_has_nodescriptor
, gfc_expr
*expr
,
5444 stmtblock_t thenblock
;
5445 stmtblock_t elseblock
;
5450 type
= TREE_TYPE (descriptor
);
5452 stride
= gfc_index_one_node
;
5453 offset
= gfc_index_zero_node
;
5455 /* Set the dtype before the alloc, because registration of coarrays needs
5457 if (expr
->ts
.type
== BT_CHARACTER
5458 && expr
->ts
.deferred
5459 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5461 type
= gfc_typenode_for_spec (&expr
->ts
);
5462 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5463 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5465 else if (expr
->ts
.type
== BT_CHARACTER
5466 && expr
->ts
.deferred
5467 && TREE_CODE (descriptor
) == COMPONENT_REF
)
5469 /* Deferred character components have their string length tucked away
5470 in a hidden field of the derived type. Obtain that and use it to
5471 set the dtype. The charlen backend decl is zero because the field
5472 type is zero length. */
5475 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5476 if (ref
->type
== REF_COMPONENT
5477 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
5479 gcc_assert (tmp
!= NULL_TREE
);
5480 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
5481 TREE_OPERAND (descriptor
, 0), tmp
, NULL_TREE
);
5482 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
5483 type
= gfc_get_character_type_len (expr
->ts
.kind
, tmp
);
5484 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5485 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5489 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5490 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5493 or_expr
= logical_false_node
;
5495 for (n
= 0; n
< rank
; n
++)
5500 /* We have 3 possibilities for determining the size of the array:
5501 lower == NULL => lbound = 1, ubound = upper[n]
5502 upper[n] = NULL => lbound = 1, ubound = lower[n]
5503 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5506 /* Set lower bound. */
5507 gfc_init_se (&se
, NULL
);
5508 if (expr3_desc
!= NULL_TREE
)
5510 if (e3_has_nodescriptor
)
5511 /* The lbound of nondescriptor arrays like array constructors,
5512 nonallocatable/nonpointer function results/variables,
5513 start at zero, but when allocating it, the standard expects
5514 the array to start at one. */
5515 se
.expr
= gfc_index_one_node
;
5517 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5520 else if (lower
== NULL
)
5521 se
.expr
= gfc_index_one_node
;
5524 gcc_assert (lower
[n
]);
5527 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5528 gfc_add_block_to_block (pblock
, &se
.pre
);
5532 se
.expr
= gfc_index_one_node
;
5536 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5537 gfc_rank_cst
[n
], se
.expr
);
5538 conv_lbound
= se
.expr
;
5540 /* Work out the offset for this component. */
5541 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5543 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5544 gfc_array_index_type
, offset
, tmp
);
5546 /* Set upper bound. */
5547 gfc_init_se (&se
, NULL
);
5548 if (expr3_desc
!= NULL_TREE
)
5550 if (e3_has_nodescriptor
)
5552 /* The lbound of nondescriptor arrays like array constructors,
5553 nonallocatable/nonpointer function results/variables,
5554 start at zero, but when allocating it, the standard expects
5555 the array to start at one. Therefore fix the upper bound to be
5556 (desc.ubound - desc.lbound) + 1. */
5557 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5558 gfc_array_index_type
,
5559 gfc_conv_descriptor_ubound_get (
5560 expr3_desc
, gfc_rank_cst
[n
]),
5561 gfc_conv_descriptor_lbound_get (
5562 expr3_desc
, gfc_rank_cst
[n
]));
5563 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5564 gfc_array_index_type
, tmp
,
5565 gfc_index_one_node
);
5566 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5569 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5574 gcc_assert (ubound
);
5575 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5576 gfc_add_block_to_block (pblock
, &se
.pre
);
5577 if (ubound
->expr_type
== EXPR_FUNCTION
)
5578 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5580 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5581 gfc_rank_cst
[n
], se
.expr
);
5582 conv_ubound
= se
.expr
;
5584 /* Store the stride. */
5585 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5586 gfc_rank_cst
[n
], stride
);
5588 /* Calculate size and check whether extent is negative. */
5589 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5590 size
= gfc_evaluate_now (size
, pblock
);
5592 /* Check whether multiplying the stride by the number of
5593 elements in this dimension would overflow. We must also check
5594 whether the current dimension has zero size in order to avoid
5597 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5598 gfc_array_index_type
,
5599 fold_convert (gfc_array_index_type
,
5600 TYPE_MAX_VALUE (gfc_array_index_type
)),
5602 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5603 logical_type_node
, tmp
, stride
),
5604 PRED_FORTRAN_OVERFLOW
);
5605 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5606 integer_one_node
, integer_zero_node
);
5607 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5608 logical_type_node
, size
,
5609 gfc_index_zero_node
),
5610 PRED_FORTRAN_SIZE_ZERO
);
5611 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5612 integer_zero_node
, tmp
);
5613 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5615 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5617 /* Multiply the stride by the number of elements in this dimension. */
5618 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5619 gfc_array_index_type
, stride
, size
);
5620 stride
= gfc_evaluate_now (stride
, pblock
);
5623 for (n
= rank
; n
< rank
+ corank
; n
++)
5627 /* Set lower bound. */
5628 gfc_init_se (&se
, NULL
);
5629 if (lower
== NULL
|| lower
[n
] == NULL
)
5631 gcc_assert (n
== rank
+ corank
- 1);
5632 se
.expr
= gfc_index_one_node
;
5636 if (ubound
|| n
== rank
+ corank
- 1)
5638 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5639 gfc_add_block_to_block (pblock
, &se
.pre
);
5643 se
.expr
= gfc_index_one_node
;
5647 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5648 gfc_rank_cst
[n
], se
.expr
);
5650 if (n
< rank
+ corank
- 1)
5652 gfc_init_se (&se
, NULL
);
5653 gcc_assert (ubound
);
5654 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5655 gfc_add_block_to_block (pblock
, &se
.pre
);
5656 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5657 gfc_rank_cst
[n
], se
.expr
);
5661 /* The stride is the number of elements in the array, so multiply by the
5662 size of an element to get the total size. Obviously, if there is a
5663 SOURCE expression (expr3) we must use its element size. */
5664 if (expr3_elem_size
!= NULL_TREE
)
5665 tmp
= expr3_elem_size
;
5666 else if (expr3
!= NULL
)
5668 if (expr3
->ts
.type
== BT_CLASS
)
5671 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5672 gfc_add_vptr_component (sz
);
5673 gfc_add_size_component (sz
);
5674 gfc_init_se (&se_sz
, NULL
);
5675 gfc_conv_expr (&se_sz
, sz
);
5681 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5682 tmp
= TYPE_SIZE_UNIT (tmp
);
5686 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5688 /* Convert to size_t. */
5689 *element_size
= fold_convert (size_type_node
, tmp
);
5692 return *element_size
;
5694 *nelems
= gfc_evaluate_now (stride
, pblock
);
5695 stride
= fold_convert (size_type_node
, stride
);
5697 /* First check for overflow. Since an array of type character can
5698 have zero element_size, we must check for that before
5700 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5702 TYPE_MAX_VALUE (size_type_node
), *element_size
);
5703 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5704 logical_type_node
, tmp
, stride
),
5705 PRED_FORTRAN_OVERFLOW
);
5706 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5707 integer_one_node
, integer_zero_node
);
5708 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5709 logical_type_node
, *element_size
,
5710 build_int_cst (size_type_node
, 0)),
5711 PRED_FORTRAN_SIZE_ZERO
);
5712 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5713 integer_zero_node
, tmp
);
5714 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5716 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5718 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5719 stride
, *element_size
);
5721 if (poffset
!= NULL
)
5723 offset
= gfc_evaluate_now (offset
, pblock
);
5727 if (integer_zerop (or_expr
))
5729 if (integer_onep (or_expr
))
5730 return build_int_cst (size_type_node
, 0);
5732 var
= gfc_create_var (TREE_TYPE (size
), "size");
5733 gfc_start_block (&thenblock
);
5734 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5735 thencase
= gfc_finish_block (&thenblock
);
5737 gfc_start_block (&elseblock
);
5738 gfc_add_modify (&elseblock
, var
, size
);
5739 elsecase
= gfc_finish_block (&elseblock
);
5741 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5742 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5743 gfc_add_expr_to_block (pblock
, tmp
);
5749 /* Retrieve the last ref from the chain. This routine is specific to
5750 gfc_array_allocate ()'s needs. */
5753 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5755 gfc_ref
*ref
, *prev_ref
;
5758 /* Prevent warnings for uninitialized variables. */
5759 prev_ref
= *prev_ref_in
;
5760 while (ref
&& ref
->next
!= NULL
)
5762 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5763 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5768 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5772 *prev_ref_in
= prev_ref
;
5776 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5777 the work for an ALLOCATE statement. */
5781 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5782 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5783 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5784 bool e3_has_nodescriptor
)
5788 tree offset
= NULL_TREE
;
5789 tree token
= NULL_TREE
;
5792 tree error
= NULL_TREE
;
5793 tree overflow
; /* Boolean storing whether size calculation overflows. */
5794 tree var_overflow
= NULL_TREE
;
5796 tree set_descriptor
;
5797 tree not_prev_allocated
= NULL_TREE
;
5798 tree element_size
= NULL_TREE
;
5799 stmtblock_t set_descriptor_block
;
5800 stmtblock_t elseblock
;
5803 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5804 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5805 non_ulimate_coarray_ptr_comp
;
5809 /* Find the last reference in the chain. */
5810 if (!retrieve_last_ref (&ref
, &prev_ref
))
5813 /* Take the allocatable and coarray properties solely from the expr-ref's
5814 attributes and not from source=-expression. */
5817 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5818 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5819 non_ulimate_coarray_ptr_comp
= false;
5823 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5824 /* Pointer components in coarrayed derived types must be treated
5825 specially in that they are registered without a check if the are
5826 already associated. This does not hold for ultimate coarray
5828 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5829 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5830 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5833 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5834 a coarray. In this case it does not matter whether we are on this_image
5837 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5838 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5845 gcc_assert (coarray
);
5847 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5849 gfc_ref
*old_ref
= ref
;
5850 /* F08:C633: Array shape from expr3. */
5853 /* Find the last reference in the chain. */
5854 if (!retrieve_last_ref (&ref
, &prev_ref
))
5856 if (expr3
->expr_type
== EXPR_FUNCTION
5857 && gfc_expr_attr (expr3
).dimension
)
5862 alloc_w_e3_arr_spec
= true;
5865 /* Figure out the size of the array. */
5866 switch (ref
->u
.ar
.type
)
5872 upper
= ref
->u
.ar
.start
;
5878 lower
= ref
->u
.ar
.start
;
5879 upper
= ref
->u
.ar
.end
;
5883 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5884 || alloc_w_e3_arr_spec
);
5886 lower
= ref
->u
.ar
.as
->lower
;
5887 upper
= ref
->u
.ar
.as
->upper
;
5895 overflow
= integer_zero_node
;
5897 if (expr
->ts
.type
== BT_CHARACTER
5898 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5899 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
5900 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5901 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5902 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5903 se
->string_length
));
5905 gfc_init_block (&set_descriptor_block
);
5906 /* Take the corank only from the actual ref and not from the coref. The
5907 later will mislead the generation of the array dimensions for allocatable/
5908 pointer components in derived types. */
5909 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5910 : ref
->u
.ar
.as
->rank
,
5911 coarray
? ref
->u
.ar
.as
->corank
: 0,
5912 &offset
, lower
, upper
,
5913 &se
->pre
, &set_descriptor_block
, &overflow
,
5914 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5915 e3_has_nodescriptor
, expr
, &element_size
);
5919 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5920 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5922 if (status
== NULL_TREE
)
5924 /* Generate the block of code handling overflow. */
5925 msg
= gfc_build_addr_expr (pchar_type_node
,
5926 gfc_build_localized_cstring_const
5927 ("Integer overflow when calculating the amount of "
5928 "memory to allocate"));
5929 error
= build_call_expr_loc (input_location
,
5930 gfor_fndecl_runtime_error
, 1, msg
);
5934 tree status_type
= TREE_TYPE (status
);
5935 stmtblock_t set_status_block
;
5937 gfc_start_block (&set_status_block
);
5938 gfc_add_modify (&set_status_block
, status
,
5939 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5940 error
= gfc_finish_block (&set_status_block
);
5944 /* Allocate memory to store the data. */
5945 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5946 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5948 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5950 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5951 : gfc_conv_descriptor_data_get (se
->expr
);
5952 token
= gfc_conv_descriptor_token (se
->expr
);
5953 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5956 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5957 STRIP_NOPS (pointer
);
5961 not_prev_allocated
= gfc_create_var (logical_type_node
,
5962 "not_prev_allocated");
5963 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5964 logical_type_node
, pointer
,
5965 build_int_cst (TREE_TYPE (pointer
), 0));
5967 gfc_add_modify (&se
->pre
, not_prev_allocated
, tmp
);
5970 gfc_start_block (&elseblock
);
5972 /* The allocatable variant takes the old pointer as first argument. */
5974 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5975 status
, errmsg
, errlen
, label_finish
, expr
,
5976 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5977 else if (non_ulimate_coarray_ptr_comp
&& token
)
5978 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5979 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5981 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5983 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5987 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5988 logical_type_node
, var_overflow
, integer_zero_node
),
5989 PRED_FORTRAN_OVERFLOW
);
5990 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5991 error
, gfc_finish_block (&elseblock
));
5994 tmp
= gfc_finish_block (&elseblock
);
5996 gfc_add_expr_to_block (&se
->pre
, tmp
);
5998 /* Update the array descriptor with the offset and the span. */
6001 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
6002 tmp
= fold_convert (gfc_array_index_type
, element_size
);
6003 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
6006 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
6007 if (status
!= NULL_TREE
)
6009 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6010 logical_type_node
, status
,
6011 build_int_cst (TREE_TYPE (status
), 0));
6013 if (not_prev_allocated
!= NULL_TREE
)
6014 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6015 logical_type_node
, cond
, not_prev_allocated
);
6017 gfc_add_expr_to_block (&se
->pre
,
6018 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6021 build_empty_stmt (input_location
)));
6024 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
6030 /* Create an array constructor from an initialization expression.
6031 We assume the frontend already did any expansions and conversions. */
6034 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
6040 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6042 if (expr
->expr_type
== EXPR_VARIABLE
6043 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6044 && expr
->symtree
->n
.sym
->value
)
6045 expr
= expr
->symtree
->n
.sym
->value
;
6047 switch (expr
->expr_type
)
6050 case EXPR_STRUCTURE
:
6051 /* A single scalar or derived type value. Create an array with all
6052 elements equal to that value. */
6053 gfc_init_se (&se
, NULL
);
6055 if (expr
->expr_type
== EXPR_CONSTANT
)
6056 gfc_conv_constant (&se
, expr
);
6058 gfc_conv_structure (&se
, expr
, 1);
6060 CONSTRUCTOR_APPEND_ELT (v
, build2 (RANGE_EXPR
, gfc_array_index_type
,
6061 TYPE_MIN_VALUE (TYPE_DOMAIN (type
)),
6062 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))),
6067 /* Create a vector of all the elements. */
6068 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6069 c
; c
= gfc_constructor_next (c
))
6073 /* Problems occur when we get something like
6074 integer :: a(lots) = (/(i, i=1, lots)/) */
6075 gfc_fatal_error ("The number of elements in the array "
6076 "constructor at %L requires an increase of "
6077 "the allowed %d upper limit. See "
6078 "%<-fmax-array-constructor%> option",
6079 &expr
->where
, flag_max_array_constructor
);
6082 if (mpz_cmp_si (c
->offset
, 0) != 0)
6083 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6087 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6093 mpz_add (maxval
, c
->offset
, c
->repeat
);
6094 mpz_sub_ui (maxval
, maxval
, 1);
6095 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6096 if (mpz_cmp_si (c
->offset
, 0) != 0)
6098 mpz_add_ui (maxval
, c
->offset
, 1);
6099 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6102 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6104 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6110 gfc_init_se (&se
, NULL
);
6111 switch (c
->expr
->expr_type
)
6114 gfc_conv_constant (&se
, c
->expr
);
6116 /* See gfortran.dg/charlen_15.f90 for instance. */
6117 if (TREE_CODE (se
.expr
) == STRING_CST
6118 && TREE_CODE (type
) == ARRAY_TYPE
)
6121 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6122 atype
= TREE_TYPE (atype
);
6123 gcc_checking_assert (TREE_CODE (TREE_TYPE (atype
))
6125 gcc_checking_assert (TREE_TYPE (TREE_TYPE (se
.expr
))
6126 == TREE_TYPE (atype
));
6127 if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6128 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6130 unsigned HOST_WIDE_INT size
6131 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6132 const char *p
= TREE_STRING_POINTER (se
.expr
);
6134 se
.expr
= build_string (size
, p
);
6136 TREE_TYPE (se
.expr
) = atype
;
6140 case EXPR_STRUCTURE
:
6141 gfc_conv_structure (&se
, c
->expr
, 1);
6145 /* Catch those occasional beasts that do not simplify
6146 for one reason or another, assuming that if they are
6147 standard defying the frontend will catch them. */
6148 gfc_conv_expr (&se
, c
->expr
);
6152 if (range
== NULL_TREE
)
6153 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6156 if (index
!= NULL_TREE
)
6157 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6158 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6164 return gfc_build_null_descriptor (type
);
6170 /* Create a constructor from the list of elements. */
6171 tmp
= build_constructor (type
, v
);
6172 TREE_CONSTANT (tmp
) = 1;
6177 /* Generate code to evaluate non-constant coarray cobounds. */
6180 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6181 const gfc_symbol
*sym
)
6189 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6191 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6193 /* Evaluate non-constant array bound expressions. */
6194 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6195 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6197 gfc_init_se (&se
, NULL
);
6198 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6199 gfc_add_block_to_block (pblock
, &se
.pre
);
6200 gfc_add_modify (pblock
, lbound
, se
.expr
);
6202 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6203 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6205 gfc_init_se (&se
, NULL
);
6206 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6207 gfc_add_block_to_block (pblock
, &se
.pre
);
6208 gfc_add_modify (pblock
, ubound
, se
.expr
);
6214 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6215 returns the size (in elements) of the array. */
6218 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6219 stmtblock_t
* pblock
)
6232 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6234 size
= gfc_index_one_node
;
6235 offset
= gfc_index_zero_node
;
6236 for (dim
= 0; dim
< as
->rank
; dim
++)
6238 /* Evaluate non-constant array bound expressions. */
6239 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6240 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6242 gfc_init_se (&se
, NULL
);
6243 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6244 gfc_add_block_to_block (pblock
, &se
.pre
);
6245 gfc_add_modify (pblock
, lbound
, se
.expr
);
6247 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6248 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6250 gfc_init_se (&se
, NULL
);
6251 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6252 gfc_add_block_to_block (pblock
, &se
.pre
);
6253 gfc_add_modify (pblock
, ubound
, se
.expr
);
6255 /* The offset of this dimension. offset = offset - lbound * stride. */
6256 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6258 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6261 /* The size of this dimension, and the stride of the next. */
6262 if (dim
+ 1 < as
->rank
)
6263 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6265 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6267 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6269 /* Calculate stride = size * (ubound + 1 - lbound). */
6270 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6271 gfc_array_index_type
,
6272 gfc_index_one_node
, lbound
);
6273 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6274 gfc_array_index_type
, ubound
, tmp
);
6275 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6276 gfc_array_index_type
, size
, tmp
);
6278 gfc_add_modify (pblock
, stride
, tmp
);
6280 stride
= gfc_evaluate_now (tmp
, pblock
);
6282 /* Make sure that negative size arrays are translated
6283 to being zero size. */
6284 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6285 stride
, gfc_index_zero_node
);
6286 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6287 gfc_array_index_type
, tmp
,
6288 stride
, gfc_index_zero_node
);
6289 gfc_add_modify (pblock
, stride
, tmp
);
6295 gfc_trans_array_cobounds (type
, pblock
, sym
);
6296 gfc_trans_vla_type_sizes (sym
, pblock
);
6303 /* Generate code to initialize/allocate an array variable. */
6306 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6307 gfc_wrapped_block
* block
)
6311 tree tmp
= NULL_TREE
;
6318 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6320 /* Do nothing for USEd variables. */
6321 if (sym
->attr
.use_assoc
)
6324 type
= TREE_TYPE (decl
);
6325 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6326 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6328 gfc_init_block (&init
);
6330 /* Evaluate character string length. */
6331 if (sym
->ts
.type
== BT_CHARACTER
6332 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6334 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6336 gfc_trans_vla_type_sizes (sym
, &init
);
6338 /* Emit a DECL_EXPR for this variable, which will cause the
6339 gimplifier to allocate storage, and all that good stuff. */
6340 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6341 gfc_add_expr_to_block (&init
, tmp
);
6346 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6350 type
= TREE_TYPE (type
);
6352 gcc_assert (!sym
->attr
.use_assoc
);
6353 gcc_assert (!TREE_STATIC (decl
));
6354 gcc_assert (!sym
->module
);
6356 if (sym
->ts
.type
== BT_CHARACTER
6357 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6358 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6360 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6362 /* Don't actually allocate space for Cray Pointees. */
6363 if (sym
->attr
.cray_pointee
)
6365 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6366 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6368 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6372 if (flag_stack_arrays
)
6374 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6375 space
= build_decl (gfc_get_location (&sym
->declared_at
),
6376 VAR_DECL
, create_tmp_var_name ("A"),
6377 TREE_TYPE (TREE_TYPE (decl
)));
6378 gfc_trans_vla_type_sizes (sym
, &init
);
6382 /* The size is the number of elements in the array, so multiply by the
6383 size of an element to get the total size. */
6384 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6385 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6386 size
, fold_convert (gfc_array_index_type
, tmp
));
6388 /* Allocate memory to hold the data. */
6389 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6390 gfc_add_modify (&init
, decl
, tmp
);
6392 /* Free the temporary. */
6393 tmp
= gfc_call_free (decl
);
6397 /* Set offset of the array. */
6398 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6399 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6401 /* Automatic arrays should not have initializers. */
6402 gcc_assert (!sym
->value
);
6404 inittree
= gfc_finish_block (&init
);
6411 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6412 where also space is located. */
6413 gfc_init_block (&init
);
6414 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6415 TREE_TYPE (space
), space
);
6416 gfc_add_expr_to_block (&init
, tmp
);
6417 addr
= fold_build1_loc (gfc_get_location (&sym
->declared_at
),
6418 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6419 gfc_add_modify (&init
, decl
, addr
);
6420 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6423 gfc_add_init_cleanup (block
, inittree
, tmp
);
6427 /* Generate entry and exit code for g77 calling convention arrays. */
6430 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6440 gfc_save_backend_locus (&loc
);
6441 gfc_set_backend_locus (&sym
->declared_at
);
6443 /* Descriptor type. */
6444 parm
= sym
->backend_decl
;
6445 type
= TREE_TYPE (parm
);
6446 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6448 gfc_start_block (&init
);
6450 if (sym
->ts
.type
== BT_CHARACTER
6451 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6452 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6454 /* Evaluate the bounds of the array. */
6455 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6457 /* Set the offset. */
6458 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6459 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6461 /* Set the pointer itself if we aren't using the parameter directly. */
6462 if (TREE_CODE (parm
) != PARM_DECL
)
6464 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6465 gfc_add_modify (&init
, parm
, tmp
);
6467 stmt
= gfc_finish_block (&init
);
6469 gfc_restore_backend_locus (&loc
);
6471 /* Add the initialization code to the start of the function. */
6473 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6475 tmp
= gfc_conv_expr_present (sym
);
6476 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6479 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6483 /* Modify the descriptor of an array parameter so that it has the
6484 correct lower bound. Also move the upper bound accordingly.
6485 If the array is not packed, it will be copied into a temporary.
6486 For each dimension we set the new lower and upper bounds. Then we copy the
6487 stride and calculate the offset for this dimension. We also work out
6488 what the stride of a packed array would be, and see it the two match.
6489 If the array need repacking, we set the stride to the values we just
6490 calculated, recalculate the offset and copy the array data.
6491 Code is also added to copy the data back at the end of the function.
6495 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6496 gfc_wrapped_block
* block
)
6503 tree stmtInit
, stmtCleanup
;
6510 tree stride
, stride2
;
6520 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6522 /* Do nothing for pointer and allocatable arrays. */
6523 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6524 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6525 || sym
->attr
.allocatable
6526 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6529 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6531 gfc_trans_g77_array (sym
, block
);
6536 gfc_save_backend_locus (&loc
);
6537 /* loc.nextc is not set by save_backend_locus but the location routines
6539 if (loc
.nextc
== NULL
)
6540 loc
.nextc
= loc
.lb
->line
;
6541 gfc_set_backend_locus (&sym
->declared_at
);
6543 /* Descriptor type. */
6544 type
= TREE_TYPE (tmpdesc
);
6545 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6546 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6548 /* For a class array the dummy array descriptor is in the _class
6550 dumdesc
= gfc_class_data_get (dumdesc
);
6552 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6553 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6554 gfc_start_block (&init
);
6556 if (sym
->ts
.type
== BT_CHARACTER
6557 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6558 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6560 checkparm
= (as
->type
== AS_EXPLICIT
6561 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6563 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6564 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6566 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6568 /* For non-constant shape arrays we only check if the first dimension
6569 is contiguous. Repacking higher dimensions wouldn't gain us
6570 anything as we still don't know the array stride. */
6571 partial
= gfc_create_var (logical_type_node
, "partial");
6572 TREE_USED (partial
) = 1;
6573 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6574 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6575 gfc_index_one_node
);
6576 gfc_add_modify (&init
, partial
, tmp
);
6579 partial
= NULL_TREE
;
6581 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6582 here, however I think it does the right thing. */
6585 /* Set the first stride. */
6586 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6587 stride
= gfc_evaluate_now (stride
, &init
);
6589 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6590 stride
, gfc_index_zero_node
);
6591 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6592 tmp
, gfc_index_one_node
, stride
);
6593 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6594 gfc_add_modify (&init
, stride
, tmp
);
6596 /* Allow the user to disable array repacking. */
6597 stmt_unpacked
= NULL_TREE
;
6601 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6602 /* A library call to repack the array if necessary. */
6603 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6604 stmt_unpacked
= build_call_expr_loc (input_location
,
6605 gfor_fndecl_in_pack
, 1, tmp
);
6607 stride
= gfc_index_one_node
;
6609 if (warn_array_temporaries
)
6610 gfc_warning (OPT_Warray_temporaries
,
6611 "Creating array temporary at %L", &loc
);
6614 /* This is for the case where the array data is used directly without
6615 calling the repack function. */
6616 if (no_repack
|| partial
!= NULL_TREE
)
6617 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6619 stmt_packed
= NULL_TREE
;
6621 /* Assign the data pointer. */
6622 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6624 /* Don't repack unknown shape arrays when the first stride is 1. */
6625 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6626 partial
, stmt_packed
, stmt_unpacked
);
6629 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6630 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6632 offset
= gfc_index_zero_node
;
6633 size
= gfc_index_one_node
;
6635 /* Evaluate the bounds of the array. */
6636 for (n
= 0; n
< as
->rank
; n
++)
6638 if (checkparm
|| !as
->upper
[n
])
6640 /* Get the bounds of the actual parameter. */
6641 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6642 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6646 dubound
= NULL_TREE
;
6647 dlbound
= NULL_TREE
;
6650 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6651 if (!INTEGER_CST_P (lbound
))
6653 gfc_init_se (&se
, NULL
);
6654 gfc_conv_expr_type (&se
, as
->lower
[n
],
6655 gfc_array_index_type
);
6656 gfc_add_block_to_block (&init
, &se
.pre
);
6657 gfc_add_modify (&init
, lbound
, se
.expr
);
6660 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6661 /* Set the desired upper bound. */
6664 /* We know what we want the upper bound to be. */
6665 if (!INTEGER_CST_P (ubound
))
6667 gfc_init_se (&se
, NULL
);
6668 gfc_conv_expr_type (&se
, as
->upper
[n
],
6669 gfc_array_index_type
);
6670 gfc_add_block_to_block (&init
, &se
.pre
);
6671 gfc_add_modify (&init
, ubound
, se
.expr
);
6674 /* Check the sizes match. */
6677 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6681 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6682 gfc_array_index_type
, ubound
, lbound
);
6683 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6684 gfc_array_index_type
,
6685 gfc_index_one_node
, temp
);
6686 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6687 gfc_array_index_type
, dubound
,
6689 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6690 gfc_array_index_type
,
6691 gfc_index_one_node
, stride2
);
6692 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6693 gfc_array_index_type
, temp
, stride2
);
6694 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6695 "%%ld instead of %%ld", n
+1, sym
->name
);
6697 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6698 fold_convert (long_integer_type_node
, temp
),
6699 fold_convert (long_integer_type_node
, stride2
));
6706 /* For assumed shape arrays move the upper bound by the same amount
6707 as the lower bound. */
6708 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6709 gfc_array_index_type
, dubound
, dlbound
);
6710 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6711 gfc_array_index_type
, tmp
, lbound
);
6712 gfc_add_modify (&init
, ubound
, tmp
);
6714 /* The offset of this dimension. offset = offset - lbound * stride. */
6715 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6717 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6718 gfc_array_index_type
, offset
, tmp
);
6720 /* The size of this dimension, and the stride of the next. */
6721 if (n
+ 1 < as
->rank
)
6723 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6725 if (no_repack
|| partial
!= NULL_TREE
)
6727 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6729 /* Figure out the stride if not a known constant. */
6730 if (!INTEGER_CST_P (stride
))
6733 stmt_packed
= NULL_TREE
;
6736 /* Calculate stride = size * (ubound + 1 - lbound). */
6737 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6738 gfc_array_index_type
,
6739 gfc_index_one_node
, lbound
);
6740 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6741 gfc_array_index_type
, ubound
, tmp
);
6742 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6743 gfc_array_index_type
, size
, tmp
);
6747 /* Assign the stride. */
6748 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6749 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6750 gfc_array_index_type
, partial
,
6751 stmt_unpacked
, stmt_packed
);
6753 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6754 gfc_add_modify (&init
, stride
, tmp
);
6759 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6761 if (stride
&& !INTEGER_CST_P (stride
))
6763 /* Calculate size = stride * (ubound + 1 - lbound). */
6764 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6765 gfc_array_index_type
,
6766 gfc_index_one_node
, lbound
);
6767 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6768 gfc_array_index_type
,
6770 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6771 gfc_array_index_type
,
6772 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6773 gfc_add_modify (&init
, stride
, tmp
);
6778 gfc_trans_array_cobounds (type
, &init
, sym
);
6780 /* Set the offset. */
6781 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6782 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6784 gfc_trans_vla_type_sizes (sym
, &init
);
6786 stmtInit
= gfc_finish_block (&init
);
6788 /* Only do the entry/initialization code if the arg is present. */
6789 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6790 optional_arg
= (sym
->attr
.optional
6791 || (sym
->ns
->proc_name
->attr
.entry_master
6792 && sym
->attr
.dummy
));
6795 tree zero_init
= fold_convert (TREE_TYPE (tmpdesc
), null_pointer_node
);
6796 zero_init
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6797 tmpdesc
, zero_init
);
6798 tmp
= gfc_conv_expr_present (sym
, true);
6799 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
, zero_init
);
6804 stmtCleanup
= NULL_TREE
;
6807 stmtblock_t cleanup
;
6808 gfc_start_block (&cleanup
);
6810 if (sym
->attr
.intent
!= INTENT_IN
)
6812 /* Copy the data back. */
6813 tmp
= build_call_expr_loc (input_location
,
6814 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6815 gfc_add_expr_to_block (&cleanup
, tmp
);
6818 /* Free the temporary. */
6819 tmp
= gfc_call_free (tmpdesc
);
6820 gfc_add_expr_to_block (&cleanup
, tmp
);
6822 stmtCleanup
= gfc_finish_block (&cleanup
);
6824 /* Only do the cleanup if the array was repacked. */
6826 /* For a class array the dummy array descriptor is in the _class
6828 tmp
= gfc_class_data_get (dumdesc
);
6830 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6831 tmp
= gfc_conv_descriptor_data_get (tmp
);
6832 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6834 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6835 build_empty_stmt (input_location
));
6839 tmp
= gfc_conv_expr_present (sym
);
6840 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6841 build_empty_stmt (input_location
));
6845 /* We don't need to free any memory allocated by internal_pack as it will
6846 be freed at the end of the function by pop_context. */
6847 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6849 gfc_restore_backend_locus (&loc
);
6853 /* Calculate the overall offset, including subreferences. */
6855 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6856 bool subref
, gfc_expr
*expr
)
6866 /* If offset is NULL and this is not a subreferenced array, there is
6868 if (offset
== NULL_TREE
)
6871 offset
= gfc_index_zero_node
;
6876 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6878 /* Offset the data pointer for pointer assignments from arrays with
6879 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6882 /* Go past the array reference. */
6883 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6884 if (ref
->type
== REF_ARRAY
&&
6885 ref
->u
.ar
.type
!= AR_ELEMENT
)
6891 /* Calculate the offset for each subsequent subreference. */
6892 for (; ref
; ref
= ref
->next
)
6897 field
= ref
->u
.c
.component
->backend_decl
;
6898 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6899 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6901 tmp
, field
, NULL_TREE
);
6905 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6906 gfc_init_se (&start
, NULL
);
6907 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6908 gfc_add_block_to_block (block
, &start
.pre
);
6909 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6913 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6914 && ref
->u
.ar
.type
== AR_ELEMENT
);
6916 /* TODO - Add bounds checking. */
6917 stride
= gfc_index_one_node
;
6918 index
= gfc_index_zero_node
;
6919 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6924 /* Update the index. */
6925 gfc_init_se (&start
, NULL
);
6926 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6927 itmp
= gfc_evaluate_now (start
.expr
, block
);
6928 gfc_init_se (&start
, NULL
);
6929 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6930 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6931 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6932 gfc_array_index_type
, itmp
, jtmp
);
6933 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6934 gfc_array_index_type
, itmp
, stride
);
6935 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6936 gfc_array_index_type
, itmp
, index
);
6937 index
= gfc_evaluate_now (index
, block
);
6939 /* Update the stride. */
6940 gfc_init_se (&start
, NULL
);
6941 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6942 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6943 gfc_array_index_type
, start
.expr
,
6945 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6946 gfc_array_index_type
,
6947 gfc_index_one_node
, itmp
);
6948 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6949 gfc_array_index_type
, stride
, itmp
);
6950 stride
= gfc_evaluate_now (stride
, block
);
6953 /* Apply the index to obtain the array element. */
6954 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6961 tmp
= fold_build1_loc (input_location
, REALPART_EXPR
,
6962 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
6966 tmp
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
6967 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
6982 /* Set the target data pointer. */
6983 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6984 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6988 /* gfc_conv_expr_descriptor needs the string length an expression
6989 so that the size of the temporary can be obtained. This is done
6990 by adding up the string lengths of all the elements in the
6991 expression. Function with non-constant expressions have their
6992 string lengths mapped onto the actual arguments using the
6993 interface mapping machinery in trans-expr.c. */
6995 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6997 gfc_interface_mapping mapping
;
6998 gfc_formal_arglist
*formal
;
6999 gfc_actual_arglist
*arg
;
7003 if (expr
->ts
.u
.cl
->length
7004 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
7006 if (!expr
->ts
.u
.cl
->backend_decl
)
7007 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7011 switch (expr
->expr_type
)
7015 /* This is somewhat brutal. The expression for the first
7016 element of the array is evaluated and assigned to a
7017 new string length for the original expression. */
7018 e
= gfc_constructor_first (expr
->value
.constructor
)->expr
;
7020 gfc_init_se (&tse
, NULL
);
7022 gfc_conv_expr_descriptor (&tse
, e
);
7024 gfc_conv_expr (&tse
, e
);
7026 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7027 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7029 if (!expr
->ts
.u
.cl
->backend_decl
|| !VAR_P (expr
->ts
.u
.cl
->backend_decl
))
7031 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
7032 expr
->ts
.u
.cl
->backend_decl
=
7033 gfc_create_var (gfc_charlen_type_node
, "sln");
7036 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7042 get_array_charlen (expr
->value
.op
.op1
, se
);
7044 /* For parentheses the expression ts.u.cl is identical. */
7045 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
7048 expr
->ts
.u
.cl
->backend_decl
=
7049 gfc_create_var (gfc_charlen_type_node
, "sln");
7051 if (expr
->value
.op
.op2
)
7053 get_array_charlen (expr
->value
.op
.op2
, se
);
7055 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
7057 /* Add the string lengths and assign them to the expression
7058 string length backend declaration. */
7059 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7060 fold_build2_loc (input_location
, PLUS_EXPR
,
7061 gfc_charlen_type_node
,
7062 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
7063 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
7066 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7067 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
7071 if (expr
->value
.function
.esym
== NULL
7072 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7074 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7078 /* Map expressions involving the dummy arguments onto the actual
7079 argument expressions. */
7080 gfc_init_interface_mapping (&mapping
);
7081 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
7082 arg
= expr
->value
.function
.actual
;
7084 /* Set se = NULL in the calls to the interface mapping, to suppress any
7086 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
7091 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
7094 gfc_init_se (&tse
, NULL
);
7096 /* Build the expression for the character length and convert it. */
7097 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
7099 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7100 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7101 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
7102 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7103 TREE_TYPE (tse
.expr
), tse
.expr
,
7104 build_zero_cst (TREE_TYPE (tse
.expr
)));
7105 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
7106 gfc_free_interface_mapping (&mapping
);
7110 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7116 /* Helper function to check dimensions. */
7118 transposed_dims (gfc_ss
*ss
)
7122 for (n
= 0; n
< ss
->dimen
; n
++)
7123 if (ss
->dim
[n
] != n
)
7129 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7130 AR_FULL, suitable for the scalarizer. */
7133 walk_coarray (gfc_expr
*e
)
7137 gcc_assert (gfc_get_corank (e
) > 0);
7139 ss
= gfc_walk_expr (e
);
7141 /* Fix scalar coarray. */
7142 if (ss
== gfc_ss_terminator
)
7149 if (ref
->type
== REF_ARRAY
7150 && ref
->u
.ar
.codimen
> 0)
7156 gcc_assert (ref
!= NULL
);
7157 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7158 ref
->u
.ar
.type
= AR_SECTION
;
7159 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7166 /* Convert an array for passing as an actual argument. Expressions and
7167 vector subscripts are evaluated and stored in a temporary, which is then
7168 passed. For whole arrays the descriptor is passed. For array sections
7169 a modified copy of the descriptor is passed, but using the original data.
7171 This function is also used for array pointer assignments, and there
7174 - se->want_pointer && !se->direct_byref
7175 EXPR is an actual argument. On exit, se->expr contains a
7176 pointer to the array descriptor.
7178 - !se->want_pointer && !se->direct_byref
7179 EXPR is an actual argument to an intrinsic function or the
7180 left-hand side of a pointer assignment. On exit, se->expr
7181 contains the descriptor for EXPR.
7183 - !se->want_pointer && se->direct_byref
7184 EXPR is the right-hand side of a pointer assignment and
7185 se->expr is the descriptor for the previously-evaluated
7186 left-hand side. The function creates an assignment from
7190 The se->force_tmp flag disables the non-copying descriptor optimization
7191 that is used for transpose. It may be used in cases where there is an
7192 alias between the transpose argument and another argument in the same
7196 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7199 gfc_ss_type ss_type
;
7200 gfc_ss_info
*ss_info
;
7202 gfc_array_info
*info
;
7210 bool subref_array_target
= false;
7211 bool deferred_array_component
= false;
7212 gfc_expr
*arg
, *ss_expr
;
7214 if (se
->want_coarray
)
7215 ss
= walk_coarray (expr
);
7217 ss
= gfc_walk_expr (expr
);
7219 gcc_assert (ss
!= NULL
);
7220 gcc_assert (ss
!= gfc_ss_terminator
);
7223 ss_type
= ss_info
->type
;
7224 ss_expr
= ss_info
->expr
;
7226 /* Special case: TRANSPOSE which needs no temporary. */
7227 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7228 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7230 /* This is a call to transpose which has already been handled by the
7231 scalarizer, so that we just need to get its argument's descriptor. */
7232 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7233 expr
= expr
->value
.function
.actual
->expr
;
7236 /* Special case things we know we can pass easily. */
7237 switch (expr
->expr_type
)
7240 /* If we have a linear array section, we can pass it directly.
7241 Otherwise we need to copy it into a temporary. */
7243 gcc_assert (ss_type
== GFC_SS_SECTION
);
7244 gcc_assert (ss_expr
== expr
);
7245 info
= &ss_info
->data
.array
;
7247 /* Get the descriptor for the array. */
7248 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7249 desc
= info
->descriptor
;
7251 /* The charlen backend decl for deferred character components cannot
7252 be used because it is fixed at zero. Instead, the hidden string
7253 length component is used. */
7254 if (expr
->ts
.type
== BT_CHARACTER
7255 && expr
->ts
.deferred
7256 && TREE_CODE (desc
) == COMPONENT_REF
)
7257 deferred_array_component
= true;
7259 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7260 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7261 && !subref_array_target
;
7265 else if (se
->force_no_tmp
)
7270 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7272 /* Create a new descriptor if the array doesn't have one. */
7275 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7277 else if (se
->direct_byref
)
7279 else if (info
->ref
->u
.ar
.dimen
== 0 && !info
->ref
->next
)
7281 else if (info
->ref
->u
.ar
.type
== AR_SECTION
&& se
->want_pointer
)
7284 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7286 if (full
&& !transposed_dims (ss
))
7288 if (se
->direct_byref
&& !se
->byref_noassign
)
7290 /* Copy the descriptor for pointer assignments. */
7291 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7293 /* Add any offsets from subreferences. */
7294 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7295 subref_array_target
, expr
);
7297 /* ....and set the span field. */
7298 tmp
= gfc_get_array_span (desc
, expr
);
7299 if (tmp
!= NULL_TREE
&& !integer_zerop (tmp
))
7300 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7302 else if (se
->want_pointer
)
7304 /* We pass full arrays directly. This means that pointers and
7305 allocatable arrays should also work. */
7306 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7313 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7314 se
->string_length
= gfc_get_expr_charlen (expr
);
7315 /* The ss_info string length is returned set to the value of the
7316 hidden string length component. */
7317 else if (deferred_array_component
)
7318 se
->string_length
= ss_info
->string_length
;
7320 gfc_free_ss_chain (ss
);
7326 /* A transformational function return value will be a temporary
7327 array descriptor. We still need to go through the scalarizer
7328 to create the descriptor. Elemental functions are handled as
7329 arbitrary expressions, i.e. copy to a temporary. */
7331 if (se
->direct_byref
)
7333 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7335 /* For pointer assignments pass the descriptor directly. */
7339 gcc_assert (se
->ss
== ss
);
7341 if (!is_pointer_array (se
->expr
))
7343 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7344 tmp
= fold_convert (gfc_array_index_type
,
7345 size_in_bytes (tmp
));
7346 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7349 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7350 gfc_conv_expr (se
, expr
);
7352 gfc_free_ss_chain (ss
);
7356 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7358 if (ss_expr
!= expr
)
7359 /* Elemental function. */
7360 gcc_assert ((expr
->value
.function
.esym
!= NULL
7361 && expr
->value
.function
.esym
->attr
.elemental
)
7362 || (expr
->value
.function
.isym
!= NULL
7363 && expr
->value
.function
.isym
->elemental
)
7364 || gfc_inline_intrinsic_function_p (expr
));
7366 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7369 if (expr
->ts
.type
== BT_CHARACTER
7370 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7371 get_array_charlen (expr
, se
);
7377 /* Transformational function. */
7378 info
= &ss_info
->data
.array
;
7384 /* Constant array constructors don't need a temporary. */
7385 if (ss_type
== GFC_SS_CONSTRUCTOR
7386 && expr
->ts
.type
!= BT_CHARACTER
7387 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7390 info
= &ss_info
->data
.array
;
7400 /* Something complicated. Copy it into a temporary. */
7406 /* If we are creating a temporary, we don't need to bother about aliases
7411 gfc_init_loopinfo (&loop
);
7413 /* Associate the SS with the loop. */
7414 gfc_add_ss_to_loop (&loop
, ss
);
7416 /* Tell the scalarizer not to bother creating loop variables, etc. */
7418 loop
.array_parameter
= 1;
7420 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7421 gcc_assert (!se
->direct_byref
);
7423 /* Do we need bounds checking or not? */
7424 ss
->no_bounds_check
= expr
->no_bounds_check
;
7426 /* Setup the scalarizing loops and bounds. */
7427 gfc_conv_ss_startstride (&loop
);
7431 if (expr
->ts
.type
== BT_CHARACTER
7432 && (!expr
->ts
.u
.cl
->backend_decl
|| expr
->expr_type
== EXPR_ARRAY
))
7433 get_array_charlen (expr
, se
);
7435 /* Tell the scalarizer to make a temporary. */
7436 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7437 ((expr
->ts
.type
== BT_CHARACTER
)
7438 ? expr
->ts
.u
.cl
->backend_decl
7442 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7443 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7444 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7447 gfc_conv_loop_setup (&loop
, & expr
->where
);
7451 /* Copy into a temporary and pass that. We don't need to copy the data
7452 back because expressions and vector subscripts must be INTENT_IN. */
7453 /* TODO: Optimize passing function return values. */
7458 /* Start the copying loops. */
7459 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7460 gfc_mark_ss_chain_used (ss
, 1);
7461 gfc_start_scalarized_body (&loop
, &block
);
7463 /* Copy each data element. */
7464 gfc_init_se (&lse
, NULL
);
7465 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7466 gfc_init_se (&rse
, NULL
);
7467 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7469 lse
.ss
= loop
.temp_ss
;
7472 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7473 if (expr
->ts
.type
== BT_CHARACTER
)
7475 gfc_conv_expr (&rse
, expr
);
7476 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7477 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7481 gfc_conv_expr_val (&rse
, expr
);
7483 gfc_add_block_to_block (&block
, &rse
.pre
);
7484 gfc_add_block_to_block (&block
, &lse
.pre
);
7486 lse
.string_length
= rse
.string_length
;
7488 deep_copy
= !se
->data_not_needed
7489 && (expr
->expr_type
== EXPR_VARIABLE
7490 || expr
->expr_type
== EXPR_ARRAY
);
7491 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7493 gfc_add_expr_to_block (&block
, tmp
);
7495 /* Finish the copying loops. */
7496 gfc_trans_scalarizing_loops (&loop
, &block
);
7498 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7500 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7502 desc
= info
->descriptor
;
7503 se
->string_length
= ss_info
->string_length
;
7507 /* We pass sections without copying to a temporary. Make a new
7508 descriptor and point it at the section we want. The loop variable
7509 limits will be the limits of the section.
7510 A function may decide to repack the array to speed up access, but
7511 we're not bothered about that here. */
7512 int dim
, ndim
, codim
;
7521 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7523 if (se
->want_coarray
)
7525 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7527 codim
= gfc_get_corank (expr
);
7528 for (n
= 0; n
< codim
- 1; n
++)
7530 /* Make sure we are not lost somehow. */
7531 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7533 /* Make sure the call to gfc_conv_section_startstride won't
7534 generate unnecessary code to calculate stride. */
7535 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7537 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7538 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7539 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7542 gcc_assert (n
== codim
- 1);
7543 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7544 info
->descriptor
, n
+ ndim
, true,
7545 ar
->as
->type
== AS_DEFERRED
);
7546 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7551 /* Set the string_length for a character array. */
7552 if (expr
->ts
.type
== BT_CHARACTER
)
7554 se
->string_length
= gfc_get_expr_charlen (expr
);
7555 if (VAR_P (se
->string_length
)
7556 && expr
->ts
.u
.cl
->backend_decl
== se
->string_length
)
7557 tmp
= ss_info
->string_length
;
7559 tmp
= se
->string_length
;
7561 if (expr
->ts
.deferred
)
7562 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
, tmp
);
7565 /* If we have an array section, are assigning or passing an array
7566 section argument make sure that the lower bound is 1. References
7567 to the full array should otherwise keep the original bounds. */
7568 if (!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
)
7569 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7570 if (!integer_onep (loop
.from
[dim
]))
7572 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7573 gfc_array_index_type
, gfc_index_one_node
,
7575 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7576 gfc_array_index_type
,
7578 loop
.from
[dim
] = gfc_index_one_node
;
7581 desc
= info
->descriptor
;
7582 if (se
->direct_byref
&& !se
->byref_noassign
)
7584 /* For pointer assignments we fill in the destination. */
7586 parmtype
= TREE_TYPE (parm
);
7590 /* Otherwise make a new one. */
7591 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7592 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7594 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7596 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7597 loop
.from
, loop
.to
, 0,
7598 GFC_ARRAY_UNKNOWN
, false);
7599 parm
= gfc_create_var (parmtype
, "parm");
7601 /* When expression is a class object, then add the class' handle to
7603 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7605 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7608 /* class_expr can be NULL, when no _class ref is in expr.
7609 We must not fix this here with a gfc_fix_class_ref (). */
7612 gfc_init_se (&classse
, NULL
);
7613 gfc_conv_expr (&classse
, class_expr
);
7614 gfc_free_expr (class_expr
);
7616 gcc_assert (classse
.pre
.head
== NULL_TREE
7617 && classse
.post
.head
== NULL_TREE
);
7618 gfc_allocate_lang_decl (parm
);
7619 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7624 /* Set the span field. */
7625 if (expr
->ts
.type
== BT_CHARACTER
&& ss_info
->string_length
)
7626 tmp
= ss_info
->string_length
;
7628 tmp
= gfc_get_array_span (desc
, expr
);
7629 if (tmp
!= NULL_TREE
)
7630 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7632 /* The following can be somewhat confusing. We have two
7633 descriptors, a new one and the original array.
7634 {parm, parmtype, dim} refer to the new one.
7635 {desc, type, n, loop} refer to the original, which maybe
7636 a descriptorless array.
7637 The bounds of the scalarization are the bounds of the section.
7638 We don't have to worry about numeric overflows when calculating
7639 the offsets because all elements are within the array data. */
7641 /* Set the dtype. */
7642 tmp
= gfc_conv_descriptor_dtype (parm
);
7643 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7645 /* The 1st element in the section. */
7646 base
= gfc_index_zero_node
;
7648 /* The offset from the 1st element in the section. */
7649 offset
= gfc_index_zero_node
;
7651 for (n
= 0; n
< ndim
; n
++)
7653 stride
= gfc_conv_array_stride (desc
, n
);
7655 /* Work out the 1st element in the section. */
7657 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7659 gcc_assert (info
->subscript
[n
]
7660 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7661 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7665 /* Evaluate and remember the start of the section. */
7666 start
= info
->start
[n
];
7667 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7670 tmp
= gfc_conv_array_lbound (desc
, n
);
7671 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7673 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7675 base
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7679 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7681 /* For elemental dimensions, we only need the 1st
7682 element in the section. */
7686 /* Vector subscripts need copying and are handled elsewhere. */
7688 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7690 /* look for the corresponding scalarizer dimension: dim. */
7691 for (dim
= 0; dim
< ndim
; dim
++)
7692 if (ss
->dim
[dim
] == n
)
7695 /* loop exited early: the DIM being looked for has been found. */
7696 gcc_assert (dim
< ndim
);
7698 /* Set the new lower bound. */
7699 from
= loop
.from
[dim
];
7702 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7703 gfc_rank_cst
[dim
], from
);
7705 /* Set the new upper bound. */
7706 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7707 gfc_rank_cst
[dim
], to
);
7709 /* Multiply the stride by the section stride to get the
7711 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7712 gfc_array_index_type
,
7713 stride
, info
->stride
[n
]);
7715 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7716 TREE_TYPE (offset
), stride
, from
);
7717 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7718 TREE_TYPE (offset
), offset
, tmp
);
7720 /* Store the new stride. */
7721 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7722 gfc_rank_cst
[dim
], stride
);
7725 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7727 from
= loop
.from
[n
];
7729 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7730 gfc_rank_cst
[n
], from
);
7731 if (n
< loop
.dimen
+ codim
- 1)
7732 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7733 gfc_rank_cst
[n
], to
);
7736 if (se
->data_not_needed
)
7737 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7738 gfc_index_zero_node
);
7740 /* Point the data pointer at the 1st element in the section. */
7741 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, base
,
7742 subref_array_target
, expr
);
7744 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, offset
);
7749 /* For class arrays add the class tree into the saved descriptor to
7750 enable getting of _vptr and the like. */
7751 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7752 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7754 gfc_allocate_lang_decl (desc
);
7755 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7756 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7757 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7758 : expr
->symtree
->n
.sym
->backend_decl
;
7760 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7761 && IS_CLASS_ARRAY (expr
))
7764 gfc_allocate_lang_decl (desc
);
7765 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7766 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7767 vtype
= gfc_class_vptr_get (tmp
);
7768 gfc_add_modify (&se
->pre
, vtype
,
7769 gfc_build_addr_expr (TREE_TYPE (vtype
),
7770 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7772 if (!se
->direct_byref
|| se
->byref_noassign
)
7774 /* Get a pointer to the new descriptor. */
7775 if (se
->want_pointer
)
7776 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7781 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7782 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7784 /* Cleanup the scalarizer. */
7785 gfc_cleanup_loop (&loop
);
7788 /* Helper function for gfc_conv_array_parameter if array size needs to be
7792 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7795 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7796 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7797 else if (expr
->rank
> 1)
7798 *size
= build_call_expr_loc (input_location
,
7799 gfor_fndecl_size0
, 1,
7800 gfc_build_addr_expr (NULL
, desc
));
7803 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7804 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7806 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7807 gfc_array_index_type
, ubound
, lbound
);
7808 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7809 *size
, gfc_index_one_node
);
7810 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7811 *size
, gfc_index_zero_node
);
7813 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7814 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7815 *size
, fold_convert (gfc_array_index_type
, elem
));
7818 /* Helper function - return true if the argument is a pointer. */
7821 is_pointer (gfc_expr
*e
)
7825 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->symtree
== NULL
)
7828 sym
= e
->symtree
->n
.sym
;
7832 return sym
->attr
.pointer
|| sym
->attr
.proc_pointer
;
7835 /* Convert an array for passing as an actual parameter. */
7838 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7839 const gfc_symbol
*fsym
, const char *proc_name
,
7844 tree tmp
= NULL_TREE
;
7846 tree parent
= DECL_CONTEXT (current_function_decl
);
7847 bool full_array_var
;
7848 bool this_array_result
;
7851 bool array_constructor
;
7852 bool good_allocatable
;
7853 bool ultimate_ptr_comp
;
7854 bool ultimate_alloc_comp
;
7859 ultimate_ptr_comp
= false;
7860 ultimate_alloc_comp
= false;
7862 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7864 if (ref
->next
== NULL
)
7867 if (ref
->type
== REF_COMPONENT
)
7869 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7870 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7874 full_array_var
= false;
7877 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7878 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7880 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7882 /* The symbol should have an array specification. */
7883 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7885 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7887 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7888 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7889 se
->string_length
= tmp
;
7892 /* Is this the result of the enclosing procedure? */
7893 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7894 if (this_array_result
7895 && (sym
->backend_decl
!= current_function_decl
)
7896 && (sym
->backend_decl
!= parent
))
7897 this_array_result
= false;
7899 /* Passing address of the array if it is not pointer or assumed-shape. */
7900 if (full_array_var
&& g77
&& !this_array_result
7901 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7903 tmp
= gfc_get_symbol_decl (sym
);
7905 if (sym
->ts
.type
== BT_CHARACTER
)
7906 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7908 if (!sym
->attr
.pointer
7910 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7911 && sym
->as
->type
!= AS_DEFERRED
7912 && sym
->as
->type
!= AS_ASSUMED_RANK
7913 && !sym
->attr
.allocatable
)
7915 /* Some variables are declared directly, others are declared as
7916 pointers and allocated on the heap. */
7917 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7920 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7922 array_parameter_size (tmp
, expr
, size
);
7926 if (sym
->attr
.allocatable
)
7928 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7930 gfc_conv_expr_descriptor (se
, expr
);
7934 array_parameter_size (tmp
, expr
, size
);
7935 se
->expr
= gfc_conv_array_data (tmp
);
7940 /* A convenient reduction in scope. */
7941 contiguous
= g77
&& !this_array_result
&& contiguous
;
7943 /* There is no need to pack and unpack the array, if it is contiguous
7944 and not a deferred- or assumed-shape array, or if it is simply
7946 no_pack
= ((sym
&& sym
->as
7947 && !sym
->attr
.pointer
7948 && sym
->as
->type
!= AS_DEFERRED
7949 && sym
->as
->type
!= AS_ASSUMED_RANK
7950 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7952 (ref
&& ref
->u
.ar
.as
7953 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7954 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7955 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7957 gfc_is_simply_contiguous (expr
, false, true));
7959 no_pack
= contiguous
&& no_pack
;
7961 /* If we have an EXPR_OP or a function returning an explicit-shaped
7962 or allocatable array, an array temporary will be generated which
7963 does not need to be packed / unpacked if passed to an
7964 explicit-shape dummy array. */
7968 if (expr
->expr_type
== EXPR_OP
)
7970 else if (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.esym
)
7972 gfc_symbol
*result
= expr
->value
.function
.esym
->result
;
7973 if (result
->attr
.dimension
7974 && (result
->as
->type
== AS_EXPLICIT
7975 || result
->attr
.allocatable
7976 || result
->attr
.contiguous
))
7981 /* Array constructors are always contiguous and do not need packing. */
7982 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7984 /* Same is true of contiguous sections from allocatable variables. */
7985 good_allocatable
= contiguous
7987 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7989 /* Or ultimate allocatable components. */
7990 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7992 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7994 gfc_conv_expr_descriptor (se
, expr
);
7995 /* Deallocate the allocatable components of structures that are
7997 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7998 && expr
->ts
.u
.derived
->attr
.alloc_comp
7999 && expr
->expr_type
!= EXPR_VARIABLE
)
8001 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
8003 /* The components shall be deallocated before their containing entity. */
8004 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8006 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->expr_type
!= EXPR_FUNCTION
)
8007 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
8009 array_parameter_size (se
->expr
, expr
, size
);
8010 se
->expr
= gfc_conv_array_data (se
->expr
);
8014 if (this_array_result
)
8016 /* Result of the enclosing function. */
8017 gfc_conv_expr_descriptor (se
, expr
);
8019 array_parameter_size (se
->expr
, expr
, size
);
8020 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8022 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
8023 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
8024 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
8031 /* Every other type of array. */
8032 se
->want_pointer
= 1;
8033 gfc_conv_expr_descriptor (se
, expr
);
8036 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
8041 /* Deallocate the allocatable components of structures that are
8042 not variable, for descriptorless arguments.
8043 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8044 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8045 && expr
->ts
.u
.derived
->attr
.alloc_comp
8046 && expr
->expr_type
!= EXPR_VARIABLE
)
8048 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8049 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
8051 /* The components shall be deallocated before their containing entity. */
8052 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8055 if (g77
|| (fsym
&& fsym
->attr
.contiguous
8056 && !gfc_is_simply_contiguous (expr
, false, true)))
8058 tree origptr
= NULL_TREE
;
8062 /* For contiguous arrays, save the original value of the descriptor. */
8065 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
8066 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8067 tmp
= gfc_conv_array_data (tmp
);
8068 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8069 TREE_TYPE (origptr
), origptr
,
8070 fold_convert (TREE_TYPE (origptr
), tmp
));
8071 gfc_add_expr_to_block (&se
->pre
, tmp
);
8074 /* Repack the array. */
8075 if (warn_array_temporaries
)
8078 gfc_warning (OPT_Warray_temporaries
,
8079 "Creating array temporary at %L for argument %qs",
8080 &expr
->where
, fsym
->name
);
8082 gfc_warning (OPT_Warray_temporaries
,
8083 "Creating array temporary at %L", &expr
->where
);
8086 /* When optmizing, we can use gfc_conv_subref_array_arg for
8087 making the packing and unpacking operation visible to the
8090 if (g77
&& flag_inline_arg_packing
&& expr
->expr_type
== EXPR_VARIABLE
8091 && !is_pointer (expr
) && ! gfc_has_dimen_vector_ref (expr
)
8092 && !(expr
->symtree
->n
.sym
->as
8093 && expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_RANK
)
8094 && (fsym
== NULL
|| fsym
->ts
.type
!= BT_ASSUMED
))
8096 gfc_conv_subref_array_arg (se
, expr
, g77
,
8097 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
8098 false, fsym
, proc_name
, sym
, true);
8102 ptr
= build_call_expr_loc (input_location
,
8103 gfor_fndecl_in_pack
, 1, desc
);
8105 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8107 tmp
= gfc_conv_expr_present (sym
);
8108 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
8109 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
8110 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
8113 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
8115 /* Use the packed data for the actual argument, except for contiguous arrays,
8116 where the descriptor's data component is set. */
8121 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8123 gfc_ss
* ss
= gfc_walk_expr (expr
);
8124 if (!transposed_dims (ss
))
8125 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
8128 tree old_field
, new_field
;
8130 /* The original descriptor has transposed dims so we can't reuse
8131 it directly; we have to create a new one. */
8132 tree old_desc
= tmp
;
8133 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8135 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8136 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8137 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8139 old_field
= gfc_conv_descriptor_offset (old_desc
);
8140 new_field
= gfc_conv_descriptor_offset (new_desc
);
8141 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8143 for (int i
= 0; i
< expr
->rank
; i
++)
8145 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8146 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8147 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8149 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8152 if (flag_coarray
== GFC_FCOARRAY_LIB
8153 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8154 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8155 == GFC_ARRAY_ALLOCATABLE
)
8157 old_field
= gfc_conv_descriptor_token (old_desc
);
8158 new_field
= gfc_conv_descriptor_token (new_desc
);
8159 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8162 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8163 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8168 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8172 if (fsym
&& proc_name
)
8173 msg
= xasprintf ("An array temporary was created for argument "
8174 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8176 msg
= xasprintf ("An array temporary was created");
8178 tmp
= build_fold_indirect_ref_loc (input_location
,
8180 tmp
= gfc_conv_array_data (tmp
);
8181 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8182 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8184 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8185 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8187 gfc_conv_expr_present (sym
), tmp
);
8189 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8194 gfc_start_block (&block
);
8196 /* Copy the data back. */
8197 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8199 tmp
= build_call_expr_loc (input_location
,
8200 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8201 gfc_add_expr_to_block (&block
, tmp
);
8204 /* Free the temporary. */
8205 tmp
= gfc_call_free (ptr
);
8206 gfc_add_expr_to_block (&block
, tmp
);
8208 stmt
= gfc_finish_block (&block
);
8210 gfc_init_block (&block
);
8211 /* Only if it was repacked. This code needs to be executed before the
8212 loop cleanup code. */
8213 tmp
= build_fold_indirect_ref_loc (input_location
,
8215 tmp
= gfc_conv_array_data (tmp
);
8216 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8217 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8219 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8220 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8222 gfc_conv_expr_present (sym
), tmp
);
8224 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8226 gfc_add_expr_to_block (&block
, tmp
);
8227 gfc_add_block_to_block (&block
, &se
->post
);
8229 gfc_init_block (&se
->post
);
8231 /* Reset the descriptor pointer. */
8234 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8235 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8238 gfc_add_block_to_block (&se
->post
, &block
);
8243 /* This helper function calculates the size in words of a full array. */
8246 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8251 idx
= gfc_rank_cst
[rank
- 1];
8252 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8253 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8254 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8256 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8257 tmp
, gfc_index_one_node
);
8258 tmp
= gfc_evaluate_now (tmp
, block
);
8260 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8261 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8263 return gfc_evaluate_now (tmp
, block
);
8267 /* Allocate dest to the same size as src, and copy src -> dest.
8268 If no_malloc is set, only the copy is done. */
8271 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8272 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8273 tree add_when_allocated
)
8282 /* If the source is null, set the destination to null. Then,
8283 allocate memory to the destination. */
8284 gfc_init_block (&block
);
8286 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8288 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8289 null_data
= gfc_finish_block (&block
);
8291 gfc_init_block (&block
);
8292 if (str_sz
!= NULL_TREE
)
8295 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8299 tmp
= gfc_call_malloc (&block
, type
, size
);
8300 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8305 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8306 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8307 fold_convert (size_type_node
, size
));
8308 gfc_add_expr_to_block (&block
, tmp
);
8313 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8314 null_data
= gfc_finish_block (&block
);
8316 gfc_init_block (&block
);
8318 nelems
= gfc_full_array_size (&block
, src
, rank
);
8320 nelems
= gfc_index_one_node
;
8322 if (str_sz
!= NULL_TREE
)
8323 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8325 tmp
= fold_convert (gfc_array_index_type
,
8326 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8327 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8331 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8332 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8333 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8336 /* We know the temporary and the value will be the same length,
8337 so can use memcpy. */
8340 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8341 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8342 gfc_conv_descriptor_data_get (dest
),
8343 gfc_conv_descriptor_data_get (src
),
8344 fold_convert (size_type_node
, size
));
8345 gfc_add_expr_to_block (&block
, tmp
);
8349 gfc_add_expr_to_block (&block
, add_when_allocated
);
8350 tmp
= gfc_finish_block (&block
);
8352 /* Null the destination if the source is null; otherwise do
8353 the allocate and copy. */
8354 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8357 null_cond
= gfc_conv_descriptor_data_get (src
);
8359 null_cond
= convert (pvoid_type_node
, null_cond
);
8360 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8361 null_cond
, null_pointer_node
);
8362 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8366 /* Allocate dest to the same size as src, and copy data src -> dest. */
8369 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8370 tree add_when_allocated
)
8372 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8373 NULL_TREE
, add_when_allocated
);
8377 /* Copy data src -> dest. */
8380 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8382 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8383 NULL_TREE
, NULL_TREE
);
8386 /* Allocate dest to the same size as src, but don't copy anything. */
8389 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8391 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8392 NULL_TREE
, NULL_TREE
);
8397 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8398 tree type
, int rank
)
8405 stmtblock_t block
, globalblock
;
8407 /* If the source is null, set the destination to null. Then,
8408 allocate memory to the destination. */
8409 gfc_init_block (&block
);
8410 gfc_init_block (&globalblock
);
8412 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8415 symbol_attribute attr
;
8418 gfc_init_se (&se
, NULL
);
8419 gfc_clear_attr (&attr
);
8420 attr
.allocatable
= 1;
8421 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8422 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8423 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8425 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8426 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8427 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8428 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8429 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8430 null_data
= gfc_finish_block (&block
);
8432 gfc_init_block (&block
);
8434 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8435 fold_convert (size_type_node
, size
),
8436 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8437 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8438 GFC_CAF_COARRAY_ALLOC
);
8440 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8441 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8442 fold_convert (size_type_node
, size
));
8443 gfc_add_expr_to_block (&block
, tmp
);
8447 /* Set the rank or unitialized memory access may be reported. */
8448 tmp
= gfc_conv_descriptor_rank (dest
);
8449 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8452 nelems
= gfc_full_array_size (&block
, src
, rank
);
8454 nelems
= integer_one_node
;
8456 tmp
= fold_convert (size_type_node
,
8457 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8458 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8459 fold_convert (size_type_node
, nelems
), tmp
);
8461 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8462 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8464 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8465 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8466 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8467 null_data
= gfc_finish_block (&block
);
8469 gfc_init_block (&block
);
8470 gfc_allocate_using_caf_lib (&block
, dest
,
8471 fold_convert (size_type_node
, size
),
8472 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8473 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8474 GFC_CAF_COARRAY_ALLOC
);
8476 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8477 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8478 gfc_conv_descriptor_data_get (dest
),
8479 gfc_conv_descriptor_data_get (src
),
8480 fold_convert (size_type_node
, size
));
8481 gfc_add_expr_to_block (&block
, tmp
);
8484 tmp
= gfc_finish_block (&block
);
8486 /* Null the destination if the source is null; otherwise do
8487 the register and copy. */
8488 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8491 null_cond
= gfc_conv_descriptor_data_get (src
);
8493 null_cond
= convert (pvoid_type_node
, null_cond
);
8494 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8495 null_cond
, null_pointer_node
);
8496 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8498 return gfc_finish_block (&globalblock
);
8502 /* Helper function to abstract whether coarray processing is enabled. */
8505 caf_enabled (int caf_mode
)
8507 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8508 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8512 /* Helper function to abstract whether coarray processing is enabled
8513 and we are in a derived type coarray. */
8516 caf_in_coarray (int caf_mode
)
8518 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8519 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8520 return (caf_mode
& pat
) == pat
;
8524 /* Helper function to abstract whether coarray is to deallocate only. */
8527 gfc_caf_is_dealloc_only (int caf_mode
)
8529 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8530 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8534 /* Recursively traverse an object of derived type, generating code to
8535 deallocate, nullify or copy allocatable components. This is the work horse
8536 function for the functions named in this enum. */
8538 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8539 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8540 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
,
8543 static gfc_actual_arglist
*pdt_param_list
;
8546 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8547 tree dest
, int rank
, int purpose
, int caf_mode
,
8548 gfc_co_subroutines_args
*args
)
8552 stmtblock_t fnblock
;
8553 stmtblock_t loopbody
;
8554 stmtblock_t tmpblock
;
8565 tree null_cond
= NULL_TREE
;
8566 tree add_when_allocated
;
8567 tree dealloc_fndecl
;
8571 symbol_attribute
*attr
;
8572 bool deallocate_called
;
8574 gfc_init_block (&fnblock
);
8576 decl_type
= TREE_TYPE (decl
);
8578 if ((POINTER_TYPE_P (decl_type
))
8579 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8581 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8582 /* Deref dest in sync with decl, but only when it is not NULL. */
8584 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8586 /* Update the decl_type because it got dereferenced. */
8587 decl_type
= TREE_TYPE (decl
);
8590 /* If this is an array of derived types with allocatable components
8591 build a loop and recursively call this function. */
8592 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8593 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8595 tmp
= gfc_conv_array_data (decl
);
8596 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8598 /* Get the number of elements - 1 and set the counter. */
8599 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8601 /* Use the descriptor for an allocatable array. Since this
8602 is a full array reference, we only need the descriptor
8603 information from dimension = rank. */
8604 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8605 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8606 gfc_array_index_type
, tmp
,
8607 gfc_index_one_node
);
8609 null_cond
= gfc_conv_descriptor_data_get (decl
);
8610 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8611 logical_type_node
, null_cond
,
8612 build_int_cst (TREE_TYPE (null_cond
), 0));
8616 /* Otherwise use the TYPE_DOMAIN information. */
8617 tmp
= array_type_nelts (decl_type
);
8618 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8621 /* Remember that this is, in fact, the no. of elements - 1. */
8622 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8623 index
= gfc_create_var (gfc_array_index_type
, "S");
8625 /* Build the body of the loop. */
8626 gfc_init_block (&loopbody
);
8628 vref
= gfc_build_array_ref (var
, index
, NULL
);
8630 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8631 && !caf_enabled (caf_mode
))
8633 tmp
= build_fold_indirect_ref_loc (input_location
,
8634 gfc_conv_array_data (dest
));
8635 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8636 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8637 COPY_ALLOC_COMP
, 0, args
);
8640 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8643 gfc_add_expr_to_block (&loopbody
, tmp
);
8645 /* Build the loop and return. */
8646 gfc_init_loopinfo (&loop
);
8648 loop
.from
[0] = gfc_index_zero_node
;
8649 loop
.loopvar
[0] = index
;
8650 loop
.to
[0] = nelems
;
8651 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8652 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8654 tmp
= gfc_finish_block (&fnblock
);
8655 /* When copying allocateable components, the above implements the
8656 deep copy. Nevertheless is a deep copy only allowed, when the current
8657 component is allocated, for which code will be generated in
8658 gfc_duplicate_allocatable (), where the deep copy code is just added
8659 into the if's body, by adding tmp (the deep copy code) as last
8660 argument to gfc_duplicate_allocatable (). */
8661 if (purpose
== COPY_ALLOC_COMP
8662 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8663 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8665 else if (null_cond
!= NULL_TREE
)
8666 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8667 build_empty_stmt (input_location
));
8672 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8674 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8675 DEALLOCATE_PDT_COMP
, 0, args
);
8676 gfc_add_expr_to_block (&fnblock
, tmp
);
8678 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8680 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8681 NULLIFY_ALLOC_COMP
, 0, args
);
8682 gfc_add_expr_to_block (&fnblock
, tmp
);
8685 /* Otherwise, act on the components or recursively call self to
8686 act on a chain of components. */
8687 for (c
= der_type
->components
; c
; c
= c
->next
)
8689 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8690 || c
->ts
.type
== BT_CLASS
)
8691 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8692 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8693 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8695 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8696 && c
->ts
.u
.derived
->attr
.pdt_type
;
8698 cdecl = c
->backend_decl
;
8699 ctype
= TREE_TYPE (cdecl);
8704 case BCAST_ALLOC_COMP
:
8708 stmtblock_t derived_type_block
;
8710 gfc_init_block (&tmpblock
);
8712 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8713 decl
, cdecl, NULL_TREE
);
8715 /* Shortcut to get the attributes of the component. */
8716 if (c
->ts
.type
== BT_CLASS
)
8718 attr
= &CLASS_DATA (c
)->attr
;
8719 if (attr
->class_pointer
)
8729 add_when_allocated
= NULL_TREE
;
8730 if (cmp_has_alloc_comps
8731 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
8733 if (c
->ts
.type
== BT_CLASS
)
8735 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8737 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8738 comp
, NULL_TREE
, rank
, purpose
,
8743 rank
= c
->as
? c
->as
->rank
: 0;
8744 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8751 gfc_init_block (&derived_type_block
);
8752 if (add_when_allocated
)
8753 gfc_add_expr_to_block (&derived_type_block
, add_when_allocated
);
8754 tmp
= gfc_finish_block (&derived_type_block
);
8755 gfc_add_expr_to_block (&tmpblock
, tmp
);
8757 /* Convert the component into a rank 1 descriptor type. */
8758 if (attr
->dimension
)
8760 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8761 ubound
= gfc_full_array_size (&tmpblock
, comp
,
8762 c
->ts
.type
== BT_CLASS
8763 ? CLASS_DATA (c
)->as
->rank
8768 tmp
= TREE_TYPE (comp
);
8769 ubound
= build_int_cst (gfc_array_index_type
, 1);
8772 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8774 GFC_ARRAY_ALLOCATABLE
, false);
8776 cdesc
= gfc_create_var (cdesc
, "cdesc");
8777 DECL_ARTIFICIAL (cdesc
) = 1;
8779 gfc_add_modify (&tmpblock
, gfc_conv_descriptor_dtype (cdesc
),
8780 gfc_get_dtype_rank_type (1, tmp
));
8781 gfc_conv_descriptor_lbound_set (&tmpblock
, cdesc
,
8782 gfc_index_zero_node
,
8783 gfc_index_one_node
);
8784 gfc_conv_descriptor_stride_set (&tmpblock
, cdesc
,
8785 gfc_index_zero_node
,
8786 gfc_index_one_node
);
8787 gfc_conv_descriptor_ubound_set (&tmpblock
, cdesc
,
8788 gfc_index_zero_node
, ubound
);
8790 if (attr
->dimension
)
8791 comp
= gfc_conv_descriptor_data_get (comp
);
8796 gfc_init_se (&se
, NULL
);
8798 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8799 c
->ts
.type
== BT_CLASS
8800 ? CLASS_DATA (c
)->attr
8802 comp
= gfc_build_addr_expr (NULL_TREE
, comp
);
8803 gfc_add_block_to_block (&tmpblock
, &se
.pre
);
8806 gfc_conv_descriptor_data_set (&tmpblock
, cdesc
, comp
);
8810 fndecl
= build_call_expr_loc (input_location
,
8811 gfor_fndecl_co_broadcast
, 5,
8812 gfc_build_addr_expr (pvoid_type_node
,cdesc
),
8814 null_pointer_node
, null_pointer_node
,
8817 gfc_add_expr_to_block (&tmpblock
, fndecl
);
8818 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8822 case DEALLOCATE_ALLOC_COMP
:
8824 gfc_init_block (&tmpblock
);
8826 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8827 decl
, cdecl, NULL_TREE
);
8829 /* Shortcut to get the attributes of the component. */
8830 if (c
->ts
.type
== BT_CLASS
)
8832 attr
= &CLASS_DATA (c
)->attr
;
8833 if (attr
->class_pointer
)
8843 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8844 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8845 /* Call the finalizer, which will free the memory and nullify the
8846 pointer of an array. */
8847 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8848 caf_enabled (caf_mode
))
8851 deallocate_called
= false;
8853 /* Add the _class ref for classes. */
8854 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8855 comp
= gfc_class_data_get (comp
);
8857 add_when_allocated
= NULL_TREE
;
8858 if (cmp_has_alloc_comps
8859 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8861 && !deallocate_called
)
8863 /* Add checked deallocation of the components. This code is
8864 obviously added because the finalizer is not trusted to free
8866 if (c
->ts
.type
== BT_CLASS
)
8868 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8870 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8871 comp
, NULL_TREE
, rank
, purpose
,
8876 rank
= c
->as
? c
->as
->rank
: 0;
8877 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8884 if (attr
->allocatable
&& !same_type
8885 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8887 /* Handle all types of components besides components of the
8888 same_type as the current one, because those would create an
8891 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8892 ? (gfc_caf_is_dealloc_only (caf_mode
)
8893 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8894 : GFC_CAF_COARRAY_DEREGISTER
)
8895 : GFC_CAF_COARRAY_NOCOARRAY
;
8897 caf_token
= NULL_TREE
;
8898 /* Coarray components are handled directly by
8899 deallocate_with_status. */
8900 if (!attr
->codimension
8901 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8904 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8905 TREE_TYPE (c
->caf_token
),
8906 decl
, c
->caf_token
, NULL_TREE
);
8907 else if (attr
->dimension
&& !attr
->proc_pointer
)
8908 caf_token
= gfc_conv_descriptor_token (comp
);
8910 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8911 /* When this is an array but not in conjunction with a coarray
8912 then add the data-ref. For coarray'ed arrays the data-ref
8913 is added by deallocate_with_status. */
8914 comp
= gfc_conv_descriptor_data_get (comp
);
8916 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8917 NULL_TREE
, NULL_TREE
, true,
8918 NULL
, caf_dereg_mode
,
8919 add_when_allocated
, caf_token
);
8921 gfc_add_expr_to_block (&tmpblock
, tmp
);
8923 else if (attr
->allocatable
&& !attr
->codimension
8924 && !deallocate_called
)
8926 /* Case of recursive allocatable derived types. */
8930 stmtblock_t dealloc_block
;
8932 gfc_init_block (&dealloc_block
);
8933 if (add_when_allocated
)
8934 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8936 /* Convert the component into a rank 1 descriptor type. */
8937 if (attr
->dimension
)
8939 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8940 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8941 c
->ts
.type
== BT_CLASS
8942 ? CLASS_DATA (c
)->as
->rank
8947 tmp
= TREE_TYPE (comp
);
8948 ubound
= build_int_cst (gfc_array_index_type
, 1);
8951 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8953 GFC_ARRAY_ALLOCATABLE
, false);
8955 cdesc
= gfc_create_var (cdesc
, "cdesc");
8956 DECL_ARTIFICIAL (cdesc
) = 1;
8958 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8959 gfc_get_dtype_rank_type (1, tmp
));
8960 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8961 gfc_index_zero_node
,
8962 gfc_index_one_node
);
8963 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8964 gfc_index_zero_node
,
8965 gfc_index_one_node
);
8966 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8967 gfc_index_zero_node
, ubound
);
8969 if (attr
->dimension
)
8970 comp
= gfc_conv_descriptor_data_get (comp
);
8972 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8974 /* Now call the deallocator. */
8975 vtab
= gfc_find_vtab (&c
->ts
);
8976 if (vtab
->backend_decl
== NULL
)
8977 gfc_get_symbol_decl (vtab
);
8978 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8979 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8980 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8982 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8983 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8984 logical_type_node
, tmp
,
8986 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8988 tmp
= build_call_expr_loc (input_location
,
8991 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8993 tmp
= gfc_finish_block (&dealloc_block
);
8995 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8996 void_type_node
, is_allocated
, tmp
,
8997 build_empty_stmt (input_location
));
8999 gfc_add_expr_to_block (&tmpblock
, tmp
);
9001 else if (add_when_allocated
)
9002 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
9004 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
9005 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
9007 /* Finally, reset the vptr to the declared type vtable and, if
9008 necessary reset the _len field.
9010 First recover the reference to the component and obtain
9012 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9013 decl
, cdecl, NULL_TREE
);
9014 tmp
= gfc_class_vptr_get (comp
);
9016 if (UNLIMITED_POLY (c
))
9018 /* Both vptr and _len field should be nulled. */
9019 gfc_add_modify (&tmpblock
, tmp
,
9020 build_int_cst (TREE_TYPE (tmp
), 0));
9021 tmp
= gfc_class_len_get (comp
);
9022 gfc_add_modify (&tmpblock
, tmp
,
9023 build_int_cst (TREE_TYPE (tmp
), 0));
9027 /* Build the vtable address and set the vptr with it. */
9030 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9031 vtab
= vtable
->backend_decl
;
9032 if (vtab
== NULL_TREE
)
9033 vtab
= gfc_get_symbol_decl (vtable
);
9034 vtab
= gfc_build_addr_expr (NULL
, vtab
);
9035 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
9036 gfc_add_modify (&tmpblock
, tmp
, vtab
);
9040 /* Now add the deallocation of this component. */
9041 gfc_add_block_to_block (&fnblock
, &tmpblock
);
9044 case NULLIFY_ALLOC_COMP
:
9046 - allocatable components (regular or in class)
9047 - components that have allocatable components
9048 - pointer components when in a coarray.
9049 Skip everything else especially proc_pointers, which may come
9050 coupled with the regular pointer attribute. */
9051 if (c
->attr
.proc_pointer
9052 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
9053 && CLASS_DATA (c
)->attr
.allocatable
)
9054 || (cmp_has_alloc_comps
9055 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
9056 || (c
->ts
.type
== BT_CLASS
9057 && !CLASS_DATA (c
)->attr
.class_pointer
)))
9058 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
9061 /* Process class components first, because they always have the
9062 pointer-attribute set which would be caught wrong else. */
9063 if (c
->ts
.type
== BT_CLASS
9064 && (CLASS_DATA (c
)->attr
.allocatable
9065 || CLASS_DATA (c
)->attr
.class_pointer
))
9069 /* Allocatable CLASS components. */
9070 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9071 decl
, cdecl, NULL_TREE
);
9073 vptr_decl
= gfc_class_vptr_get (comp
);
9075 comp
= gfc_class_data_get (comp
);
9076 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
9077 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9081 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9082 void_type_node
, comp
,
9083 build_int_cst (TREE_TYPE (comp
), 0));
9084 gfc_add_expr_to_block (&fnblock
, tmp
);
9087 /* The dynamic type of a disassociated pointer or unallocated
9088 allocatable variable is its declared type. An unlimited
9089 polymorphic entity has no declared type. */
9090 if (!UNLIMITED_POLY (c
))
9092 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9093 if (!vtab
->backend_decl
)
9094 gfc_get_symbol_decl (vtab
);
9095 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9098 tmp
= build_int_cst (TREE_TYPE (vptr_decl
), 0);
9100 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9101 void_type_node
, vptr_decl
, tmp
);
9102 gfc_add_expr_to_block (&fnblock
, tmp
);
9104 cmp_has_alloc_comps
= false;
9106 /* Coarrays need the component to be nulled before the api-call
9108 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
9110 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9111 decl
, cdecl, NULL_TREE
);
9112 if (c
->attr
.dimension
|| c
->attr
.codimension
)
9113 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9116 gfc_add_modify (&fnblock
, comp
,
9117 build_int_cst (TREE_TYPE (comp
), 0));
9118 if (gfc_deferred_strlen (c
, &comp
))
9120 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9122 decl
, comp
, NULL_TREE
);
9123 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9124 TREE_TYPE (comp
), comp
,
9125 build_int_cst (TREE_TYPE (comp
), 0));
9126 gfc_add_expr_to_block (&fnblock
, tmp
);
9128 cmp_has_alloc_comps
= false;
9131 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
9133 /* Register a component of a derived type coarray with the
9134 coarray library. Do not register ultimate component
9135 coarrays here. They are treated like regular coarrays and
9136 are either allocated on all images or on none. */
9139 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9140 decl
, cdecl, NULL_TREE
);
9141 if (c
->attr
.dimension
)
9143 /* Set the dtype, because caf_register needs it. */
9144 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
9145 gfc_get_dtype (TREE_TYPE (comp
)));
9146 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9147 decl
, cdecl, NULL_TREE
);
9148 token
= gfc_conv_descriptor_token (tmp
);
9154 gfc_init_se (&se
, NULL
);
9155 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9156 pvoid_type_node
, decl
, c
->caf_token
,
9158 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
9159 c
->ts
.type
== BT_CLASS
9160 ? CLASS_DATA (c
)->attr
9162 gfc_add_block_to_block (&fnblock
, &se
.pre
);
9165 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
9166 gfc_build_addr_expr (NULL_TREE
,
9168 NULL_TREE
, NULL_TREE
, NULL_TREE
,
9169 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
9172 if (cmp_has_alloc_comps
)
9174 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9175 decl
, cdecl, NULL_TREE
);
9176 rank
= c
->as
? c
->as
->rank
: 0;
9177 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
9178 rank
, purpose
, caf_mode
, args
);
9179 gfc_add_expr_to_block (&fnblock
, tmp
);
9183 case REASSIGN_CAF_COMP
:
9184 if (caf_enabled (caf_mode
)
9185 && (c
->attr
.codimension
9186 || (c
->ts
.type
== BT_CLASS
9187 && (CLASS_DATA (c
)->attr
.coarray_comp
9188 || caf_in_coarray (caf_mode
)))
9189 || (c
->ts
.type
== BT_DERIVED
9190 && (c
->ts
.u
.derived
->attr
.coarray_comp
9191 || caf_in_coarray (caf_mode
))))
9194 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9195 decl
, cdecl, NULL_TREE
);
9196 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9197 dest
, cdecl, NULL_TREE
);
9199 if (c
->attr
.codimension
)
9201 if (c
->ts
.type
== BT_CLASS
)
9203 comp
= gfc_class_data_get (comp
);
9204 dcmp
= gfc_class_data_get (dcmp
);
9206 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
9207 gfc_conv_descriptor_data_get (comp
));
9211 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
9212 rank
, purpose
, caf_mode
9213 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
,
9215 gfc_add_expr_to_block (&fnblock
, tmp
);
9220 case COPY_ALLOC_COMP
:
9221 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
9224 /* We need source and destination components. */
9225 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
9227 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
9229 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
9231 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
9239 dst_data
= gfc_class_data_get (dcmp
);
9240 src_data
= gfc_class_data_get (comp
);
9241 size
= fold_convert (size_type_node
,
9242 gfc_class_vtab_size_get (comp
));
9244 if (CLASS_DATA (c
)->attr
.dimension
)
9246 nelems
= gfc_conv_descriptor_size (src_data
,
9247 CLASS_DATA (c
)->as
->rank
);
9248 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9249 size_type_node
, size
,
9250 fold_convert (size_type_node
,
9254 nelems
= build_int_cst (size_type_node
, 1);
9256 if (CLASS_DATA (c
)->attr
.dimension
9257 || CLASS_DATA (c
)->attr
.codimension
)
9259 src_data
= gfc_conv_descriptor_data_get (src_data
);
9260 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
9263 gfc_init_block (&tmpblock
);
9265 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
9266 gfc_class_vptr_get (comp
));
9268 /* Copy the unlimited '_len' field. If it is greater than zero
9269 (ie. a character(_len)), multiply it by size and use this
9270 for the malloc call. */
9271 if (UNLIMITED_POLY (c
))
9274 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
9275 gfc_class_len_get (comp
));
9277 size
= gfc_evaluate_now (size
, &tmpblock
);
9278 tmp
= gfc_class_len_get (comp
);
9279 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9280 size_type_node
, size
,
9281 fold_convert (size_type_node
, tmp
));
9282 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9283 logical_type_node
, tmp
,
9284 build_zero_cst (TREE_TYPE (tmp
)));
9285 size
= fold_build3_loc (input_location
, COND_EXPR
,
9286 size_type_node
, tmp
, ctmp
, size
);
9287 size
= gfc_evaluate_now (size
, &tmpblock
);
9290 /* Coarray component have to have the same allocation status and
9291 shape/type-parameter/effective-type on the LHS and RHS of an
9292 intrinsic assignment. Hence, we did not deallocated them - and
9293 do not allocate them here. */
9294 if (!CLASS_DATA (c
)->attr
.codimension
)
9296 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9297 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9298 gfc_add_modify (&tmpblock
, dst_data
,
9299 fold_convert (TREE_TYPE (dst_data
), tmp
));
9302 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9303 UNLIMITED_POLY (c
));
9304 gfc_add_expr_to_block (&tmpblock
, tmp
);
9305 tmp
= gfc_finish_block (&tmpblock
);
9307 gfc_init_block (&tmpblock
);
9308 gfc_add_modify (&tmpblock
, dst_data
,
9309 fold_convert (TREE_TYPE (dst_data
),
9310 null_pointer_node
));
9311 null_data
= gfc_finish_block (&tmpblock
);
9313 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9314 logical_type_node
, src_data
,
9317 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9322 /* To implement guarded deep copy, i.e., deep copy only allocatable
9323 components that are really allocated, the deep copy code has to
9324 be generated first and then added to the if-block in
9325 gfc_duplicate_allocatable (). */
9326 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9328 rank
= c
->as
? c
->as
->rank
: 0;
9329 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9330 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9331 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9337 add_when_allocated
= NULL_TREE
;
9339 if (gfc_deferred_strlen (c
, &tmp
))
9343 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9345 decl
, len
, NULL_TREE
);
9346 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9348 dest
, len
, NULL_TREE
);
9349 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9350 TREE_TYPE (len
), len
, tmp
);
9351 gfc_add_expr_to_block (&fnblock
, tmp
);
9352 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9353 /* This component cannot have allocatable components,
9354 therefore add_when_allocated of duplicate_allocatable ()
9356 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9357 false, false, size
, NULL_TREE
);
9358 gfc_add_expr_to_block (&fnblock
, tmp
);
9360 else if (c
->attr
.pdt_array
)
9362 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9363 c
->as
? c
->as
->rank
: 0,
9364 false, false, NULL_TREE
, NULL_TREE
);
9365 gfc_add_expr_to_block (&fnblock
, tmp
);
9367 else if ((c
->attr
.allocatable
)
9368 && !c
->attr
.proc_pointer
&& !same_type
9369 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9370 || caf_in_coarray (caf_mode
)))
9372 rank
= c
->as
? c
->as
->rank
: 0;
9373 if (c
->attr
.codimension
)
9374 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9375 else if (flag_coarray
== GFC_FCOARRAY_LIB
9376 && caf_in_coarray (caf_mode
))
9378 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
9379 : fold_build3_loc (input_location
,
9381 pvoid_type_node
, dest
,
9384 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9388 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9389 add_when_allocated
);
9390 gfc_add_expr_to_block (&fnblock
, tmp
);
9393 if (cmp_has_alloc_comps
|| is_pdt_type
)
9394 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9398 case ALLOCATE_PDT_COMP
:
9400 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9401 decl
, cdecl, NULL_TREE
);
9403 /* Set the PDT KIND and LEN fields. */
9404 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9407 gfc_expr
*c_expr
= NULL
;
9408 gfc_actual_arglist
*param
= pdt_param_list
;
9409 gfc_init_se (&tse
, NULL
);
9410 for (; param
; param
= param
->next
)
9411 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9412 c_expr
= param
->expr
;
9415 c_expr
= c
->initializer
;
9419 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9420 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9424 if (c
->attr
.pdt_string
)
9427 gfc_init_se (&tse
, NULL
);
9428 tree strlen
= NULL_TREE
;
9429 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9430 /* Convert the parameterized string length to its value. The
9431 string length is stored in a hidden field in the same way as
9432 deferred string lengths. */
9433 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9434 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9436 gfc_conv_expr_type (&tse
, e
,
9437 TREE_TYPE (strlen
));
9438 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9440 decl
, strlen
, NULL_TREE
);
9441 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9442 c
->ts
.u
.cl
->backend_decl
= strlen
;
9446 /* Scalar parameterized strings can be allocated now. */
9449 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9450 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9451 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9452 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9453 gfc_add_modify (&fnblock
, comp
, tmp
);
9457 /* Allocate parameterized arrays of parameterized derived types. */
9458 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9459 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9460 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9463 if (c
->ts
.type
== BT_CLASS
)
9464 comp
= gfc_class_data_get (comp
);
9466 if (c
->attr
.pdt_array
)
9470 tree size
= gfc_index_one_node
;
9471 tree offset
= gfc_index_zero_node
;
9475 /* This chunk takes the expressions for 'lower' and 'upper'
9476 in the arrayspec and substitutes in the expressions for
9477 the parameters from 'pdt_param_list'. The descriptor
9478 fields can then be filled from the values so obtained. */
9479 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9480 for (i
= 0; i
< c
->as
->rank
; i
++)
9482 gfc_init_se (&tse
, NULL
);
9483 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9484 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9485 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9488 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9491 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9492 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9493 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9496 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9499 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9502 size
= gfc_evaluate_now (size
, &fnblock
);
9503 offset
= fold_build2_loc (input_location
,
9505 gfc_array_index_type
,
9507 offset
= gfc_evaluate_now (offset
, &fnblock
);
9508 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9509 gfc_array_index_type
,
9511 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9512 gfc_array_index_type
,
9513 tmp
, gfc_index_one_node
);
9514 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9515 gfc_array_index_type
, size
, tmp
);
9517 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9518 if (c
->ts
.type
== BT_CLASS
)
9520 tmp
= gfc_get_vptr_from_expr (comp
);
9521 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9522 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9523 tmp
= gfc_vptr_size_get (tmp
);
9526 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9527 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9528 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9529 gfc_array_index_type
, size
, tmp
);
9530 size
= gfc_evaluate_now (size
, &fnblock
);
9531 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9532 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9533 tmp
= gfc_conv_descriptor_dtype (comp
);
9534 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9536 if (c
->initializer
&& c
->initializer
->rank
)
9538 gfc_init_se (&tse
, NULL
);
9539 e
= gfc_copy_expr (c
->initializer
);
9540 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9541 gfc_conv_expr_descriptor (&tse
, e
);
9542 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9544 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9545 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9546 gfc_conv_descriptor_data_get (comp
),
9547 gfc_conv_descriptor_data_get (tse
.expr
),
9548 fold_convert (size_type_node
, size
));
9549 gfc_add_expr_to_block (&fnblock
, tmp
);
9550 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9554 /* Recurse in to PDT components. */
9555 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9556 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9557 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9559 bool is_deferred
= false;
9560 gfc_actual_arglist
*tail
= c
->param_list
;
9562 for (; tail
; tail
= tail
->next
)
9566 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9567 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9568 c
->as
? c
->as
->rank
: 0,
9570 gfc_add_expr_to_block (&fnblock
, tmp
);
9575 case DEALLOCATE_PDT_COMP
:
9576 /* Deallocate array or parameterized string length components
9577 of parameterized derived types. */
9578 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9579 && !c
->attr
.pdt_string
9580 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9581 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9584 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9585 decl
, cdecl, NULL_TREE
);
9586 if (c
->ts
.type
== BT_CLASS
)
9587 comp
= gfc_class_data_get (comp
);
9589 /* Recurse in to PDT components. */
9590 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9591 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9592 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9594 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9595 c
->as
? c
->as
->rank
: 0);
9596 gfc_add_expr_to_block (&fnblock
, tmp
);
9599 if (c
->attr
.pdt_array
)
9601 tmp
= gfc_conv_descriptor_data_get (comp
);
9602 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9603 logical_type_node
, tmp
,
9604 build_int_cst (TREE_TYPE (tmp
), 0));
9605 tmp
= gfc_call_free (tmp
);
9606 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9607 build_empty_stmt (input_location
));
9608 gfc_add_expr_to_block (&fnblock
, tmp
);
9609 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9611 else if (c
->attr
.pdt_string
)
9613 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9614 logical_type_node
, comp
,
9615 build_int_cst (TREE_TYPE (comp
), 0));
9616 tmp
= gfc_call_free (comp
);
9617 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9618 build_empty_stmt (input_location
));
9619 gfc_add_expr_to_block (&fnblock
, tmp
);
9620 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9621 gfc_add_modify (&fnblock
, comp
, tmp
);
9626 case CHECK_PDT_DUMMY
:
9628 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9629 decl
, cdecl, NULL_TREE
);
9630 if (c
->ts
.type
== BT_CLASS
)
9631 comp
= gfc_class_data_get (comp
);
9633 /* Recurse in to PDT components. */
9634 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9635 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9637 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9638 c
->as
? c
->as
->rank
: 0,
9640 gfc_add_expr_to_block (&fnblock
, tmp
);
9643 if (!c
->attr
.pdt_len
)
9648 gfc_expr
*c_expr
= NULL
;
9649 gfc_actual_arglist
*param
= pdt_param_list
;
9651 gfc_init_se (&tse
, NULL
);
9652 for (; param
; param
= param
->next
)
9653 if (!strcmp (c
->name
, param
->name
)
9654 && param
->spec_type
== SPEC_EXPLICIT
)
9655 c_expr
= param
->expr
;
9659 tree error
, cond
, cname
;
9660 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9661 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9664 cname
= gfc_build_cstring_const (c
->name
);
9665 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9666 error
= gfc_trans_runtime_error (true, NULL
,
9667 "The value of the PDT LEN "
9668 "parameter '%s' does not "
9669 "agree with that in the "
9670 "dummy declaration",
9672 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9673 void_type_node
, cond
, error
,
9674 build_empty_stmt (input_location
));
9675 gfc_add_expr_to_block (&fnblock
, tmp
);
9686 return gfc_finish_block (&fnblock
);
9689 /* Recursively traverse an object of derived type, generating code to
9690 nullify allocatable components. */
9693 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9696 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9698 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9702 /* Recursively traverse an object of derived type, generating code to
9703 deallocate allocatable components. */
9706 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9709 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9710 DEALLOCATE_ALLOC_COMP
,
9711 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9715 gfc_bcast_alloc_comp (gfc_symbol
*derived
, gfc_expr
*expr
, int rank
,
9716 tree image_index
, tree stat
, tree errmsg
,
9721 stmtblock_t block
, post_block
;
9722 gfc_co_subroutines_args args
;
9724 args
.image_index
= image_index
;
9726 args
.errmsg
= errmsg
;
9727 args
.errmsg
= errmsg_len
;
9731 gfc_start_block (&block
);
9732 gfc_init_block (&post_block
);
9733 gfc_init_se (&argse
, NULL
);
9734 gfc_conv_expr (&argse
, expr
);
9735 gfc_add_block_to_block (&block
, &argse
.pre
);
9736 gfc_add_block_to_block (&post_block
, &argse
.post
);
9741 gfc_init_se (&argse
, NULL
);
9742 argse
.want_pointer
= 1;
9743 gfc_conv_expr_descriptor (&argse
, expr
);
9747 tmp
= structure_alloc_comps (derived
, array
, NULL_TREE
, rank
,
9749 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, &args
);
9753 /* Recursively traverse an object of derived type, generating code to
9754 deallocate allocatable components. But do not deallocate coarrays.
9755 To be used for intrinsic assignment, which may not change the allocation
9756 status of coarrays. */
9759 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9761 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9762 DEALLOCATE_ALLOC_COMP
, 0, NULL
);
9767 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9769 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9770 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, NULL
);
9774 /* Recursively traverse an object of derived type, generating code to
9775 copy it and its allocatable components. */
9778 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9781 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9786 /* Recursively traverse an object of derived type, generating code to
9787 copy only its allocatable components. */
9790 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9792 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9793 COPY_ONLY_ALLOC_COMP
, 0, NULL
);
9797 /* Recursively traverse an object of parameterized derived type, generating
9798 code to allocate parameterized components. */
9801 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9802 gfc_actual_arglist
*param_list
)
9805 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9806 pdt_param_list
= param_list
;
9807 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9808 ALLOCATE_PDT_COMP
, 0, NULL
);
9809 pdt_param_list
= old_param_list
;
9813 /* Recursively traverse an object of parameterized derived type, generating
9814 code to deallocate parameterized components. */
9817 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9819 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9820 DEALLOCATE_PDT_COMP
, 0, NULL
);
9824 /* Recursively traverse a dummy of parameterized derived type to check the
9825 values of LEN parameters. */
9828 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9829 gfc_actual_arglist
*param_list
)
9832 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9833 pdt_param_list
= param_list
;
9834 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9835 CHECK_PDT_DUMMY
, 0, NULL
);
9836 pdt_param_list
= old_param_list
;
9841 /* Returns the value of LBOUND for an expression. This could be broken out
9842 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9843 called by gfc_alloc_allocatable_for_assignment. */
9845 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9850 tree cond
, cond1
, cond3
, cond4
;
9854 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9856 tmp
= gfc_rank_cst
[dim
];
9857 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9858 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9859 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9860 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9862 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9863 stride
, gfc_index_zero_node
);
9864 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9865 logical_type_node
, cond3
, cond1
);
9866 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9867 stride
, gfc_index_zero_node
);
9869 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9870 tmp
, build_int_cst (gfc_array_index_type
,
9873 cond
= logical_false_node
;
9875 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9876 logical_type_node
, cond3
, cond4
);
9877 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9878 logical_type_node
, cond
, cond1
);
9880 return fold_build3_loc (input_location
, COND_EXPR
,
9881 gfc_array_index_type
, cond
,
9882 lbound
, gfc_index_one_node
);
9885 if (expr
->expr_type
== EXPR_FUNCTION
)
9887 /* A conversion function, so use the argument. */
9888 gcc_assert (expr
->value
.function
.isym
9889 && expr
->value
.function
.isym
->conversion
);
9890 expr
= expr
->value
.function
.actual
->expr
;
9893 if (expr
->expr_type
== EXPR_VARIABLE
)
9895 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9896 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9898 if (ref
->type
== REF_COMPONENT
9899 && ref
->u
.c
.component
->as
9901 && ref
->next
->u
.ar
.type
== AR_FULL
)
9902 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9904 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9907 return gfc_index_one_node
;
9911 /* Returns true if an expression represents an lhs that can be reallocated
9915 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9923 sym
= expr
->symtree
->n
.sym
;
9925 if (sym
->attr
.associate_var
&& !expr
->ref
)
9928 /* An allocatable class variable with no reference. */
9929 if (sym
->ts
.type
== BT_CLASS
9930 && !sym
->attr
.associate_var
9931 && CLASS_DATA (sym
)->attr
.allocatable
9933 && ((expr
->ref
->type
== REF_ARRAY
&& expr
->ref
->u
.ar
.type
== AR_FULL
9934 && expr
->ref
->next
== NULL
)
9935 || (expr
->ref
->type
== REF_COMPONENT
9936 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9937 && (expr
->ref
->next
== NULL
9938 || (expr
->ref
->next
->type
== REF_ARRAY
9939 && expr
->ref
->next
->u
.ar
.type
== AR_FULL
9940 && expr
->ref
->next
->next
== NULL
)))))
9943 /* An allocatable variable. */
9944 if (sym
->attr
.allocatable
9945 && !sym
->attr
.associate_var
9947 && expr
->ref
->type
== REF_ARRAY
9948 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9951 /* All that can be left are allocatable components. */
9952 if ((sym
->ts
.type
!= BT_DERIVED
9953 && sym
->ts
.type
!= BT_CLASS
)
9954 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9957 /* Find a component ref followed by an array reference. */
9958 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9960 && ref
->type
== REF_COMPONENT
9961 && ref
->next
->type
== REF_ARRAY
9962 && !ref
->next
->next
)
9968 /* Return true if valid reallocatable lhs. */
9969 if (ref
->u
.c
.component
->attr
.allocatable
9970 && ref
->next
->u
.ar
.type
== AR_FULL
)
9978 concat_str_length (gfc_expr
* expr
)
9985 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9986 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9987 if (len1
== NULL_TREE
)
9989 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9990 len1
= concat_str_length (expr
->value
.op
.op1
);
9991 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9992 len1
= build_int_cst (gfc_charlen_type_node
,
9993 expr
->value
.op
.op1
->value
.character
.length
);
9994 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9996 gfc_init_se (&se
, NULL
);
9997 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
10003 gfc_init_se (&se
, NULL
);
10004 se
.want_pointer
= 1;
10005 se
.descriptor_only
= 1;
10006 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
10007 len1
= se
.string_length
;
10011 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
10012 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10013 if (len2
== NULL_TREE
)
10015 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
10016 len2
= concat_str_length (expr
->value
.op
.op2
);
10017 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
10018 len2
= build_int_cst (gfc_charlen_type_node
,
10019 expr
->value
.op
.op2
->value
.character
.length
);
10020 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
10022 gfc_init_se (&se
, NULL
);
10023 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
10029 gfc_init_se (&se
, NULL
);
10030 se
.want_pointer
= 1;
10031 se
.descriptor_only
= 1;
10032 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
10033 len2
= se
.string_length
;
10037 gcc_assert(len1
&& len2
);
10038 len1
= fold_convert (gfc_charlen_type_node
, len1
);
10039 len2
= fold_convert (gfc_charlen_type_node
, len2
);
10041 return fold_build2_loc (input_location
, PLUS_EXPR
,
10042 gfc_charlen_type_node
, len1
, len2
);
10046 /* Allocate the lhs of an assignment to an allocatable array, otherwise
10050 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
10054 stmtblock_t realloc_block
;
10055 stmtblock_t alloc_block
;
10056 stmtblock_t fblock
;
10059 gfc_array_info
*linfo
;
10081 gfc_array_spec
* as
;
10082 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
10083 && gfc_caf_attr (expr1
, true).codimension
);
10087 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
10088 Find the lhs expression in the loop chain and set expr1 and
10089 expr2 accordingly. */
10090 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
10093 /* Find the ss for the lhs. */
10095 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10096 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
10098 if (lss
== gfc_ss_terminator
)
10100 expr1
= lss
->info
->expr
;
10103 /* Bail out if this is not a valid allocate on assignment. */
10104 if (!gfc_is_reallocatable_lhs (expr1
)
10105 || (expr2
&& !expr2
->rank
))
10108 /* Find the ss for the lhs. */
10110 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10111 if (lss
->info
->expr
== expr1
)
10114 if (lss
== gfc_ss_terminator
)
10117 linfo
= &lss
->info
->data
.array
;
10119 /* Find an ss for the rhs. For operator expressions, we see the
10120 ss's for the operands. Any one of these will do. */
10122 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
10123 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
10126 if (expr2
&& rss
== gfc_ss_terminator
)
10129 /* Ensure that the string length from the current scope is used. */
10130 if (expr2
->ts
.type
== BT_CHARACTER
10131 && expr2
->expr_type
== EXPR_FUNCTION
10132 && !expr2
->value
.function
.isym
)
10133 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
10135 gfc_start_block (&fblock
);
10137 /* Since the lhs is allocatable, this must be a descriptor type.
10138 Get the data and array size. */
10139 desc
= linfo
->descriptor
;
10140 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
10141 array1
= gfc_conv_descriptor_data_get (desc
);
10143 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
10144 deallocated if expr is an array of different shape or any of the
10145 corresponding length type parameter values of variable and expr
10146 differ." This assures F95 compatibility. */
10147 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10148 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10150 /* Allocate if data is NULL. */
10151 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10152 array1
, build_int_cst (TREE_TYPE (array1
), 0));
10154 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10156 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10158 lss
->info
->string_length
,
10159 rss
->info
->string_length
);
10160 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10161 logical_type_node
, tmp
, cond_null
);
10164 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10166 tmp
= build3_v (COND_EXPR
, cond_null
,
10167 build1_v (GOTO_EXPR
, jump_label1
),
10168 build_empty_stmt (input_location
));
10169 gfc_add_expr_to_block (&fblock
, tmp
);
10171 /* Get arrayspec if expr is a full array. */
10172 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
10173 && expr2
->value
.function
.isym
10174 && expr2
->value
.function
.isym
->conversion
)
10176 /* For conversion functions, take the arg. */
10177 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
10178 as
= gfc_get_full_arrayspec_from_expr (arg
);
10181 as
= gfc_get_full_arrayspec_from_expr (expr2
);
10185 /* If the lhs shape is not the same as the rhs jump to setting the
10186 bounds and doing the reallocation....... */
10187 for (n
= 0; n
< expr1
->rank
; n
++)
10189 /* Check the shape. */
10190 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10191 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10192 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10193 gfc_array_index_type
,
10194 loop
->to
[n
], loop
->from
[n
]);
10195 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10196 gfc_array_index_type
,
10198 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10199 gfc_array_index_type
,
10201 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10203 tmp
, gfc_index_zero_node
);
10204 tmp
= build3_v (COND_EXPR
, cond
,
10205 build1_v (GOTO_EXPR
, jump_label1
),
10206 build_empty_stmt (input_location
));
10207 gfc_add_expr_to_block (&fblock
, tmp
);
10210 /* ....else jump past the (re)alloc code. */
10211 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10212 gfc_add_expr_to_block (&fblock
, tmp
);
10214 /* Add the label to start automatic (re)allocation. */
10215 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10216 gfc_add_expr_to_block (&fblock
, tmp
);
10218 /* If the lhs has not been allocated, its bounds will not have been
10219 initialized and so its size is set to zero. */
10220 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
10221 gfc_init_block (&alloc_block
);
10222 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
10223 gfc_init_block (&realloc_block
);
10224 gfc_add_modify (&realloc_block
, size1
,
10225 gfc_conv_descriptor_size (desc
, expr1
->rank
));
10226 tmp
= build3_v (COND_EXPR
, cond_null
,
10227 gfc_finish_block (&alloc_block
),
10228 gfc_finish_block (&realloc_block
));
10229 gfc_add_expr_to_block (&fblock
, tmp
);
10231 /* Get the rhs size and fix it. */
10233 desc2
= rss
->info
->data
.array
.descriptor
;
10237 size2
= gfc_index_one_node
;
10238 for (n
= 0; n
< expr2
->rank
; n
++)
10240 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10241 gfc_array_index_type
,
10242 loop
->to
[n
], loop
->from
[n
]);
10243 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10244 gfc_array_index_type
,
10245 tmp
, gfc_index_one_node
);
10246 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10247 gfc_array_index_type
,
10250 size2
= gfc_evaluate_now (size2
, &fblock
);
10252 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10255 /* If the lhs is deferred length, assume that the element size
10256 changes and force a reallocation. */
10257 if (expr1
->ts
.deferred
)
10258 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
10260 neq_size
= gfc_evaluate_now (cond
, &fblock
);
10262 /* Deallocation of allocatable components will have to occur on
10263 reallocation. Fix the old descriptor now. */
10264 if ((expr1
->ts
.type
== BT_DERIVED
)
10265 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10266 old_desc
= gfc_evaluate_now (desc
, &fblock
);
10268 old_desc
= NULL_TREE
;
10270 /* Now modify the lhs descriptor and the associated scalarizer
10271 variables. F2003 7.4.1.3: "If variable is or becomes an
10272 unallocated allocatable variable, then it is allocated with each
10273 deferred type parameter equal to the corresponding type parameters
10274 of expr , with the shape of expr , and with each lower bound equal
10275 to the corresponding element of LBOUND(expr)."
10276 Reuse size1 to keep a dimension-by-dimension track of the
10277 stride of the new array. */
10278 size1
= gfc_index_one_node
;
10279 offset
= gfc_index_zero_node
;
10281 for (n
= 0; n
< expr2
->rank
; n
++)
10283 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10284 gfc_array_index_type
,
10285 loop
->to
[n
], loop
->from
[n
]);
10286 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10287 gfc_array_index_type
,
10288 tmp
, gfc_index_one_node
);
10290 lbound
= gfc_index_one_node
;
10295 lbd
= get_std_lbound (expr2
, desc2
, n
,
10296 as
->type
== AS_ASSUMED_SIZE
);
10297 ubound
= fold_build2_loc (input_location
,
10299 gfc_array_index_type
,
10301 ubound
= fold_build2_loc (input_location
,
10303 gfc_array_index_type
,
10308 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
10311 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
10314 gfc_conv_descriptor_stride_set (&fblock
, desc
,
10317 lbound
= gfc_conv_descriptor_lbound_get (desc
,
10319 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
10320 gfc_array_index_type
,
10322 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10323 gfc_array_index_type
,
10325 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10326 gfc_array_index_type
,
10330 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10331 the array offset is saved and the info.offset is used for a
10332 running offset. Use the saved_offset instead. */
10333 tmp
= gfc_conv_descriptor_offset (desc
);
10334 gfc_add_modify (&fblock
, tmp
, offset
);
10335 if (linfo
->saved_offset
10336 && VAR_P (linfo
->saved_offset
))
10337 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10339 /* Now set the deltas for the lhs. */
10340 for (n
= 0; n
< expr1
->rank
; n
++)
10342 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10344 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10345 gfc_array_index_type
, tmp
,
10347 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10348 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10351 /* Get the new lhs size in bytes. */
10352 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10354 if (expr2
->ts
.deferred
)
10356 if (expr2
->ts
.u
.cl
->backend_decl
10357 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10358 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10360 tmp
= rss
->info
->string_length
;
10364 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10365 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10366 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10368 tmp
= concat_str_length (expr2
);
10369 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10371 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10374 gfc_init_se (&tmpse
, NULL
);
10375 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10376 gfc_charlen_type_node
);
10378 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10380 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10383 if (expr1
->ts
.u
.cl
->backend_decl
10384 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10385 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10387 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10389 if (expr1
->ts
.kind
> 1)
10390 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10392 tmp
, build_int_cst (TREE_TYPE (tmp
),
10395 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10397 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10398 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10399 gfc_array_index_type
, tmp
,
10400 expr1
->ts
.u
.cl
->backend_decl
);
10402 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10403 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10405 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10406 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10408 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10409 gfc_conv_descriptor_span_set (&fblock
, desc
, tmp
);
10411 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10412 gfc_array_index_type
,
10414 size2
= fold_convert (size_type_node
, size2
);
10415 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10416 size2
, size_one_node
);
10417 size2
= gfc_evaluate_now (size2
, &fblock
);
10419 /* For deferred character length, the 'size' field of the dtype might
10420 have changed so set the dtype. */
10421 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10422 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10425 tmp
= gfc_conv_descriptor_dtype (desc
);
10426 if (expr2
->ts
.u
.cl
->backend_decl
)
10427 type
= gfc_typenode_for_spec (&expr2
->ts
);
10429 type
= gfc_typenode_for_spec (&expr1
->ts
);
10431 gfc_add_modify (&fblock
, tmp
,
10432 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10434 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10437 tmp
= gfc_conv_descriptor_dtype (desc
);
10438 type
= gfc_typenode_for_spec (&expr2
->ts
);
10439 gfc_add_modify (&fblock
, tmp
,
10440 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10441 /* Set the _len field as well... */
10442 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10443 if (expr2
->ts
.type
== BT_CHARACTER
)
10444 gfc_add_modify (&fblock
, tmp
,
10445 fold_convert (TREE_TYPE (tmp
),
10446 TYPE_SIZE_UNIT (type
)));
10448 gfc_add_modify (&fblock
, tmp
,
10449 build_int_cst (TREE_TYPE (tmp
), 0));
10450 /* ...and the vptr. */
10451 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10452 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10453 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10454 gfc_add_modify (&fblock
, tmp
, tmp2
);
10456 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10458 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10459 gfc_get_dtype (TREE_TYPE (desc
)));
10462 /* Realloc expression. Note that the scalarizer uses desc.data
10463 in the array reference - (*desc.data)[<element>]. */
10464 gfc_init_block (&realloc_block
);
10465 gfc_init_se (&caf_se
, NULL
);
10469 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10470 if (token
== NULL_TREE
)
10472 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10473 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10474 tmp
= build_fold_indirect_ref (tmp
);
10475 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10477 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10480 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10482 if ((expr1
->ts
.type
== BT_DERIVED
)
10483 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10485 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10487 gfc_add_expr_to_block (&realloc_block
, tmp
);
10492 tmp
= build_call_expr_loc (input_location
,
10493 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10494 fold_convert (pvoid_type_node
, array1
),
10496 gfc_conv_descriptor_data_set (&realloc_block
,
10501 tmp
= build_call_expr_loc (input_location
,
10502 gfor_fndecl_caf_deregister
, 5, token
,
10503 build_int_cst (integer_type_node
,
10504 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10505 null_pointer_node
, null_pointer_node
,
10506 integer_zero_node
);
10507 gfc_add_expr_to_block (&realloc_block
, tmp
);
10508 tmp
= build_call_expr_loc (input_location
,
10509 gfor_fndecl_caf_register
,
10511 build_int_cst (integer_type_node
,
10512 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10513 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10514 null_pointer_node
, null_pointer_node
,
10515 integer_zero_node
);
10516 gfc_add_expr_to_block (&realloc_block
, tmp
);
10519 if ((expr1
->ts
.type
== BT_DERIVED
)
10520 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10522 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10524 gfc_add_expr_to_block (&realloc_block
, tmp
);
10527 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10528 realloc_expr
= gfc_finish_block (&realloc_block
);
10530 /* Only reallocate if sizes are different. */
10531 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10532 build_empty_stmt (input_location
));
10533 realloc_expr
= tmp
;
10536 /* Malloc expression. */
10537 gfc_init_block (&alloc_block
);
10540 tmp
= build_call_expr_loc (input_location
,
10541 builtin_decl_explicit (BUILT_IN_MALLOC
),
10543 gfc_conv_descriptor_data_set (&alloc_block
,
10548 tmp
= build_call_expr_loc (input_location
,
10549 gfor_fndecl_caf_register
,
10551 build_int_cst (integer_type_node
,
10552 GFC_CAF_COARRAY_ALLOC
),
10553 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10554 null_pointer_node
, null_pointer_node
,
10555 integer_zero_node
);
10556 gfc_add_expr_to_block (&alloc_block
, tmp
);
10560 /* We already set the dtype in the case of deferred character
10561 length arrays and unlimited polymorphic arrays. */
10562 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10563 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10565 && !UNLIMITED_POLY (expr1
))
10567 tmp
= gfc_conv_descriptor_dtype (desc
);
10568 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10571 if ((expr1
->ts
.type
== BT_DERIVED
)
10572 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10574 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10576 gfc_add_expr_to_block (&alloc_block
, tmp
);
10578 alloc_expr
= gfc_finish_block (&alloc_block
);
10580 /* Malloc if not allocated; realloc otherwise. */
10581 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10582 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10585 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10586 gfc_add_expr_to_block (&fblock
, tmp
);
10588 /* Make sure that the scalarizer data pointer is updated. */
10589 if (linfo
->data
&& VAR_P (linfo
->data
))
10591 tmp
= gfc_conv_descriptor_data_get (desc
);
10592 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10595 /* Add the exit label. */
10596 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10597 gfc_add_expr_to_block (&fblock
, tmp
);
10599 return gfc_finish_block (&fblock
);
10603 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10604 Do likewise, recursively if necessary, with the allocatable components of
10605 derived types. This function is also called for assumed-rank arrays, which
10606 are always dummy arguments. */
10609 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10615 stmtblock_t cleanup
;
10618 bool sym_has_alloc_comp
, has_finalizer
;
10620 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10621 || sym
->ts
.type
== BT_CLASS
)
10622 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10623 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10624 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10626 /* Make sure the frontend gets these right. */
10627 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10629 || (sym
->as
->type
== AS_ASSUMED_RANK
&& sym
->attr
.dummy
));
10631 gfc_save_backend_locus (&loc
);
10632 gfc_set_backend_locus (&sym
->declared_at
);
10633 gfc_init_block (&init
);
10635 gcc_assert (VAR_P (sym
->backend_decl
)
10636 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10638 if (sym
->ts
.type
== BT_CHARACTER
10639 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10641 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10642 gfc_trans_vla_type_sizes (sym
, &init
);
10645 /* Dummy, use associated and result variables don't need anything special. */
10646 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10648 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10649 gfc_restore_backend_locus (&loc
);
10653 descriptor
= sym
->backend_decl
;
10655 /* Although static, derived types with default initializers and
10656 allocatable components must not be nulled wholesale; instead they
10657 are treated component by component. */
10658 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10660 /* SAVEd variables are not freed on exit. */
10661 gfc_trans_static_array_pointer (sym
);
10663 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10664 gfc_restore_backend_locus (&loc
);
10668 /* Get the descriptor type. */
10669 type
= TREE_TYPE (sym
->backend_decl
);
10671 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10672 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10674 if (!sym
->attr
.save
10675 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10677 if (sym
->value
== NULL
10678 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10680 rank
= sym
->as
? sym
->as
->rank
: 0;
10681 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10683 gfc_add_expr_to_block (&init
, tmp
);
10686 gfc_init_default_dt (sym
, &init
, false);
10689 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10691 /* If the backend_decl is not a descriptor, we must have a pointer
10693 descriptor
= build_fold_indirect_ref_loc (input_location
,
10694 sym
->backend_decl
);
10695 type
= TREE_TYPE (descriptor
);
10698 /* NULLIFY the data pointer, for non-saved allocatables. */
10699 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10701 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10702 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10704 /* Declare the variable static so its array descriptor stays present
10705 after leaving the scope. It may still be accessed through another
10706 image. This may happen, for example, with the caf_mpi
10708 TREE_STATIC (descriptor
) = 1;
10709 tmp
= gfc_conv_descriptor_token (descriptor
);
10710 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10711 null_pointer_node
));
10715 gfc_restore_backend_locus (&loc
);
10716 gfc_init_block (&cleanup
);
10718 /* Allocatable arrays need to be freed when they go out of scope.
10719 The allocatable components of pointers must not be touched. */
10720 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10721 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10722 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10725 sym
->attr
.referenced
= 1;
10726 e
= gfc_lval_expr_from_sym (sym
);
10727 gfc_add_finalizer_call (&cleanup
, e
);
10730 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10731 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10732 && !sym
->attr
.pointer
&& !sym
->attr
.save
10733 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10736 rank
= sym
->as
? sym
->as
->rank
: 0;
10737 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10738 gfc_add_expr_to_block (&cleanup
, tmp
);
10741 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10742 && !sym
->attr
.save
&& !sym
->attr
.result
10743 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10746 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10747 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10748 NULL_TREE
, NULL_TREE
, true, e
,
10749 sym
->attr
.codimension
10750 ? GFC_CAF_COARRAY_DEREGISTER
10751 : GFC_CAF_COARRAY_NOCOARRAY
);
10754 gfc_add_expr_to_block (&cleanup
, tmp
);
10757 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10758 gfc_finish_block (&cleanup
));
10761 /************ Expression Walking Functions ******************/
10763 /* Walk a variable reference.
10765 Possible extension - multiple component subscripts.
10766 x(:,:) = foo%a(:)%b(:)
10768 forall (i=..., j=...)
10769 x(i,j) = foo%a(j)%b(i)
10771 This adds a fair amount of complexity because you need to deal with more
10772 than one ref. Maybe handle in a similar manner to vector subscripts.
10773 Maybe not worth the effort. */
10777 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10781 gfc_fix_class_refs (expr
);
10783 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10784 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10787 return gfc_walk_array_ref (ss
, expr
, ref
);
10792 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10798 for (; ref
; ref
= ref
->next
)
10800 if (ref
->type
== REF_SUBSTRING
)
10802 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10803 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10806 /* We're only interested in array sections from now on. */
10807 if (ref
->type
!= REF_ARRAY
)
10815 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10816 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10820 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10821 newss
->info
->data
.array
.ref
= ref
;
10823 /* Make sure array is the same as array(:,:), this way
10824 we don't need to special case all the time. */
10825 ar
->dimen
= ar
->as
->rank
;
10826 for (n
= 0; n
< ar
->dimen
; n
++)
10828 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10830 gcc_assert (ar
->start
[n
] == NULL
);
10831 gcc_assert (ar
->end
[n
] == NULL
);
10832 gcc_assert (ar
->stride
[n
] == NULL
);
10838 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10839 newss
->info
->data
.array
.ref
= ref
;
10841 /* We add SS chains for all the subscripts in the section. */
10842 for (n
= 0; n
< ar
->dimen
; n
++)
10846 switch (ar
->dimen_type
[n
])
10848 case DIMEN_ELEMENT
:
10849 /* Add SS for elemental (scalar) subscripts. */
10850 gcc_assert (ar
->start
[n
]);
10851 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10852 indexss
->loop_chain
= gfc_ss_terminator
;
10853 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10857 /* We don't add anything for sections, just remember this
10858 dimension for later. */
10859 newss
->dim
[newss
->dimen
] = n
;
10864 /* Create a GFC_SS_VECTOR index in which we can store
10865 the vector's descriptor. */
10866 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10868 indexss
->loop_chain
= gfc_ss_terminator
;
10869 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10870 newss
->dim
[newss
->dimen
] = n
;
10875 /* We should know what sort of section it is by now. */
10876 gcc_unreachable ();
10879 /* We should have at least one non-elemental dimension,
10880 unless we are creating a descriptor for a (scalar) coarray. */
10881 gcc_assert (newss
->dimen
> 0
10882 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10887 /* We should know what sort of section it is by now. */
10888 gcc_unreachable ();
10896 /* Walk an expression operator. If only one operand of a binary expression is
10897 scalar, we must also add the scalar term to the SS chain. */
10900 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10905 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10906 if (expr
->value
.op
.op2
== NULL
)
10909 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10911 /* All operands are scalar. Pass back and let the caller deal with it. */
10915 /* All operands require scalarization. */
10916 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10919 /* One of the operands needs scalarization, the other is scalar.
10920 Create a gfc_ss for the scalar expression. */
10923 /* First operand is scalar. We build the chain in reverse order, so
10924 add the scalar SS after the second operand. */
10926 while (head
&& head
->next
!= ss
)
10928 /* Check we haven't somehow broken the chain. */
10930 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10932 else /* head2 == head */
10934 gcc_assert (head2
== head
);
10935 /* Second operand is scalar. */
10936 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10943 /* Reverse a SS chain. */
10946 gfc_reverse_ss (gfc_ss
* ss
)
10951 gcc_assert (ss
!= NULL
);
10953 head
= gfc_ss_terminator
;
10954 while (ss
!= gfc_ss_terminator
)
10957 /* Check we didn't somehow break the chain. */
10958 gcc_assert (next
!= NULL
);
10968 /* Given an expression referring to a procedure, return the symbol of its
10969 interface. We can't get the procedure symbol directly as we have to handle
10970 the case of (deferred) type-bound procedures. */
10973 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10978 if (procedure_ref
== NULL
)
10981 /* Normal procedure case. */
10982 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10983 && procedure_ref
->value
.function
.esym
)
10984 sym
= procedure_ref
->value
.function
.esym
;
10986 sym
= procedure_ref
->symtree
->n
.sym
;
10988 /* Typebound procedure case. */
10989 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10991 if (ref
->type
== REF_COMPONENT
10992 && ref
->u
.c
.component
->attr
.proc_pointer
)
10993 sym
= ref
->u
.c
.component
->ts
.interface
;
11002 /* Walk the arguments of an elemental function.
11003 PROC_EXPR is used to check whether an argument is permitted to be absent. If
11004 it is NULL, we don't do the check and the argument is assumed to be present.
11008 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
11009 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
11011 gfc_formal_arglist
*dummy_arg
;
11017 head
= gfc_ss_terminator
;
11021 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
11026 for (; arg
; arg
= arg
->next
)
11028 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
11029 goto loop_continue
;
11031 newss
= gfc_walk_subexpr (head
, arg
->expr
);
11034 /* Scalar argument. */
11035 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
11036 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
11037 newss
->info
->type
= type
;
11039 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
11044 if (dummy_arg
!= NULL
11045 && dummy_arg
->sym
->attr
.optional
11046 && arg
->expr
->expr_type
== EXPR_VARIABLE
11047 && (gfc_expr_attr (arg
->expr
).optional
11048 || gfc_expr_attr (arg
->expr
).allocatable
11049 || gfc_expr_attr (arg
->expr
).pointer
))
11050 newss
->info
->can_be_null_ref
= true;
11056 while (tail
->next
!= gfc_ss_terminator
)
11061 if (dummy_arg
!= NULL
)
11062 dummy_arg
= dummy_arg
->next
;
11067 /* If all the arguments are scalar we don't need the argument SS. */
11068 gfc_free_ss_chain (head
);
11069 /* Pass it back. */
11073 /* Add it onto the existing chain. */
11079 /* Walk a function call. Scalar functions are passed back, and taken out of
11080 scalarization loops. For elemental functions we walk their arguments.
11081 The result of functions returning arrays is stored in a temporary outside
11082 the loop, so that the function is only called once. Hence we do not need
11083 to walk their arguments. */
11086 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11088 gfc_intrinsic_sym
*isym
;
11090 gfc_component
*comp
= NULL
;
11092 isym
= expr
->value
.function
.isym
;
11094 /* Handle intrinsic functions separately. */
11096 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
11098 sym
= expr
->value
.function
.esym
;
11100 sym
= expr
->symtree
->n
.sym
;
11102 if (gfc_is_class_array_function (expr
))
11103 return gfc_get_array_ss (ss
, expr
,
11104 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
11107 /* A function that returns arrays. */
11108 comp
= gfc_get_proc_ptr_comp (expr
);
11109 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
11110 || (comp
&& comp
->attr
.dimension
))
11111 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
11113 /* Walk the parameters of an elemental function. For now we always pass
11115 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
11117 gfc_ss
*old_ss
= ss
;
11119 ss
= gfc_walk_elemental_function_args (old_ss
,
11120 expr
->value
.function
.actual
,
11121 gfc_get_proc_ifc_for_expr (expr
),
11125 || sym
->attr
.proc_pointer
11126 || sym
->attr
.if_source
!= IFSRC_DECL
11127 || sym
->attr
.array_outer_dependency
))
11128 ss
->info
->array_outer_dependency
= 1;
11131 /* Scalar functions are OK as these are evaluated outside the scalarization
11132 loop. Pass back and let the caller deal with it. */
11137 /* An array temporary is constructed for array constructors. */
11140 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
11142 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
11146 /* Walk an expression. Add walked expressions to the head of the SS chain.
11147 A wholly scalar expression will not be added. */
11150 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
11154 switch (expr
->expr_type
)
11156 case EXPR_VARIABLE
:
11157 head
= gfc_walk_variable_expr (ss
, expr
);
11161 head
= gfc_walk_op_expr (ss
, expr
);
11164 case EXPR_FUNCTION
:
11165 head
= gfc_walk_function_expr (ss
, expr
);
11168 case EXPR_CONSTANT
:
11170 case EXPR_STRUCTURE
:
11171 /* Pass back and let the caller deal with it. */
11175 head
= gfc_walk_array_constructor (ss
, expr
);
11178 case EXPR_SUBSTRING
:
11179 /* Pass back and let the caller deal with it. */
11183 gfc_internal_error ("bad expression type during walk (%d)",
11190 /* Entry point for expression walking.
11191 A return value equal to the passed chain means this is
11192 a scalar expression. It is up to the caller to take whatever action is
11193 necessary to translate these. */
11196 gfc_walk_expr (gfc_expr
* expr
)
11200 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
11201 return gfc_reverse_ss (res
);