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
);
3675 cst_offset
= offset
= gfc_index_zero_node
;
3676 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3678 /* Calculate the offsets from all the dimensions. Make sure to associate
3679 the final offset so that we form a chain of loop invariant summands. */
3680 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3682 /* Calculate the index for this dimension. */
3683 gfc_init_se (&indexse
, se
);
3684 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3685 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3687 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3689 /* Check array bounds. */
3693 /* Evaluate the indexse.expr only once. */
3694 indexse
.expr
= save_expr (indexse
.expr
);
3697 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3698 if (sym
->attr
.temporary
)
3700 gfc_init_se (&tmpse
, se
);
3701 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3702 gfc_array_index_type
);
3703 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3707 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3709 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3710 "below lower bound of %%ld", n
+1, var_name
);
3711 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3712 fold_convert (long_integer_type_node
,
3714 fold_convert (long_integer_type_node
, tmp
));
3717 /* Upper bound, but not for the last dimension of assumed-size
3719 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3721 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3722 if (sym
->attr
.temporary
)
3724 gfc_init_se (&tmpse
, se
);
3725 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3726 gfc_array_index_type
);
3727 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3731 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3732 logical_type_node
, indexse
.expr
, tmp
);
3733 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3734 "above upper bound of %%ld", n
+1, var_name
);
3735 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3736 fold_convert (long_integer_type_node
,
3738 fold_convert (long_integer_type_node
, tmp
));
3743 /* Multiply the index by the stride. */
3744 stride
= gfc_conv_array_stride (se
->expr
, n
);
3745 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3746 indexse
.expr
, stride
);
3748 /* And add it to the total. */
3749 add_to_offset (&cst_offset
, &offset
, tmp
);
3752 if (!integer_zerop (cst_offset
))
3753 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3754 gfc_array_index_type
, offset
, cst_offset
);
3756 /* A pointer array component can be detected from its field decl. Fix
3757 the descriptor, mark the resulting variable decl and pass it to
3759 if (get_CFI_desc (sym
, expr
, &decl
, ar
))
3760 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3761 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3762 && is_pointer_array (se
->expr
))
3764 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3766 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3767 decl
= TREE_OPERAND (se
->expr
, 0);
3771 else if (expr
->ts
.deferred
3772 || (sym
->ts
.type
== BT_CHARACTER
3773 && sym
->attr
.select_type_temporary
))
3775 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3778 if (TREE_CODE (decl
) == INDIRECT_REF
)
3779 decl
= TREE_OPERAND (decl
, 0);
3782 decl
= sym
->backend_decl
;
3784 else if (sym
->ts
.type
== BT_CLASS
)
3787 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3791 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3792 LOOP_DIM dimension (if any) to array's offset. */
3795 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3796 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3799 gfc_array_info
*info
;
3802 info
= &ss
->info
->data
.array
;
3804 gfc_init_se (&se
, NULL
);
3806 se
.expr
= info
->descriptor
;
3807 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3808 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3809 gfc_add_block_to_block (pblock
, &se
.pre
);
3811 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3812 gfc_array_index_type
,
3813 info
->offset
, index
);
3814 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3818 /* Generate the code to be executed immediately before entering a
3819 scalarization loop. */
3822 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3823 stmtblock_t
* pblock
)
3826 gfc_ss_info
*ss_info
;
3827 gfc_array_info
*info
;
3828 gfc_ss_type ss_type
;
3830 gfc_loopinfo
*ploop
;
3834 /* This code will be executed before entering the scalarization loop
3835 for this dimension. */
3836 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3840 if ((ss_info
->useflags
& flag
) == 0)
3843 ss_type
= ss_info
->type
;
3844 if (ss_type
!= GFC_SS_SECTION
3845 && ss_type
!= GFC_SS_FUNCTION
3846 && ss_type
!= GFC_SS_CONSTRUCTOR
3847 && ss_type
!= GFC_SS_COMPONENT
)
3850 info
= &ss_info
->data
.array
;
3852 gcc_assert (dim
< ss
->dimen
);
3853 gcc_assert (ss
->dimen
== loop
->dimen
);
3856 ar
= &info
->ref
->u
.ar
;
3860 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3862 /* If we are in the outermost dimension of this loop, the previous
3863 dimension shall be in the parent loop. */
3864 gcc_assert (ss
->parent
!= NULL
);
3867 ploop
= loop
->parent
;
3869 /* ss and ss->parent are about the same array. */
3870 gcc_assert (ss_info
== pss
->info
);
3878 if (dim
== loop
->dimen
- 1)
3883 /* For the time being, there is no loop reordering. */
3884 gcc_assert (i
== ploop
->order
[i
]);
3885 i
= ploop
->order
[i
];
3887 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3889 stride
= gfc_conv_array_stride (info
->descriptor
,
3890 innermost_ss (ss
)->dim
[i
]);
3892 /* Calculate the stride of the innermost loop. Hopefully this will
3893 allow the backend optimizers to do their stuff more effectively.
3895 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3897 /* For the outermost loop calculate the offset due to any
3898 elemental dimensions. It will have been initialized with the
3899 base offset of the array. */
3902 for (i
= 0; i
< ar
->dimen
; i
++)
3904 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3907 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3912 /* Add the offset for the previous loop dimension. */
3913 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3915 /* Remember this offset for the second loop. */
3916 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3917 info
->saved_offset
= info
->offset
;
3922 /* Start a scalarized expression. Creates a scope and declares loop
3926 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3932 gcc_assert (!loop
->array_parameter
);
3934 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3936 n
= loop
->order
[dim
];
3938 gfc_start_block (&loop
->code
[n
]);
3940 /* Create the loop variable. */
3941 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3943 if (dim
< loop
->temp_dim
)
3947 /* Calculate values that will be constant within this loop. */
3948 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3950 gfc_start_block (pbody
);
3954 /* Generates the actual loop code for a scalarization loop. */
3957 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3958 stmtblock_t
* pbody
)
3969 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3970 | OMPWS_SCALARIZER_BODY
))
3971 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3972 && n
== loop
->dimen
- 1)
3974 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3975 init
= make_tree_vec (1);
3976 cond
= make_tree_vec (1);
3977 incr
= make_tree_vec (1);
3979 /* Cycle statement is implemented with a goto. Exit statement must not
3980 be present for this loop. */
3981 exit_label
= gfc_build_label_decl (NULL_TREE
);
3982 TREE_USED (exit_label
) = 1;
3984 /* Label for cycle statements (if needed). */
3985 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3986 gfc_add_expr_to_block (pbody
, tmp
);
3988 stmt
= make_node (OMP_FOR
);
3990 TREE_TYPE (stmt
) = void_type_node
;
3991 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3993 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3994 OMP_CLAUSE_SCHEDULE
);
3995 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3996 = OMP_CLAUSE_SCHEDULE_STATIC
;
3997 if (ompws_flags
& OMPWS_NOWAIT
)
3998 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3999 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
4001 /* Initialize the loopvar. */
4002 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
4004 OMP_FOR_INIT (stmt
) = init
;
4005 /* The exit condition. */
4006 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
4008 loop
->loopvar
[n
], loop
->to
[n
]);
4009 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
4010 OMP_FOR_COND (stmt
) = cond
;
4011 /* Increment the loopvar. */
4012 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4013 loop
->loopvar
[n
], gfc_index_one_node
);
4014 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
4015 void_type_node
, loop
->loopvar
[n
], tmp
);
4016 OMP_FOR_INCR (stmt
) = incr
;
4018 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
4019 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
4023 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
4024 && (loop
->temp_ss
== NULL
);
4026 loopbody
= gfc_finish_block (pbody
);
4029 std::swap (loop
->from
[n
], loop
->to
[n
]);
4031 /* Initialize the loopvar. */
4032 if (loop
->loopvar
[n
] != loop
->from
[n
])
4033 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
4035 exit_label
= gfc_build_label_decl (NULL_TREE
);
4037 /* Generate the loop body. */
4038 gfc_init_block (&block
);
4040 /* The exit condition. */
4041 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
4042 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
4043 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4044 TREE_USED (exit_label
) = 1;
4045 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4046 gfc_add_expr_to_block (&block
, tmp
);
4048 /* The main body. */
4049 gfc_add_expr_to_block (&block
, loopbody
);
4051 /* Increment the loopvar. */
4052 tmp
= fold_build2_loc (input_location
,
4053 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
4054 gfc_array_index_type
, loop
->loopvar
[n
],
4055 gfc_index_one_node
);
4057 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
4059 /* Build the loop. */
4060 tmp
= gfc_finish_block (&block
);
4061 tmp
= build1_v (LOOP_EXPR
, tmp
);
4062 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4064 /* Add the exit label. */
4065 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4066 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4072 /* Finishes and generates the loops for a scalarized expression. */
4075 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4080 stmtblock_t
*pblock
;
4084 /* Generate the loops. */
4085 for (dim
= 0; dim
< loop
->dimen
; dim
++)
4087 n
= loop
->order
[dim
];
4088 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4089 loop
->loopvar
[n
] = NULL_TREE
;
4090 pblock
= &loop
->code
[n
];
4093 tmp
= gfc_finish_block (pblock
);
4094 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4096 /* Clear all the used flags. */
4097 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4098 if (ss
->parent
== NULL
)
4099 ss
->info
->useflags
= 0;
4103 /* Finish the main body of a scalarized expression, and start the secondary
4107 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4111 stmtblock_t
*pblock
;
4115 /* We finish as many loops as are used by the temporary. */
4116 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4118 n
= loop
->order
[dim
];
4119 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4120 loop
->loopvar
[n
] = NULL_TREE
;
4121 pblock
= &loop
->code
[n
];
4124 /* We don't want to finish the outermost loop entirely. */
4125 n
= loop
->order
[loop
->temp_dim
- 1];
4126 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4128 /* Restore the initial offsets. */
4129 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4131 gfc_ss_type ss_type
;
4132 gfc_ss_info
*ss_info
;
4136 if ((ss_info
->useflags
& 2) == 0)
4139 ss_type
= ss_info
->type
;
4140 if (ss_type
!= GFC_SS_SECTION
4141 && ss_type
!= GFC_SS_FUNCTION
4142 && ss_type
!= GFC_SS_CONSTRUCTOR
4143 && ss_type
!= GFC_SS_COMPONENT
)
4146 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4149 /* Restart all the inner loops we just finished. */
4150 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4152 n
= loop
->order
[dim
];
4154 gfc_start_block (&loop
->code
[n
]);
4156 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4158 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4161 /* Start a block for the secondary copying code. */
4162 gfc_start_block (body
);
4166 /* Precalculate (either lower or upper) bound of an array section.
4167 BLOCK: Block in which the (pre)calculation code will go.
4168 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4169 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4170 DESC: Array descriptor from which the bound will be picked if unspecified
4171 (either lower or upper bound according to LBOUND). */
4174 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4175 tree desc
, int dim
, bool lbound
, bool deferred
)
4178 gfc_expr
* input_val
= values
[dim
];
4179 tree
*output
= &bounds
[dim
];
4184 /* Specified section bound. */
4185 gfc_init_se (&se
, NULL
);
4186 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4187 gfc_add_block_to_block (block
, &se
.pre
);
4190 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4192 /* The gfc_conv_array_lbound () routine returns a constant zero for
4193 deferred length arrays, which in the scalarizer wreaks havoc, when
4194 copying to a (newly allocated) one-based array.
4195 Keep returning the actual result in sync for both bounds. */
4196 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4198 gfc_conv_descriptor_ubound_get (desc
,
4203 /* No specific bound specified so use the bound of the array. */
4204 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4205 gfc_conv_array_ubound (desc
, dim
);
4207 *output
= gfc_evaluate_now (*output
, block
);
4211 /* Calculate the lower bound of an array section. */
4214 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4216 gfc_expr
*stride
= NULL
;
4219 gfc_array_info
*info
;
4222 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4224 info
= &ss
->info
->data
.array
;
4225 ar
= &info
->ref
->u
.ar
;
4227 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4229 /* We use a zero-based index to access the vector. */
4230 info
->start
[dim
] = gfc_index_zero_node
;
4231 info
->end
[dim
] = NULL
;
4232 info
->stride
[dim
] = gfc_index_one_node
;
4236 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4237 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4238 desc
= info
->descriptor
;
4239 stride
= ar
->stride
[dim
];
4242 /* Calculate the start of the range. For vector subscripts this will
4243 be the range of the vector. */
4244 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4245 ar
->as
->type
== AS_DEFERRED
);
4247 /* Similarly calculate the end. Although this is not used in the
4248 scalarizer, it is needed when checking bounds and where the end
4249 is an expression with side-effects. */
4250 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4251 ar
->as
->type
== AS_DEFERRED
);
4254 /* Calculate the stride. */
4256 info
->stride
[dim
] = gfc_index_one_node
;
4259 gfc_init_se (&se
, NULL
);
4260 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4261 gfc_add_block_to_block (block
, &se
.pre
);
4262 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4267 /* Calculates the range start and stride for a SS chain. Also gets the
4268 descriptor and data pointer. The range of vector subscripts is the size
4269 of the vector. Array bounds are also checked. */
4272 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4279 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4282 /* Determine the rank of the loop. */
4283 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4285 switch (ss
->info
->type
)
4287 case GFC_SS_SECTION
:
4288 case GFC_SS_CONSTRUCTOR
:
4289 case GFC_SS_FUNCTION
:
4290 case GFC_SS_COMPONENT
:
4291 loop
->dimen
= ss
->dimen
;
4294 /* As usual, lbound and ubound are exceptions!. */
4295 case GFC_SS_INTRINSIC
:
4296 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4298 case GFC_ISYM_LBOUND
:
4299 case GFC_ISYM_UBOUND
:
4300 case GFC_ISYM_LCOBOUND
:
4301 case GFC_ISYM_UCOBOUND
:
4302 case GFC_ISYM_THIS_IMAGE
:
4303 loop
->dimen
= ss
->dimen
;
4315 /* We should have determined the rank of the expression by now. If
4316 not, that's bad news. */
4320 /* Loop over all the SS in the chain. */
4321 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4323 gfc_ss_info
*ss_info
;
4324 gfc_array_info
*info
;
4328 expr
= ss_info
->expr
;
4329 info
= &ss_info
->data
.array
;
4331 if (expr
&& expr
->shape
&& !info
->shape
)
4332 info
->shape
= expr
->shape
;
4334 switch (ss_info
->type
)
4336 case GFC_SS_SECTION
:
4337 /* Get the descriptor for the array. If it is a cross loops array,
4338 we got the descriptor already in the outermost loop. */
4339 if (ss
->parent
== NULL
)
4340 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4341 !loop
->array_parameter
);
4343 for (n
= 0; n
< ss
->dimen
; n
++)
4344 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4347 case GFC_SS_INTRINSIC
:
4348 switch (expr
->value
.function
.isym
->id
)
4350 /* Fall through to supply start and stride. */
4351 case GFC_ISYM_LBOUND
:
4352 case GFC_ISYM_UBOUND
:
4356 /* This is the variant without DIM=... */
4357 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4359 arg
= expr
->value
.function
.actual
->expr
;
4360 if (arg
->rank
== -1)
4365 /* The rank (hence the return value's shape) is unknown,
4366 we have to retrieve it. */
4367 gfc_init_se (&se
, NULL
);
4368 se
.descriptor_only
= 1;
4369 gfc_conv_expr (&se
, arg
);
4370 /* This is a bare variable, so there is no preliminary
4372 gcc_assert (se
.pre
.head
== NULL_TREE
4373 && se
.post
.head
== NULL_TREE
);
4374 rank
= gfc_conv_descriptor_rank (se
.expr
);
4375 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4376 gfc_array_index_type
,
4377 fold_convert (gfc_array_index_type
,
4379 gfc_index_one_node
);
4380 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4381 info
->start
[0] = gfc_index_zero_node
;
4382 info
->stride
[0] = gfc_index_one_node
;
4385 /* Otherwise fall through GFC_SS_FUNCTION. */
4388 case GFC_ISYM_LCOBOUND
:
4389 case GFC_ISYM_UCOBOUND
:
4390 case GFC_ISYM_THIS_IMAGE
:
4398 case GFC_SS_CONSTRUCTOR
:
4399 case GFC_SS_FUNCTION
:
4400 for (n
= 0; n
< ss
->dimen
; n
++)
4402 int dim
= ss
->dim
[n
];
4404 info
->start
[dim
] = gfc_index_zero_node
;
4405 info
->end
[dim
] = gfc_index_zero_node
;
4406 info
->stride
[dim
] = gfc_index_one_node
;
4415 /* The rest is just runtime bounds checking. */
4416 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4419 tree lbound
, ubound
;
4421 tree size
[GFC_MAX_DIMENSIONS
];
4422 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4423 gfc_array_info
*info
;
4427 gfc_start_block (&block
);
4429 for (n
= 0; n
< loop
->dimen
; n
++)
4430 size
[n
] = NULL_TREE
;
4432 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4435 gfc_ss_info
*ss_info
;
4438 const char *expr_name
;
4441 if (ss_info
->type
!= GFC_SS_SECTION
)
4444 /* Catch allocatable lhs in f2003. */
4445 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4448 expr
= ss_info
->expr
;
4449 expr_loc
= &expr
->where
;
4450 expr_name
= expr
->symtree
->name
;
4452 gfc_start_block (&inner
);
4454 /* TODO: range checking for mapped dimensions. */
4455 info
= &ss_info
->data
.array
;
4457 /* This code only checks ranges. Elemental and vector
4458 dimensions are checked later. */
4459 for (n
= 0; n
< loop
->dimen
; n
++)
4464 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4467 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4468 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4469 check_upper
= false;
4473 /* Zero stride is not allowed. */
4474 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4475 info
->stride
[dim
], gfc_index_zero_node
);
4476 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4477 "of array '%s'", dim
+ 1, expr_name
);
4478 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4482 desc
= info
->descriptor
;
4484 /* This is the run-time equivalent of resolve.c's
4485 check_dimension(). The logical is more readable there
4486 than it is here, with all the trees. */
4487 lbound
= gfc_conv_array_lbound (desc
, dim
);
4488 end
= info
->end
[dim
];
4490 ubound
= gfc_conv_array_ubound (desc
, dim
);
4494 /* non_zerosized is true when the selected range is not
4496 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4497 logical_type_node
, info
->stride
[dim
],
4498 gfc_index_zero_node
);
4499 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4500 info
->start
[dim
], end
);
4501 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4502 logical_type_node
, stride_pos
, tmp
);
4504 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4506 info
->stride
[dim
], gfc_index_zero_node
);
4507 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4508 info
->start
[dim
], end
);
4509 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4512 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4514 stride_pos
, stride_neg
);
4516 /* Check the start of the range against the lower and upper
4517 bounds of the array, if the range is not empty.
4518 If upper bound is present, include both bounds in the
4522 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4524 info
->start
[dim
], lbound
);
4525 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4527 non_zerosized
, tmp
);
4528 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4530 info
->start
[dim
], ubound
);
4531 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4533 non_zerosized
, tmp2
);
4534 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4535 "outside of expected range (%%ld:%%ld)",
4536 dim
+ 1, expr_name
);
4537 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4539 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4540 fold_convert (long_integer_type_node
, lbound
),
4541 fold_convert (long_integer_type_node
, ubound
));
4542 gfc_trans_runtime_check (true, false, tmp2
, &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
));
4551 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4553 info
->start
[dim
], lbound
);
4554 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4555 logical_type_node
, non_zerosized
, tmp
);
4556 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4557 "below lower bound of %%ld",
4558 dim
+ 1, expr_name
);
4559 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4561 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4562 fold_convert (long_integer_type_node
, lbound
));
4566 /* Compute the last element of the range, which is not
4567 necessarily "end" (think 0:5:3, which doesn't contain 5)
4568 and check it against both lower and upper bounds. */
4570 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4571 gfc_array_index_type
, end
,
4573 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4574 gfc_array_index_type
, tmp
,
4576 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4577 gfc_array_index_type
, end
, tmp
);
4578 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4579 logical_type_node
, tmp
, lbound
);
4580 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4581 logical_type_node
, non_zerosized
, tmp2
);
4584 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4585 logical_type_node
, tmp
, ubound
);
4586 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4587 logical_type_node
, non_zerosized
, tmp3
);
4588 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4589 "outside of expected range (%%ld:%%ld)",
4590 dim
+ 1, expr_name
);
4591 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4593 fold_convert (long_integer_type_node
, tmp
),
4594 fold_convert (long_integer_type_node
, ubound
),
4595 fold_convert (long_integer_type_node
, lbound
));
4596 gfc_trans_runtime_check (true, false, tmp3
, &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
));
4605 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4606 "below lower bound of %%ld",
4607 dim
+ 1, expr_name
);
4608 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4610 fold_convert (long_integer_type_node
, tmp
),
4611 fold_convert (long_integer_type_node
, lbound
));
4615 /* Check the section sizes match. */
4616 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4617 gfc_array_index_type
, end
,
4619 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4620 gfc_array_index_type
, tmp
,
4622 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4623 gfc_array_index_type
,
4624 gfc_index_one_node
, tmp
);
4625 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4626 gfc_array_index_type
, tmp
,
4627 build_int_cst (gfc_array_index_type
, 0));
4628 /* We remember the size of the first section, and check all the
4629 others against this. */
4632 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4633 logical_type_node
, tmp
, size
[n
]);
4634 msg
= xasprintf ("Array bound mismatch for dimension %d "
4635 "of array '%s' (%%ld/%%ld)",
4636 dim
+ 1, expr_name
);
4638 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4640 fold_convert (long_integer_type_node
, tmp
),
4641 fold_convert (long_integer_type_node
, size
[n
]));
4646 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4649 tmp
= gfc_finish_block (&inner
);
4651 /* For optional arguments, only check bounds if the argument is
4653 if (expr
->symtree
->n
.sym
->attr
.optional
4654 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4655 tmp
= build3_v (COND_EXPR
,
4656 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4657 tmp
, build_empty_stmt (input_location
));
4659 gfc_add_expr_to_block (&block
, tmp
);
4663 tmp
= gfc_finish_block (&block
);
4664 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4667 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4668 gfc_conv_ss_startstride (loop
);
4671 /* Return true if both symbols could refer to the same data object. Does
4672 not take account of aliasing due to equivalence statements. */
4675 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4676 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4678 /* Aliasing isn't possible if the symbols have different base types. */
4679 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4682 /* Pointers can point to other pointers and target objects. */
4684 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4685 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4688 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4689 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4691 if (lsym_target
&& rsym_target
4692 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4693 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4694 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4695 && (!rsym
->attr
.dimension
4696 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4703 /* Return true if the two SS could be aliased, i.e. both point to the same data
4705 /* TODO: resolve aliases based on frontend expressions. */
4708 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4712 gfc_expr
*lexpr
, *rexpr
;
4715 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4717 lexpr
= lss
->info
->expr
;
4718 rexpr
= rss
->info
->expr
;
4720 lsym
= lexpr
->symtree
->n
.sym
;
4721 rsym
= rexpr
->symtree
->n
.sym
;
4723 lsym_pointer
= lsym
->attr
.pointer
;
4724 lsym_target
= lsym
->attr
.target
;
4725 rsym_pointer
= rsym
->attr
.pointer
;
4726 rsym_target
= rsym
->attr
.target
;
4728 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4729 rsym_pointer
, rsym_target
))
4732 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4733 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4736 /* For derived types we must check all the component types. We can ignore
4737 array references as these will have the same base type as the previous
4739 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4741 if (lref
->type
!= REF_COMPONENT
)
4744 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4745 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4747 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4748 rsym_pointer
, rsym_target
))
4751 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4752 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4754 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4759 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4762 if (rref
->type
!= REF_COMPONENT
)
4765 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4766 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4768 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4769 lsym_pointer
, lsym_target
,
4770 rsym_pointer
, rsym_target
))
4773 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4774 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4776 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4777 &rref
->u
.c
.sym
->ts
))
4779 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4780 &rref
->u
.c
.component
->ts
))
4782 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4783 &rref
->u
.c
.component
->ts
))
4789 lsym_pointer
= lsym
->attr
.pointer
;
4790 lsym_target
= lsym
->attr
.target
;
4792 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4794 if (rref
->type
!= REF_COMPONENT
)
4797 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4798 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4800 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4801 lsym_pointer
, lsym_target
,
4802 rsym_pointer
, rsym_target
))
4805 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4806 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4808 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4817 /* Resolve array data dependencies. Creates a temporary if required. */
4818 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4822 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4828 gfc_ss_info
*ss_info
;
4829 gfc_expr
*dest_expr
;
4834 loop
->temp_ss
= NULL
;
4835 dest_expr
= dest
->info
->expr
;
4837 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4840 ss_expr
= ss_info
->expr
;
4842 if (ss_info
->array_outer_dependency
)
4848 if (ss_info
->type
!= GFC_SS_SECTION
)
4850 if (flag_realloc_lhs
4851 && dest_expr
!= ss_expr
4852 && gfc_is_reallocatable_lhs (dest_expr
)
4854 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4856 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4857 if (!nDepend
&& dest_expr
->rank
> 0
4858 && dest_expr
->ts
.type
== BT_CHARACTER
4859 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4861 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4863 if (ss_info
->type
== GFC_SS_REFERENCE
4864 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4865 ss_info
->data
.scalar
.needs_temporary
= 1;
4873 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4875 if (gfc_could_be_alias (dest
, ss
)
4876 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4884 lref
= dest_expr
->ref
;
4885 rref
= ss_expr
->ref
;
4887 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4892 for (i
= 0; i
< dest
->dimen
; i
++)
4893 for (j
= 0; j
< ss
->dimen
; j
++)
4895 && dest
->dim
[i
] == ss
->dim
[j
])
4897 /* If we don't access array elements in the same order,
4898 there is a dependency. */
4903 /* TODO : loop shifting. */
4906 /* Mark the dimensions for LOOP SHIFTING */
4907 for (n
= 0; n
< loop
->dimen
; n
++)
4909 int dim
= dest
->data
.info
.dim
[n
];
4911 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4913 else if (! gfc_is_same_range (&lref
->u
.ar
,
4914 &rref
->u
.ar
, dim
, 0))
4918 /* Put all the dimensions with dependencies in the
4921 for (n
= 0; n
< loop
->dimen
; n
++)
4923 gcc_assert (loop
->order
[n
] == n
);
4925 loop
->order
[dim
++] = n
;
4927 for (n
= 0; n
< loop
->dimen
; n
++)
4930 loop
->order
[dim
++] = n
;
4933 gcc_assert (dim
== loop
->dimen
);
4944 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4945 if (GFC_ARRAY_TYPE_P (base_type
)
4946 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4947 base_type
= gfc_get_element_type (base_type
);
4948 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4950 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4953 loop
->temp_ss
= NULL
;
4957 /* Browse through each array's information from the scalarizer and set the loop
4958 bounds according to the "best" one (per dimension), i.e. the one which
4959 provides the most information (constant bounds, shape, etc.). */
4962 set_loop_bounds (gfc_loopinfo
*loop
)
4964 int n
, dim
, spec_dim
;
4965 gfc_array_info
*info
;
4966 gfc_array_info
*specinfo
;
4970 bool dynamic
[GFC_MAX_DIMENSIONS
];
4973 bool nonoptional_arr
;
4975 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4977 loopspec
= loop
->specloop
;
4980 for (n
= 0; n
< loop
->dimen
; n
++)
4985 /* If there are both optional and nonoptional array arguments, scalarize
4986 over the nonoptional; otherwise, it does not matter as then all
4987 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4989 nonoptional_arr
= false;
4991 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4992 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4993 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4995 nonoptional_arr
= true;
4999 /* We use one SS term, and use that to determine the bounds of the
5000 loop for this dimension. We try to pick the simplest term. */
5001 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5003 gfc_ss_type ss_type
;
5005 ss_type
= ss
->info
->type
;
5006 if (ss_type
== GFC_SS_SCALAR
5007 || ss_type
== GFC_SS_TEMP
5008 || ss_type
== GFC_SS_REFERENCE
5009 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
5012 info
= &ss
->info
->data
.array
;
5015 if (loopspec
[n
] != NULL
)
5017 specinfo
= &loopspec
[n
]->info
->data
.array
;
5018 spec_dim
= loopspec
[n
]->dim
[n
];
5022 /* Silence uninitialized warnings. */
5029 gcc_assert (info
->shape
[dim
]);
5030 /* The frontend has worked out the size for us. */
5033 || !integer_zerop (specinfo
->start
[spec_dim
]))
5034 /* Prefer zero-based descriptors if possible. */
5039 if (ss_type
== GFC_SS_CONSTRUCTOR
)
5041 gfc_constructor_base base
;
5042 /* An unknown size constructor will always be rank one.
5043 Higher rank constructors will either have known shape,
5044 or still be wrapped in a call to reshape. */
5045 gcc_assert (loop
->dimen
== 1);
5047 /* Always prefer to use the constructor bounds if the size
5048 can be determined at compile time. Prefer not to otherwise,
5049 since the general case involves realloc, and it's better to
5050 avoid that overhead if possible. */
5051 base
= ss
->info
->expr
->value
.constructor
;
5052 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
5053 if (!dynamic
[n
] || !loopspec
[n
])
5058 /* Avoid using an allocatable lhs in an assignment, since
5059 there might be a reallocation coming. */
5060 if (loopspec
[n
] && ss
->is_alloc_lhs
)
5065 /* Criteria for choosing a loop specifier (most important first):
5066 doesn't need realloc
5072 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
5074 else if (integer_onep (info
->stride
[dim
])
5075 && !integer_onep (specinfo
->stride
[spec_dim
]))
5077 else if (INTEGER_CST_P (info
->stride
[dim
])
5078 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5080 else if (INTEGER_CST_P (info
->start
[dim
])
5081 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
5082 && integer_onep (info
->stride
[dim
])
5083 == integer_onep (specinfo
->stride
[spec_dim
])
5084 && INTEGER_CST_P (info
->stride
[dim
])
5085 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5087 /* We don't work out the upper bound.
5088 else if (INTEGER_CST_P (info->finish[n])
5089 && ! INTEGER_CST_P (specinfo->finish[n]))
5090 loopspec[n] = ss; */
5093 /* We should have found the scalarization loop specifier. If not,
5095 gcc_assert (loopspec
[n
]);
5097 info
= &loopspec
[n
]->info
->data
.array
;
5098 dim
= loopspec
[n
]->dim
[n
];
5100 /* Set the extents of this range. */
5101 cshape
= info
->shape
;
5102 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5103 && INTEGER_CST_P (info
->stride
[dim
]))
5105 loop
->from
[n
] = info
->start
[dim
];
5106 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5107 mpz_sub_ui (i
, i
, 1);
5108 /* To = from + (size - 1) * stride. */
5109 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5110 if (!integer_onep (info
->stride
[dim
]))
5111 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5112 gfc_array_index_type
, tmp
,
5114 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5115 gfc_array_index_type
,
5116 loop
->from
[n
], tmp
);
5120 loop
->from
[n
] = info
->start
[dim
];
5121 switch (loopspec
[n
]->info
->type
)
5123 case GFC_SS_CONSTRUCTOR
:
5124 /* The upper bound is calculated when we expand the
5126 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5129 case GFC_SS_SECTION
:
5130 /* Use the end expression if it exists and is not constant,
5131 so that it is only evaluated once. */
5132 loop
->to
[n
] = info
->end
[dim
];
5135 case GFC_SS_FUNCTION
:
5136 /* The loop bound will be set when we generate the call. */
5137 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5140 case GFC_SS_INTRINSIC
:
5142 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5144 /* The {l,u}bound of an assumed rank. */
5145 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5146 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5147 && expr
->value
.function
.actual
->next
->expr
== NULL
5148 && expr
->value
.function
.actual
->expr
->rank
== -1);
5150 loop
->to
[n
] = info
->end
[dim
];
5154 case GFC_SS_COMPONENT
:
5156 if (info
->end
[dim
] != NULL_TREE
)
5158 loop
->to
[n
] = info
->end
[dim
];
5170 /* Transform everything so we have a simple incrementing variable. */
5171 if (integer_onep (info
->stride
[dim
]))
5172 info
->delta
[dim
] = gfc_index_zero_node
;
5175 /* Set the delta for this section. */
5176 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5177 /* Number of iterations is (end - start + step) / step.
5178 with start = 0, this simplifies to
5180 for (i = 0; i<=last; i++){...}; */
5181 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5182 gfc_array_index_type
, loop
->to
[n
],
5184 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5185 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5186 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5187 tmp
, build_int_cst (gfc_array_index_type
, -1));
5188 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5189 /* Make the loop variable start at 0. */
5190 loop
->from
[n
] = gfc_index_zero_node
;
5195 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5196 set_loop_bounds (loop
);
5200 /* Initialize the scalarization loop. Creates the loop variables. Determines
5201 the range of the loop variables. Creates a temporary if required.
5202 Also generates code for scalar expressions which have been
5203 moved outside the loop. */
5206 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5211 set_loop_bounds (loop
);
5213 /* Add all the scalar code that can be taken out of the loops.
5214 This may include calculating the loop bounds, so do it before
5215 allocating the temporary. */
5216 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5218 tmp_ss
= loop
->temp_ss
;
5219 /* If we want a temporary then create it. */
5222 gfc_ss_info
*tmp_ss_info
;
5224 tmp_ss_info
= tmp_ss
->info
;
5225 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5226 gcc_assert (loop
->parent
== NULL
);
5228 /* Make absolutely sure that this is a complete type. */
5229 if (tmp_ss_info
->string_length
)
5230 tmp_ss_info
->data
.temp
.type
5231 = gfc_get_character_type_len_for_eltype
5232 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5233 tmp_ss_info
->string_length
);
5235 tmp
= tmp_ss_info
->data
.temp
.type
;
5236 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5237 tmp_ss_info
->type
= GFC_SS_SECTION
;
5239 gcc_assert (tmp_ss
->dimen
!= 0);
5241 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5242 NULL_TREE
, false, true, false, where
);
5245 /* For array parameters we don't have loop variables, so don't calculate the
5247 if (!loop
->array_parameter
)
5248 gfc_set_delta (loop
);
5252 /* Calculates how to transform from loop variables to array indices for each
5253 array: once loop bounds are chosen, sets the difference (DELTA field) between
5254 loop bounds and array reference bounds, for each array info. */
5257 gfc_set_delta (gfc_loopinfo
*loop
)
5259 gfc_ss
*ss
, **loopspec
;
5260 gfc_array_info
*info
;
5264 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5266 loopspec
= loop
->specloop
;
5268 /* Calculate the translation from loop variables to array indices. */
5269 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5271 gfc_ss_type ss_type
;
5273 ss_type
= ss
->info
->type
;
5274 if (ss_type
!= GFC_SS_SECTION
5275 && ss_type
!= GFC_SS_COMPONENT
5276 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5279 info
= &ss
->info
->data
.array
;
5281 for (n
= 0; n
< ss
->dimen
; n
++)
5283 /* If we are specifying the range the delta is already set. */
5284 if (loopspec
[n
] != ss
)
5288 /* Calculate the offset relative to the loop variable.
5289 First multiply by the stride. */
5290 tmp
= loop
->from
[n
];
5291 if (!integer_onep (info
->stride
[dim
]))
5292 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5293 gfc_array_index_type
,
5294 tmp
, info
->stride
[dim
]);
5296 /* Then subtract this from our starting value. */
5297 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5298 gfc_array_index_type
,
5299 info
->start
[dim
], tmp
);
5301 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5306 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5307 gfc_set_delta (loop
);
5311 /* Calculate the size of a given array dimension from the bounds. This
5312 is simply (ubound - lbound + 1) if this expression is positive
5313 or 0 if it is negative (pick either one if it is zero). Optionally
5314 (if or_expr is present) OR the (expression != 0) condition to it. */
5317 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5322 /* Calculate (ubound - lbound + 1). */
5323 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5325 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5326 gfc_index_one_node
);
5328 /* Check whether the size for this dimension is negative. */
5329 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5330 gfc_index_zero_node
);
5331 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5332 gfc_index_zero_node
, res
);
5334 /* Build OR expression. */
5336 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5337 logical_type_node
, *or_expr
, cond
);
5343 /* For an array descriptor, get the total number of elements. This is just
5344 the product of the extents along from_dim to to_dim. */
5347 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5352 res
= gfc_index_one_node
;
5354 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5360 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5361 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5363 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5364 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5372 /* Full size of an array. */
5375 gfc_conv_descriptor_size (tree desc
, int rank
)
5377 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5381 /* Size of a coarray for all dimensions but the last. */
5384 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5386 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5390 /* Fills in an array descriptor, and returns the size of the array.
5391 The size will be a simple_val, ie a variable or a constant. Also
5392 calculates the offset of the base. The pointer argument overflow,
5393 which should be of integer type, will increase in value if overflow
5394 occurs during the size calculation. Returns the size of the array.
5398 for (n = 0; n < rank; n++)
5400 a.lbound[n] = specified_lower_bound;
5401 offset = offset + a.lbond[n] * stride;
5403 a.ubound[n] = specified_upper_bound;
5404 a.stride[n] = stride;
5405 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5406 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5407 stride = stride * size;
5409 for (n = rank; n < rank+corank; n++)
5410 (Set lcobound/ucobound as above.)
5411 element_size = sizeof (array element);
5414 stride = (size_t) stride;
5415 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5416 stride = stride * element_size;
5422 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5423 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5424 stmtblock_t
* descriptor_block
, tree
* overflow
,
5425 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5426 tree expr3_desc
, bool e3_has_nodescriptor
, gfc_expr
*expr
,
5439 stmtblock_t thenblock
;
5440 stmtblock_t elseblock
;
5445 type
= TREE_TYPE (descriptor
);
5447 stride
= gfc_index_one_node
;
5448 offset
= gfc_index_zero_node
;
5450 /* Set the dtype before the alloc, because registration of coarrays needs
5452 if (expr
->ts
.type
== BT_CHARACTER
5453 && expr
->ts
.deferred
5454 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5456 type
= gfc_typenode_for_spec (&expr
->ts
);
5457 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5458 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5460 else if (expr
->ts
.type
== BT_CHARACTER
5461 && expr
->ts
.deferred
5462 && TREE_CODE (descriptor
) == COMPONENT_REF
)
5464 /* Deferred character components have their string length tucked away
5465 in a hidden field of the derived type. Obtain that and use it to
5466 set the dtype. The charlen backend decl is zero because the field
5467 type is zero length. */
5470 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5471 if (ref
->type
== REF_COMPONENT
5472 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
5474 gcc_assert (tmp
!= NULL_TREE
);
5475 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
5476 TREE_OPERAND (descriptor
, 0), tmp
, NULL_TREE
);
5477 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
5478 type
= gfc_get_character_type_len (expr
->ts
.kind
, tmp
);
5479 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5480 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5484 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5485 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5488 or_expr
= logical_false_node
;
5490 for (n
= 0; n
< rank
; n
++)
5495 /* We have 3 possibilities for determining the size of the array:
5496 lower == NULL => lbound = 1, ubound = upper[n]
5497 upper[n] = NULL => lbound = 1, ubound = lower[n]
5498 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5501 /* Set lower bound. */
5502 gfc_init_se (&se
, NULL
);
5503 if (expr3_desc
!= NULL_TREE
)
5505 if (e3_has_nodescriptor
)
5506 /* The lbound of nondescriptor arrays like array constructors,
5507 nonallocatable/nonpointer function results/variables,
5508 start at zero, but when allocating it, the standard expects
5509 the array to start at one. */
5510 se
.expr
= gfc_index_one_node
;
5512 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5515 else if (lower
== NULL
)
5516 se
.expr
= gfc_index_one_node
;
5519 gcc_assert (lower
[n
]);
5522 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5523 gfc_add_block_to_block (pblock
, &se
.pre
);
5527 se
.expr
= gfc_index_one_node
;
5531 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5532 gfc_rank_cst
[n
], se
.expr
);
5533 conv_lbound
= se
.expr
;
5535 /* Work out the offset for this component. */
5536 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5538 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5539 gfc_array_index_type
, offset
, tmp
);
5541 /* Set upper bound. */
5542 gfc_init_se (&se
, NULL
);
5543 if (expr3_desc
!= NULL_TREE
)
5545 if (e3_has_nodescriptor
)
5547 /* The lbound of nondescriptor arrays like array constructors,
5548 nonallocatable/nonpointer function results/variables,
5549 start at zero, but when allocating it, the standard expects
5550 the array to start at one. Therefore fix the upper bound to be
5551 (desc.ubound - desc.lbound) + 1. */
5552 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5553 gfc_array_index_type
,
5554 gfc_conv_descriptor_ubound_get (
5555 expr3_desc
, gfc_rank_cst
[n
]),
5556 gfc_conv_descriptor_lbound_get (
5557 expr3_desc
, gfc_rank_cst
[n
]));
5558 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5559 gfc_array_index_type
, tmp
,
5560 gfc_index_one_node
);
5561 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5564 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5569 gcc_assert (ubound
);
5570 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5571 gfc_add_block_to_block (pblock
, &se
.pre
);
5572 if (ubound
->expr_type
== EXPR_FUNCTION
)
5573 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5575 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5576 gfc_rank_cst
[n
], se
.expr
);
5577 conv_ubound
= se
.expr
;
5579 /* Store the stride. */
5580 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5581 gfc_rank_cst
[n
], stride
);
5583 /* Calculate size and check whether extent is negative. */
5584 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5585 size
= gfc_evaluate_now (size
, pblock
);
5587 /* Check whether multiplying the stride by the number of
5588 elements in this dimension would overflow. We must also check
5589 whether the current dimension has zero size in order to avoid
5592 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5593 gfc_array_index_type
,
5594 fold_convert (gfc_array_index_type
,
5595 TYPE_MAX_VALUE (gfc_array_index_type
)),
5597 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5598 logical_type_node
, tmp
, stride
),
5599 PRED_FORTRAN_OVERFLOW
);
5600 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5601 integer_one_node
, integer_zero_node
);
5602 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5603 logical_type_node
, size
,
5604 gfc_index_zero_node
),
5605 PRED_FORTRAN_SIZE_ZERO
);
5606 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5607 integer_zero_node
, tmp
);
5608 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5610 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5612 /* Multiply the stride by the number of elements in this dimension. */
5613 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5614 gfc_array_index_type
, stride
, size
);
5615 stride
= gfc_evaluate_now (stride
, pblock
);
5618 for (n
= rank
; n
< rank
+ corank
; n
++)
5622 /* Set lower bound. */
5623 gfc_init_se (&se
, NULL
);
5624 if (lower
== NULL
|| lower
[n
] == NULL
)
5626 gcc_assert (n
== rank
+ corank
- 1);
5627 se
.expr
= gfc_index_one_node
;
5631 if (ubound
|| n
== rank
+ corank
- 1)
5633 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5634 gfc_add_block_to_block (pblock
, &se
.pre
);
5638 se
.expr
= gfc_index_one_node
;
5642 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5643 gfc_rank_cst
[n
], se
.expr
);
5645 if (n
< rank
+ corank
- 1)
5647 gfc_init_se (&se
, NULL
);
5648 gcc_assert (ubound
);
5649 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5650 gfc_add_block_to_block (pblock
, &se
.pre
);
5651 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5652 gfc_rank_cst
[n
], se
.expr
);
5656 /* The stride is the number of elements in the array, so multiply by the
5657 size of an element to get the total size. Obviously, if there is a
5658 SOURCE expression (expr3) we must use its element size. */
5659 if (expr3_elem_size
!= NULL_TREE
)
5660 tmp
= expr3_elem_size
;
5661 else if (expr3
!= NULL
)
5663 if (expr3
->ts
.type
== BT_CLASS
)
5666 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5667 gfc_add_vptr_component (sz
);
5668 gfc_add_size_component (sz
);
5669 gfc_init_se (&se_sz
, NULL
);
5670 gfc_conv_expr (&se_sz
, sz
);
5676 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5677 tmp
= TYPE_SIZE_UNIT (tmp
);
5681 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5683 /* Convert to size_t. */
5684 *element_size
= fold_convert (size_type_node
, tmp
);
5687 return *element_size
;
5689 *nelems
= gfc_evaluate_now (stride
, pblock
);
5690 stride
= fold_convert (size_type_node
, stride
);
5692 /* First check for overflow. Since an array of type character can
5693 have zero element_size, we must check for that before
5695 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5697 TYPE_MAX_VALUE (size_type_node
), *element_size
);
5698 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5699 logical_type_node
, tmp
, stride
),
5700 PRED_FORTRAN_OVERFLOW
);
5701 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5702 integer_one_node
, integer_zero_node
);
5703 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5704 logical_type_node
, *element_size
,
5705 build_int_cst (size_type_node
, 0)),
5706 PRED_FORTRAN_SIZE_ZERO
);
5707 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5708 integer_zero_node
, tmp
);
5709 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5711 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5713 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5714 stride
, *element_size
);
5716 if (poffset
!= NULL
)
5718 offset
= gfc_evaluate_now (offset
, pblock
);
5722 if (integer_zerop (or_expr
))
5724 if (integer_onep (or_expr
))
5725 return build_int_cst (size_type_node
, 0);
5727 var
= gfc_create_var (TREE_TYPE (size
), "size");
5728 gfc_start_block (&thenblock
);
5729 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5730 thencase
= gfc_finish_block (&thenblock
);
5732 gfc_start_block (&elseblock
);
5733 gfc_add_modify (&elseblock
, var
, size
);
5734 elsecase
= gfc_finish_block (&elseblock
);
5736 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5737 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5738 gfc_add_expr_to_block (pblock
, tmp
);
5744 /* Retrieve the last ref from the chain. This routine is specific to
5745 gfc_array_allocate ()'s needs. */
5748 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5750 gfc_ref
*ref
, *prev_ref
;
5753 /* Prevent warnings for uninitialized variables. */
5754 prev_ref
= *prev_ref_in
;
5755 while (ref
&& ref
->next
!= NULL
)
5757 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5758 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5763 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5767 *prev_ref_in
= prev_ref
;
5771 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5772 the work for an ALLOCATE statement. */
5776 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5777 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5778 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5779 bool e3_has_nodescriptor
)
5783 tree offset
= NULL_TREE
;
5784 tree token
= NULL_TREE
;
5787 tree error
= NULL_TREE
;
5788 tree overflow
; /* Boolean storing whether size calculation overflows. */
5789 tree var_overflow
= NULL_TREE
;
5791 tree set_descriptor
;
5792 tree not_prev_allocated
= NULL_TREE
;
5793 tree element_size
= NULL_TREE
;
5794 stmtblock_t set_descriptor_block
;
5795 stmtblock_t elseblock
;
5798 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5799 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5800 non_ulimate_coarray_ptr_comp
;
5804 /* Find the last reference in the chain. */
5805 if (!retrieve_last_ref (&ref
, &prev_ref
))
5808 /* Take the allocatable and coarray properties solely from the expr-ref's
5809 attributes and not from source=-expression. */
5812 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5813 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5814 non_ulimate_coarray_ptr_comp
= false;
5818 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5819 /* Pointer components in coarrayed derived types must be treated
5820 specially in that they are registered without a check if the are
5821 already associated. This does not hold for ultimate coarray
5823 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5824 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5825 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5828 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5829 a coarray. In this case it does not matter whether we are on this_image
5832 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5833 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5840 gcc_assert (coarray
);
5842 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5844 gfc_ref
*old_ref
= ref
;
5845 /* F08:C633: Array shape from expr3. */
5848 /* Find the last reference in the chain. */
5849 if (!retrieve_last_ref (&ref
, &prev_ref
))
5851 if (expr3
->expr_type
== EXPR_FUNCTION
5852 && gfc_expr_attr (expr3
).dimension
)
5857 alloc_w_e3_arr_spec
= true;
5860 /* Figure out the size of the array. */
5861 switch (ref
->u
.ar
.type
)
5867 upper
= ref
->u
.ar
.start
;
5873 lower
= ref
->u
.ar
.start
;
5874 upper
= ref
->u
.ar
.end
;
5878 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5879 || alloc_w_e3_arr_spec
);
5881 lower
= ref
->u
.ar
.as
->lower
;
5882 upper
= ref
->u
.ar
.as
->upper
;
5890 overflow
= integer_zero_node
;
5892 if (expr
->ts
.type
== BT_CHARACTER
5893 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5894 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
5895 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5896 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5897 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5898 se
->string_length
));
5900 gfc_init_block (&set_descriptor_block
);
5901 /* Take the corank only from the actual ref and not from the coref. The
5902 later will mislead the generation of the array dimensions for allocatable/
5903 pointer components in derived types. */
5904 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5905 : ref
->u
.ar
.as
->rank
,
5906 coarray
? ref
->u
.ar
.as
->corank
: 0,
5907 &offset
, lower
, upper
,
5908 &se
->pre
, &set_descriptor_block
, &overflow
,
5909 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5910 e3_has_nodescriptor
, expr
, &element_size
);
5914 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5915 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5917 if (status
== NULL_TREE
)
5919 /* Generate the block of code handling overflow. */
5920 msg
= gfc_build_addr_expr (pchar_type_node
,
5921 gfc_build_localized_cstring_const
5922 ("Integer overflow when calculating the amount of "
5923 "memory to allocate"));
5924 error
= build_call_expr_loc (input_location
,
5925 gfor_fndecl_runtime_error
, 1, msg
);
5929 tree status_type
= TREE_TYPE (status
);
5930 stmtblock_t set_status_block
;
5932 gfc_start_block (&set_status_block
);
5933 gfc_add_modify (&set_status_block
, status
,
5934 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5935 error
= gfc_finish_block (&set_status_block
);
5939 /* Allocate memory to store the data. */
5940 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5941 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5943 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5945 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5946 : gfc_conv_descriptor_data_get (se
->expr
);
5947 token
= gfc_conv_descriptor_token (se
->expr
);
5948 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5951 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5952 STRIP_NOPS (pointer
);
5956 not_prev_allocated
= gfc_create_var (logical_type_node
,
5957 "not_prev_allocated");
5958 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5959 logical_type_node
, pointer
,
5960 build_int_cst (TREE_TYPE (pointer
), 0));
5962 gfc_add_modify (&se
->pre
, not_prev_allocated
, tmp
);
5965 gfc_start_block (&elseblock
);
5967 /* The allocatable variant takes the old pointer as first argument. */
5969 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5970 status
, errmsg
, errlen
, label_finish
, expr
,
5971 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5972 else if (non_ulimate_coarray_ptr_comp
&& token
)
5973 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5974 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5976 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5978 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5982 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5983 logical_type_node
, var_overflow
, integer_zero_node
),
5984 PRED_FORTRAN_OVERFLOW
);
5985 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5986 error
, gfc_finish_block (&elseblock
));
5989 tmp
= gfc_finish_block (&elseblock
);
5991 gfc_add_expr_to_block (&se
->pre
, tmp
);
5993 /* Update the array descriptor with the offset and the span. */
5996 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5997 tmp
= fold_convert (gfc_array_index_type
, element_size
);
5998 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
6001 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
6002 if (status
!= NULL_TREE
)
6004 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6005 logical_type_node
, status
,
6006 build_int_cst (TREE_TYPE (status
), 0));
6008 if (not_prev_allocated
!= NULL_TREE
)
6009 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6010 logical_type_node
, cond
, not_prev_allocated
);
6012 gfc_add_expr_to_block (&se
->pre
,
6013 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6016 build_empty_stmt (input_location
)));
6019 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
6025 /* Create an array constructor from an initialization expression.
6026 We assume the frontend already did any expansions and conversions. */
6029 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
6035 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6037 if (expr
->expr_type
== EXPR_VARIABLE
6038 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6039 && expr
->symtree
->n
.sym
->value
)
6040 expr
= expr
->symtree
->n
.sym
->value
;
6042 switch (expr
->expr_type
)
6045 case EXPR_STRUCTURE
:
6046 /* A single scalar or derived type value. Create an array with all
6047 elements equal to that value. */
6048 gfc_init_se (&se
, NULL
);
6050 if (expr
->expr_type
== EXPR_CONSTANT
)
6051 gfc_conv_constant (&se
, expr
);
6053 gfc_conv_structure (&se
, expr
, 1);
6055 CONSTRUCTOR_APPEND_ELT (v
, build2 (RANGE_EXPR
, gfc_array_index_type
,
6056 TYPE_MIN_VALUE (TYPE_DOMAIN (type
)),
6057 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))),
6062 /* Create a vector of all the elements. */
6063 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6064 c
; c
= gfc_constructor_next (c
))
6068 /* Problems occur when we get something like
6069 integer :: a(lots) = (/(i, i=1, lots)/) */
6070 gfc_fatal_error ("The number of elements in the array "
6071 "constructor at %L requires an increase of "
6072 "the allowed %d upper limit. See "
6073 "%<-fmax-array-constructor%> option",
6074 &expr
->where
, flag_max_array_constructor
);
6077 if (mpz_cmp_si (c
->offset
, 0) != 0)
6078 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6082 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6088 mpz_add (maxval
, c
->offset
, c
->repeat
);
6089 mpz_sub_ui (maxval
, maxval
, 1);
6090 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6091 if (mpz_cmp_si (c
->offset
, 0) != 0)
6093 mpz_add_ui (maxval
, c
->offset
, 1);
6094 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6097 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6099 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6105 gfc_init_se (&se
, NULL
);
6106 switch (c
->expr
->expr_type
)
6109 gfc_conv_constant (&se
, c
->expr
);
6111 /* See gfortran.dg/charlen_15.f90 for instance. */
6112 if (TREE_CODE (se
.expr
) == STRING_CST
6113 && TREE_CODE (type
) == ARRAY_TYPE
)
6116 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6117 atype
= TREE_TYPE (atype
);
6118 gcc_checking_assert (TREE_CODE (TREE_TYPE (atype
))
6120 gcc_checking_assert (TREE_TYPE (TREE_TYPE (se
.expr
))
6121 == TREE_TYPE (atype
));
6122 if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6123 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6125 unsigned HOST_WIDE_INT size
6126 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6127 const char *p
= TREE_STRING_POINTER (se
.expr
);
6129 se
.expr
= build_string (size
, p
);
6131 TREE_TYPE (se
.expr
) = atype
;
6135 case EXPR_STRUCTURE
:
6136 gfc_conv_structure (&se
, c
->expr
, 1);
6140 /* Catch those occasional beasts that do not simplify
6141 for one reason or another, assuming that if they are
6142 standard defying the frontend will catch them. */
6143 gfc_conv_expr (&se
, c
->expr
);
6147 if (range
== NULL_TREE
)
6148 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6151 if (index
!= NULL_TREE
)
6152 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6153 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6159 return gfc_build_null_descriptor (type
);
6165 /* Create a constructor from the list of elements. */
6166 tmp
= build_constructor (type
, v
);
6167 TREE_CONSTANT (tmp
) = 1;
6172 /* Generate code to evaluate non-constant coarray cobounds. */
6175 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6176 const gfc_symbol
*sym
)
6184 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6186 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6188 /* Evaluate non-constant array bound expressions. */
6189 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6190 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6192 gfc_init_se (&se
, NULL
);
6193 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6194 gfc_add_block_to_block (pblock
, &se
.pre
);
6195 gfc_add_modify (pblock
, lbound
, se
.expr
);
6197 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6198 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6200 gfc_init_se (&se
, NULL
);
6201 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6202 gfc_add_block_to_block (pblock
, &se
.pre
);
6203 gfc_add_modify (pblock
, ubound
, se
.expr
);
6209 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6210 returns the size (in elements) of the array. */
6213 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6214 stmtblock_t
* pblock
)
6227 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6229 size
= gfc_index_one_node
;
6230 offset
= gfc_index_zero_node
;
6231 for (dim
= 0; dim
< as
->rank
; dim
++)
6233 /* Evaluate non-constant array bound expressions. */
6234 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6235 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6237 gfc_init_se (&se
, NULL
);
6238 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6239 gfc_add_block_to_block (pblock
, &se
.pre
);
6240 gfc_add_modify (pblock
, lbound
, se
.expr
);
6242 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6243 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6245 gfc_init_se (&se
, NULL
);
6246 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6247 gfc_add_block_to_block (pblock
, &se
.pre
);
6248 gfc_add_modify (pblock
, ubound
, se
.expr
);
6250 /* The offset of this dimension. offset = offset - lbound * stride. */
6251 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6253 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6256 /* The size of this dimension, and the stride of the next. */
6257 if (dim
+ 1 < as
->rank
)
6258 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6260 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6262 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6264 /* Calculate stride = size * (ubound + 1 - lbound). */
6265 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6266 gfc_array_index_type
,
6267 gfc_index_one_node
, lbound
);
6268 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6269 gfc_array_index_type
, ubound
, tmp
);
6270 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6271 gfc_array_index_type
, size
, tmp
);
6273 gfc_add_modify (pblock
, stride
, tmp
);
6275 stride
= gfc_evaluate_now (tmp
, pblock
);
6277 /* Make sure that negative size arrays are translated
6278 to being zero size. */
6279 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6280 stride
, gfc_index_zero_node
);
6281 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6282 gfc_array_index_type
, tmp
,
6283 stride
, gfc_index_zero_node
);
6284 gfc_add_modify (pblock
, stride
, tmp
);
6290 gfc_trans_array_cobounds (type
, pblock
, sym
);
6291 gfc_trans_vla_type_sizes (sym
, pblock
);
6298 /* Generate code to initialize/allocate an array variable. */
6301 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6302 gfc_wrapped_block
* block
)
6306 tree tmp
= NULL_TREE
;
6313 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6315 /* Do nothing for USEd variables. */
6316 if (sym
->attr
.use_assoc
)
6319 type
= TREE_TYPE (decl
);
6320 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6321 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6323 gfc_init_block (&init
);
6325 /* Evaluate character string length. */
6326 if (sym
->ts
.type
== BT_CHARACTER
6327 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6329 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6331 gfc_trans_vla_type_sizes (sym
, &init
);
6333 /* Emit a DECL_EXPR for this variable, which will cause the
6334 gimplifier to allocate storage, and all that good stuff. */
6335 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6336 gfc_add_expr_to_block (&init
, tmp
);
6341 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6345 type
= TREE_TYPE (type
);
6347 gcc_assert (!sym
->attr
.use_assoc
);
6348 gcc_assert (!TREE_STATIC (decl
));
6349 gcc_assert (!sym
->module
);
6351 if (sym
->ts
.type
== BT_CHARACTER
6352 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6353 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6355 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6357 /* Don't actually allocate space for Cray Pointees. */
6358 if (sym
->attr
.cray_pointee
)
6360 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6361 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6363 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6367 if (flag_stack_arrays
)
6369 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6370 space
= build_decl (gfc_get_location (&sym
->declared_at
),
6371 VAR_DECL
, create_tmp_var_name ("A"),
6372 TREE_TYPE (TREE_TYPE (decl
)));
6373 gfc_trans_vla_type_sizes (sym
, &init
);
6377 /* The size is the number of elements in the array, so multiply by the
6378 size of an element to get the total size. */
6379 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6380 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6381 size
, fold_convert (gfc_array_index_type
, tmp
));
6383 /* Allocate memory to hold the data. */
6384 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6385 gfc_add_modify (&init
, decl
, tmp
);
6387 /* Free the temporary. */
6388 tmp
= gfc_call_free (decl
);
6392 /* Set offset of the array. */
6393 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6394 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6396 /* Automatic arrays should not have initializers. */
6397 gcc_assert (!sym
->value
);
6399 inittree
= gfc_finish_block (&init
);
6406 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6407 where also space is located. */
6408 gfc_init_block (&init
);
6409 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6410 TREE_TYPE (space
), space
);
6411 gfc_add_expr_to_block (&init
, tmp
);
6412 addr
= fold_build1_loc (gfc_get_location (&sym
->declared_at
),
6413 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6414 gfc_add_modify (&init
, decl
, addr
);
6415 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6418 gfc_add_init_cleanup (block
, inittree
, tmp
);
6422 /* Generate entry and exit code for g77 calling convention arrays. */
6425 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6435 gfc_save_backend_locus (&loc
);
6436 gfc_set_backend_locus (&sym
->declared_at
);
6438 /* Descriptor type. */
6439 parm
= sym
->backend_decl
;
6440 type
= TREE_TYPE (parm
);
6441 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6443 gfc_start_block (&init
);
6445 if (sym
->ts
.type
== BT_CHARACTER
6446 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6447 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6449 /* Evaluate the bounds of the array. */
6450 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6452 /* Set the offset. */
6453 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6454 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6456 /* Set the pointer itself if we aren't using the parameter directly. */
6457 if (TREE_CODE (parm
) != PARM_DECL
)
6459 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6460 gfc_add_modify (&init
, parm
, tmp
);
6462 stmt
= gfc_finish_block (&init
);
6464 gfc_restore_backend_locus (&loc
);
6466 /* Add the initialization code to the start of the function. */
6468 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6470 tmp
= gfc_conv_expr_present (sym
);
6471 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6474 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6478 /* Modify the descriptor of an array parameter so that it has the
6479 correct lower bound. Also move the upper bound accordingly.
6480 If the array is not packed, it will be copied into a temporary.
6481 For each dimension we set the new lower and upper bounds. Then we copy the
6482 stride and calculate the offset for this dimension. We also work out
6483 what the stride of a packed array would be, and see it the two match.
6484 If the array need repacking, we set the stride to the values we just
6485 calculated, recalculate the offset and copy the array data.
6486 Code is also added to copy the data back at the end of the function.
6490 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6491 gfc_wrapped_block
* block
)
6498 tree stmtInit
, stmtCleanup
;
6505 tree stride
, stride2
;
6515 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6517 /* Do nothing for pointer and allocatable arrays. */
6518 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6519 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6520 || sym
->attr
.allocatable
6521 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6524 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6526 gfc_trans_g77_array (sym
, block
);
6531 gfc_save_backend_locus (&loc
);
6532 /* loc.nextc is not set by save_backend_locus but the location routines
6534 if (loc
.nextc
== NULL
)
6535 loc
.nextc
= loc
.lb
->line
;
6536 gfc_set_backend_locus (&sym
->declared_at
);
6538 /* Descriptor type. */
6539 type
= TREE_TYPE (tmpdesc
);
6540 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6541 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6543 /* For a class array the dummy array descriptor is in the _class
6545 dumdesc
= gfc_class_data_get (dumdesc
);
6547 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6548 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6549 gfc_start_block (&init
);
6551 if (sym
->ts
.type
== BT_CHARACTER
6552 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6553 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6555 checkparm
= (as
->type
== AS_EXPLICIT
6556 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6558 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6559 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6561 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6563 /* For non-constant shape arrays we only check if the first dimension
6564 is contiguous. Repacking higher dimensions wouldn't gain us
6565 anything as we still don't know the array stride. */
6566 partial
= gfc_create_var (logical_type_node
, "partial");
6567 TREE_USED (partial
) = 1;
6568 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6569 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6570 gfc_index_one_node
);
6571 gfc_add_modify (&init
, partial
, tmp
);
6574 partial
= NULL_TREE
;
6576 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6577 here, however I think it does the right thing. */
6580 /* Set the first stride. */
6581 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6582 stride
= gfc_evaluate_now (stride
, &init
);
6584 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6585 stride
, gfc_index_zero_node
);
6586 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6587 tmp
, gfc_index_one_node
, stride
);
6588 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6589 gfc_add_modify (&init
, stride
, tmp
);
6591 /* Allow the user to disable array repacking. */
6592 stmt_unpacked
= NULL_TREE
;
6596 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6597 /* A library call to repack the array if necessary. */
6598 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6599 stmt_unpacked
= build_call_expr_loc (input_location
,
6600 gfor_fndecl_in_pack
, 1, tmp
);
6602 stride
= gfc_index_one_node
;
6604 if (warn_array_temporaries
)
6605 gfc_warning (OPT_Warray_temporaries
,
6606 "Creating array temporary at %L", &loc
);
6609 /* This is for the case where the array data is used directly without
6610 calling the repack function. */
6611 if (no_repack
|| partial
!= NULL_TREE
)
6612 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6614 stmt_packed
= NULL_TREE
;
6616 /* Assign the data pointer. */
6617 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6619 /* Don't repack unknown shape arrays when the first stride is 1. */
6620 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6621 partial
, stmt_packed
, stmt_unpacked
);
6624 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6625 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6627 offset
= gfc_index_zero_node
;
6628 size
= gfc_index_one_node
;
6630 /* Evaluate the bounds of the array. */
6631 for (n
= 0; n
< as
->rank
; n
++)
6633 if (checkparm
|| !as
->upper
[n
])
6635 /* Get the bounds of the actual parameter. */
6636 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6637 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6641 dubound
= NULL_TREE
;
6642 dlbound
= NULL_TREE
;
6645 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6646 if (!INTEGER_CST_P (lbound
))
6648 gfc_init_se (&se
, NULL
);
6649 gfc_conv_expr_type (&se
, as
->lower
[n
],
6650 gfc_array_index_type
);
6651 gfc_add_block_to_block (&init
, &se
.pre
);
6652 gfc_add_modify (&init
, lbound
, se
.expr
);
6655 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6656 /* Set the desired upper bound. */
6659 /* We know what we want the upper bound to be. */
6660 if (!INTEGER_CST_P (ubound
))
6662 gfc_init_se (&se
, NULL
);
6663 gfc_conv_expr_type (&se
, as
->upper
[n
],
6664 gfc_array_index_type
);
6665 gfc_add_block_to_block (&init
, &se
.pre
);
6666 gfc_add_modify (&init
, ubound
, se
.expr
);
6669 /* Check the sizes match. */
6672 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6676 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6677 gfc_array_index_type
, ubound
, lbound
);
6678 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6679 gfc_array_index_type
,
6680 gfc_index_one_node
, temp
);
6681 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6682 gfc_array_index_type
, dubound
,
6684 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6685 gfc_array_index_type
,
6686 gfc_index_one_node
, stride2
);
6687 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6688 gfc_array_index_type
, temp
, stride2
);
6689 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6690 "%%ld instead of %%ld", n
+1, sym
->name
);
6692 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6693 fold_convert (long_integer_type_node
, temp
),
6694 fold_convert (long_integer_type_node
, stride2
));
6701 /* For assumed shape arrays move the upper bound by the same amount
6702 as the lower bound. */
6703 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6704 gfc_array_index_type
, dubound
, dlbound
);
6705 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6706 gfc_array_index_type
, tmp
, lbound
);
6707 gfc_add_modify (&init
, ubound
, tmp
);
6709 /* The offset of this dimension. offset = offset - lbound * stride. */
6710 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6712 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6713 gfc_array_index_type
, offset
, tmp
);
6715 /* The size of this dimension, and the stride of the next. */
6716 if (n
+ 1 < as
->rank
)
6718 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6720 if (no_repack
|| partial
!= NULL_TREE
)
6722 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6724 /* Figure out the stride if not a known constant. */
6725 if (!INTEGER_CST_P (stride
))
6728 stmt_packed
= NULL_TREE
;
6731 /* Calculate stride = size * (ubound + 1 - lbound). */
6732 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6733 gfc_array_index_type
,
6734 gfc_index_one_node
, lbound
);
6735 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6736 gfc_array_index_type
, ubound
, tmp
);
6737 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6738 gfc_array_index_type
, size
, tmp
);
6742 /* Assign the stride. */
6743 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6744 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6745 gfc_array_index_type
, partial
,
6746 stmt_unpacked
, stmt_packed
);
6748 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6749 gfc_add_modify (&init
, stride
, tmp
);
6754 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6756 if (stride
&& !INTEGER_CST_P (stride
))
6758 /* Calculate size = stride * (ubound + 1 - lbound). */
6759 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6760 gfc_array_index_type
,
6761 gfc_index_one_node
, lbound
);
6762 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6763 gfc_array_index_type
,
6765 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6766 gfc_array_index_type
,
6767 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6768 gfc_add_modify (&init
, stride
, tmp
);
6773 gfc_trans_array_cobounds (type
, &init
, sym
);
6775 /* Set the offset. */
6776 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6777 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6779 gfc_trans_vla_type_sizes (sym
, &init
);
6781 stmtInit
= gfc_finish_block (&init
);
6783 /* Only do the entry/initialization code if the arg is present. */
6784 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6785 optional_arg
= (sym
->attr
.optional
6786 || (sym
->ns
->proc_name
->attr
.entry_master
6787 && sym
->attr
.dummy
));
6790 tree zero_init
= fold_convert (TREE_TYPE (tmpdesc
), null_pointer_node
);
6791 zero_init
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6792 tmpdesc
, zero_init
);
6793 tmp
= gfc_conv_expr_present (sym
, true);
6794 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
, zero_init
);
6799 stmtCleanup
= NULL_TREE
;
6802 stmtblock_t cleanup
;
6803 gfc_start_block (&cleanup
);
6805 if (sym
->attr
.intent
!= INTENT_IN
)
6807 /* Copy the data back. */
6808 tmp
= build_call_expr_loc (input_location
,
6809 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6810 gfc_add_expr_to_block (&cleanup
, tmp
);
6813 /* Free the temporary. */
6814 tmp
= gfc_call_free (tmpdesc
);
6815 gfc_add_expr_to_block (&cleanup
, tmp
);
6817 stmtCleanup
= gfc_finish_block (&cleanup
);
6819 /* Only do the cleanup if the array was repacked. */
6821 /* For a class array the dummy array descriptor is in the _class
6823 tmp
= gfc_class_data_get (dumdesc
);
6825 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6826 tmp
= gfc_conv_descriptor_data_get (tmp
);
6827 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6829 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6830 build_empty_stmt (input_location
));
6834 tmp
= gfc_conv_expr_present (sym
);
6835 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6836 build_empty_stmt (input_location
));
6840 /* We don't need to free any memory allocated by internal_pack as it will
6841 be freed at the end of the function by pop_context. */
6842 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6844 gfc_restore_backend_locus (&loc
);
6848 /* Calculate the overall offset, including subreferences. */
6850 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6851 bool subref
, gfc_expr
*expr
)
6861 /* If offset is NULL and this is not a subreferenced array, there is
6863 if (offset
== NULL_TREE
)
6866 offset
= gfc_index_zero_node
;
6871 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6873 /* Offset the data pointer for pointer assignments from arrays with
6874 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6877 /* Go past the array reference. */
6878 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6879 if (ref
->type
== REF_ARRAY
&&
6880 ref
->u
.ar
.type
!= AR_ELEMENT
)
6886 /* Calculate the offset for each subsequent subreference. */
6887 for (; ref
; ref
= ref
->next
)
6892 field
= ref
->u
.c
.component
->backend_decl
;
6893 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6894 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6896 tmp
, field
, NULL_TREE
);
6900 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6901 gfc_init_se (&start
, NULL
);
6902 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6903 gfc_add_block_to_block (block
, &start
.pre
);
6904 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6908 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6909 && ref
->u
.ar
.type
== AR_ELEMENT
);
6911 /* TODO - Add bounds checking. */
6912 stride
= gfc_index_one_node
;
6913 index
= gfc_index_zero_node
;
6914 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6919 /* Update the index. */
6920 gfc_init_se (&start
, NULL
);
6921 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6922 itmp
= gfc_evaluate_now (start
.expr
, block
);
6923 gfc_init_se (&start
, NULL
);
6924 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6925 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6926 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6927 gfc_array_index_type
, itmp
, jtmp
);
6928 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6929 gfc_array_index_type
, itmp
, stride
);
6930 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6931 gfc_array_index_type
, itmp
, index
);
6932 index
= gfc_evaluate_now (index
, block
);
6934 /* Update the stride. */
6935 gfc_init_se (&start
, NULL
);
6936 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6937 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6938 gfc_array_index_type
, start
.expr
,
6940 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6941 gfc_array_index_type
,
6942 gfc_index_one_node
, itmp
);
6943 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6944 gfc_array_index_type
, stride
, itmp
);
6945 stride
= gfc_evaluate_now (stride
, block
);
6948 /* Apply the index to obtain the array element. */
6949 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6956 tmp
= fold_build1_loc (input_location
, REALPART_EXPR
,
6957 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
6961 tmp
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
6962 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
6977 /* Set the target data pointer. */
6978 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6979 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6983 /* gfc_conv_expr_descriptor needs the string length an expression
6984 so that the size of the temporary can be obtained. This is done
6985 by adding up the string lengths of all the elements in the
6986 expression. Function with non-constant expressions have their
6987 string lengths mapped onto the actual arguments using the
6988 interface mapping machinery in trans-expr.c. */
6990 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6992 gfc_interface_mapping mapping
;
6993 gfc_formal_arglist
*formal
;
6994 gfc_actual_arglist
*arg
;
6998 if (expr
->ts
.u
.cl
->length
6999 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
7001 if (!expr
->ts
.u
.cl
->backend_decl
)
7002 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7006 switch (expr
->expr_type
)
7010 /* This is somewhat brutal. The expression for the first
7011 element of the array is evaluated and assigned to a
7012 new string length for the original expression. */
7013 e
= gfc_constructor_first (expr
->value
.constructor
)->expr
;
7015 gfc_init_se (&tse
, NULL
);
7017 gfc_conv_expr_descriptor (&tse
, e
);
7019 gfc_conv_expr (&tse
, e
);
7021 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7022 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7024 if (!expr
->ts
.u
.cl
->backend_decl
|| !VAR_P (expr
->ts
.u
.cl
->backend_decl
))
7026 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
7027 expr
->ts
.u
.cl
->backend_decl
=
7028 gfc_create_var (gfc_charlen_type_node
, "sln");
7031 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7037 get_array_charlen (expr
->value
.op
.op1
, se
);
7039 /* For parentheses the expression ts.u.cl is identical. */
7040 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
7043 expr
->ts
.u
.cl
->backend_decl
=
7044 gfc_create_var (gfc_charlen_type_node
, "sln");
7046 if (expr
->value
.op
.op2
)
7048 get_array_charlen (expr
->value
.op
.op2
, se
);
7050 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
7052 /* Add the string lengths and assign them to the expression
7053 string length backend declaration. */
7054 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7055 fold_build2_loc (input_location
, PLUS_EXPR
,
7056 gfc_charlen_type_node
,
7057 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
7058 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
7061 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7062 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
7066 if (expr
->value
.function
.esym
== NULL
7067 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7069 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7073 /* Map expressions involving the dummy arguments onto the actual
7074 argument expressions. */
7075 gfc_init_interface_mapping (&mapping
);
7076 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
7077 arg
= expr
->value
.function
.actual
;
7079 /* Set se = NULL in the calls to the interface mapping, to suppress any
7081 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
7086 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
7089 gfc_init_se (&tse
, NULL
);
7091 /* Build the expression for the character length and convert it. */
7092 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
7094 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7095 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7096 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
7097 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7098 TREE_TYPE (tse
.expr
), tse
.expr
,
7099 build_zero_cst (TREE_TYPE (tse
.expr
)));
7100 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
7101 gfc_free_interface_mapping (&mapping
);
7105 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7111 /* Helper function to check dimensions. */
7113 transposed_dims (gfc_ss
*ss
)
7117 for (n
= 0; n
< ss
->dimen
; n
++)
7118 if (ss
->dim
[n
] != n
)
7124 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7125 AR_FULL, suitable for the scalarizer. */
7128 walk_coarray (gfc_expr
*e
)
7132 gcc_assert (gfc_get_corank (e
) > 0);
7134 ss
= gfc_walk_expr (e
);
7136 /* Fix scalar coarray. */
7137 if (ss
== gfc_ss_terminator
)
7144 if (ref
->type
== REF_ARRAY
7145 && ref
->u
.ar
.codimen
> 0)
7151 gcc_assert (ref
!= NULL
);
7152 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7153 ref
->u
.ar
.type
= AR_SECTION
;
7154 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7161 /* Convert an array for passing as an actual argument. Expressions and
7162 vector subscripts are evaluated and stored in a temporary, which is then
7163 passed. For whole arrays the descriptor is passed. For array sections
7164 a modified copy of the descriptor is passed, but using the original data.
7166 This function is also used for array pointer assignments, and there
7169 - se->want_pointer && !se->direct_byref
7170 EXPR is an actual argument. On exit, se->expr contains a
7171 pointer to the array descriptor.
7173 - !se->want_pointer && !se->direct_byref
7174 EXPR is an actual argument to an intrinsic function or the
7175 left-hand side of a pointer assignment. On exit, se->expr
7176 contains the descriptor for EXPR.
7178 - !se->want_pointer && se->direct_byref
7179 EXPR is the right-hand side of a pointer assignment and
7180 se->expr is the descriptor for the previously-evaluated
7181 left-hand side. The function creates an assignment from
7185 The se->force_tmp flag disables the non-copying descriptor optimization
7186 that is used for transpose. It may be used in cases where there is an
7187 alias between the transpose argument and another argument in the same
7191 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7194 gfc_ss_type ss_type
;
7195 gfc_ss_info
*ss_info
;
7197 gfc_array_info
*info
;
7206 bool subref_array_target
= false;
7207 bool deferred_array_component
= false;
7208 gfc_expr
*arg
, *ss_expr
;
7210 if (se
->want_coarray
)
7211 ss
= walk_coarray (expr
);
7213 ss
= gfc_walk_expr (expr
);
7215 gcc_assert (ss
!= NULL
);
7216 gcc_assert (ss
!= gfc_ss_terminator
);
7219 ss_type
= ss_info
->type
;
7220 ss_expr
= ss_info
->expr
;
7222 /* Special case: TRANSPOSE which needs no temporary. */
7223 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7224 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7226 /* This is a call to transpose which has already been handled by the
7227 scalarizer, so that we just need to get its argument's descriptor. */
7228 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7229 expr
= expr
->value
.function
.actual
->expr
;
7232 /* Special case things we know we can pass easily. */
7233 switch (expr
->expr_type
)
7236 /* If we have a linear array section, we can pass it directly.
7237 Otherwise we need to copy it into a temporary. */
7239 gcc_assert (ss_type
== GFC_SS_SECTION
);
7240 gcc_assert (ss_expr
== expr
);
7241 info
= &ss_info
->data
.array
;
7243 /* Get the descriptor for the array. */
7244 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7245 desc
= info
->descriptor
;
7247 /* The charlen backend decl for deferred character components cannot
7248 be used because it is fixed at zero. Instead, the hidden string
7249 length component is used. */
7250 if (expr
->ts
.type
== BT_CHARACTER
7251 && expr
->ts
.deferred
7252 && TREE_CODE (desc
) == COMPONENT_REF
)
7253 deferred_array_component
= true;
7255 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7256 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7257 && !subref_array_target
;
7261 else if (se
->force_no_tmp
)
7266 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7268 /* Create a new descriptor if the array doesn't have one. */
7271 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7273 else if (se
->direct_byref
)
7276 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7278 if (full
&& !transposed_dims (ss
))
7280 if (se
->direct_byref
&& !se
->byref_noassign
)
7282 /* Copy the descriptor for pointer assignments. */
7283 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7285 /* Add any offsets from subreferences. */
7286 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7287 subref_array_target
, expr
);
7289 /* ....and set the span field. */
7290 tmp
= gfc_get_array_span (desc
, expr
);
7291 if (tmp
!= NULL_TREE
&& !integer_zerop (tmp
))
7292 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7294 else if (se
->want_pointer
)
7296 /* We pass full arrays directly. This means that pointers and
7297 allocatable arrays should also work. */
7298 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7305 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7306 se
->string_length
= gfc_get_expr_charlen (expr
);
7307 /* The ss_info string length is returned set to the value of the
7308 hidden string length component. */
7309 else if (deferred_array_component
)
7310 se
->string_length
= ss_info
->string_length
;
7312 gfc_free_ss_chain (ss
);
7318 /* A transformational function return value will be a temporary
7319 array descriptor. We still need to go through the scalarizer
7320 to create the descriptor. Elemental functions are handled as
7321 arbitrary expressions, i.e. copy to a temporary. */
7323 if (se
->direct_byref
)
7325 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7327 /* For pointer assignments pass the descriptor directly. */
7331 gcc_assert (se
->ss
== ss
);
7333 if (!is_pointer_array (se
->expr
))
7335 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7336 tmp
= fold_convert (gfc_array_index_type
,
7337 size_in_bytes (tmp
));
7338 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7341 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7342 gfc_conv_expr (se
, expr
);
7344 gfc_free_ss_chain (ss
);
7348 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7350 if (ss_expr
!= expr
)
7351 /* Elemental function. */
7352 gcc_assert ((expr
->value
.function
.esym
!= NULL
7353 && expr
->value
.function
.esym
->attr
.elemental
)
7354 || (expr
->value
.function
.isym
!= NULL
7355 && expr
->value
.function
.isym
->elemental
)
7356 || gfc_inline_intrinsic_function_p (expr
));
7358 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7361 if (expr
->ts
.type
== BT_CHARACTER
7362 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7363 get_array_charlen (expr
, se
);
7369 /* Transformational function. */
7370 info
= &ss_info
->data
.array
;
7376 /* Constant array constructors don't need a temporary. */
7377 if (ss_type
== GFC_SS_CONSTRUCTOR
7378 && expr
->ts
.type
!= BT_CHARACTER
7379 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7382 info
= &ss_info
->data
.array
;
7392 /* Something complicated. Copy it into a temporary. */
7398 /* If we are creating a temporary, we don't need to bother about aliases
7403 gfc_init_loopinfo (&loop
);
7405 /* Associate the SS with the loop. */
7406 gfc_add_ss_to_loop (&loop
, ss
);
7408 /* Tell the scalarizer not to bother creating loop variables, etc. */
7410 loop
.array_parameter
= 1;
7412 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7413 gcc_assert (!se
->direct_byref
);
7415 /* Do we need bounds checking or not? */
7416 ss
->no_bounds_check
= expr
->no_bounds_check
;
7418 /* Setup the scalarizing loops and bounds. */
7419 gfc_conv_ss_startstride (&loop
);
7423 if (expr
->ts
.type
== BT_CHARACTER
7424 && (!expr
->ts
.u
.cl
->backend_decl
|| expr
->expr_type
== EXPR_ARRAY
))
7425 get_array_charlen (expr
, se
);
7427 /* Tell the scalarizer to make a temporary. */
7428 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7429 ((expr
->ts
.type
== BT_CHARACTER
)
7430 ? expr
->ts
.u
.cl
->backend_decl
7434 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7435 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7436 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7439 gfc_conv_loop_setup (&loop
, & expr
->where
);
7443 /* Copy into a temporary and pass that. We don't need to copy the data
7444 back because expressions and vector subscripts must be INTENT_IN. */
7445 /* TODO: Optimize passing function return values. */
7450 /* Start the copying loops. */
7451 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7452 gfc_mark_ss_chain_used (ss
, 1);
7453 gfc_start_scalarized_body (&loop
, &block
);
7455 /* Copy each data element. */
7456 gfc_init_se (&lse
, NULL
);
7457 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7458 gfc_init_se (&rse
, NULL
);
7459 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7461 lse
.ss
= loop
.temp_ss
;
7464 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7465 if (expr
->ts
.type
== BT_CHARACTER
)
7467 gfc_conv_expr (&rse
, expr
);
7468 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7469 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7473 gfc_conv_expr_val (&rse
, expr
);
7475 gfc_add_block_to_block (&block
, &rse
.pre
);
7476 gfc_add_block_to_block (&block
, &lse
.pre
);
7478 lse
.string_length
= rse
.string_length
;
7480 deep_copy
= !se
->data_not_needed
7481 && (expr
->expr_type
== EXPR_VARIABLE
7482 || expr
->expr_type
== EXPR_ARRAY
);
7483 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7485 gfc_add_expr_to_block (&block
, tmp
);
7487 /* Finish the copying loops. */
7488 gfc_trans_scalarizing_loops (&loop
, &block
);
7490 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7492 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7494 desc
= info
->descriptor
;
7495 se
->string_length
= ss_info
->string_length
;
7499 /* We pass sections without copying to a temporary. Make a new
7500 descriptor and point it at the section we want. The loop variable
7501 limits will be the limits of the section.
7502 A function may decide to repack the array to speed up access, but
7503 we're not bothered about that here. */
7504 int dim
, ndim
, codim
;
7511 bool onebased
= false, rank_remap
;
7513 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7514 rank_remap
= ss
->dimen
< ndim
;
7516 if (se
->want_coarray
)
7518 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7520 codim
= gfc_get_corank (expr
);
7521 for (n
= 0; n
< codim
- 1; n
++)
7523 /* Make sure we are not lost somehow. */
7524 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7526 /* Make sure the call to gfc_conv_section_startstride won't
7527 generate unnecessary code to calculate stride. */
7528 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7530 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7531 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7532 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7535 gcc_assert (n
== codim
- 1);
7536 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7537 info
->descriptor
, n
+ ndim
, true,
7538 ar
->as
->type
== AS_DEFERRED
);
7539 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7544 /* Set the string_length for a character array. */
7545 if (expr
->ts
.type
== BT_CHARACTER
)
7547 se
->string_length
= gfc_get_expr_charlen (expr
);
7548 if (VAR_P (se
->string_length
)
7549 && expr
->ts
.u
.cl
->backend_decl
== se
->string_length
)
7550 tmp
= ss_info
->string_length
;
7552 tmp
= se
->string_length
;
7554 if (expr
->ts
.deferred
)
7555 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
, tmp
);
7558 /* If we have an array section or are assigning make sure that
7559 the lower bound is 1. References to the full
7560 array should otherwise keep the original bounds. */
7561 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7562 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7563 if (!integer_onep (loop
.from
[dim
]))
7565 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7566 gfc_array_index_type
, gfc_index_one_node
,
7568 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7569 gfc_array_index_type
,
7571 loop
.from
[dim
] = gfc_index_one_node
;
7574 desc
= info
->descriptor
;
7575 if (se
->direct_byref
&& !se
->byref_noassign
)
7577 /* For pointer assignments we fill in the destination. */
7579 parmtype
= TREE_TYPE (parm
);
7583 /* Otherwise make a new one. */
7584 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7585 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7587 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7589 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7590 loop
.from
, loop
.to
, 0,
7591 GFC_ARRAY_UNKNOWN
, false);
7592 parm
= gfc_create_var (parmtype
, "parm");
7594 /* When expression is a class object, then add the class' handle to
7596 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7598 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7601 /* class_expr can be NULL, when no _class ref is in expr.
7602 We must not fix this here with a gfc_fix_class_ref (). */
7605 gfc_init_se (&classse
, NULL
);
7606 gfc_conv_expr (&classse
, class_expr
);
7607 gfc_free_expr (class_expr
);
7609 gcc_assert (classse
.pre
.head
== NULL_TREE
7610 && classse
.post
.head
== NULL_TREE
);
7611 gfc_allocate_lang_decl (parm
);
7612 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7617 /* Set the span field. */
7618 if (expr
->ts
.type
== BT_CHARACTER
&& ss_info
->string_length
)
7619 tmp
= ss_info
->string_length
;
7621 tmp
= gfc_get_array_span (desc
, expr
);
7622 if (tmp
!= NULL_TREE
)
7623 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7625 offset
= gfc_index_zero_node
;
7627 /* The following can be somewhat confusing. We have two
7628 descriptors, a new one and the original array.
7629 {parm, parmtype, dim} refer to the new one.
7630 {desc, type, n, loop} refer to the original, which maybe
7631 a descriptorless array.
7632 The bounds of the scalarization are the bounds of the section.
7633 We don't have to worry about numeric overflows when calculating
7634 the offsets because all elements are within the array data. */
7636 /* Set the dtype. */
7637 tmp
= gfc_conv_descriptor_dtype (parm
);
7638 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7640 /* Set offset for assignments to pointer only to zero if it is not
7642 if ((se
->direct_byref
|| se
->use_offset
)
7643 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7644 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7645 base
= gfc_index_zero_node
;
7646 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7647 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7651 for (n
= 0; n
< ndim
; n
++)
7653 stride
= gfc_conv_array_stride (desc
, n
);
7655 /* Work out the offset. */
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 offset
= 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 offset. */
7685 /* Vector subscripts need copying and are handled elsewhere. */
7687 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7689 /* look for the corresponding scalarizer dimension: dim. */
7690 for (dim
= 0; dim
< ndim
; dim
++)
7691 if (ss
->dim
[dim
] == n
)
7694 /* loop exited early: the DIM being looked for has been found. */
7695 gcc_assert (dim
< ndim
);
7697 /* Set the new lower bound. */
7698 from
= loop
.from
[dim
];
7701 onebased
= integer_onep (from
);
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 if ((se
->direct_byref
|| se
->use_offset
)
7716 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7717 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7719 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7720 TREE_TYPE (base
), base
, stride
);
7722 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7725 tmp
= gfc_conv_array_lbound (desc
, n
);
7726 toonebased
= integer_onep (tmp
);
7727 // lb(arr) - from (- start + 1)
7728 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7729 TREE_TYPE (base
), tmp
, from
);
7730 if (onebased
&& toonebased
)
7732 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7733 TREE_TYPE (base
), tmp
, start
);
7734 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7735 TREE_TYPE (base
), tmp
,
7736 gfc_index_one_node
);
7738 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7739 TREE_TYPE (base
), tmp
,
7740 gfc_conv_array_stride (desc
, n
));
7741 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7742 TREE_TYPE (base
), tmp
, base
);
7745 /* Store the new stride. */
7746 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7747 gfc_rank_cst
[dim
], stride
);
7750 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7752 from
= loop
.from
[n
];
7754 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7755 gfc_rank_cst
[n
], from
);
7756 if (n
< loop
.dimen
+ codim
- 1)
7757 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7758 gfc_rank_cst
[n
], to
);
7761 if (se
->data_not_needed
)
7762 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7763 gfc_index_zero_node
);
7765 /* Point the data pointer at the 1st element in the section. */
7766 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7767 subref_array_target
, expr
);
7769 /* Force the offset to be -1, when the lower bound of the highest
7770 dimension is one and the symbol is present and is not a
7771 pointer/allocatable or associated. */
7772 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7773 && !se
->data_not_needed
)
7774 || (se
->use_offset
&& base
!= NULL_TREE
))
7776 /* Set the offset depending on base. */
7777 tmp
= rank_remap
&& !se
->direct_byref
?
7778 fold_build2_loc (input_location
, PLUS_EXPR
,
7779 gfc_array_index_type
, base
,
7782 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7784 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7785 && !se
->data_not_needed
7786 && (!rank_remap
|| se
->use_offset
))
7788 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7789 gfc_conv_descriptor_offset_get (desc
));
7791 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7792 && !se
->data_not_needed
7793 && gfc_expr_attr (expr
).select_rank_temporary
)
7795 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7797 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7799 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7800 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7801 && !expr
->symtree
->n
.sym
->attr
.allocatable
7802 && !expr
->symtree
->n
.sym
->attr
.pointer
7803 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7804 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7806 /* Set the offset to -1. */
7808 mpz_init_set_si (minus_one
, -1);
7809 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7810 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7814 /* Only the callee knows what the correct offset it, so just set
7816 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7821 /* For class arrays add the class tree into the saved descriptor to
7822 enable getting of _vptr and the like. */
7823 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7824 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7826 gfc_allocate_lang_decl (desc
);
7827 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7828 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7829 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7830 : expr
->symtree
->n
.sym
->backend_decl
;
7832 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7833 && IS_CLASS_ARRAY (expr
))
7836 gfc_allocate_lang_decl (desc
);
7837 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7838 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7839 vtype
= gfc_class_vptr_get (tmp
);
7840 gfc_add_modify (&se
->pre
, vtype
,
7841 gfc_build_addr_expr (TREE_TYPE (vtype
),
7842 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7844 if (!se
->direct_byref
|| se
->byref_noassign
)
7846 /* Get a pointer to the new descriptor. */
7847 if (se
->want_pointer
)
7848 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7853 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7854 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7856 /* Cleanup the scalarizer. */
7857 gfc_cleanup_loop (&loop
);
7860 /* Helper function for gfc_conv_array_parameter if array size needs to be
7864 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7867 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7868 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7869 else if (expr
->rank
> 1)
7870 *size
= build_call_expr_loc (input_location
,
7871 gfor_fndecl_size0
, 1,
7872 gfc_build_addr_expr (NULL
, desc
));
7875 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7876 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7878 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7879 gfc_array_index_type
, ubound
, lbound
);
7880 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7881 *size
, gfc_index_one_node
);
7882 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7883 *size
, gfc_index_zero_node
);
7885 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7886 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7887 *size
, fold_convert (gfc_array_index_type
, elem
));
7890 /* Helper function - return true if the argument is a pointer. */
7893 is_pointer (gfc_expr
*e
)
7897 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->symtree
== NULL
)
7900 sym
= e
->symtree
->n
.sym
;
7904 return sym
->attr
.pointer
|| sym
->attr
.proc_pointer
;
7907 /* Convert an array for passing as an actual parameter. */
7910 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7911 const gfc_symbol
*fsym
, const char *proc_name
,
7916 tree tmp
= NULL_TREE
;
7918 tree parent
= DECL_CONTEXT (current_function_decl
);
7919 bool full_array_var
;
7920 bool this_array_result
;
7923 bool array_constructor
;
7924 bool good_allocatable
;
7925 bool ultimate_ptr_comp
;
7926 bool ultimate_alloc_comp
;
7931 ultimate_ptr_comp
= false;
7932 ultimate_alloc_comp
= false;
7934 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7936 if (ref
->next
== NULL
)
7939 if (ref
->type
== REF_COMPONENT
)
7941 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7942 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7946 full_array_var
= false;
7949 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7950 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7952 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7954 /* The symbol should have an array specification. */
7955 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7957 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7959 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7960 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7961 se
->string_length
= tmp
;
7964 /* Is this the result of the enclosing procedure? */
7965 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7966 if (this_array_result
7967 && (sym
->backend_decl
!= current_function_decl
)
7968 && (sym
->backend_decl
!= parent
))
7969 this_array_result
= false;
7971 /* Passing address of the array if it is not pointer or assumed-shape. */
7972 if (full_array_var
&& g77
&& !this_array_result
7973 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7975 tmp
= gfc_get_symbol_decl (sym
);
7977 if (sym
->ts
.type
== BT_CHARACTER
)
7978 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7980 if (!sym
->attr
.pointer
7982 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7983 && sym
->as
->type
!= AS_DEFERRED
7984 && sym
->as
->type
!= AS_ASSUMED_RANK
7985 && !sym
->attr
.allocatable
)
7987 /* Some variables are declared directly, others are declared as
7988 pointers and allocated on the heap. */
7989 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7992 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7994 array_parameter_size (tmp
, expr
, size
);
7998 if (sym
->attr
.allocatable
)
8000 if (sym
->attr
.dummy
|| sym
->attr
.result
)
8002 gfc_conv_expr_descriptor (se
, expr
);
8006 array_parameter_size (tmp
, expr
, size
);
8007 se
->expr
= gfc_conv_array_data (tmp
);
8012 /* A convenient reduction in scope. */
8013 contiguous
= g77
&& !this_array_result
&& contiguous
;
8015 /* There is no need to pack and unpack the array, if it is contiguous
8016 and not a deferred- or assumed-shape array, or if it is simply
8018 no_pack
= ((sym
&& sym
->as
8019 && !sym
->attr
.pointer
8020 && sym
->as
->type
!= AS_DEFERRED
8021 && sym
->as
->type
!= AS_ASSUMED_RANK
8022 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
8024 (ref
&& ref
->u
.ar
.as
8025 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
8026 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
8027 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
8029 gfc_is_simply_contiguous (expr
, false, true));
8031 no_pack
= contiguous
&& no_pack
;
8033 /* If we have an EXPR_OP or a function returning an explicit-shaped
8034 or allocatable array, an array temporary will be generated which
8035 does not need to be packed / unpacked if passed to an
8036 explicit-shape dummy array. */
8040 if (expr
->expr_type
== EXPR_OP
)
8042 else if (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.esym
)
8044 gfc_symbol
*result
= expr
->value
.function
.esym
->result
;
8045 if (result
->attr
.dimension
8046 && (result
->as
->type
== AS_EXPLICIT
8047 || result
->attr
.allocatable
8048 || result
->attr
.contiguous
))
8053 /* Array constructors are always contiguous and do not need packing. */
8054 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
8056 /* Same is true of contiguous sections from allocatable variables. */
8057 good_allocatable
= contiguous
8059 && expr
->symtree
->n
.sym
->attr
.allocatable
;
8061 /* Or ultimate allocatable components. */
8062 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
8064 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
8066 gfc_conv_expr_descriptor (se
, expr
);
8067 /* Deallocate the allocatable components of structures that are
8069 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8070 && expr
->ts
.u
.derived
->attr
.alloc_comp
8071 && expr
->expr_type
!= EXPR_VARIABLE
)
8073 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
8075 /* The components shall be deallocated before their containing entity. */
8076 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8078 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->expr_type
!= EXPR_FUNCTION
)
8079 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
8081 array_parameter_size (se
->expr
, expr
, size
);
8082 se
->expr
= gfc_conv_array_data (se
->expr
);
8086 if (this_array_result
)
8088 /* Result of the enclosing function. */
8089 gfc_conv_expr_descriptor (se
, expr
);
8091 array_parameter_size (se
->expr
, expr
, size
);
8092 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8094 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
8095 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
8096 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
8103 /* Every other type of array. */
8104 se
->want_pointer
= 1;
8105 gfc_conv_expr_descriptor (se
, expr
);
8108 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
8113 /* Deallocate the allocatable components of structures that are
8114 not variable, for descriptorless arguments.
8115 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8116 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8117 && expr
->ts
.u
.derived
->attr
.alloc_comp
8118 && expr
->expr_type
!= EXPR_VARIABLE
)
8120 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8121 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
8123 /* The components shall be deallocated before their containing entity. */
8124 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8127 if (g77
|| (fsym
&& fsym
->attr
.contiguous
8128 && !gfc_is_simply_contiguous (expr
, false, true)))
8130 tree origptr
= NULL_TREE
;
8134 /* For contiguous arrays, save the original value of the descriptor. */
8137 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
8138 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8139 tmp
= gfc_conv_array_data (tmp
);
8140 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8141 TREE_TYPE (origptr
), origptr
,
8142 fold_convert (TREE_TYPE (origptr
), tmp
));
8143 gfc_add_expr_to_block (&se
->pre
, tmp
);
8146 /* Repack the array. */
8147 if (warn_array_temporaries
)
8150 gfc_warning (OPT_Warray_temporaries
,
8151 "Creating array temporary at %L for argument %qs",
8152 &expr
->where
, fsym
->name
);
8154 gfc_warning (OPT_Warray_temporaries
,
8155 "Creating array temporary at %L", &expr
->where
);
8158 /* When optmizing, we can use gfc_conv_subref_array_arg for
8159 making the packing and unpacking operation visible to the
8162 if (g77
&& flag_inline_arg_packing
&& expr
->expr_type
== EXPR_VARIABLE
8163 && !is_pointer (expr
) && ! gfc_has_dimen_vector_ref (expr
)
8164 && !(expr
->symtree
->n
.sym
->as
8165 && expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_RANK
)
8166 && (fsym
== NULL
|| fsym
->ts
.type
!= BT_ASSUMED
))
8168 gfc_conv_subref_array_arg (se
, expr
, g77
,
8169 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
8170 false, fsym
, proc_name
, sym
, true);
8174 ptr
= build_call_expr_loc (input_location
,
8175 gfor_fndecl_in_pack
, 1, desc
);
8177 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8179 tmp
= gfc_conv_expr_present (sym
);
8180 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
8181 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
8182 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
8185 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
8187 /* Use the packed data for the actual argument, except for contiguous arrays,
8188 where the descriptor's data component is set. */
8193 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8195 gfc_ss
* ss
= gfc_walk_expr (expr
);
8196 if (!transposed_dims (ss
))
8197 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
8200 tree old_field
, new_field
;
8202 /* The original descriptor has transposed dims so we can't reuse
8203 it directly; we have to create a new one. */
8204 tree old_desc
= tmp
;
8205 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8207 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8208 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8209 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8211 old_field
= gfc_conv_descriptor_offset (old_desc
);
8212 new_field
= gfc_conv_descriptor_offset (new_desc
);
8213 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8215 for (int i
= 0; i
< expr
->rank
; i
++)
8217 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8218 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8219 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8221 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8224 if (flag_coarray
== GFC_FCOARRAY_LIB
8225 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8226 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8227 == GFC_ARRAY_ALLOCATABLE
)
8229 old_field
= gfc_conv_descriptor_token (old_desc
);
8230 new_field
= gfc_conv_descriptor_token (new_desc
);
8231 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8234 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8235 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8240 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8244 if (fsym
&& proc_name
)
8245 msg
= xasprintf ("An array temporary was created for argument "
8246 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8248 msg
= xasprintf ("An array temporary was created");
8250 tmp
= build_fold_indirect_ref_loc (input_location
,
8252 tmp
= gfc_conv_array_data (tmp
);
8253 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8254 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8256 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8257 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8259 gfc_conv_expr_present (sym
), tmp
);
8261 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8266 gfc_start_block (&block
);
8268 /* Copy the data back. */
8269 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8271 tmp
= build_call_expr_loc (input_location
,
8272 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8273 gfc_add_expr_to_block (&block
, tmp
);
8276 /* Free the temporary. */
8277 tmp
= gfc_call_free (ptr
);
8278 gfc_add_expr_to_block (&block
, tmp
);
8280 stmt
= gfc_finish_block (&block
);
8282 gfc_init_block (&block
);
8283 /* Only if it was repacked. This code needs to be executed before the
8284 loop cleanup code. */
8285 tmp
= build_fold_indirect_ref_loc (input_location
,
8287 tmp
= gfc_conv_array_data (tmp
);
8288 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8289 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8291 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8292 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8294 gfc_conv_expr_present (sym
), tmp
);
8296 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8298 gfc_add_expr_to_block (&block
, tmp
);
8299 gfc_add_block_to_block (&block
, &se
->post
);
8301 gfc_init_block (&se
->post
);
8303 /* Reset the descriptor pointer. */
8306 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8307 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8310 gfc_add_block_to_block (&se
->post
, &block
);
8315 /* This helper function calculates the size in words of a full array. */
8318 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8323 idx
= gfc_rank_cst
[rank
- 1];
8324 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8325 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8326 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8328 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8329 tmp
, gfc_index_one_node
);
8330 tmp
= gfc_evaluate_now (tmp
, block
);
8332 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8333 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8335 return gfc_evaluate_now (tmp
, block
);
8339 /* Allocate dest to the same size as src, and copy src -> dest.
8340 If no_malloc is set, only the copy is done. */
8343 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8344 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8345 tree add_when_allocated
)
8354 /* If the source is null, set the destination to null. Then,
8355 allocate memory to the destination. */
8356 gfc_init_block (&block
);
8358 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8360 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8361 null_data
= gfc_finish_block (&block
);
8363 gfc_init_block (&block
);
8364 if (str_sz
!= NULL_TREE
)
8367 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8371 tmp
= gfc_call_malloc (&block
, type
, size
);
8372 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8377 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8378 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8379 fold_convert (size_type_node
, size
));
8380 gfc_add_expr_to_block (&block
, tmp
);
8385 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8386 null_data
= gfc_finish_block (&block
);
8388 gfc_init_block (&block
);
8390 nelems
= gfc_full_array_size (&block
, src
, rank
);
8392 nelems
= gfc_index_one_node
;
8394 if (str_sz
!= NULL_TREE
)
8395 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8397 tmp
= fold_convert (gfc_array_index_type
,
8398 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8399 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8403 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8404 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8405 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8408 /* We know the temporary and the value will be the same length,
8409 so can use memcpy. */
8412 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8413 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8414 gfc_conv_descriptor_data_get (dest
),
8415 gfc_conv_descriptor_data_get (src
),
8416 fold_convert (size_type_node
, size
));
8417 gfc_add_expr_to_block (&block
, tmp
);
8421 gfc_add_expr_to_block (&block
, add_when_allocated
);
8422 tmp
= gfc_finish_block (&block
);
8424 /* Null the destination if the source is null; otherwise do
8425 the allocate and copy. */
8426 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8429 null_cond
= gfc_conv_descriptor_data_get (src
);
8431 null_cond
= convert (pvoid_type_node
, null_cond
);
8432 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8433 null_cond
, null_pointer_node
);
8434 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8438 /* Allocate dest to the same size as src, and copy data src -> dest. */
8441 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8442 tree add_when_allocated
)
8444 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8445 NULL_TREE
, add_when_allocated
);
8449 /* Copy data src -> dest. */
8452 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8454 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8455 NULL_TREE
, NULL_TREE
);
8458 /* Allocate dest to the same size as src, but don't copy anything. */
8461 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8463 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8464 NULL_TREE
, NULL_TREE
);
8469 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8470 tree type
, int rank
)
8477 stmtblock_t block
, globalblock
;
8479 /* If the source is null, set the destination to null. Then,
8480 allocate memory to the destination. */
8481 gfc_init_block (&block
);
8482 gfc_init_block (&globalblock
);
8484 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8487 symbol_attribute attr
;
8490 gfc_init_se (&se
, NULL
);
8491 gfc_clear_attr (&attr
);
8492 attr
.allocatable
= 1;
8493 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8494 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8495 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8497 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8498 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8499 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8500 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8501 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8502 null_data
= gfc_finish_block (&block
);
8504 gfc_init_block (&block
);
8506 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8507 fold_convert (size_type_node
, size
),
8508 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8509 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8510 GFC_CAF_COARRAY_ALLOC
);
8512 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8513 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8514 fold_convert (size_type_node
, size
));
8515 gfc_add_expr_to_block (&block
, tmp
);
8519 /* Set the rank or unitialized memory access may be reported. */
8520 tmp
= gfc_conv_descriptor_rank (dest
);
8521 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8524 nelems
= gfc_full_array_size (&block
, src
, rank
);
8526 nelems
= integer_one_node
;
8528 tmp
= fold_convert (size_type_node
,
8529 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8530 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8531 fold_convert (size_type_node
, nelems
), tmp
);
8533 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8534 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8536 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8537 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8538 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8539 null_data
= gfc_finish_block (&block
);
8541 gfc_init_block (&block
);
8542 gfc_allocate_using_caf_lib (&block
, dest
,
8543 fold_convert (size_type_node
, size
),
8544 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8545 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8546 GFC_CAF_COARRAY_ALLOC
);
8548 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8549 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8550 gfc_conv_descriptor_data_get (dest
),
8551 gfc_conv_descriptor_data_get (src
),
8552 fold_convert (size_type_node
, size
));
8553 gfc_add_expr_to_block (&block
, tmp
);
8556 tmp
= gfc_finish_block (&block
);
8558 /* Null the destination if the source is null; otherwise do
8559 the register and copy. */
8560 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8563 null_cond
= gfc_conv_descriptor_data_get (src
);
8565 null_cond
= convert (pvoid_type_node
, null_cond
);
8566 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8567 null_cond
, null_pointer_node
);
8568 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8570 return gfc_finish_block (&globalblock
);
8574 /* Helper function to abstract whether coarray processing is enabled. */
8577 caf_enabled (int caf_mode
)
8579 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8580 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8584 /* Helper function to abstract whether coarray processing is enabled
8585 and we are in a derived type coarray. */
8588 caf_in_coarray (int caf_mode
)
8590 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8591 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8592 return (caf_mode
& pat
) == pat
;
8596 /* Helper function to abstract whether coarray is to deallocate only. */
8599 gfc_caf_is_dealloc_only (int caf_mode
)
8601 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8602 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8606 /* Recursively traverse an object of derived type, generating code to
8607 deallocate, nullify or copy allocatable components. This is the work horse
8608 function for the functions named in this enum. */
8610 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8611 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8612 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
,
8615 static gfc_actual_arglist
*pdt_param_list
;
8618 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8619 tree dest
, int rank
, int purpose
, int caf_mode
,
8620 gfc_co_subroutines_args
*args
)
8624 stmtblock_t fnblock
;
8625 stmtblock_t loopbody
;
8626 stmtblock_t tmpblock
;
8637 tree null_cond
= NULL_TREE
;
8638 tree add_when_allocated
;
8639 tree dealloc_fndecl
;
8643 symbol_attribute
*attr
;
8644 bool deallocate_called
;
8646 gfc_init_block (&fnblock
);
8648 decl_type
= TREE_TYPE (decl
);
8650 if ((POINTER_TYPE_P (decl_type
))
8651 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8653 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8654 /* Deref dest in sync with decl, but only when it is not NULL. */
8656 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8658 /* Update the decl_type because it got dereferenced. */
8659 decl_type
= TREE_TYPE (decl
);
8662 /* If this is an array of derived types with allocatable components
8663 build a loop and recursively call this function. */
8664 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8665 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8667 tmp
= gfc_conv_array_data (decl
);
8668 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8670 /* Get the number of elements - 1 and set the counter. */
8671 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8673 /* Use the descriptor for an allocatable array. Since this
8674 is a full array reference, we only need the descriptor
8675 information from dimension = rank. */
8676 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8677 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8678 gfc_array_index_type
, tmp
,
8679 gfc_index_one_node
);
8681 null_cond
= gfc_conv_descriptor_data_get (decl
);
8682 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8683 logical_type_node
, null_cond
,
8684 build_int_cst (TREE_TYPE (null_cond
), 0));
8688 /* Otherwise use the TYPE_DOMAIN information. */
8689 tmp
= array_type_nelts (decl_type
);
8690 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8693 /* Remember that this is, in fact, the no. of elements - 1. */
8694 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8695 index
= gfc_create_var (gfc_array_index_type
, "S");
8697 /* Build the body of the loop. */
8698 gfc_init_block (&loopbody
);
8700 vref
= gfc_build_array_ref (var
, index
, NULL
);
8702 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8703 && !caf_enabled (caf_mode
))
8705 tmp
= build_fold_indirect_ref_loc (input_location
,
8706 gfc_conv_array_data (dest
));
8707 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8708 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8709 COPY_ALLOC_COMP
, 0, args
);
8712 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8715 gfc_add_expr_to_block (&loopbody
, tmp
);
8717 /* Build the loop and return. */
8718 gfc_init_loopinfo (&loop
);
8720 loop
.from
[0] = gfc_index_zero_node
;
8721 loop
.loopvar
[0] = index
;
8722 loop
.to
[0] = nelems
;
8723 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8724 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8726 tmp
= gfc_finish_block (&fnblock
);
8727 /* When copying allocateable components, the above implements the
8728 deep copy. Nevertheless is a deep copy only allowed, when the current
8729 component is allocated, for which code will be generated in
8730 gfc_duplicate_allocatable (), where the deep copy code is just added
8731 into the if's body, by adding tmp (the deep copy code) as last
8732 argument to gfc_duplicate_allocatable (). */
8733 if (purpose
== COPY_ALLOC_COMP
8734 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8735 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8737 else if (null_cond
!= NULL_TREE
)
8738 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8739 build_empty_stmt (input_location
));
8744 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8746 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8747 DEALLOCATE_PDT_COMP
, 0, args
);
8748 gfc_add_expr_to_block (&fnblock
, tmp
);
8750 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8752 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8753 NULLIFY_ALLOC_COMP
, 0, args
);
8754 gfc_add_expr_to_block (&fnblock
, tmp
);
8757 /* Otherwise, act on the components or recursively call self to
8758 act on a chain of components. */
8759 for (c
= der_type
->components
; c
; c
= c
->next
)
8761 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8762 || c
->ts
.type
== BT_CLASS
)
8763 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8764 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8765 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8767 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8768 && c
->ts
.u
.derived
->attr
.pdt_type
;
8770 cdecl = c
->backend_decl
;
8771 ctype
= TREE_TYPE (cdecl);
8776 case BCAST_ALLOC_COMP
:
8780 stmtblock_t derived_type_block
;
8782 gfc_init_block (&tmpblock
);
8784 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8785 decl
, cdecl, NULL_TREE
);
8787 /* Shortcut to get the attributes of the component. */
8788 if (c
->ts
.type
== BT_CLASS
)
8790 attr
= &CLASS_DATA (c
)->attr
;
8791 if (attr
->class_pointer
)
8801 add_when_allocated
= NULL_TREE
;
8802 if (cmp_has_alloc_comps
8803 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
8805 if (c
->ts
.type
== BT_CLASS
)
8807 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8809 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8810 comp
, NULL_TREE
, rank
, purpose
,
8815 rank
= c
->as
? c
->as
->rank
: 0;
8816 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8823 gfc_init_block (&derived_type_block
);
8824 if (add_when_allocated
)
8825 gfc_add_expr_to_block (&derived_type_block
, add_when_allocated
);
8826 tmp
= gfc_finish_block (&derived_type_block
);
8827 gfc_add_expr_to_block (&tmpblock
, tmp
);
8829 /* Convert the component into a rank 1 descriptor type. */
8830 if (attr
->dimension
)
8832 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8833 ubound
= gfc_full_array_size (&tmpblock
, comp
,
8834 c
->ts
.type
== BT_CLASS
8835 ? CLASS_DATA (c
)->as
->rank
8840 tmp
= TREE_TYPE (comp
);
8841 ubound
= build_int_cst (gfc_array_index_type
, 1);
8844 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8846 GFC_ARRAY_ALLOCATABLE
, false);
8848 cdesc
= gfc_create_var (cdesc
, "cdesc");
8849 DECL_ARTIFICIAL (cdesc
) = 1;
8851 gfc_add_modify (&tmpblock
, gfc_conv_descriptor_dtype (cdesc
),
8852 gfc_get_dtype_rank_type (1, tmp
));
8853 gfc_conv_descriptor_lbound_set (&tmpblock
, cdesc
,
8854 gfc_index_zero_node
,
8855 gfc_index_one_node
);
8856 gfc_conv_descriptor_stride_set (&tmpblock
, cdesc
,
8857 gfc_index_zero_node
,
8858 gfc_index_one_node
);
8859 gfc_conv_descriptor_ubound_set (&tmpblock
, cdesc
,
8860 gfc_index_zero_node
, ubound
);
8862 if (attr
->dimension
)
8863 comp
= gfc_conv_descriptor_data_get (comp
);
8868 gfc_init_se (&se
, NULL
);
8870 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8871 c
->ts
.type
== BT_CLASS
8872 ? CLASS_DATA (c
)->attr
8874 comp
= gfc_build_addr_expr (NULL_TREE
, comp
);
8875 gfc_add_block_to_block (&tmpblock
, &se
.pre
);
8878 gfc_conv_descriptor_data_set (&tmpblock
, cdesc
, comp
);
8882 fndecl
= build_call_expr_loc (input_location
,
8883 gfor_fndecl_co_broadcast
, 5,
8884 gfc_build_addr_expr (pvoid_type_node
,cdesc
),
8886 null_pointer_node
, null_pointer_node
,
8889 gfc_add_expr_to_block (&tmpblock
, fndecl
);
8890 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8894 case DEALLOCATE_ALLOC_COMP
:
8896 gfc_init_block (&tmpblock
);
8898 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8899 decl
, cdecl, NULL_TREE
);
8901 /* Shortcut to get the attributes of the component. */
8902 if (c
->ts
.type
== BT_CLASS
)
8904 attr
= &CLASS_DATA (c
)->attr
;
8905 if (attr
->class_pointer
)
8915 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8916 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8917 /* Call the finalizer, which will free the memory and nullify the
8918 pointer of an array. */
8919 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8920 caf_enabled (caf_mode
))
8923 deallocate_called
= false;
8925 /* Add the _class ref for classes. */
8926 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8927 comp
= gfc_class_data_get (comp
);
8929 add_when_allocated
= NULL_TREE
;
8930 if (cmp_has_alloc_comps
8931 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8933 && !deallocate_called
)
8935 /* Add checked deallocation of the components. This code is
8936 obviously added because the finalizer is not trusted to free
8938 if (c
->ts
.type
== BT_CLASS
)
8940 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8942 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8943 comp
, NULL_TREE
, rank
, purpose
,
8948 rank
= c
->as
? c
->as
->rank
: 0;
8949 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8956 if (attr
->allocatable
&& !same_type
8957 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8959 /* Handle all types of components besides components of the
8960 same_type as the current one, because those would create an
8963 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8964 ? (gfc_caf_is_dealloc_only (caf_mode
)
8965 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8966 : GFC_CAF_COARRAY_DEREGISTER
)
8967 : GFC_CAF_COARRAY_NOCOARRAY
;
8969 caf_token
= NULL_TREE
;
8970 /* Coarray components are handled directly by
8971 deallocate_with_status. */
8972 if (!attr
->codimension
8973 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8976 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8977 TREE_TYPE (c
->caf_token
),
8978 decl
, c
->caf_token
, NULL_TREE
);
8979 else if (attr
->dimension
&& !attr
->proc_pointer
)
8980 caf_token
= gfc_conv_descriptor_token (comp
);
8982 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8983 /* When this is an array but not in conjunction with a coarray
8984 then add the data-ref. For coarray'ed arrays the data-ref
8985 is added by deallocate_with_status. */
8986 comp
= gfc_conv_descriptor_data_get (comp
);
8988 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8989 NULL_TREE
, NULL_TREE
, true,
8990 NULL
, caf_dereg_mode
,
8991 add_when_allocated
, caf_token
);
8993 gfc_add_expr_to_block (&tmpblock
, tmp
);
8995 else if (attr
->allocatable
&& !attr
->codimension
8996 && !deallocate_called
)
8998 /* Case of recursive allocatable derived types. */
9002 stmtblock_t dealloc_block
;
9004 gfc_init_block (&dealloc_block
);
9005 if (add_when_allocated
)
9006 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
9008 /* Convert the component into a rank 1 descriptor type. */
9009 if (attr
->dimension
)
9011 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
9012 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
9013 c
->ts
.type
== BT_CLASS
9014 ? CLASS_DATA (c
)->as
->rank
9019 tmp
= TREE_TYPE (comp
);
9020 ubound
= build_int_cst (gfc_array_index_type
, 1);
9023 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
9025 GFC_ARRAY_ALLOCATABLE
, false);
9027 cdesc
= gfc_create_var (cdesc
, "cdesc");
9028 DECL_ARTIFICIAL (cdesc
) = 1;
9030 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
9031 gfc_get_dtype_rank_type (1, tmp
));
9032 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
9033 gfc_index_zero_node
,
9034 gfc_index_one_node
);
9035 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
9036 gfc_index_zero_node
,
9037 gfc_index_one_node
);
9038 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
9039 gfc_index_zero_node
, ubound
);
9041 if (attr
->dimension
)
9042 comp
= gfc_conv_descriptor_data_get (comp
);
9044 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
9046 /* Now call the deallocator. */
9047 vtab
= gfc_find_vtab (&c
->ts
);
9048 if (vtab
->backend_decl
== NULL
)
9049 gfc_get_symbol_decl (vtab
);
9050 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9051 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
9052 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
9054 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
9055 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
9056 logical_type_node
, tmp
,
9058 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
9060 tmp
= build_call_expr_loc (input_location
,
9063 gfc_add_expr_to_block (&dealloc_block
, tmp
);
9065 tmp
= gfc_finish_block (&dealloc_block
);
9067 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9068 void_type_node
, is_allocated
, tmp
,
9069 build_empty_stmt (input_location
));
9071 gfc_add_expr_to_block (&tmpblock
, tmp
);
9073 else if (add_when_allocated
)
9074 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
9076 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
9077 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
9079 /* Finally, reset the vptr to the declared type vtable and, if
9080 necessary reset the _len field.
9082 First recover the reference to the component and obtain
9084 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9085 decl
, cdecl, NULL_TREE
);
9086 tmp
= gfc_class_vptr_get (comp
);
9088 if (UNLIMITED_POLY (c
))
9090 /* Both vptr and _len field should be nulled. */
9091 gfc_add_modify (&tmpblock
, tmp
,
9092 build_int_cst (TREE_TYPE (tmp
), 0));
9093 tmp
= gfc_class_len_get (comp
);
9094 gfc_add_modify (&tmpblock
, tmp
,
9095 build_int_cst (TREE_TYPE (tmp
), 0));
9099 /* Build the vtable address and set the vptr with it. */
9102 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9103 vtab
= vtable
->backend_decl
;
9104 if (vtab
== NULL_TREE
)
9105 vtab
= gfc_get_symbol_decl (vtable
);
9106 vtab
= gfc_build_addr_expr (NULL
, vtab
);
9107 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
9108 gfc_add_modify (&tmpblock
, tmp
, vtab
);
9112 /* Now add the deallocation of this component. */
9113 gfc_add_block_to_block (&fnblock
, &tmpblock
);
9116 case NULLIFY_ALLOC_COMP
:
9118 - allocatable components (regular or in class)
9119 - components that have allocatable components
9120 - pointer components when in a coarray.
9121 Skip everything else especially proc_pointers, which may come
9122 coupled with the regular pointer attribute. */
9123 if (c
->attr
.proc_pointer
9124 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
9125 && CLASS_DATA (c
)->attr
.allocatable
)
9126 || (cmp_has_alloc_comps
9127 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
9128 || (c
->ts
.type
== BT_CLASS
9129 && !CLASS_DATA (c
)->attr
.class_pointer
)))
9130 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
9133 /* Process class components first, because they always have the
9134 pointer-attribute set which would be caught wrong else. */
9135 if (c
->ts
.type
== BT_CLASS
9136 && (CLASS_DATA (c
)->attr
.allocatable
9137 || CLASS_DATA (c
)->attr
.class_pointer
))
9141 /* Allocatable CLASS components. */
9142 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9143 decl
, cdecl, NULL_TREE
);
9145 vptr_decl
= gfc_class_vptr_get (comp
);
9147 comp
= gfc_class_data_get (comp
);
9148 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
9149 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9153 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9154 void_type_node
, comp
,
9155 build_int_cst (TREE_TYPE (comp
), 0));
9156 gfc_add_expr_to_block (&fnblock
, tmp
);
9159 /* The dynamic type of a disassociated pointer or unallocated
9160 allocatable variable is its declared type. An unlimited
9161 polymorphic entity has no declared type. */
9162 if (!UNLIMITED_POLY (c
))
9164 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9165 if (!vtab
->backend_decl
)
9166 gfc_get_symbol_decl (vtab
);
9167 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9170 tmp
= build_int_cst (TREE_TYPE (vptr_decl
), 0);
9172 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9173 void_type_node
, vptr_decl
, tmp
);
9174 gfc_add_expr_to_block (&fnblock
, tmp
);
9176 cmp_has_alloc_comps
= false;
9178 /* Coarrays need the component to be nulled before the api-call
9180 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
9182 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9183 decl
, cdecl, NULL_TREE
);
9184 if (c
->attr
.dimension
|| c
->attr
.codimension
)
9185 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9188 gfc_add_modify (&fnblock
, comp
,
9189 build_int_cst (TREE_TYPE (comp
), 0));
9190 if (gfc_deferred_strlen (c
, &comp
))
9192 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9194 decl
, comp
, NULL_TREE
);
9195 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9196 TREE_TYPE (comp
), comp
,
9197 build_int_cst (TREE_TYPE (comp
), 0));
9198 gfc_add_expr_to_block (&fnblock
, tmp
);
9200 cmp_has_alloc_comps
= false;
9203 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
9205 /* Register a component of a derived type coarray with the
9206 coarray library. Do not register ultimate component
9207 coarrays here. They are treated like regular coarrays and
9208 are either allocated on all images or on none. */
9211 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9212 decl
, cdecl, NULL_TREE
);
9213 if (c
->attr
.dimension
)
9215 /* Set the dtype, because caf_register needs it. */
9216 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
9217 gfc_get_dtype (TREE_TYPE (comp
)));
9218 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9219 decl
, cdecl, NULL_TREE
);
9220 token
= gfc_conv_descriptor_token (tmp
);
9226 gfc_init_se (&se
, NULL
);
9227 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9228 pvoid_type_node
, decl
, c
->caf_token
,
9230 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
9231 c
->ts
.type
== BT_CLASS
9232 ? CLASS_DATA (c
)->attr
9234 gfc_add_block_to_block (&fnblock
, &se
.pre
);
9237 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
9238 gfc_build_addr_expr (NULL_TREE
,
9240 NULL_TREE
, NULL_TREE
, NULL_TREE
,
9241 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
9244 if (cmp_has_alloc_comps
)
9246 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9247 decl
, cdecl, NULL_TREE
);
9248 rank
= c
->as
? c
->as
->rank
: 0;
9249 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
9250 rank
, purpose
, caf_mode
, args
);
9251 gfc_add_expr_to_block (&fnblock
, tmp
);
9255 case REASSIGN_CAF_COMP
:
9256 if (caf_enabled (caf_mode
)
9257 && (c
->attr
.codimension
9258 || (c
->ts
.type
== BT_CLASS
9259 && (CLASS_DATA (c
)->attr
.coarray_comp
9260 || caf_in_coarray (caf_mode
)))
9261 || (c
->ts
.type
== BT_DERIVED
9262 && (c
->ts
.u
.derived
->attr
.coarray_comp
9263 || caf_in_coarray (caf_mode
))))
9266 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9267 decl
, cdecl, NULL_TREE
);
9268 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9269 dest
, cdecl, NULL_TREE
);
9271 if (c
->attr
.codimension
)
9273 if (c
->ts
.type
== BT_CLASS
)
9275 comp
= gfc_class_data_get (comp
);
9276 dcmp
= gfc_class_data_get (dcmp
);
9278 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
9279 gfc_conv_descriptor_data_get (comp
));
9283 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
9284 rank
, purpose
, caf_mode
9285 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
,
9287 gfc_add_expr_to_block (&fnblock
, tmp
);
9292 case COPY_ALLOC_COMP
:
9293 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
9296 /* We need source and destination components. */
9297 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
9299 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
9301 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
9303 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
9311 dst_data
= gfc_class_data_get (dcmp
);
9312 src_data
= gfc_class_data_get (comp
);
9313 size
= fold_convert (size_type_node
,
9314 gfc_class_vtab_size_get (comp
));
9316 if (CLASS_DATA (c
)->attr
.dimension
)
9318 nelems
= gfc_conv_descriptor_size (src_data
,
9319 CLASS_DATA (c
)->as
->rank
);
9320 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9321 size_type_node
, size
,
9322 fold_convert (size_type_node
,
9326 nelems
= build_int_cst (size_type_node
, 1);
9328 if (CLASS_DATA (c
)->attr
.dimension
9329 || CLASS_DATA (c
)->attr
.codimension
)
9331 src_data
= gfc_conv_descriptor_data_get (src_data
);
9332 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
9335 gfc_init_block (&tmpblock
);
9337 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
9338 gfc_class_vptr_get (comp
));
9340 /* Copy the unlimited '_len' field. If it is greater than zero
9341 (ie. a character(_len)), multiply it by size and use this
9342 for the malloc call. */
9343 if (UNLIMITED_POLY (c
))
9346 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
9347 gfc_class_len_get (comp
));
9349 size
= gfc_evaluate_now (size
, &tmpblock
);
9350 tmp
= gfc_class_len_get (comp
);
9351 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9352 size_type_node
, size
,
9353 fold_convert (size_type_node
, tmp
));
9354 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9355 logical_type_node
, tmp
,
9356 build_zero_cst (TREE_TYPE (tmp
)));
9357 size
= fold_build3_loc (input_location
, COND_EXPR
,
9358 size_type_node
, tmp
, ctmp
, size
);
9359 size
= gfc_evaluate_now (size
, &tmpblock
);
9362 /* Coarray component have to have the same allocation status and
9363 shape/type-parameter/effective-type on the LHS and RHS of an
9364 intrinsic assignment. Hence, we did not deallocated them - and
9365 do not allocate them here. */
9366 if (!CLASS_DATA (c
)->attr
.codimension
)
9368 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9369 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9370 gfc_add_modify (&tmpblock
, dst_data
,
9371 fold_convert (TREE_TYPE (dst_data
), tmp
));
9374 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9375 UNLIMITED_POLY (c
));
9376 gfc_add_expr_to_block (&tmpblock
, tmp
);
9377 tmp
= gfc_finish_block (&tmpblock
);
9379 gfc_init_block (&tmpblock
);
9380 gfc_add_modify (&tmpblock
, dst_data
,
9381 fold_convert (TREE_TYPE (dst_data
),
9382 null_pointer_node
));
9383 null_data
= gfc_finish_block (&tmpblock
);
9385 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9386 logical_type_node
, src_data
,
9389 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9394 /* To implement guarded deep copy, i.e., deep copy only allocatable
9395 components that are really allocated, the deep copy code has to
9396 be generated first and then added to the if-block in
9397 gfc_duplicate_allocatable (). */
9398 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9400 rank
= c
->as
? c
->as
->rank
: 0;
9401 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9402 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9403 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9409 add_when_allocated
= NULL_TREE
;
9411 if (gfc_deferred_strlen (c
, &tmp
))
9415 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9417 decl
, len
, NULL_TREE
);
9418 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9420 dest
, len
, NULL_TREE
);
9421 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9422 TREE_TYPE (len
), len
, tmp
);
9423 gfc_add_expr_to_block (&fnblock
, tmp
);
9424 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9425 /* This component cannot have allocatable components,
9426 therefore add_when_allocated of duplicate_allocatable ()
9428 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9429 false, false, size
, NULL_TREE
);
9430 gfc_add_expr_to_block (&fnblock
, tmp
);
9432 else if (c
->attr
.pdt_array
)
9434 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9435 c
->as
? c
->as
->rank
: 0,
9436 false, false, NULL_TREE
, NULL_TREE
);
9437 gfc_add_expr_to_block (&fnblock
, tmp
);
9439 else if ((c
->attr
.allocatable
)
9440 && !c
->attr
.proc_pointer
&& !same_type
9441 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9442 || caf_in_coarray (caf_mode
)))
9444 rank
= c
->as
? c
->as
->rank
: 0;
9445 if (c
->attr
.codimension
)
9446 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9447 else if (flag_coarray
== GFC_FCOARRAY_LIB
9448 && caf_in_coarray (caf_mode
))
9450 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
9451 : fold_build3_loc (input_location
,
9453 pvoid_type_node
, dest
,
9456 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9460 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9461 add_when_allocated
);
9462 gfc_add_expr_to_block (&fnblock
, tmp
);
9465 if (cmp_has_alloc_comps
|| is_pdt_type
)
9466 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9470 case ALLOCATE_PDT_COMP
:
9472 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9473 decl
, cdecl, NULL_TREE
);
9475 /* Set the PDT KIND and LEN fields. */
9476 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9479 gfc_expr
*c_expr
= NULL
;
9480 gfc_actual_arglist
*param
= pdt_param_list
;
9481 gfc_init_se (&tse
, NULL
);
9482 for (; param
; param
= param
->next
)
9483 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9484 c_expr
= param
->expr
;
9487 c_expr
= c
->initializer
;
9491 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9492 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9496 if (c
->attr
.pdt_string
)
9499 gfc_init_se (&tse
, NULL
);
9500 tree strlen
= NULL_TREE
;
9501 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9502 /* Convert the parameterized string length to its value. The
9503 string length is stored in a hidden field in the same way as
9504 deferred string lengths. */
9505 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9506 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9508 gfc_conv_expr_type (&tse
, e
,
9509 TREE_TYPE (strlen
));
9510 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9512 decl
, strlen
, NULL_TREE
);
9513 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9514 c
->ts
.u
.cl
->backend_decl
= strlen
;
9518 /* Scalar parameterized strings can be allocated now. */
9521 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9522 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9523 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9524 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9525 gfc_add_modify (&fnblock
, comp
, tmp
);
9529 /* Allocate parameterized arrays of parameterized derived types. */
9530 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9531 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9532 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9535 if (c
->ts
.type
== BT_CLASS
)
9536 comp
= gfc_class_data_get (comp
);
9538 if (c
->attr
.pdt_array
)
9542 tree size
= gfc_index_one_node
;
9543 tree offset
= gfc_index_zero_node
;
9547 /* This chunk takes the expressions for 'lower' and 'upper'
9548 in the arrayspec and substitutes in the expressions for
9549 the parameters from 'pdt_param_list'. The descriptor
9550 fields can then be filled from the values so obtained. */
9551 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9552 for (i
= 0; i
< c
->as
->rank
; i
++)
9554 gfc_init_se (&tse
, NULL
);
9555 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9556 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9557 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9560 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9563 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9564 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9565 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9568 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9571 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9574 size
= gfc_evaluate_now (size
, &fnblock
);
9575 offset
= fold_build2_loc (input_location
,
9577 gfc_array_index_type
,
9579 offset
= gfc_evaluate_now (offset
, &fnblock
);
9580 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9581 gfc_array_index_type
,
9583 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9584 gfc_array_index_type
,
9585 tmp
, gfc_index_one_node
);
9586 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9587 gfc_array_index_type
, size
, tmp
);
9589 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9590 if (c
->ts
.type
== BT_CLASS
)
9592 tmp
= gfc_get_vptr_from_expr (comp
);
9593 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9594 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9595 tmp
= gfc_vptr_size_get (tmp
);
9598 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9599 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9600 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9601 gfc_array_index_type
, size
, tmp
);
9602 size
= gfc_evaluate_now (size
, &fnblock
);
9603 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9604 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9605 tmp
= gfc_conv_descriptor_dtype (comp
);
9606 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9608 if (c
->initializer
&& c
->initializer
->rank
)
9610 gfc_init_se (&tse
, NULL
);
9611 e
= gfc_copy_expr (c
->initializer
);
9612 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9613 gfc_conv_expr_descriptor (&tse
, e
);
9614 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9616 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9617 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9618 gfc_conv_descriptor_data_get (comp
),
9619 gfc_conv_descriptor_data_get (tse
.expr
),
9620 fold_convert (size_type_node
, size
));
9621 gfc_add_expr_to_block (&fnblock
, tmp
);
9622 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9626 /* Recurse in to PDT components. */
9627 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9628 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9629 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9631 bool is_deferred
= false;
9632 gfc_actual_arglist
*tail
= c
->param_list
;
9634 for (; tail
; tail
= tail
->next
)
9638 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9639 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9640 c
->as
? c
->as
->rank
: 0,
9642 gfc_add_expr_to_block (&fnblock
, tmp
);
9647 case DEALLOCATE_PDT_COMP
:
9648 /* Deallocate array or parameterized string length components
9649 of parameterized derived types. */
9650 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9651 && !c
->attr
.pdt_string
9652 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9653 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9656 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9657 decl
, cdecl, NULL_TREE
);
9658 if (c
->ts
.type
== BT_CLASS
)
9659 comp
= gfc_class_data_get (comp
);
9661 /* Recurse in to PDT components. */
9662 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9663 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9664 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9666 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9667 c
->as
? c
->as
->rank
: 0);
9668 gfc_add_expr_to_block (&fnblock
, tmp
);
9671 if (c
->attr
.pdt_array
)
9673 tmp
= gfc_conv_descriptor_data_get (comp
);
9674 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9675 logical_type_node
, tmp
,
9676 build_int_cst (TREE_TYPE (tmp
), 0));
9677 tmp
= gfc_call_free (tmp
);
9678 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9679 build_empty_stmt (input_location
));
9680 gfc_add_expr_to_block (&fnblock
, tmp
);
9681 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9683 else if (c
->attr
.pdt_string
)
9685 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9686 logical_type_node
, comp
,
9687 build_int_cst (TREE_TYPE (comp
), 0));
9688 tmp
= gfc_call_free (comp
);
9689 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9690 build_empty_stmt (input_location
));
9691 gfc_add_expr_to_block (&fnblock
, tmp
);
9692 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9693 gfc_add_modify (&fnblock
, comp
, tmp
);
9698 case CHECK_PDT_DUMMY
:
9700 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9701 decl
, cdecl, NULL_TREE
);
9702 if (c
->ts
.type
== BT_CLASS
)
9703 comp
= gfc_class_data_get (comp
);
9705 /* Recurse in to PDT components. */
9706 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9707 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9709 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9710 c
->as
? c
->as
->rank
: 0,
9712 gfc_add_expr_to_block (&fnblock
, tmp
);
9715 if (!c
->attr
.pdt_len
)
9720 gfc_expr
*c_expr
= NULL
;
9721 gfc_actual_arglist
*param
= pdt_param_list
;
9723 gfc_init_se (&tse
, NULL
);
9724 for (; param
; param
= param
->next
)
9725 if (!strcmp (c
->name
, param
->name
)
9726 && param
->spec_type
== SPEC_EXPLICIT
)
9727 c_expr
= param
->expr
;
9731 tree error
, cond
, cname
;
9732 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9733 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9736 cname
= gfc_build_cstring_const (c
->name
);
9737 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9738 error
= gfc_trans_runtime_error (true, NULL
,
9739 "The value of the PDT LEN "
9740 "parameter '%s' does not "
9741 "agree with that in the "
9742 "dummy declaration",
9744 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9745 void_type_node
, cond
, error
,
9746 build_empty_stmt (input_location
));
9747 gfc_add_expr_to_block (&fnblock
, tmp
);
9758 return gfc_finish_block (&fnblock
);
9761 /* Recursively traverse an object of derived type, generating code to
9762 nullify allocatable components. */
9765 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9768 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9770 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9774 /* Recursively traverse an object of derived type, generating code to
9775 deallocate allocatable components. */
9778 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9781 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9782 DEALLOCATE_ALLOC_COMP
,
9783 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9787 gfc_bcast_alloc_comp (gfc_symbol
*derived
, gfc_expr
*expr
, int rank
,
9788 tree image_index
, tree stat
, tree errmsg
,
9793 stmtblock_t block
, post_block
;
9794 gfc_co_subroutines_args args
;
9796 args
.image_index
= image_index
;
9798 args
.errmsg
= errmsg
;
9799 args
.errmsg
= errmsg_len
;
9803 gfc_start_block (&block
);
9804 gfc_init_block (&post_block
);
9805 gfc_init_se (&argse
, NULL
);
9806 gfc_conv_expr (&argse
, expr
);
9807 gfc_add_block_to_block (&block
, &argse
.pre
);
9808 gfc_add_block_to_block (&post_block
, &argse
.post
);
9813 gfc_init_se (&argse
, NULL
);
9814 argse
.want_pointer
= 1;
9815 gfc_conv_expr_descriptor (&argse
, expr
);
9819 tmp
= structure_alloc_comps (derived
, array
, NULL_TREE
, rank
,
9821 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, &args
);
9825 /* Recursively traverse an object of derived type, generating code to
9826 deallocate allocatable components. But do not deallocate coarrays.
9827 To be used for intrinsic assignment, which may not change the allocation
9828 status of coarrays. */
9831 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9833 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9834 DEALLOCATE_ALLOC_COMP
, 0, NULL
);
9839 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9841 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9842 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, NULL
);
9846 /* Recursively traverse an object of derived type, generating code to
9847 copy it and its allocatable components. */
9850 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9853 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9858 /* Recursively traverse an object of derived type, generating code to
9859 copy only its allocatable components. */
9862 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9864 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9865 COPY_ONLY_ALLOC_COMP
, 0, NULL
);
9869 /* Recursively traverse an object of parameterized derived type, generating
9870 code to allocate parameterized components. */
9873 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9874 gfc_actual_arglist
*param_list
)
9877 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9878 pdt_param_list
= param_list
;
9879 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9880 ALLOCATE_PDT_COMP
, 0, NULL
);
9881 pdt_param_list
= old_param_list
;
9885 /* Recursively traverse an object of parameterized derived type, generating
9886 code to deallocate parameterized components. */
9889 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9891 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9892 DEALLOCATE_PDT_COMP
, 0, NULL
);
9896 /* Recursively traverse a dummy of parameterized derived type to check the
9897 values of LEN parameters. */
9900 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9901 gfc_actual_arglist
*param_list
)
9904 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9905 pdt_param_list
= param_list
;
9906 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9907 CHECK_PDT_DUMMY
, 0, NULL
);
9908 pdt_param_list
= old_param_list
;
9913 /* Returns the value of LBOUND for an expression. This could be broken out
9914 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9915 called by gfc_alloc_allocatable_for_assignment. */
9917 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9922 tree cond
, cond1
, cond3
, cond4
;
9926 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9928 tmp
= gfc_rank_cst
[dim
];
9929 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9930 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9931 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9932 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9934 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9935 stride
, gfc_index_zero_node
);
9936 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9937 logical_type_node
, cond3
, cond1
);
9938 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9939 stride
, gfc_index_zero_node
);
9941 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9942 tmp
, build_int_cst (gfc_array_index_type
,
9945 cond
= logical_false_node
;
9947 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9948 logical_type_node
, cond3
, cond4
);
9949 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9950 logical_type_node
, cond
, cond1
);
9952 return fold_build3_loc (input_location
, COND_EXPR
,
9953 gfc_array_index_type
, cond
,
9954 lbound
, gfc_index_one_node
);
9957 if (expr
->expr_type
== EXPR_FUNCTION
)
9959 /* A conversion function, so use the argument. */
9960 gcc_assert (expr
->value
.function
.isym
9961 && expr
->value
.function
.isym
->conversion
);
9962 expr
= expr
->value
.function
.actual
->expr
;
9965 if (expr
->expr_type
== EXPR_VARIABLE
)
9967 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9968 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9970 if (ref
->type
== REF_COMPONENT
9971 && ref
->u
.c
.component
->as
9973 && ref
->next
->u
.ar
.type
== AR_FULL
)
9974 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9976 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9979 return gfc_index_one_node
;
9983 /* Returns true if an expression represents an lhs that can be reallocated
9987 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9995 sym
= expr
->symtree
->n
.sym
;
9997 if (sym
->attr
.associate_var
&& !expr
->ref
)
10000 /* An allocatable class variable with no reference. */
10001 if (sym
->ts
.type
== BT_CLASS
10002 && !sym
->attr
.associate_var
10003 && CLASS_DATA (sym
)->attr
.allocatable
10005 && ((expr
->ref
->type
== REF_ARRAY
&& expr
->ref
->u
.ar
.type
== AR_FULL
10006 && expr
->ref
->next
== NULL
)
10007 || (expr
->ref
->type
== REF_COMPONENT
10008 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
10009 && (expr
->ref
->next
== NULL
10010 || (expr
->ref
->next
->type
== REF_ARRAY
10011 && expr
->ref
->next
->u
.ar
.type
== AR_FULL
10012 && expr
->ref
->next
->next
== NULL
)))))
10015 /* An allocatable variable. */
10016 if (sym
->attr
.allocatable
10017 && !sym
->attr
.associate_var
10019 && expr
->ref
->type
== REF_ARRAY
10020 && expr
->ref
->u
.ar
.type
== AR_FULL
)
10023 /* All that can be left are allocatable components. */
10024 if ((sym
->ts
.type
!= BT_DERIVED
10025 && sym
->ts
.type
!= BT_CLASS
)
10026 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
10029 /* Find a component ref followed by an array reference. */
10030 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10032 && ref
->type
== REF_COMPONENT
10033 && ref
->next
->type
== REF_ARRAY
10034 && !ref
->next
->next
)
10040 /* Return true if valid reallocatable lhs. */
10041 if (ref
->u
.c
.component
->attr
.allocatable
10042 && ref
->next
->u
.ar
.type
== AR_FULL
)
10050 concat_str_length (gfc_expr
* expr
)
10057 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
10058 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10059 if (len1
== NULL_TREE
)
10061 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
10062 len1
= concat_str_length (expr
->value
.op
.op1
);
10063 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
10064 len1
= build_int_cst (gfc_charlen_type_node
,
10065 expr
->value
.op
.op1
->value
.character
.length
);
10066 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
10068 gfc_init_se (&se
, NULL
);
10069 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
10075 gfc_init_se (&se
, NULL
);
10076 se
.want_pointer
= 1;
10077 se
.descriptor_only
= 1;
10078 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
10079 len1
= se
.string_length
;
10083 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
10084 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10085 if (len2
== NULL_TREE
)
10087 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
10088 len2
= concat_str_length (expr
->value
.op
.op2
);
10089 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
10090 len2
= build_int_cst (gfc_charlen_type_node
,
10091 expr
->value
.op
.op2
->value
.character
.length
);
10092 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
10094 gfc_init_se (&se
, NULL
);
10095 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
10101 gfc_init_se (&se
, NULL
);
10102 se
.want_pointer
= 1;
10103 se
.descriptor_only
= 1;
10104 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
10105 len2
= se
.string_length
;
10109 gcc_assert(len1
&& len2
);
10110 len1
= fold_convert (gfc_charlen_type_node
, len1
);
10111 len2
= fold_convert (gfc_charlen_type_node
, len2
);
10113 return fold_build2_loc (input_location
, PLUS_EXPR
,
10114 gfc_charlen_type_node
, len1
, len2
);
10118 /* Allocate the lhs of an assignment to an allocatable array, otherwise
10122 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
10126 stmtblock_t realloc_block
;
10127 stmtblock_t alloc_block
;
10128 stmtblock_t fblock
;
10131 gfc_array_info
*linfo
;
10153 gfc_array_spec
* as
;
10154 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
10155 && gfc_caf_attr (expr1
, true).codimension
);
10159 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
10160 Find the lhs expression in the loop chain and set expr1 and
10161 expr2 accordingly. */
10162 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
10165 /* Find the ss for the lhs. */
10167 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10168 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
10170 if (lss
== gfc_ss_terminator
)
10172 expr1
= lss
->info
->expr
;
10175 /* Bail out if this is not a valid allocate on assignment. */
10176 if (!gfc_is_reallocatable_lhs (expr1
)
10177 || (expr2
&& !expr2
->rank
))
10180 /* Find the ss for the lhs. */
10182 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10183 if (lss
->info
->expr
== expr1
)
10186 if (lss
== gfc_ss_terminator
)
10189 linfo
= &lss
->info
->data
.array
;
10191 /* Find an ss for the rhs. For operator expressions, we see the
10192 ss's for the operands. Any one of these will do. */
10194 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
10195 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
10198 if (expr2
&& rss
== gfc_ss_terminator
)
10201 /* Ensure that the string length from the current scope is used. */
10202 if (expr2
->ts
.type
== BT_CHARACTER
10203 && expr2
->expr_type
== EXPR_FUNCTION
10204 && !expr2
->value
.function
.isym
)
10205 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
10207 gfc_start_block (&fblock
);
10209 /* Since the lhs is allocatable, this must be a descriptor type.
10210 Get the data and array size. */
10211 desc
= linfo
->descriptor
;
10212 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
10213 array1
= gfc_conv_descriptor_data_get (desc
);
10215 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
10216 deallocated if expr is an array of different shape or any of the
10217 corresponding length type parameter values of variable and expr
10218 differ." This assures F95 compatibility. */
10219 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10220 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10222 /* Allocate if data is NULL. */
10223 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10224 array1
, build_int_cst (TREE_TYPE (array1
), 0));
10226 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10228 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10230 lss
->info
->string_length
,
10231 rss
->info
->string_length
);
10232 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10233 logical_type_node
, tmp
, cond_null
);
10236 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10238 tmp
= build3_v (COND_EXPR
, cond_null
,
10239 build1_v (GOTO_EXPR
, jump_label1
),
10240 build_empty_stmt (input_location
));
10241 gfc_add_expr_to_block (&fblock
, tmp
);
10243 /* Get arrayspec if expr is a full array. */
10244 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
10245 && expr2
->value
.function
.isym
10246 && expr2
->value
.function
.isym
->conversion
)
10248 /* For conversion functions, take the arg. */
10249 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
10250 as
= gfc_get_full_arrayspec_from_expr (arg
);
10253 as
= gfc_get_full_arrayspec_from_expr (expr2
);
10257 /* If the lhs shape is not the same as the rhs jump to setting the
10258 bounds and doing the reallocation....... */
10259 for (n
= 0; n
< expr1
->rank
; n
++)
10261 /* Check the shape. */
10262 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10263 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10264 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10265 gfc_array_index_type
,
10266 loop
->to
[n
], loop
->from
[n
]);
10267 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10268 gfc_array_index_type
,
10270 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10271 gfc_array_index_type
,
10273 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10275 tmp
, gfc_index_zero_node
);
10276 tmp
= build3_v (COND_EXPR
, cond
,
10277 build1_v (GOTO_EXPR
, jump_label1
),
10278 build_empty_stmt (input_location
));
10279 gfc_add_expr_to_block (&fblock
, tmp
);
10282 /* ....else jump past the (re)alloc code. */
10283 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10284 gfc_add_expr_to_block (&fblock
, tmp
);
10286 /* Add the label to start automatic (re)allocation. */
10287 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10288 gfc_add_expr_to_block (&fblock
, tmp
);
10290 /* If the lhs has not been allocated, its bounds will not have been
10291 initialized and so its size is set to zero. */
10292 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
10293 gfc_init_block (&alloc_block
);
10294 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
10295 gfc_init_block (&realloc_block
);
10296 gfc_add_modify (&realloc_block
, size1
,
10297 gfc_conv_descriptor_size (desc
, expr1
->rank
));
10298 tmp
= build3_v (COND_EXPR
, cond_null
,
10299 gfc_finish_block (&alloc_block
),
10300 gfc_finish_block (&realloc_block
));
10301 gfc_add_expr_to_block (&fblock
, tmp
);
10303 /* Get the rhs size and fix it. */
10305 desc2
= rss
->info
->data
.array
.descriptor
;
10309 size2
= gfc_index_one_node
;
10310 for (n
= 0; n
< expr2
->rank
; n
++)
10312 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10313 gfc_array_index_type
,
10314 loop
->to
[n
], loop
->from
[n
]);
10315 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10316 gfc_array_index_type
,
10317 tmp
, gfc_index_one_node
);
10318 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10319 gfc_array_index_type
,
10322 size2
= gfc_evaluate_now (size2
, &fblock
);
10324 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10327 /* If the lhs is deferred length, assume that the element size
10328 changes and force a reallocation. */
10329 if (expr1
->ts
.deferred
)
10330 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
10332 neq_size
= gfc_evaluate_now (cond
, &fblock
);
10334 /* Deallocation of allocatable components will have to occur on
10335 reallocation. Fix the old descriptor now. */
10336 if ((expr1
->ts
.type
== BT_DERIVED
)
10337 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10338 old_desc
= gfc_evaluate_now (desc
, &fblock
);
10340 old_desc
= NULL_TREE
;
10342 /* Now modify the lhs descriptor and the associated scalarizer
10343 variables. F2003 7.4.1.3: "If variable is or becomes an
10344 unallocated allocatable variable, then it is allocated with each
10345 deferred type parameter equal to the corresponding type parameters
10346 of expr , with the shape of expr , and with each lower bound equal
10347 to the corresponding element of LBOUND(expr)."
10348 Reuse size1 to keep a dimension-by-dimension track of the
10349 stride of the new array. */
10350 size1
= gfc_index_one_node
;
10351 offset
= gfc_index_zero_node
;
10353 for (n
= 0; n
< expr2
->rank
; n
++)
10355 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10356 gfc_array_index_type
,
10357 loop
->to
[n
], loop
->from
[n
]);
10358 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10359 gfc_array_index_type
,
10360 tmp
, gfc_index_one_node
);
10362 lbound
= gfc_index_one_node
;
10367 lbd
= get_std_lbound (expr2
, desc2
, n
,
10368 as
->type
== AS_ASSUMED_SIZE
);
10369 ubound
= fold_build2_loc (input_location
,
10371 gfc_array_index_type
,
10373 ubound
= fold_build2_loc (input_location
,
10375 gfc_array_index_type
,
10380 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
10383 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
10386 gfc_conv_descriptor_stride_set (&fblock
, desc
,
10389 lbound
= gfc_conv_descriptor_lbound_get (desc
,
10391 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
10392 gfc_array_index_type
,
10394 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10395 gfc_array_index_type
,
10397 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10398 gfc_array_index_type
,
10402 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10403 the array offset is saved and the info.offset is used for a
10404 running offset. Use the saved_offset instead. */
10405 tmp
= gfc_conv_descriptor_offset (desc
);
10406 gfc_add_modify (&fblock
, tmp
, offset
);
10407 if (linfo
->saved_offset
10408 && VAR_P (linfo
->saved_offset
))
10409 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10411 /* Now set the deltas for the lhs. */
10412 for (n
= 0; n
< expr1
->rank
; n
++)
10414 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10416 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10417 gfc_array_index_type
, tmp
,
10419 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10420 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10423 /* Get the new lhs size in bytes. */
10424 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10426 if (expr2
->ts
.deferred
)
10428 if (expr2
->ts
.u
.cl
->backend_decl
10429 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10430 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10432 tmp
= rss
->info
->string_length
;
10436 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10437 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10438 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10440 tmp
= concat_str_length (expr2
);
10441 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10443 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10446 gfc_init_se (&tmpse
, NULL
);
10447 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10448 gfc_charlen_type_node
);
10450 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10452 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10455 if (expr1
->ts
.u
.cl
->backend_decl
10456 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10457 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10459 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10461 if (expr1
->ts
.kind
> 1)
10462 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10464 tmp
, build_int_cst (TREE_TYPE (tmp
),
10467 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10469 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10470 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10471 gfc_array_index_type
, tmp
,
10472 expr1
->ts
.u
.cl
->backend_decl
);
10474 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10475 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10477 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10478 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10480 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10481 gfc_conv_descriptor_span_set (&fblock
, desc
, tmp
);
10483 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10484 gfc_array_index_type
,
10486 size2
= fold_convert (size_type_node
, size2
);
10487 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10488 size2
, size_one_node
);
10489 size2
= gfc_evaluate_now (size2
, &fblock
);
10491 /* For deferred character length, the 'size' field of the dtype might
10492 have changed so set the dtype. */
10493 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10494 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10497 tmp
= gfc_conv_descriptor_dtype (desc
);
10498 if (expr2
->ts
.u
.cl
->backend_decl
)
10499 type
= gfc_typenode_for_spec (&expr2
->ts
);
10501 type
= gfc_typenode_for_spec (&expr1
->ts
);
10503 gfc_add_modify (&fblock
, tmp
,
10504 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10506 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10509 tmp
= gfc_conv_descriptor_dtype (desc
);
10510 type
= gfc_typenode_for_spec (&expr2
->ts
);
10511 gfc_add_modify (&fblock
, tmp
,
10512 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10513 /* Set the _len field as well... */
10514 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10515 if (expr2
->ts
.type
== BT_CHARACTER
)
10516 gfc_add_modify (&fblock
, tmp
,
10517 fold_convert (TREE_TYPE (tmp
),
10518 TYPE_SIZE_UNIT (type
)));
10520 gfc_add_modify (&fblock
, tmp
,
10521 build_int_cst (TREE_TYPE (tmp
), 0));
10522 /* ...and the vptr. */
10523 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10524 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10525 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10526 gfc_add_modify (&fblock
, tmp
, tmp2
);
10528 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10530 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10531 gfc_get_dtype (TREE_TYPE (desc
)));
10534 /* Realloc expression. Note that the scalarizer uses desc.data
10535 in the array reference - (*desc.data)[<element>]. */
10536 gfc_init_block (&realloc_block
);
10537 gfc_init_se (&caf_se
, NULL
);
10541 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10542 if (token
== NULL_TREE
)
10544 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10545 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10546 tmp
= build_fold_indirect_ref (tmp
);
10547 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10549 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10552 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10554 if ((expr1
->ts
.type
== BT_DERIVED
)
10555 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10557 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10559 gfc_add_expr_to_block (&realloc_block
, tmp
);
10564 tmp
= build_call_expr_loc (input_location
,
10565 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10566 fold_convert (pvoid_type_node
, array1
),
10568 gfc_conv_descriptor_data_set (&realloc_block
,
10573 tmp
= build_call_expr_loc (input_location
,
10574 gfor_fndecl_caf_deregister
, 5, token
,
10575 build_int_cst (integer_type_node
,
10576 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10577 null_pointer_node
, null_pointer_node
,
10578 integer_zero_node
);
10579 gfc_add_expr_to_block (&realloc_block
, tmp
);
10580 tmp
= build_call_expr_loc (input_location
,
10581 gfor_fndecl_caf_register
,
10583 build_int_cst (integer_type_node
,
10584 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10585 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10586 null_pointer_node
, null_pointer_node
,
10587 integer_zero_node
);
10588 gfc_add_expr_to_block (&realloc_block
, tmp
);
10591 if ((expr1
->ts
.type
== BT_DERIVED
)
10592 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10594 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10596 gfc_add_expr_to_block (&realloc_block
, tmp
);
10599 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10600 realloc_expr
= gfc_finish_block (&realloc_block
);
10602 /* Only reallocate if sizes are different. */
10603 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10604 build_empty_stmt (input_location
));
10605 realloc_expr
= tmp
;
10608 /* Malloc expression. */
10609 gfc_init_block (&alloc_block
);
10612 tmp
= build_call_expr_loc (input_location
,
10613 builtin_decl_explicit (BUILT_IN_MALLOC
),
10615 gfc_conv_descriptor_data_set (&alloc_block
,
10620 tmp
= build_call_expr_loc (input_location
,
10621 gfor_fndecl_caf_register
,
10623 build_int_cst (integer_type_node
,
10624 GFC_CAF_COARRAY_ALLOC
),
10625 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10626 null_pointer_node
, null_pointer_node
,
10627 integer_zero_node
);
10628 gfc_add_expr_to_block (&alloc_block
, tmp
);
10632 /* We already set the dtype in the case of deferred character
10633 length arrays and unlimited polymorphic arrays. */
10634 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10635 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10637 && !UNLIMITED_POLY (expr1
))
10639 tmp
= gfc_conv_descriptor_dtype (desc
);
10640 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10643 if ((expr1
->ts
.type
== BT_DERIVED
)
10644 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10646 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10648 gfc_add_expr_to_block (&alloc_block
, tmp
);
10650 alloc_expr
= gfc_finish_block (&alloc_block
);
10652 /* Malloc if not allocated; realloc otherwise. */
10653 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10654 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10657 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10658 gfc_add_expr_to_block (&fblock
, tmp
);
10660 /* Make sure that the scalarizer data pointer is updated. */
10661 if (linfo
->data
&& VAR_P (linfo
->data
))
10663 tmp
= gfc_conv_descriptor_data_get (desc
);
10664 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10667 /* Add the exit label. */
10668 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10669 gfc_add_expr_to_block (&fblock
, tmp
);
10671 return gfc_finish_block (&fblock
);
10675 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10676 Do likewise, recursively if necessary, with the allocatable components of
10677 derived types. This function is also called for assumed-rank arrays, which
10678 are always dummy arguments. */
10681 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10687 stmtblock_t cleanup
;
10690 bool sym_has_alloc_comp
, has_finalizer
;
10692 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10693 || sym
->ts
.type
== BT_CLASS
)
10694 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10695 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10696 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10698 /* Make sure the frontend gets these right. */
10699 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10701 || (sym
->as
->type
== AS_ASSUMED_RANK
&& sym
->attr
.dummy
));
10703 gfc_save_backend_locus (&loc
);
10704 gfc_set_backend_locus (&sym
->declared_at
);
10705 gfc_init_block (&init
);
10707 gcc_assert (VAR_P (sym
->backend_decl
)
10708 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10710 if (sym
->ts
.type
== BT_CHARACTER
10711 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10713 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10714 gfc_trans_vla_type_sizes (sym
, &init
);
10717 /* Dummy, use associated and result variables don't need anything special. */
10718 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10720 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10721 gfc_restore_backend_locus (&loc
);
10725 descriptor
= sym
->backend_decl
;
10727 /* Although static, derived types with default initializers and
10728 allocatable components must not be nulled wholesale; instead they
10729 are treated component by component. */
10730 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10732 /* SAVEd variables are not freed on exit. */
10733 gfc_trans_static_array_pointer (sym
);
10735 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10736 gfc_restore_backend_locus (&loc
);
10740 /* Get the descriptor type. */
10741 type
= TREE_TYPE (sym
->backend_decl
);
10743 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10744 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10746 if (!sym
->attr
.save
10747 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10749 if (sym
->value
== NULL
10750 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10752 rank
= sym
->as
? sym
->as
->rank
: 0;
10753 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10755 gfc_add_expr_to_block (&init
, tmp
);
10758 gfc_init_default_dt (sym
, &init
, false);
10761 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10763 /* If the backend_decl is not a descriptor, we must have a pointer
10765 descriptor
= build_fold_indirect_ref_loc (input_location
,
10766 sym
->backend_decl
);
10767 type
= TREE_TYPE (descriptor
);
10770 /* NULLIFY the data pointer, for non-saved allocatables. */
10771 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10773 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10774 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10776 /* Declare the variable static so its array descriptor stays present
10777 after leaving the scope. It may still be accessed through another
10778 image. This may happen, for example, with the caf_mpi
10780 TREE_STATIC (descriptor
) = 1;
10781 tmp
= gfc_conv_descriptor_token (descriptor
);
10782 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10783 null_pointer_node
));
10787 gfc_restore_backend_locus (&loc
);
10788 gfc_init_block (&cleanup
);
10790 /* Allocatable arrays need to be freed when they go out of scope.
10791 The allocatable components of pointers must not be touched. */
10792 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10793 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10794 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10797 sym
->attr
.referenced
= 1;
10798 e
= gfc_lval_expr_from_sym (sym
);
10799 gfc_add_finalizer_call (&cleanup
, e
);
10802 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10803 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10804 && !sym
->attr
.pointer
&& !sym
->attr
.save
10805 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10808 rank
= sym
->as
? sym
->as
->rank
: 0;
10809 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10810 gfc_add_expr_to_block (&cleanup
, tmp
);
10813 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10814 && !sym
->attr
.save
&& !sym
->attr
.result
10815 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10818 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10819 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10820 NULL_TREE
, NULL_TREE
, true, e
,
10821 sym
->attr
.codimension
10822 ? GFC_CAF_COARRAY_DEREGISTER
10823 : GFC_CAF_COARRAY_NOCOARRAY
);
10826 gfc_add_expr_to_block (&cleanup
, tmp
);
10829 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10830 gfc_finish_block (&cleanup
));
10833 /************ Expression Walking Functions ******************/
10835 /* Walk a variable reference.
10837 Possible extension - multiple component subscripts.
10838 x(:,:) = foo%a(:)%b(:)
10840 forall (i=..., j=...)
10841 x(i,j) = foo%a(j)%b(i)
10843 This adds a fair amount of complexity because you need to deal with more
10844 than one ref. Maybe handle in a similar manner to vector subscripts.
10845 Maybe not worth the effort. */
10849 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10853 gfc_fix_class_refs (expr
);
10855 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10856 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10859 return gfc_walk_array_ref (ss
, expr
, ref
);
10864 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10870 for (; ref
; ref
= ref
->next
)
10872 if (ref
->type
== REF_SUBSTRING
)
10874 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10875 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10878 /* We're only interested in array sections from now on. */
10879 if (ref
->type
!= REF_ARRAY
)
10887 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10888 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10892 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10893 newss
->info
->data
.array
.ref
= ref
;
10895 /* Make sure array is the same as array(:,:), this way
10896 we don't need to special case all the time. */
10897 ar
->dimen
= ar
->as
->rank
;
10898 for (n
= 0; n
< ar
->dimen
; n
++)
10900 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10902 gcc_assert (ar
->start
[n
] == NULL
);
10903 gcc_assert (ar
->end
[n
] == NULL
);
10904 gcc_assert (ar
->stride
[n
] == NULL
);
10910 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10911 newss
->info
->data
.array
.ref
= ref
;
10913 /* We add SS chains for all the subscripts in the section. */
10914 for (n
= 0; n
< ar
->dimen
; n
++)
10918 switch (ar
->dimen_type
[n
])
10920 case DIMEN_ELEMENT
:
10921 /* Add SS for elemental (scalar) subscripts. */
10922 gcc_assert (ar
->start
[n
]);
10923 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10924 indexss
->loop_chain
= gfc_ss_terminator
;
10925 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10929 /* We don't add anything for sections, just remember this
10930 dimension for later. */
10931 newss
->dim
[newss
->dimen
] = n
;
10936 /* Create a GFC_SS_VECTOR index in which we can store
10937 the vector's descriptor. */
10938 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10940 indexss
->loop_chain
= gfc_ss_terminator
;
10941 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10942 newss
->dim
[newss
->dimen
] = n
;
10947 /* We should know what sort of section it is by now. */
10948 gcc_unreachable ();
10951 /* We should have at least one non-elemental dimension,
10952 unless we are creating a descriptor for a (scalar) coarray. */
10953 gcc_assert (newss
->dimen
> 0
10954 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10959 /* We should know what sort of section it is by now. */
10960 gcc_unreachable ();
10968 /* Walk an expression operator. If only one operand of a binary expression is
10969 scalar, we must also add the scalar term to the SS chain. */
10972 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10977 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10978 if (expr
->value
.op
.op2
== NULL
)
10981 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10983 /* All operands are scalar. Pass back and let the caller deal with it. */
10987 /* All operands require scalarization. */
10988 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10991 /* One of the operands needs scalarization, the other is scalar.
10992 Create a gfc_ss for the scalar expression. */
10995 /* First operand is scalar. We build the chain in reverse order, so
10996 add the scalar SS after the second operand. */
10998 while (head
&& head
->next
!= ss
)
11000 /* Check we haven't somehow broken the chain. */
11002 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
11004 else /* head2 == head */
11006 gcc_assert (head2
== head
);
11007 /* Second operand is scalar. */
11008 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
11015 /* Reverse a SS chain. */
11018 gfc_reverse_ss (gfc_ss
* ss
)
11023 gcc_assert (ss
!= NULL
);
11025 head
= gfc_ss_terminator
;
11026 while (ss
!= gfc_ss_terminator
)
11029 /* Check we didn't somehow break the chain. */
11030 gcc_assert (next
!= NULL
);
11040 /* Given an expression referring to a procedure, return the symbol of its
11041 interface. We can't get the procedure symbol directly as we have to handle
11042 the case of (deferred) type-bound procedures. */
11045 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
11050 if (procedure_ref
== NULL
)
11053 /* Normal procedure case. */
11054 if (procedure_ref
->expr_type
== EXPR_FUNCTION
11055 && procedure_ref
->value
.function
.esym
)
11056 sym
= procedure_ref
->value
.function
.esym
;
11058 sym
= procedure_ref
->symtree
->n
.sym
;
11060 /* Typebound procedure case. */
11061 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
11063 if (ref
->type
== REF_COMPONENT
11064 && ref
->u
.c
.component
->attr
.proc_pointer
)
11065 sym
= ref
->u
.c
.component
->ts
.interface
;
11074 /* Walk the arguments of an elemental function.
11075 PROC_EXPR is used to check whether an argument is permitted to be absent. If
11076 it is NULL, we don't do the check and the argument is assumed to be present.
11080 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
11081 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
11083 gfc_formal_arglist
*dummy_arg
;
11089 head
= gfc_ss_terminator
;
11093 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
11098 for (; arg
; arg
= arg
->next
)
11100 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
11101 goto loop_continue
;
11103 newss
= gfc_walk_subexpr (head
, arg
->expr
);
11106 /* Scalar argument. */
11107 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
11108 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
11109 newss
->info
->type
= type
;
11111 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
11116 if (dummy_arg
!= NULL
11117 && dummy_arg
->sym
->attr
.optional
11118 && arg
->expr
->expr_type
== EXPR_VARIABLE
11119 && (gfc_expr_attr (arg
->expr
).optional
11120 || gfc_expr_attr (arg
->expr
).allocatable
11121 || gfc_expr_attr (arg
->expr
).pointer
))
11122 newss
->info
->can_be_null_ref
= true;
11128 while (tail
->next
!= gfc_ss_terminator
)
11133 if (dummy_arg
!= NULL
)
11134 dummy_arg
= dummy_arg
->next
;
11139 /* If all the arguments are scalar we don't need the argument SS. */
11140 gfc_free_ss_chain (head
);
11141 /* Pass it back. */
11145 /* Add it onto the existing chain. */
11151 /* Walk a function call. Scalar functions are passed back, and taken out of
11152 scalarization loops. For elemental functions we walk their arguments.
11153 The result of functions returning arrays is stored in a temporary outside
11154 the loop, so that the function is only called once. Hence we do not need
11155 to walk their arguments. */
11158 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11160 gfc_intrinsic_sym
*isym
;
11162 gfc_component
*comp
= NULL
;
11164 isym
= expr
->value
.function
.isym
;
11166 /* Handle intrinsic functions separately. */
11168 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
11170 sym
= expr
->value
.function
.esym
;
11172 sym
= expr
->symtree
->n
.sym
;
11174 if (gfc_is_class_array_function (expr
))
11175 return gfc_get_array_ss (ss
, expr
,
11176 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
11179 /* A function that returns arrays. */
11180 comp
= gfc_get_proc_ptr_comp (expr
);
11181 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
11182 || (comp
&& comp
->attr
.dimension
))
11183 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
11185 /* Walk the parameters of an elemental function. For now we always pass
11187 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
11189 gfc_ss
*old_ss
= ss
;
11191 ss
= gfc_walk_elemental_function_args (old_ss
,
11192 expr
->value
.function
.actual
,
11193 gfc_get_proc_ifc_for_expr (expr
),
11197 || sym
->attr
.proc_pointer
11198 || sym
->attr
.if_source
!= IFSRC_DECL
11199 || sym
->attr
.array_outer_dependency
))
11200 ss
->info
->array_outer_dependency
= 1;
11203 /* Scalar functions are OK as these are evaluated outside the scalarization
11204 loop. Pass back and let the caller deal with it. */
11209 /* An array temporary is constructed for array constructors. */
11212 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
11214 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
11218 /* Walk an expression. Add walked expressions to the head of the SS chain.
11219 A wholly scalar expression will not be added. */
11222 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
11226 switch (expr
->expr_type
)
11228 case EXPR_VARIABLE
:
11229 head
= gfc_walk_variable_expr (ss
, expr
);
11233 head
= gfc_walk_op_expr (ss
, expr
);
11236 case EXPR_FUNCTION
:
11237 head
= gfc_walk_function_expr (ss
, expr
);
11240 case EXPR_CONSTANT
:
11242 case EXPR_STRUCTURE
:
11243 /* Pass back and let the caller deal with it. */
11247 head
= gfc_walk_array_constructor (ss
, expr
);
11250 case EXPR_SUBSTRING
:
11251 /* Pass back and let the caller deal with it. */
11255 gfc_internal_error ("bad expression type during walk (%d)",
11262 /* Entry point for expression walking.
11263 A return value equal to the passed chain means this is
11264 a scalar expression. It is up to the caller to take whatever action is
11265 necessary to translate these. */
11268 gfc_walk_expr (gfc_expr
* expr
)
11272 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
11273 return gfc_reverse_ss (res
);