1 /* Array translation routines
2 Copyright (C) 2002-2020 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
80 #include "coretypes.h"
84 #include "gimple-expr.h"
86 #include "fold-const.h"
87 #include "constructor.h"
88 #include "trans-types.h"
89 #include "trans-array.h"
90 #include "trans-const.h"
91 #include "dependency.h"
93 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
95 /* The contents of this structure aren't actually used, just the address. */
96 static gfc_ss gfc_ss_terminator_var
;
97 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
101 gfc_array_dataptr_type (tree desc
)
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
107 /* Build expressions to access the members of an array descriptor.
108 It's surprisingly easy to mess up here, so never access
109 an array descriptor by "brute force", always use these
110 functions. This also avoids problems if we change the format
111 of an array descriptor.
113 To understand these magic numbers, look at the comments
114 before gfc_build_array_type() in trans-types.c.
116 The code within these defines should be the only code which knows the format
117 of an array descriptor.
119 Any code just needing to read obtain the bounds of an array should use
120 gfc_conv_array_* rather than the following functions as these will return
121 know constant values, and work with arrays which do not have descriptors.
123 Don't forget to #undef these! */
126 #define OFFSET_FIELD 1
127 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 4
130 #define CAF_TOKEN_FIELD 5
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc
)
144 type
= TREE_TYPE (desc
);
145 if (TREE_CODE (type
) == REFERENCE_TYPE
)
146 type
= TREE_TYPE (type
);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
150 field
= TYPE_FIELDS (type
);
151 gcc_assert (DATA_FIELD
== 0);
153 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
155 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
160 /* This provides WRITE access to the data field.
162 TUPLES_P is true if we are generating tuples.
164 This function gets called through the following macros:
165 gfc_conv_descriptor_data_set
166 gfc_conv_descriptor_data_set. */
169 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
173 type
= TREE_TYPE (desc
);
174 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
176 field
= TYPE_FIELDS (type
);
177 gcc_assert (DATA_FIELD
== 0);
179 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
181 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
185 /* This provides address access to the data field. This should only be
186 used by array allocation, passing this on to the runtime. */
189 gfc_conv_descriptor_data_addr (tree desc
)
193 type
= TREE_TYPE (desc
);
194 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
196 field
= TYPE_FIELDS (type
);
197 gcc_assert (DATA_FIELD
== 0);
199 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
201 return gfc_build_addr_expr (NULL_TREE
, t
);
205 gfc_conv_descriptor_offset (tree desc
)
210 type
= TREE_TYPE (desc
);
211 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
213 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
214 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
216 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
217 desc
, field
, NULL_TREE
);
221 gfc_conv_descriptor_offset_get (tree desc
)
223 return gfc_conv_descriptor_offset (desc
);
227 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
230 tree t
= gfc_conv_descriptor_offset (desc
);
231 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
236 gfc_conv_descriptor_dtype (tree desc
)
241 type
= TREE_TYPE (desc
);
242 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
244 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
245 gcc_assert (field
!= NULL_TREE
246 && TREE_TYPE (field
) == get_dtype_type_node ());
248 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
249 desc
, field
, NULL_TREE
);
253 gfc_conv_descriptor_span (tree desc
)
258 type
= TREE_TYPE (desc
);
259 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
261 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
262 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
264 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
265 desc
, field
, NULL_TREE
);
269 gfc_conv_descriptor_span_get (tree desc
)
271 return gfc_conv_descriptor_span (desc
);
275 gfc_conv_descriptor_span_set (stmtblock_t
*block
, tree desc
,
278 tree t
= gfc_conv_descriptor_span (desc
);
279 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
284 gfc_conv_descriptor_rank (tree desc
)
289 dtype
= gfc_conv_descriptor_dtype (desc
);
290 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)), GFC_DTYPE_RANK
);
291 gcc_assert (tmp
!= NULL_TREE
292 && TREE_TYPE (tmp
) == signed_char_type_node
);
293 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
294 dtype
, tmp
, NULL_TREE
);
298 /* Return the element length from the descriptor dtype field. */
301 gfc_conv_descriptor_elem_len (tree desc
)
306 dtype
= gfc_conv_descriptor_dtype (desc
);
307 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
309 gcc_assert (tmp
!= NULL_TREE
310 && TREE_TYPE (tmp
) == size_type_node
);
311 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
312 dtype
, tmp
, NULL_TREE
);
317 gfc_conv_descriptor_attribute (tree desc
)
322 dtype
= gfc_conv_descriptor_dtype (desc
);
323 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)),
324 GFC_DTYPE_ATTRIBUTE
);
325 gcc_assert (tmp
!= NULL_TREE
326 && TREE_TYPE (tmp
) == short_integer_type_node
);
327 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
328 dtype
, tmp
, NULL_TREE
);
333 gfc_get_descriptor_dimension (tree desc
)
337 type
= TREE_TYPE (desc
);
338 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
340 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
341 gcc_assert (field
!= NULL_TREE
342 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
343 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
345 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
346 desc
, field
, NULL_TREE
);
351 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
355 tmp
= gfc_get_descriptor_dimension (desc
);
357 return gfc_build_array_ref (tmp
, dim
, NULL
);
362 gfc_conv_descriptor_token (tree desc
)
367 type
= TREE_TYPE (desc
);
368 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
369 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
370 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
372 /* Should be a restricted pointer - except in the finalization wrapper. */
373 gcc_assert (field
!= NULL_TREE
374 && (TREE_TYPE (field
) == prvoid_type_node
375 || TREE_TYPE (field
) == pvoid_type_node
));
377 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
378 desc
, field
, NULL_TREE
);
383 gfc_conv_descriptor_stride (tree desc
, tree dim
)
388 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
389 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
390 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
391 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
393 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
394 tmp
, field
, NULL_TREE
);
399 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
401 tree type
= TREE_TYPE (desc
);
402 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
403 if (integer_zerop (dim
)
404 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
405 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
406 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
407 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
408 return gfc_index_one_node
;
410 return gfc_conv_descriptor_stride (desc
, dim
);
414 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
415 tree dim
, tree value
)
417 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
418 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
422 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
427 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
428 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
429 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
430 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
432 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
433 tmp
, field
, NULL_TREE
);
438 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
440 return gfc_conv_descriptor_lbound (desc
, dim
);
444 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
445 tree dim
, tree value
)
447 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
448 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
452 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
457 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
458 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
459 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
460 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
462 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
463 tmp
, field
, NULL_TREE
);
468 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
470 return gfc_conv_descriptor_ubound (desc
, dim
);
474 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
475 tree dim
, tree value
)
477 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
478 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
481 /* Build a null array descriptor constructor. */
484 gfc_build_null_descriptor (tree type
)
489 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
490 gcc_assert (DATA_FIELD
== 0);
491 field
= TYPE_FIELDS (type
);
493 /* Set a NULL data pointer. */
494 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
495 TREE_CONSTANT (tmp
) = 1;
496 /* All other fields are ignored. */
502 /* Modify a descriptor such that the lbound of a given dimension is the value
503 specified. This also updates ubound and offset accordingly. */
506 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
507 int dim
, tree new_lbound
)
509 tree offs
, ubound
, lbound
, stride
;
510 tree diff
, offs_diff
;
512 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
514 offs
= gfc_conv_descriptor_offset_get (desc
);
515 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
516 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
517 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
519 /* Get difference (new - old) by which to shift stuff. */
520 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
523 /* Shift ubound and offset accordingly. This has to be done before
524 updating the lbound, as they depend on the lbound expression! */
525 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
527 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
528 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
530 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
532 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
534 /* Finally set lbound to value we want. */
535 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
539 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
542 gfc_get_descriptor_offsets_for_info (const_tree desc_type
, tree
*data_off
,
543 tree
*dtype_off
, tree
*span_off
,
544 tree
*dim_off
, tree
*dim_size
,
545 tree
*stride_suboff
, tree
*lower_suboff
,
551 type
= TYPE_MAIN_VARIANT (desc_type
);
552 field
= gfc_advance_chain (TYPE_FIELDS (type
), DATA_FIELD
);
553 *data_off
= byte_position (field
);
554 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
555 *dtype_off
= byte_position (field
);
556 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
557 *span_off
= byte_position (field
);
558 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
559 *dim_off
= byte_position (field
);
560 type
= TREE_TYPE (TREE_TYPE (field
));
561 *dim_size
= TYPE_SIZE_UNIT (type
);
562 field
= gfc_advance_chain (TYPE_FIELDS (type
), STRIDE_SUBFIELD
);
563 *stride_suboff
= byte_position (field
);
564 field
= gfc_advance_chain (TYPE_FIELDS (type
), LBOUND_SUBFIELD
);
565 *lower_suboff
= byte_position (field
);
566 field
= gfc_advance_chain (TYPE_FIELDS (type
), UBOUND_SUBFIELD
);
567 *upper_suboff
= byte_position (field
);
571 /* Cleanup those #defines. */
577 #undef DIMENSION_FIELD
578 #undef CAF_TOKEN_FIELD
579 #undef STRIDE_SUBFIELD
580 #undef LBOUND_SUBFIELD
581 #undef UBOUND_SUBFIELD
584 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
585 flags & 1 = Main loop body.
586 flags & 2 = temp copy loop. */
589 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
591 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
592 ss
->info
->useflags
= flags
;
596 /* Free a gfc_ss chain. */
599 gfc_free_ss_chain (gfc_ss
* ss
)
603 while (ss
!= gfc_ss_terminator
)
605 gcc_assert (ss
!= NULL
);
614 free_ss_info (gfc_ss_info
*ss_info
)
619 if (ss_info
->refcount
> 0)
622 gcc_assert (ss_info
->refcount
== 0);
624 switch (ss_info
->type
)
627 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
628 if (ss_info
->data
.array
.subscript
[n
])
629 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
643 gfc_free_ss (gfc_ss
* ss
)
645 free_ss_info (ss
->info
);
650 /* Creates and initializes an array type gfc_ss struct. */
653 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
656 gfc_ss_info
*ss_info
;
659 ss_info
= gfc_get_ss_info ();
661 ss_info
->type
= type
;
662 ss_info
->expr
= expr
;
668 for (i
= 0; i
< ss
->dimen
; i
++)
675 /* Creates and initializes a temporary type gfc_ss struct. */
678 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
681 gfc_ss_info
*ss_info
;
684 ss_info
= gfc_get_ss_info ();
686 ss_info
->type
= GFC_SS_TEMP
;
687 ss_info
->string_length
= string_length
;
688 ss_info
->data
.temp
.type
= type
;
692 ss
->next
= gfc_ss_terminator
;
694 for (i
= 0; i
< ss
->dimen
; i
++)
701 /* Creates and initializes a scalar type gfc_ss struct. */
704 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
707 gfc_ss_info
*ss_info
;
709 ss_info
= gfc_get_ss_info ();
711 ss_info
->type
= GFC_SS_SCALAR
;
712 ss_info
->expr
= expr
;
722 /* Free all the SS associated with a loop. */
725 gfc_cleanup_loop (gfc_loopinfo
* loop
)
727 gfc_loopinfo
*loop_next
, **ploop
;
732 while (ss
!= gfc_ss_terminator
)
734 gcc_assert (ss
!= NULL
);
735 next
= ss
->loop_chain
;
740 /* Remove reference to self in the parent loop. */
742 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
749 /* Free non-freed nested loops. */
750 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
752 loop_next
= loop
->next
;
753 gfc_cleanup_loop (loop
);
760 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
764 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
768 if (ss
->info
->type
== GFC_SS_SCALAR
769 || ss
->info
->type
== GFC_SS_REFERENCE
770 || ss
->info
->type
== GFC_SS_TEMP
)
773 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
774 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
775 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
780 /* Associate a SS chain with a loop. */
783 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
786 gfc_loopinfo
*nested_loop
;
788 if (head
== gfc_ss_terminator
)
791 set_ss_loop (head
, loop
);
794 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
798 nested_loop
= ss
->nested_ss
->loop
;
800 /* More than one ss can belong to the same loop. Hence, we add the
801 loop to the chain only if it is different from the previously
802 added one, to avoid duplicate nested loops. */
803 if (nested_loop
!= loop
->nested
)
805 gcc_assert (nested_loop
->parent
== NULL
);
806 nested_loop
->parent
= loop
;
808 gcc_assert (nested_loop
->next
== NULL
);
809 nested_loop
->next
= loop
->nested
;
810 loop
->nested
= nested_loop
;
813 gcc_assert (nested_loop
->parent
== loop
);
816 if (ss
->next
== gfc_ss_terminator
)
817 ss
->loop_chain
= loop
->ss
;
819 ss
->loop_chain
= ss
->next
;
821 gcc_assert (ss
== gfc_ss_terminator
);
826 /* Returns true if the expression is an array pointer. */
829 is_pointer_array (tree expr
)
831 if (expr
== NULL_TREE
832 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr
))
833 || GFC_CLASS_TYPE_P (TREE_TYPE (expr
)))
836 if (TREE_CODE (expr
) == VAR_DECL
837 && GFC_DECL_PTR_ARRAY_P (expr
))
840 if (TREE_CODE (expr
) == PARM_DECL
841 && GFC_DECL_PTR_ARRAY_P (expr
))
844 if (TREE_CODE (expr
) == INDIRECT_REF
845 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 0)))
848 /* The field declaration is marked as an pointer array. */
849 if (TREE_CODE (expr
) == COMPONENT_REF
850 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 1))
851 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr
, 1))))
858 /* If the symbol or expression reference a CFI descriptor, return the
859 pointer to the converted gfc descriptor. If an array reference is
860 present as the last argument, check that it is the one applied to
861 the CFI descriptor in the expression. Note that the CFI object is
862 always the symbol in the expression! */
865 get_CFI_desc (gfc_symbol
*sym
, gfc_expr
*expr
,
866 tree
*desc
, gfc_array_ref
*ar
)
870 if (!is_CFI_desc (sym
, expr
))
875 if (!(expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
876 || (&expr
->ref
->u
.ar
!= ar
))
881 tmp
= expr
->symtree
->n
.sym
->backend_decl
;
883 tmp
= sym
->backend_decl
;
885 if (tmp
&& DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
886 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
893 /* Return the span of an array. */
896 gfc_get_array_span (tree desc
, gfc_expr
*expr
)
900 if (is_pointer_array (desc
) || get_CFI_desc (NULL
, expr
, &desc
, NULL
))
902 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
903 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
905 /* This will have the span field set. */
906 tmp
= gfc_conv_descriptor_span_get (desc
);
908 else if (TREE_CODE (desc
) == COMPONENT_REF
909 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
910 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
912 /* The descriptor is a class _data field and so use the vtable
913 size for the receiving span field. */
914 tmp
= gfc_get_vptr_from_expr (desc
);
915 tmp
= gfc_vptr_size_get (tmp
);
917 else if (expr
&& expr
->expr_type
== EXPR_VARIABLE
918 && expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
919 && expr
->ref
->type
== REF_COMPONENT
920 && expr
->ref
->next
->type
== REF_ARRAY
921 && expr
->ref
->next
->next
== NULL
922 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.dimension
)
924 /* Dummys come in sometimes with the descriptor detached from
925 the class field or declaration. */
926 tmp
= gfc_class_vptr_get (expr
->symtree
->n
.sym
->backend_decl
);
927 tmp
= gfc_vptr_size_get (tmp
);
931 /* If none of the fancy stuff works, the span is the element
932 size of the array. Attempt to deal with unbounded character
933 types if possible. Otherwise, return NULL_TREE. */
934 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
935 if (tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
936 && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) == NULL_TREE
937 || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)))))
939 if (expr
->expr_type
== EXPR_VARIABLE
940 && expr
->ts
.type
== BT_CHARACTER
)
941 tmp
= fold_convert (gfc_array_index_type
,
942 gfc_get_expr_charlen (expr
));
947 tmp
= fold_convert (gfc_array_index_type
,
948 size_in_bytes (tmp
));
954 /* Generate an initializer for a static pointer or allocatable array. */
957 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
961 gcc_assert (TREE_STATIC (sym
->backend_decl
));
962 /* Just zero the data member. */
963 type
= TREE_TYPE (sym
->backend_decl
);
964 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
968 /* If the bounds of SE's loop have not yet been set, see if they can be
969 determined from array spec AS, which is the array spec of a called
970 function. MAPPING maps the callee's dummy arguments to the values
971 that the caller is passing. Add any initialization and finalization
975 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
976 gfc_se
* se
, gfc_array_spec
* as
)
978 int n
, dim
, total_dim
;
987 if (!as
|| as
->type
!= AS_EXPLICIT
)
990 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
992 total_dim
+= ss
->loop
->dimen
;
993 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
995 /* The bound is known, nothing to do. */
996 if (ss
->loop
->to
[n
] != NULL_TREE
)
1000 gcc_assert (dim
< as
->rank
);
1001 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
1003 /* Evaluate the lower bound. */
1004 gfc_init_se (&tmpse
, NULL
);
1005 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
1006 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
1007 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
1008 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
1010 /* ...and the upper bound. */
1011 gfc_init_se (&tmpse
, NULL
);
1012 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
1013 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
1014 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
1015 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
1017 /* Set the upper bound of the loop to UPPER - LOWER. */
1018 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1019 gfc_array_index_type
, upper
, lower
);
1020 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1021 ss
->loop
->to
[n
] = tmp
;
1025 gcc_assert (total_dim
== as
->rank
);
1029 /* Generate code to allocate an array temporary, or create a variable to
1030 hold the data. If size is NULL, zero the descriptor so that the
1031 callee will allocate the array. If DEALLOC is true, also generate code to
1032 free the array afterwards.
1034 If INITIAL is not NULL, it is packed using internal_pack and the result used
1035 as data instead of allocating a fresh, unitialized area of memory.
1037 Initialization code is added to PRE and finalization code to POST.
1038 DYNAMIC is true if the caller may want to extend the array later
1039 using realloc. This prevents us from putting the array on the stack. */
1042 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
1043 gfc_array_info
* info
, tree size
, tree nelem
,
1044 tree initial
, bool dynamic
, bool dealloc
)
1050 desc
= info
->descriptor
;
1051 info
->offset
= gfc_index_zero_node
;
1052 if (size
== NULL_TREE
|| integer_zerop (size
))
1054 /* A callee allocated array. */
1055 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
1060 /* Allocate the temporary. */
1061 onstack
= !dynamic
&& initial
== NULL_TREE
1062 && (flag_stack_arrays
1063 || gfc_can_put_var_on_stack (size
));
1067 /* Make a temporary variable to hold the data. */
1068 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
1069 nelem
, gfc_index_one_node
);
1070 tmp
= gfc_evaluate_now (tmp
, pre
);
1071 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1073 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
1075 tmp
= gfc_create_var (tmp
, "A");
1076 /* If we're here only because of -fstack-arrays we have to
1077 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1078 if (!gfc_can_put_var_on_stack (size
))
1079 gfc_add_expr_to_block (pre
,
1080 fold_build1_loc (input_location
,
1081 DECL_EXPR
, TREE_TYPE (tmp
),
1083 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1084 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1088 /* Allocate memory to hold the data or call internal_pack. */
1089 if (initial
== NULL_TREE
)
1091 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1092 tmp
= gfc_evaluate_now (tmp
, pre
);
1099 stmtblock_t do_copying
;
1101 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1102 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1103 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1104 tmp
= gfc_get_element_type (tmp
);
1105 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1106 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1108 tmp
= build_call_expr_loc (input_location
,
1109 gfor_fndecl_in_pack
, 1, initial
);
1110 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1111 gfc_add_modify (pre
, packed
, tmp
);
1113 tmp
= build_fold_indirect_ref_loc (input_location
,
1115 source_data
= gfc_conv_descriptor_data_get (tmp
);
1117 /* internal_pack may return source->data without any allocation
1118 or copying if it is already packed. If that's the case, we
1119 need to allocate and copy manually. */
1121 gfc_start_block (&do_copying
);
1122 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1123 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1124 gfc_add_modify (&do_copying
, packed
, tmp
);
1125 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1126 gfc_add_expr_to_block (&do_copying
, tmp
);
1128 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1129 logical_type_node
, packed
,
1131 tmp
= gfc_finish_block (&do_copying
);
1132 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1133 build_empty_stmt (input_location
));
1134 gfc_add_expr_to_block (pre
, tmp
);
1136 tmp
= fold_convert (pvoid_type_node
, packed
);
1139 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1142 info
->data
= gfc_conv_descriptor_data_get (desc
);
1144 /* The offset is zero because we create temporaries with a zero
1146 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1148 if (dealloc
&& !onstack
)
1150 /* Free the temporary. */
1151 tmp
= gfc_conv_descriptor_data_get (desc
);
1152 tmp
= gfc_call_free (tmp
);
1153 gfc_add_expr_to_block (post
, tmp
);
1158 /* Get the scalarizer array dimension corresponding to actual array dimension
1161 For example, if SS represents the array ref a(1,:,:,1), it is a
1162 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1163 and 1 for ARRAY_DIM=2.
1164 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1165 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1167 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1168 array. If called on the inner ss, the result would be respectively 0,1,2 for
1169 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1170 for ARRAY_DIM=1,2. */
1173 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1180 for (; ss
; ss
= ss
->parent
)
1181 for (n
= 0; n
< ss
->dimen
; n
++)
1182 if (ss
->dim
[n
] < array_dim
)
1185 return array_ref_dim
;
1190 innermost_ss (gfc_ss
*ss
)
1192 while (ss
->nested_ss
!= NULL
)
1200 /* Get the array reference dimension corresponding to the given loop dimension.
1201 It is different from the true array dimension given by the dim array in
1202 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1203 It is different from the loop dimension in the case of a transposed array.
1207 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1209 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1214 /* Generate code to create and initialize the descriptor for a temporary
1215 array. This is used for both temporaries needed by the scalarizer, and
1216 functions returning arrays. Adjusts the loop variables to be
1217 zero-based, and calculates the loop bounds for callee allocated arrays.
1218 Allocate the array unless it's callee allocated (we have a callee
1219 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1220 NULL_TREE for any n). Also fills in the descriptor, data and offset
1221 fields of info if known. Returns the size of the array, or NULL for a
1222 callee allocated array.
1224 'eltype' == NULL signals that the temporary should be a class object.
1225 The 'initial' expression is used to obtain the size of the dynamic
1226 type; otherwise the allocation and initialization proceeds as for any
1229 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1230 gfc_trans_allocate_array_storage. */
1233 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1234 tree eltype
, tree initial
, bool dynamic
,
1235 bool dealloc
, bool callee_alloc
, locus
* where
)
1239 gfc_array_info
*info
;
1240 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1249 tree class_expr
= NULL_TREE
;
1250 int n
, dim
, tmp_dim
;
1253 /* This signals a class array for which we need the size of the
1254 dynamic type. Generate an eltype and then the class expression. */
1255 if (eltype
== NULL_TREE
&& initial
)
1257 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1258 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1259 eltype
= TREE_TYPE (class_expr
);
1260 eltype
= gfc_get_element_type (eltype
);
1261 /* Obtain the structure (class) expression. */
1262 class_expr
= TREE_OPERAND (class_expr
, 0);
1263 gcc_assert (class_expr
);
1266 memset (from
, 0, sizeof (from
));
1267 memset (to
, 0, sizeof (to
));
1269 info
= &ss
->info
->data
.array
;
1271 gcc_assert (ss
->dimen
> 0);
1272 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1274 if (warn_array_temporaries
&& where
)
1275 gfc_warning (OPT_Warray_temporaries
,
1276 "Creating array temporary at %L", where
);
1278 /* Set the lower bound to zero. */
1279 for (s
= ss
; s
; s
= s
->parent
)
1283 total_dim
+= loop
->dimen
;
1284 for (n
= 0; n
< loop
->dimen
; n
++)
1288 /* Callee allocated arrays may not have a known bound yet. */
1290 loop
->to
[n
] = gfc_evaluate_now (
1291 fold_build2_loc (input_location
, MINUS_EXPR
,
1292 gfc_array_index_type
,
1293 loop
->to
[n
], loop
->from
[n
]),
1295 loop
->from
[n
] = gfc_index_zero_node
;
1297 /* We have just changed the loop bounds, we must clear the
1298 corresponding specloop, so that delta calculation is not skipped
1299 later in gfc_set_delta. */
1300 loop
->specloop
[n
] = NULL
;
1302 /* We are constructing the temporary's descriptor based on the loop
1303 dimensions. As the dimensions may be accessed in arbitrary order
1304 (think of transpose) the size taken from the n'th loop may not map
1305 to the n'th dimension of the array. We need to reconstruct loop
1306 infos in the right order before using it to set the descriptor
1308 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1309 from
[tmp_dim
] = loop
->from
[n
];
1310 to
[tmp_dim
] = loop
->to
[n
];
1312 info
->delta
[dim
] = gfc_index_zero_node
;
1313 info
->start
[dim
] = gfc_index_zero_node
;
1314 info
->end
[dim
] = gfc_index_zero_node
;
1315 info
->stride
[dim
] = gfc_index_one_node
;
1319 /* Initialize the descriptor. */
1321 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1322 GFC_ARRAY_UNKNOWN
, true);
1323 desc
= gfc_create_var (type
, "atmp");
1324 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1326 info
->descriptor
= desc
;
1327 size
= gfc_index_one_node
;
1329 /* Emit a DECL_EXPR for the variable sized array type in
1330 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1331 sizes works correctly. */
1332 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1333 if (! TYPE_NAME (arraytype
))
1334 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1335 NULL_TREE
, arraytype
);
1336 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1337 arraytype
, TYPE_NAME (arraytype
)));
1339 /* Fill in the array dtype. */
1340 tmp
= gfc_conv_descriptor_dtype (desc
);
1341 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1344 Fill in the bounds and stride. This is a packed array, so:
1347 for (n = 0; n < rank; n++)
1350 delta = ubound[n] + 1 - lbound[n];
1351 size = size * delta;
1353 size = size * sizeof(element);
1356 or_expr
= NULL_TREE
;
1358 /* If there is at least one null loop->to[n], it is a callee allocated
1360 for (n
= 0; n
< total_dim
; n
++)
1361 if (to
[n
] == NULL_TREE
)
1367 if (size
== NULL_TREE
)
1368 for (s
= ss
; s
; s
= s
->parent
)
1369 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1371 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1373 /* For a callee allocated array express the loop bounds in terms
1374 of the descriptor fields. */
1375 tmp
= fold_build2_loc (input_location
,
1376 MINUS_EXPR
, gfc_array_index_type
,
1377 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1378 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1379 s
->loop
->to
[n
] = tmp
;
1383 for (n
= 0; n
< total_dim
; n
++)
1385 /* Store the stride and bound components in the descriptor. */
1386 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1388 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1389 gfc_index_zero_node
);
1391 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1393 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1394 gfc_array_index_type
,
1395 to
[n
], gfc_index_one_node
);
1397 /* Check whether the size for this dimension is negative. */
1398 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1399 tmp
, gfc_index_zero_node
);
1400 cond
= gfc_evaluate_now (cond
, pre
);
1405 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1406 logical_type_node
, or_expr
, cond
);
1408 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1409 gfc_array_index_type
, size
, tmp
);
1410 size
= gfc_evaluate_now (size
, pre
);
1414 if (class_expr
== NULL_TREE
)
1415 elemsize
= fold_convert (gfc_array_index_type
,
1416 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1418 elemsize
= gfc_class_vtab_size_get (class_expr
);
1420 /* Get the size of the array. */
1421 if (size
&& !callee_alloc
)
1423 /* If or_expr is true, then the extent in at least one
1424 dimension is zero and the size is set to zero. */
1425 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1426 or_expr
, gfc_index_zero_node
, size
);
1429 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1439 tmp
= fold_convert (gfc_array_index_type
, elemsize
);
1440 gfc_conv_descriptor_span_set (pre
, desc
, tmp
);
1442 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1448 if (ss
->dimen
> ss
->loop
->temp_dim
)
1449 ss
->loop
->temp_dim
= ss
->dimen
;
1455 /* Return the number of iterations in a loop that starts at START,
1456 ends at END, and has step STEP. */
1459 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1464 type
= TREE_TYPE (step
);
1465 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1466 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1467 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1468 build_int_cst (type
, 1));
1469 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1470 build_int_cst (type
, 0));
1471 return fold_convert (gfc_array_index_type
, tmp
);
1475 /* Extend the data in array DESC by EXTRA elements. */
1478 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1485 if (integer_zerop (extra
))
1488 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1490 /* Add EXTRA to the upper bound. */
1491 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1493 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1495 /* Get the value of the current data pointer. */
1496 arg0
= gfc_conv_descriptor_data_get (desc
);
1498 /* Calculate the new array size. */
1499 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1500 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1501 ubound
, gfc_index_one_node
);
1502 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1503 fold_convert (size_type_node
, tmp
),
1504 fold_convert (size_type_node
, size
));
1506 /* Call the realloc() function. */
1507 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1508 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1512 /* Return true if the bounds of iterator I can only be determined
1516 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1518 return (i
->start
->expr_type
!= EXPR_CONSTANT
1519 || i
->end
->expr_type
!= EXPR_CONSTANT
1520 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1524 /* Split the size of constructor element EXPR into the sum of two terms,
1525 one of which can be determined at compile time and one of which must
1526 be calculated at run time. Set *SIZE to the former and return true
1527 if the latter might be nonzero. */
1530 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1532 if (expr
->expr_type
== EXPR_ARRAY
)
1533 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1534 else if (expr
->rank
> 0)
1536 /* Calculate everything at run time. */
1537 mpz_set_ui (*size
, 0);
1542 /* A single element. */
1543 mpz_set_ui (*size
, 1);
1549 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1550 of array constructor C. */
1553 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1561 mpz_set_ui (*size
, 0);
1566 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1569 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1573 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1576 /* Multiply the static part of the element size by the
1577 number of iterations. */
1578 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1579 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1580 mpz_add_ui (val
, val
, 1);
1581 if (mpz_sgn (val
) > 0)
1582 mpz_mul (len
, len
, val
);
1584 mpz_set_ui (len
, 0);
1586 mpz_add (*size
, *size
, len
);
1595 /* Make sure offset is a variable. */
1598 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1601 /* We should have already created the offset variable. We cannot
1602 create it here because we may be in an inner scope. */
1603 gcc_assert (*offsetvar
!= NULL_TREE
);
1604 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1605 *poffset
= *offsetvar
;
1606 TREE_USED (*offsetvar
) = 1;
1610 /* Variables needed for bounds-checking. */
1611 static bool first_len
;
1612 static tree first_len_val
;
1613 static bool typespec_chararray_ctor
;
1616 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1617 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1621 gfc_conv_expr (se
, expr
);
1623 /* Store the value. */
1624 tmp
= build_fold_indirect_ref_loc (input_location
,
1625 gfc_conv_descriptor_data_get (desc
));
1626 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1628 if (expr
->ts
.type
== BT_CHARACTER
)
1630 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1633 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1634 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1635 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1636 TREE_TYPE (esize
), esize
,
1637 build_int_cst (TREE_TYPE (esize
),
1638 gfc_character_kinds
[i
].bit_size
/ 8));
1640 gfc_conv_string_parameter (se
);
1641 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1643 /* The temporary is an array of pointers. */
1644 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1645 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1649 /* The temporary is an array of string values. */
1650 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1651 /* We know the temporary and the value will be the same length,
1652 so can use memcpy. */
1653 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1654 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1656 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1660 gfc_add_modify (&se
->pre
, first_len_val
,
1661 fold_convert (TREE_TYPE (first_len_val
),
1662 se
->string_length
));
1667 /* Verify that all constructor elements are of the same
1669 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1671 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1672 logical_type_node
, first_len_val
,
1674 gfc_trans_runtime_check
1675 (true, false, cond
, &se
->pre
, &expr
->where
,
1676 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1677 fold_convert (long_integer_type_node
, first_len_val
),
1678 fold_convert (long_integer_type_node
, se
->string_length
));
1682 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1683 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1685 /* Assignment of a CLASS array constructor to a derived type array. */
1686 if (expr
->expr_type
== EXPR_FUNCTION
)
1687 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1688 se
->expr
= gfc_class_data_get (se
->expr
);
1689 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1690 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1691 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1695 /* TODO: Should the frontend already have done this conversion? */
1696 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1697 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1700 gfc_add_block_to_block (pblock
, &se
->pre
);
1701 gfc_add_block_to_block (pblock
, &se
->post
);
1705 /* Add the contents of an array to the constructor. DYNAMIC is as for
1706 gfc_trans_array_constructor_value. */
1709 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1710 tree type ATTRIBUTE_UNUSED
,
1711 tree desc
, gfc_expr
* expr
,
1712 tree
* poffset
, tree
* offsetvar
,
1723 /* We need this to be a variable so we can increment it. */
1724 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1726 gfc_init_se (&se
, NULL
);
1728 /* Walk the array expression. */
1729 ss
= gfc_walk_expr (expr
);
1730 gcc_assert (ss
!= gfc_ss_terminator
);
1732 /* Initialize the scalarizer. */
1733 gfc_init_loopinfo (&loop
);
1734 gfc_add_ss_to_loop (&loop
, ss
);
1736 /* Initialize the loop. */
1737 gfc_conv_ss_startstride (&loop
);
1738 gfc_conv_loop_setup (&loop
, &expr
->where
);
1740 /* Make sure the constructed array has room for the new data. */
1743 /* Set SIZE to the total number of elements in the subarray. */
1744 size
= gfc_index_one_node
;
1745 for (n
= 0; n
< loop
.dimen
; n
++)
1747 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1748 gfc_index_one_node
);
1749 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1750 gfc_array_index_type
, size
, tmp
);
1753 /* Grow the constructed array by SIZE elements. */
1754 gfc_grow_array (&loop
.pre
, desc
, size
);
1757 /* Make the loop body. */
1758 gfc_mark_ss_chain_used (ss
, 1);
1759 gfc_start_scalarized_body (&loop
, &body
);
1760 gfc_copy_loopinfo_to_se (&se
, &loop
);
1763 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1764 gcc_assert (se
.ss
== gfc_ss_terminator
);
1766 /* Increment the offset. */
1767 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1768 *poffset
, gfc_index_one_node
);
1769 gfc_add_modify (&body
, *poffset
, tmp
);
1771 /* Finish the loop. */
1772 gfc_trans_scalarizing_loops (&loop
, &body
);
1773 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1774 tmp
= gfc_finish_block (&loop
.pre
);
1775 gfc_add_expr_to_block (pblock
, tmp
);
1777 gfc_cleanup_loop (&loop
);
1781 /* Assign the values to the elements of an array constructor. DYNAMIC
1782 is true if descriptor DESC only contains enough data for the static
1783 size calculated by gfc_get_array_constructor_size. When true, memory
1784 for the dynamic parts must be allocated using realloc. */
1787 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1788 tree desc
, gfc_constructor_base base
,
1789 tree
* poffset
, tree
* offsetvar
,
1793 tree start
= NULL_TREE
;
1794 tree end
= NULL_TREE
;
1795 tree step
= NULL_TREE
;
1801 tree shadow_loopvar
= NULL_TREE
;
1802 gfc_saved_var saved_loopvar
;
1805 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1807 /* If this is an iterator or an array, the offset must be a variable. */
1808 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1809 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1811 /* Shadowing the iterator avoids changing its value and saves us from
1812 keeping track of it. Further, it makes sure that there's always a
1813 backend-decl for the symbol, even if there wasn't one before,
1814 e.g. in the case of an iterator that appears in a specification
1815 expression in an interface mapping. */
1821 /* Evaluate loop bounds before substituting the loop variable
1822 in case they depend on it. Such a case is invalid, but it is
1823 not more expensive to do the right thing here.
1825 gfc_init_se (&se
, NULL
);
1826 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1827 gfc_add_block_to_block (pblock
, &se
.pre
);
1828 start
= gfc_evaluate_now (se
.expr
, pblock
);
1830 gfc_init_se (&se
, NULL
);
1831 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1832 gfc_add_block_to_block (pblock
, &se
.pre
);
1833 end
= gfc_evaluate_now (se
.expr
, pblock
);
1835 gfc_init_se (&se
, NULL
);
1836 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1837 gfc_add_block_to_block (pblock
, &se
.pre
);
1838 step
= gfc_evaluate_now (se
.expr
, pblock
);
1840 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1841 type
= gfc_typenode_for_spec (&sym
->ts
);
1843 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1844 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1847 gfc_start_block (&body
);
1849 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1851 /* Array constructors can be nested. */
1852 gfc_trans_array_constructor_value (&body
, type
, desc
,
1853 c
->expr
->value
.constructor
,
1854 poffset
, offsetvar
, dynamic
);
1856 else if (c
->expr
->rank
> 0)
1858 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1859 poffset
, offsetvar
, dynamic
);
1863 /* This code really upsets the gimplifier so don't bother for now. */
1870 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1872 p
= gfc_constructor_next (p
);
1877 /* Scalar values. */
1878 gfc_init_se (&se
, NULL
);
1879 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1882 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1883 gfc_array_index_type
,
1884 *poffset
, gfc_index_one_node
);
1888 /* Collect multiple scalar constants into a constructor. */
1889 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1893 HOST_WIDE_INT idx
= 0;
1896 /* Count the number of consecutive scalar constants. */
1897 while (p
&& !(p
->iterator
1898 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1900 gfc_init_se (&se
, NULL
);
1901 gfc_conv_constant (&se
, p
->expr
);
1903 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1904 se
.expr
= fold_convert (type
, se
.expr
);
1905 /* For constant character array constructors we build
1906 an array of pointers. */
1907 else if (POINTER_TYPE_P (type
))
1908 se
.expr
= gfc_build_addr_expr
1909 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1912 CONSTRUCTOR_APPEND_ELT (v
,
1913 build_int_cst (gfc_array_index_type
,
1917 p
= gfc_constructor_next (p
);
1920 bound
= size_int (n
- 1);
1921 /* Create an array type to hold them. */
1922 tmptype
= build_range_type (gfc_array_index_type
,
1923 gfc_index_zero_node
, bound
);
1924 tmptype
= build_array_type (type
, tmptype
);
1926 init
= build_constructor (tmptype
, v
);
1927 TREE_CONSTANT (init
) = 1;
1928 TREE_STATIC (init
) = 1;
1929 /* Create a static variable to hold the data. */
1930 tmp
= gfc_create_var (tmptype
, "data");
1931 TREE_STATIC (tmp
) = 1;
1932 TREE_CONSTANT (tmp
) = 1;
1933 TREE_READONLY (tmp
) = 1;
1934 DECL_INITIAL (tmp
) = init
;
1937 /* Use BUILTIN_MEMCPY to assign the values. */
1938 tmp
= gfc_conv_descriptor_data_get (desc
);
1939 tmp
= build_fold_indirect_ref_loc (input_location
,
1941 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1942 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1943 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1945 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1946 bound
= build_int_cst (size_type_node
, n
* size
);
1947 tmp
= build_call_expr_loc (input_location
,
1948 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1949 3, tmp
, init
, bound
);
1950 gfc_add_expr_to_block (&body
, tmp
);
1952 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1953 gfc_array_index_type
, *poffset
,
1954 build_int_cst (gfc_array_index_type
, n
));
1956 if (!INTEGER_CST_P (*poffset
))
1958 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1959 *poffset
= *offsetvar
;
1963 /* The frontend should already have done any expansions
1967 /* Pass the code as is. */
1968 tmp
= gfc_finish_block (&body
);
1969 gfc_add_expr_to_block (pblock
, tmp
);
1973 /* Build the implied do-loop. */
1974 stmtblock_t implied_do_block
;
1980 loopbody
= gfc_finish_block (&body
);
1982 /* Create a new block that holds the implied-do loop. A temporary
1983 loop-variable is used. */
1984 gfc_start_block(&implied_do_block
);
1986 /* Initialize the loop. */
1987 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1989 /* If this array expands dynamically, and the number of iterations
1990 is not constant, we won't have allocated space for the static
1991 part of C->EXPR's size. Do that now. */
1992 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1994 /* Get the number of iterations. */
1995 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1997 /* Get the static part of C->EXPR's size. */
1998 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1999 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2001 /* Grow the array by TMP * TMP2 elements. */
2002 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
2003 gfc_array_index_type
, tmp
, tmp2
);
2004 gfc_grow_array (&implied_do_block
, desc
, tmp
);
2007 /* Generate the loop body. */
2008 exit_label
= gfc_build_label_decl (NULL_TREE
);
2009 gfc_start_block (&body
);
2011 /* Generate the exit condition. Depending on the sign of
2012 the step variable we have to generate the correct
2014 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2015 step
, build_int_cst (TREE_TYPE (step
), 0));
2016 cond
= fold_build3_loc (input_location
, COND_EXPR
,
2017 logical_type_node
, tmp
,
2018 fold_build2_loc (input_location
, GT_EXPR
,
2019 logical_type_node
, shadow_loopvar
, end
),
2020 fold_build2_loc (input_location
, LT_EXPR
,
2021 logical_type_node
, shadow_loopvar
, end
));
2022 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2023 TREE_USED (exit_label
) = 1;
2024 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2025 build_empty_stmt (input_location
));
2026 gfc_add_expr_to_block (&body
, tmp
);
2028 /* The main loop body. */
2029 gfc_add_expr_to_block (&body
, loopbody
);
2031 /* Increase loop variable by step. */
2032 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2033 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
2035 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
2037 /* Finish the loop. */
2038 tmp
= gfc_finish_block (&body
);
2039 tmp
= build1_v (LOOP_EXPR
, tmp
);
2040 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2042 /* Add the exit label. */
2043 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2044 gfc_add_expr_to_block (&implied_do_block
, tmp
);
2046 /* Finish the implied-do loop. */
2047 tmp
= gfc_finish_block(&implied_do_block
);
2048 gfc_add_expr_to_block(pblock
, tmp
);
2050 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
2057 /* The array constructor code can create a string length with an operand
2058 in the form of a temporary variable. This variable will retain its
2059 context (current_function_decl). If we store this length tree in a
2060 gfc_charlen structure which is shared by a variable in another
2061 context, the resulting gfc_charlen structure with a variable in a
2062 different context, we could trip the assertion in expand_expr_real_1
2063 when it sees that a variable has been created in one context and
2064 referenced in another.
2066 If this might be the case, we create a new gfc_charlen structure and
2067 link it into the current namespace. */
2070 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
2074 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
2077 (*clp
)->backend_decl
= len
;
2080 /* A catch-all to obtain the string length for anything that is not
2081 a substring of non-constant length, a constant, array or variable. */
2084 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2088 /* Don't bother if we already know the length is a constant. */
2089 if (*len
&& INTEGER_CST_P (*len
))
2092 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2093 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2096 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2097 *len
= e
->ts
.u
.cl
->backend_decl
;
2101 /* Otherwise, be brutal even if inefficient. */
2102 gfc_init_se (&se
, NULL
);
2104 /* No function call, in case of side effects. */
2105 se
.no_function_call
= 1;
2107 gfc_conv_expr (&se
, e
);
2109 gfc_conv_expr_descriptor (&se
, e
);
2111 /* Fix the value. */
2112 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2114 gfc_add_block_to_block (block
, &se
.pre
);
2115 gfc_add_block_to_block (block
, &se
.post
);
2117 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2122 /* Figure out the string length of a variable reference expression.
2123 Used by get_array_ctor_strlen. */
2126 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2132 /* Don't bother if we already know the length is a constant. */
2133 if (*len
&& INTEGER_CST_P (*len
))
2136 ts
= &expr
->symtree
->n
.sym
->ts
;
2137 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2142 /* Array references don't change the string length. */
2144 get_array_ctor_all_strlen (block
, expr
, len
);
2148 /* Use the length of the component. */
2149 ts
= &ref
->u
.c
.component
->ts
;
2153 if (ref
->u
.ss
.end
== NULL
2154 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2155 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2157 /* Note that this might evaluate expr. */
2158 get_array_ctor_all_strlen (block
, expr
, len
);
2161 mpz_init_set_ui (char_len
, 1);
2162 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2163 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2164 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2165 mpz_clear (char_len
);
2176 *len
= ts
->u
.cl
->backend_decl
;
2180 /* Figure out the string length of a character array constructor.
2181 If len is NULL, don't calculate the length; this happens for recursive calls
2182 when a sub-array-constructor is an element but not at the first position,
2183 so when we're not interested in the length.
2184 Returns TRUE if all elements are character constants. */
2187 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2194 if (gfc_constructor_first (base
) == NULL
)
2197 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2201 /* Loop over all constructor elements to find out is_const, but in len we
2202 want to store the length of the first, not the last, element. We can
2203 of course exit the loop as soon as is_const is found to be false. */
2204 for (c
= gfc_constructor_first (base
);
2205 c
&& is_const
; c
= gfc_constructor_next (c
))
2207 switch (c
->expr
->expr_type
)
2210 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2211 *len
= build_int_cstu (gfc_charlen_type_node
,
2212 c
->expr
->value
.character
.length
);
2216 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2223 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2229 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2233 /* After the first iteration, we don't want the length modified. */
2240 /* Check whether the array constructor C consists entirely of constant
2241 elements, and if so returns the number of those elements, otherwise
2242 return zero. Note, an empty or NULL array constructor returns zero. */
2244 unsigned HOST_WIDE_INT
2245 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2247 unsigned HOST_WIDE_INT nelem
= 0;
2249 gfc_constructor
*c
= gfc_constructor_first (base
);
2253 || c
->expr
->rank
> 0
2254 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2256 c
= gfc_constructor_next (c
);
2263 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2264 and the tree type of it's elements, TYPE, return a static constant
2265 variable that is compile-time initialized. */
2268 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2270 tree tmptype
, init
, tmp
;
2271 HOST_WIDE_INT nelem
;
2276 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2278 /* First traverse the constructor list, converting the constants
2279 to tree to build an initializer. */
2281 c
= gfc_constructor_first (expr
->value
.constructor
);
2284 gfc_init_se (&se
, NULL
);
2285 gfc_conv_constant (&se
, c
->expr
);
2286 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2287 se
.expr
= fold_convert (type
, se
.expr
);
2288 else if (POINTER_TYPE_P (type
))
2289 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2291 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2293 c
= gfc_constructor_next (c
);
2297 /* Next determine the tree type for the array. We use the gfortran
2298 front-end's gfc_get_nodesc_array_type in order to create a suitable
2299 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2301 memset (&as
, 0, sizeof (gfc_array_spec
));
2303 as
.rank
= expr
->rank
;
2304 as
.type
= AS_EXPLICIT
;
2307 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2308 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2312 for (i
= 0; i
< expr
->rank
; i
++)
2314 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2315 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2316 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2320 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2322 /* as is not needed anymore. */
2323 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2325 gfc_free_expr (as
.lower
[i
]);
2326 gfc_free_expr (as
.upper
[i
]);
2329 init
= build_constructor (tmptype
, v
);
2331 TREE_CONSTANT (init
) = 1;
2332 TREE_STATIC (init
) = 1;
2334 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2336 DECL_ARTIFICIAL (tmp
) = 1;
2337 DECL_IGNORED_P (tmp
) = 1;
2338 TREE_STATIC (tmp
) = 1;
2339 TREE_CONSTANT (tmp
) = 1;
2340 TREE_READONLY (tmp
) = 1;
2341 DECL_INITIAL (tmp
) = init
;
2348 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2349 This mostly initializes the scalarizer state info structure with the
2350 appropriate values to directly use the array created by the function
2351 gfc_build_constant_array_constructor. */
2354 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2356 gfc_array_info
*info
;
2360 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2362 info
= &ss
->info
->data
.array
;
2364 info
->descriptor
= tmp
;
2365 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2366 info
->offset
= gfc_index_zero_node
;
2368 for (i
= 0; i
< ss
->dimen
; i
++)
2370 info
->delta
[i
] = gfc_index_zero_node
;
2371 info
->start
[i
] = gfc_index_zero_node
;
2372 info
->end
[i
] = gfc_index_zero_node
;
2373 info
->stride
[i
] = gfc_index_one_node
;
2379 get_rank (gfc_loopinfo
*loop
)
2384 for (; loop
; loop
= loop
->parent
)
2385 rank
+= loop
->dimen
;
2391 /* Helper routine of gfc_trans_array_constructor to determine if the
2392 bounds of the loop specified by LOOP are constant and simple enough
2393 to use with trans_constant_array_constructor. Returns the
2394 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2397 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2400 tree size
= gfc_index_one_node
;
2404 total_dim
= get_rank (l
);
2406 for (loop
= l
; loop
; loop
= loop
->parent
)
2408 for (i
= 0; i
< loop
->dimen
; i
++)
2410 /* If the bounds aren't constant, return NULL_TREE. */
2411 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2413 if (!integer_zerop (loop
->from
[i
]))
2415 /* Only allow nonzero "from" in one-dimensional arrays. */
2418 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2419 gfc_array_index_type
,
2420 loop
->to
[i
], loop
->from
[i
]);
2424 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2425 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2426 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2427 gfc_array_index_type
, size
, tmp
);
2436 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2441 gcc_assert (array
->nested_ss
== NULL
);
2443 for (ss
= array
; ss
; ss
= ss
->parent
)
2444 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2445 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2446 return &(ss
->loop
->to
[n
]);
2452 static gfc_loopinfo
*
2453 outermost_loop (gfc_loopinfo
* loop
)
2455 while (loop
->parent
!= NULL
)
2456 loop
= loop
->parent
;
2462 /* Array constructors are handled by constructing a temporary, then using that
2463 within the scalarization loop. This is not optimal, but seems by far the
2467 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2469 gfc_constructor_base c
;
2477 bool old_first_len
, old_typespec_chararray_ctor
;
2478 tree old_first_len_val
;
2479 gfc_loopinfo
*loop
, *outer_loop
;
2480 gfc_ss_info
*ss_info
;
2486 /* Save the old values for nested checking. */
2487 old_first_len
= first_len
;
2488 old_first_len_val
= first_len_val
;
2489 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2492 outer_loop
= outermost_loop (loop
);
2494 expr
= ss_info
->expr
;
2496 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2497 typespec was given for the array constructor. */
2498 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2500 && expr
->ts
.u
.cl
->length_from_typespec
);
2502 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2503 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2505 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2509 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2511 c
= expr
->value
.constructor
;
2512 if (expr
->ts
.type
== BT_CHARACTER
)
2515 bool force_new_cl
= false;
2517 /* get_array_ctor_strlen walks the elements of the constructor, if a
2518 typespec was given, we already know the string length and want the one
2520 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2521 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2525 const_string
= false;
2526 gfc_init_se (&length_se
, NULL
);
2527 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2528 gfc_charlen_type_node
);
2529 ss_info
->string_length
= length_se
.expr
;
2531 /* Check if the character length is negative. If it is, then
2533 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2534 logical_type_node
, ss_info
->string_length
,
2535 build_zero_cst (TREE_TYPE
2536 (ss_info
->string_length
)));
2537 /* Print a warning if bounds checking is enabled. */
2538 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2540 msg
= xasprintf ("Negative character length treated as LEN = 0");
2541 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2546 ss_info
->string_length
2547 = fold_build3_loc (input_location
, COND_EXPR
,
2548 gfc_charlen_type_node
, neg_len
,
2550 (TREE_TYPE (ss_info
->string_length
)),
2551 ss_info
->string_length
);
2552 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2554 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2555 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2559 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2560 &ss_info
->string_length
);
2561 force_new_cl
= true;
2564 /* Complex character array constructors should have been taken care of
2565 and not end up here. */
2566 gcc_assert (ss_info
->string_length
);
2568 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2570 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2572 type
= build_pointer_type (type
);
2575 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2576 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2578 /* See if the constructor determines the loop bounds. */
2581 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2583 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2585 /* We have a multidimensional parameter. */
2586 for (s
= ss
; s
; s
= s
->parent
)
2589 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2591 s
->loop
->from
[n
] = gfc_index_zero_node
;
2592 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2593 gfc_index_integer_kind
);
2594 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2595 gfc_array_index_type
,
2597 gfc_index_one_node
);
2602 if (*loop_ubound0
== NULL_TREE
)
2606 /* We should have a 1-dimensional, zero-based loop. */
2607 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2608 gcc_assert (loop
->dimen
== 1);
2609 gcc_assert (integer_zerop (loop
->from
[0]));
2611 /* Split the constructor size into a static part and a dynamic part.
2612 Allocate the static size up-front and record whether the dynamic
2613 size might be nonzero. */
2615 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2616 mpz_sub_ui (size
, size
, 1);
2617 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2621 /* Special case constant array constructors. */
2624 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2627 tree size
= constant_array_constructor_loop_size (loop
);
2628 if (size
&& compare_tree_int (size
, nelem
) == 0)
2630 trans_constant_array_constructor (ss
, type
);
2636 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2637 NULL_TREE
, dynamic
, true, false, where
);
2639 desc
= ss_info
->data
.array
.descriptor
;
2640 offset
= gfc_index_zero_node
;
2641 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2642 TREE_NO_WARNING (offsetvar
) = 1;
2643 TREE_USED (offsetvar
) = 0;
2644 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2645 &offset
, &offsetvar
, dynamic
);
2647 /* If the array grows dynamically, the upper bound of the loop variable
2648 is determined by the array's final upper bound. */
2651 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2652 gfc_array_index_type
,
2653 offsetvar
, gfc_index_one_node
);
2654 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2655 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2656 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2657 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2659 *loop_ubound0
= tmp
;
2662 if (TREE_USED (offsetvar
))
2663 pushdecl (offsetvar
);
2665 gcc_assert (INTEGER_CST_P (offset
));
2668 /* Disable bound checking for now because it's probably broken. */
2669 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2676 /* Restore old values of globals. */
2677 first_len
= old_first_len
;
2678 first_len_val
= old_first_len_val
;
2679 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2683 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2684 called after evaluating all of INFO's vector dimensions. Go through
2685 each such vector dimension and see if we can now fill in any missing
2689 set_vector_loop_bounds (gfc_ss
* ss
)
2691 gfc_loopinfo
*loop
, *outer_loop
;
2692 gfc_array_info
*info
;
2700 outer_loop
= outermost_loop (ss
->loop
);
2702 info
= &ss
->info
->data
.array
;
2704 for (; ss
; ss
= ss
->parent
)
2708 for (n
= 0; n
< loop
->dimen
; n
++)
2711 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2712 || loop
->to
[n
] != NULL
)
2715 /* Loop variable N indexes vector dimension DIM, and we don't
2716 yet know the upper bound of loop variable N. Set it to the
2717 difference between the vector's upper and lower bounds. */
2718 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2719 gcc_assert (info
->subscript
[dim
]
2720 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2722 gfc_init_se (&se
, NULL
);
2723 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2724 zero
= gfc_rank_cst
[0];
2725 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2726 gfc_array_index_type
,
2727 gfc_conv_descriptor_ubound_get (desc
, zero
),
2728 gfc_conv_descriptor_lbound_get (desc
, zero
));
2729 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2736 /* Tells whether a scalar argument to an elemental procedure is saved out
2737 of a scalarization loop as a value or as a reference. */
2740 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2742 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2745 if (ss_info
->data
.scalar
.needs_temporary
)
2748 /* If the actual argument can be absent (in other words, it can
2749 be a NULL reference), don't try to evaluate it; pass instead
2750 the reference directly. */
2751 if (ss_info
->can_be_null_ref
)
2754 /* If the expression is of polymorphic type, it's actual size is not known,
2755 so we avoid copying it anywhere. */
2756 if (ss_info
->data
.scalar
.dummy_arg
2757 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2758 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2761 /* If the expression is a data reference of aggregate type,
2762 and the data reference is not used on the left hand side,
2763 avoid a copy by saving a reference to the content. */
2764 if (!ss_info
->data
.scalar
.needs_temporary
2765 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2766 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2767 && gfc_expr_is_variable (ss_info
->expr
))
2770 /* Otherwise the expression is evaluated to a temporary variable before the
2771 scalarization loop. */
2776 /* Add the pre and post chains for all the scalar expressions in a SS chain
2777 to loop. This is called after the loop parameters have been calculated,
2778 but before the actual scalarizing loops. */
2781 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2784 gfc_loopinfo
*nested_loop
, *outer_loop
;
2786 gfc_ss_info
*ss_info
;
2787 gfc_array_info
*info
;
2791 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2792 arguments could get evaluated multiple times. */
2793 if (ss
->is_alloc_lhs
)
2796 outer_loop
= outermost_loop (loop
);
2798 /* TODO: This can generate bad code if there are ordering dependencies,
2799 e.g., a callee allocated function and an unknown size constructor. */
2800 gcc_assert (ss
!= NULL
);
2802 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2806 /* Cross loop arrays are handled from within the most nested loop. */
2807 if (ss
->nested_ss
!= NULL
)
2811 expr
= ss_info
->expr
;
2812 info
= &ss_info
->data
.array
;
2814 switch (ss_info
->type
)
2817 /* Scalar expression. Evaluate this now. This includes elemental
2818 dimension indices, but not array section bounds. */
2819 gfc_init_se (&se
, NULL
);
2820 gfc_conv_expr (&se
, expr
);
2821 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2823 if (expr
->ts
.type
!= BT_CHARACTER
2824 && !gfc_is_alloc_class_scalar_function (expr
))
2826 /* Move the evaluation of scalar expressions outside the
2827 scalarization loop, except for WHERE assignments. */
2829 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2830 if (!ss_info
->where
)
2831 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2832 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2835 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2837 ss_info
->data
.scalar
.value
= se
.expr
;
2838 ss_info
->string_length
= se
.string_length
;
2841 case GFC_SS_REFERENCE
:
2842 /* Scalar argument to elemental procedure. */
2843 gfc_init_se (&se
, NULL
);
2844 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2845 gfc_conv_expr_reference (&se
, expr
);
2848 /* Evaluate the argument outside the loop and pass
2849 a reference to the value. */
2850 gfc_conv_expr (&se
, expr
);
2853 /* Ensure that a pointer to the string is stored. */
2854 if (expr
->ts
.type
== BT_CHARACTER
)
2855 gfc_conv_string_parameter (&se
);
2857 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2858 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2859 if (gfc_is_class_scalar_expr (expr
))
2860 /* This is necessary because the dynamic type will always be
2861 large than the declared type. In consequence, assigning
2862 the value to a temporary could segfault.
2863 OOP-TODO: see if this is generally correct or is the value
2864 has to be written to an allocated temporary, whose address
2865 is passed via ss_info. */
2866 ss_info
->data
.scalar
.value
= se
.expr
;
2868 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2871 ss_info
->string_length
= se
.string_length
;
2874 case GFC_SS_SECTION
:
2875 /* Add the expressions for scalar and vector subscripts. */
2876 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2877 if (info
->subscript
[n
])
2878 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2880 set_vector_loop_bounds (ss
);
2884 /* Get the vector's descriptor and store it in SS. */
2885 gfc_init_se (&se
, NULL
);
2886 gfc_conv_expr_descriptor (&se
, expr
);
2887 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2888 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2889 info
->descriptor
= se
.expr
;
2892 case GFC_SS_INTRINSIC
:
2893 gfc_add_intrinsic_ss_code (loop
, ss
);
2896 case GFC_SS_FUNCTION
:
2897 /* Array function return value. We call the function and save its
2898 result in a temporary for use inside the loop. */
2899 gfc_init_se (&se
, NULL
);
2902 if (gfc_is_class_array_function (expr
))
2903 expr
->must_finalize
= 1;
2904 gfc_conv_expr (&se
, expr
);
2905 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2906 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2907 ss_info
->string_length
= se
.string_length
;
2910 case GFC_SS_CONSTRUCTOR
:
2911 if (expr
->ts
.type
== BT_CHARACTER
2912 && ss_info
->string_length
== NULL
2914 && expr
->ts
.u
.cl
->length
2915 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2917 gfc_init_se (&se
, NULL
);
2918 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2919 gfc_charlen_type_node
);
2920 ss_info
->string_length
= se
.expr
;
2921 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2922 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2924 trans_array_constructor (ss
, where
);
2928 case GFC_SS_COMPONENT
:
2929 /* Do nothing. These are handled elsewhere. */
2938 for (nested_loop
= loop
->nested
; nested_loop
;
2939 nested_loop
= nested_loop
->next
)
2940 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2944 /* Translate expressions for the descriptor and data pointer of a SS. */
2948 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2951 gfc_ss_info
*ss_info
;
2952 gfc_array_info
*info
;
2956 info
= &ss_info
->data
.array
;
2958 /* Get the descriptor for the array to be scalarized. */
2959 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2960 gfc_init_se (&se
, NULL
);
2961 se
.descriptor_only
= 1;
2962 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2963 gfc_add_block_to_block (block
, &se
.pre
);
2964 info
->descriptor
= se
.expr
;
2965 ss_info
->string_length
= se
.string_length
;
2969 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2970 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2972 /* Emit a DECL_EXPR for the variable sized array type in
2973 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2974 sizes works correctly. */
2975 tree arraytype
= TREE_TYPE (
2976 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2977 if (! TYPE_NAME (arraytype
))
2978 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2979 NULL_TREE
, arraytype
);
2980 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2981 TYPE_NAME (arraytype
)));
2983 /* Also the data pointer. */
2984 tmp
= gfc_conv_array_data (se
.expr
);
2985 /* If this is a variable or address of a variable we use it directly.
2986 Otherwise we must evaluate it now to avoid breaking dependency
2987 analysis by pulling the expressions for elemental array indices
2990 || (TREE_CODE (tmp
) == ADDR_EXPR
2991 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2992 tmp
= gfc_evaluate_now (tmp
, block
);
2995 tmp
= gfc_conv_array_offset (se
.expr
);
2996 info
->offset
= gfc_evaluate_now (tmp
, block
);
2998 /* Make absolutely sure that the saved_offset is indeed saved
2999 so that the variable is still accessible after the loops
3001 info
->saved_offset
= info
->offset
;
3006 /* Initialize a gfc_loopinfo structure. */
3009 gfc_init_loopinfo (gfc_loopinfo
* loop
)
3013 memset (loop
, 0, sizeof (gfc_loopinfo
));
3014 gfc_init_block (&loop
->pre
);
3015 gfc_init_block (&loop
->post
);
3017 /* Initially scalarize in order and default to no loop reversal. */
3018 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
3021 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
3024 loop
->ss
= gfc_ss_terminator
;
3028 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3032 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
3038 /* Return an expression for the data pointer of an array. */
3041 gfc_conv_array_data (tree descriptor
)
3045 type
= TREE_TYPE (descriptor
);
3046 if (GFC_ARRAY_TYPE_P (type
))
3048 if (TREE_CODE (type
) == POINTER_TYPE
)
3052 /* Descriptorless arrays. */
3053 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
3057 return gfc_conv_descriptor_data_get (descriptor
);
3061 /* Return an expression for the base offset of an array. */
3064 gfc_conv_array_offset (tree descriptor
)
3068 type
= TREE_TYPE (descriptor
);
3069 if (GFC_ARRAY_TYPE_P (type
))
3070 return GFC_TYPE_ARRAY_OFFSET (type
);
3072 return gfc_conv_descriptor_offset_get (descriptor
);
3076 /* Get an expression for the array stride. */
3079 gfc_conv_array_stride (tree descriptor
, int dim
)
3084 type
= TREE_TYPE (descriptor
);
3086 /* For descriptorless arrays use the array size. */
3087 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
3088 if (tmp
!= NULL_TREE
)
3091 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3096 /* Like gfc_conv_array_stride, but for the lower bound. */
3099 gfc_conv_array_lbound (tree descriptor
, int dim
)
3104 type
= TREE_TYPE (descriptor
);
3106 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3107 if (tmp
!= NULL_TREE
)
3110 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3115 /* Like gfc_conv_array_stride, but for the upper bound. */
3118 gfc_conv_array_ubound (tree descriptor
, int dim
)
3123 type
= TREE_TYPE (descriptor
);
3125 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3126 if (tmp
!= NULL_TREE
)
3129 /* This should only ever happen when passing an assumed shape array
3130 as an actual parameter. The value will never be used. */
3131 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3132 return gfc_index_zero_node
;
3134 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3139 /* Generate code to perform an array index bound check. */
3142 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3143 locus
* where
, bool check_upper
)
3146 tree tmp_lo
, tmp_up
;
3149 const char * name
= NULL
;
3151 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3154 descriptor
= ss
->info
->data
.array
.descriptor
;
3156 index
= gfc_evaluate_now (index
, &se
->pre
);
3158 /* We find a name for the error message. */
3159 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3160 gcc_assert (name
!= NULL
);
3162 if (VAR_P (descriptor
))
3163 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3165 /* If upper bound is present, include both bounds in the error message. */
3168 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3169 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3172 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3173 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3175 msg
= xasprintf ("Index '%%ld' of dimension %d "
3176 "outside of expected range (%%ld:%%ld)", n
+1);
3178 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3180 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3181 fold_convert (long_integer_type_node
, index
),
3182 fold_convert (long_integer_type_node
, tmp_lo
),
3183 fold_convert (long_integer_type_node
, tmp_up
));
3184 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3186 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3187 fold_convert (long_integer_type_node
, index
),
3188 fold_convert (long_integer_type_node
, tmp_lo
),
3189 fold_convert (long_integer_type_node
, tmp_up
));
3194 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3197 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3198 "below lower bound of %%ld", n
+1, name
);
3200 msg
= xasprintf ("Index '%%ld' of dimension %d "
3201 "below lower bound of %%ld", n
+1);
3203 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3205 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3206 fold_convert (long_integer_type_node
, index
),
3207 fold_convert (long_integer_type_node
, tmp_lo
));
3215 /* Return the offset for an index. Performs bound checking for elemental
3216 dimensions. Single element references are processed separately.
3217 DIM is the array dimension, I is the loop dimension. */
3220 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3221 gfc_array_ref
* ar
, tree stride
)
3223 gfc_array_info
*info
;
3228 info
= &ss
->info
->data
.array
;
3230 /* Get the index into the array for this dimension. */
3233 gcc_assert (ar
->type
!= AR_ELEMENT
);
3234 switch (ar
->dimen_type
[dim
])
3236 case DIMEN_THIS_IMAGE
:
3240 /* Elemental dimension. */
3241 gcc_assert (info
->subscript
[dim
]
3242 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3243 /* We've already translated this value outside the loop. */
3244 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3246 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3247 ar
->as
->type
!= AS_ASSUMED_SIZE
3248 || dim
< ar
->dimen
- 1);
3252 gcc_assert (info
&& se
->loop
);
3253 gcc_assert (info
->subscript
[dim
]
3254 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3255 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3257 /* Get a zero-based index into the vector. */
3258 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3259 gfc_array_index_type
,
3260 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3262 /* Multiply the index by the stride. */
3263 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3264 gfc_array_index_type
,
3265 index
, gfc_conv_array_stride (desc
, 0));
3267 /* Read the vector to get an index into info->descriptor. */
3268 data
= build_fold_indirect_ref_loc (input_location
,
3269 gfc_conv_array_data (desc
));
3270 index
= gfc_build_array_ref (data
, index
, NULL
);
3271 index
= gfc_evaluate_now (index
, &se
->pre
);
3272 index
= fold_convert (gfc_array_index_type
, index
);
3274 /* Do any bounds checking on the final info->descriptor index. */
3275 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3276 ar
->as
->type
!= AS_ASSUMED_SIZE
3277 || dim
< ar
->dimen
- 1);
3281 /* Scalarized dimension. */
3282 gcc_assert (info
&& se
->loop
);
3284 /* Multiply the loop variable by the stride and delta. */
3285 index
= se
->loop
->loopvar
[i
];
3286 if (!integer_onep (info
->stride
[dim
]))
3287 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3288 gfc_array_index_type
, index
,
3290 if (!integer_zerop (info
->delta
[dim
]))
3291 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3292 gfc_array_index_type
, index
,
3302 /* Temporary array or derived type component. */
3303 gcc_assert (se
->loop
);
3304 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3306 /* Pointer functions can have stride[0] different from unity.
3307 Use the stride returned by the function call and stored in
3308 the descriptor for the temporary. */
3309 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3310 && se
->ss
->info
->expr
3311 && se
->ss
->info
->expr
->symtree
3312 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3313 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3314 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3317 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3318 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3319 gfc_array_index_type
, index
, info
->delta
[dim
]);
3322 /* Multiply by the stride. */
3323 if (stride
!= NULL
&& !integer_onep (stride
))
3324 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3331 /* Build a scalarized array reference using the vptr 'size'. */
3334 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3339 tree decl
= NULL_TREE
;
3341 gfc_expr
*expr
= se
->ss
->info
->expr
;
3343 gfc_ref
*class_ref
= NULL
;
3346 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3347 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3348 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3353 || (expr
->ts
.type
!= BT_CLASS
3354 && !gfc_is_class_array_function (expr
)
3355 && !gfc_is_class_array_ref (expr
, NULL
)))
3358 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3359 ts
= &expr
->symtree
->n
.sym
->ts
;
3363 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3365 if (ref
->type
== REF_COMPONENT
3366 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3367 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3368 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3370 && ref
->next
->next
->type
== REF_ARRAY
3371 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3373 ts
= &ref
->u
.c
.component
->ts
;
3383 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3384 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3385 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3387 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3389 else if (expr
&& gfc_is_class_array_function (expr
))
3393 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3396 type
= TREE_TYPE (tmp
);
3399 if (GFC_CLASS_TYPE_P (type
))
3401 if (type
!= TYPE_CANONICAL (type
))
3402 type
= TYPE_CANONICAL (type
);
3410 if (decl
== NULL_TREE
)
3413 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3415 else if (class_ref
== NULL
)
3417 if (decl
== NULL_TREE
)
3418 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3419 /* For class arrays the tree containing the class is stored in
3420 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3421 For all others it's sym's backend_decl directly. */
3422 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3423 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3427 /* Remove everything after the last class reference, convert the
3428 expression and then recover its tailend once more. */
3430 ref
= class_ref
->next
;
3431 class_ref
->next
= NULL
;
3432 gfc_init_se (&tmpse
, NULL
);
3433 gfc_conv_expr (&tmpse
, expr
);
3434 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3436 class_ref
->next
= ref
;
3439 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3440 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3442 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3445 size
= gfc_class_vtab_size_get (decl
);
3447 /* For unlimited polymorphic entities then _len component needs to be
3448 multiplied with the size. If no _len component is present, then
3449 gfc_class_len_or_zero_get () return a zero_node. */
3450 tmp
= gfc_class_len_or_zero_get (decl
);
3451 if (!integer_zerop (tmp
))
3452 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3453 fold_convert (TREE_TYPE (index
), size
),
3454 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3455 fold_convert (TREE_TYPE (index
), tmp
),
3456 fold_convert (TREE_TYPE (index
),
3457 integer_one_node
)));
3459 size
= fold_convert (TREE_TYPE (index
), size
);
3461 /* Build the address of the element. */
3462 type
= TREE_TYPE (TREE_TYPE (base
));
3463 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3464 gfc_array_index_type
,
3466 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3467 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3468 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3470 /* Return the element in the se expression. */
3471 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3476 /* Build a scalarized reference to an array. */
3479 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3481 gfc_array_info
*info
;
3482 tree decl
= NULL_TREE
;
3490 expr
= ss
->info
->expr
;
3491 info
= &ss
->info
->data
.array
;
3493 n
= se
->loop
->order
[0];
3497 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3498 /* Add the offset for this dimension to the stored offset for all other
3500 if (info
->offset
&& !integer_zerop (info
->offset
))
3501 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3502 index
, info
->offset
);
3504 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3506 /* Use the vptr 'size' field to access the element of a class array. */
3507 if (build_class_array_ref (se
, base
, index
))
3510 if (get_CFI_desc (NULL
, expr
, &decl
, ar
))
3511 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3513 /* A pointer array component can be detected from its field decl. Fix
3514 the descriptor, mark the resulting variable decl and pass it to
3515 gfc_build_array_ref. */
3516 if (is_pointer_array (info
->descriptor
)
3517 || (expr
&& expr
->ts
.deferred
&& info
->descriptor
3518 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
))))
3520 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3521 decl
= info
->descriptor
;
3522 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3523 decl
= TREE_OPERAND (info
->descriptor
, 0);
3525 if (decl
== NULL_TREE
)
3526 decl
= info
->descriptor
;
3529 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3533 /* Translate access of temporary array. */
3536 gfc_conv_tmp_array_ref (gfc_se
* se
)
3538 se
->string_length
= se
->ss
->info
->string_length
;
3539 gfc_conv_scalarized_array_ref (se
, NULL
);
3540 gfc_advance_se_ss_chain (se
);
3543 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3546 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3548 if (TREE_CODE (t
) == INTEGER_CST
)
3549 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3552 if (!integer_zerop (*offset
))
3553 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3554 gfc_array_index_type
, *offset
, t
);
3562 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3568 /* For class arrays the class declaration is stored in the saved
3570 if (INDIRECT_REF_P (desc
)
3571 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3572 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3573 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3574 TREE_OPERAND (desc
, 0)));
3578 /* Class container types do not always have the GFC_CLASS_TYPE_P
3579 but the canonical type does. */
3580 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3581 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3583 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3584 if (TYPE_CANONICAL (type
)
3585 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3586 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3589 tmp
= gfc_conv_array_data (desc
);
3590 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3591 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3596 /* Build an array reference. se->expr already holds the array descriptor.
3597 This should be either a variable, indirect variable reference or component
3598 reference. For arrays which do not have a descriptor, se->expr will be
3600 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3603 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3607 tree offset
, cst_offset
;
3610 tree decl
= NULL_TREE
;
3613 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3614 char *var_name
= NULL
;
3618 gcc_assert (ar
->codimen
|| sym
->attr
.select_rank_temporary
3619 || (ar
->as
&& ar
->as
->corank
));
3621 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3622 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3625 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3626 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3627 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3629 /* Use the actual tree type and not the wrapped coarray. */
3630 if (!se
->want_pointer
)
3631 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3638 /* Handle scalarized references separately. */
3639 if (ar
->type
!= AR_ELEMENT
)
3641 gfc_conv_scalarized_array_ref (se
, ar
);
3642 gfc_advance_se_ss_chain (se
);
3646 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3651 len
= strlen (sym
->name
) + 1;
3652 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3654 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3656 if (ref
->type
== REF_COMPONENT
)
3657 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3660 var_name
= XALLOCAVEC (char, len
);
3661 strcpy (var_name
, sym
->name
);
3663 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3665 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3667 if (ref
->type
== REF_COMPONENT
)
3669 strcat (var_name
, "%%");
3670 strcat (var_name
, ref
->u
.c
.component
->name
);
3676 if (IS_CLASS_ARRAY (sym
) && sym
->attr
.dummy
&& ar
->as
->type
!= AS_DEFERRED
)
3677 decl
= sym
->backend_decl
;
3679 cst_offset
= offset
= gfc_index_zero_node
;
3680 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (decl
));
3682 /* Calculate the offsets from all the dimensions. Make sure to associate
3683 the final offset so that we form a chain of loop invariant summands. */
3684 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3686 /* Calculate the index for this dimension. */
3687 gfc_init_se (&indexse
, se
);
3688 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3689 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3691 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3693 /* Check array bounds. */
3697 /* Evaluate the indexse.expr only once. */
3698 indexse
.expr
= save_expr (indexse
.expr
);
3701 tmp
= gfc_conv_array_lbound (decl
, n
);
3702 if (sym
->attr
.temporary
)
3704 gfc_init_se (&tmpse
, se
);
3705 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3706 gfc_array_index_type
);
3707 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3711 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3713 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3714 "below lower bound of %%ld", n
+1, var_name
);
3715 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3716 fold_convert (long_integer_type_node
,
3718 fold_convert (long_integer_type_node
, tmp
));
3721 /* Upper bound, but not for the last dimension of assumed-size
3723 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3725 tmp
= gfc_conv_array_ubound (decl
, n
);
3726 if (sym
->attr
.temporary
)
3728 gfc_init_se (&tmpse
, se
);
3729 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3730 gfc_array_index_type
);
3731 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3735 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3736 logical_type_node
, indexse
.expr
, tmp
);
3737 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3738 "above upper bound of %%ld", n
+1, var_name
);
3739 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3740 fold_convert (long_integer_type_node
,
3742 fold_convert (long_integer_type_node
, tmp
));
3747 /* Multiply the index by the stride. */
3748 stride
= gfc_conv_array_stride (decl
, n
);
3749 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3750 indexse
.expr
, stride
);
3752 /* And add it to the total. */
3753 add_to_offset (&cst_offset
, &offset
, tmp
);
3756 if (!integer_zerop (cst_offset
))
3757 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3758 gfc_array_index_type
, offset
, cst_offset
);
3760 /* A pointer array component can be detected from its field decl. Fix
3761 the descriptor, mark the resulting variable decl and pass it to
3764 if (get_CFI_desc (sym
, expr
, &decl
, ar
))
3765 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3766 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3767 && is_pointer_array (se
->expr
))
3769 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3771 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3772 decl
= TREE_OPERAND (se
->expr
, 0);
3776 else if (expr
->ts
.deferred
3777 || (sym
->ts
.type
== BT_CHARACTER
3778 && sym
->attr
.select_type_temporary
))
3780 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3783 if (TREE_CODE (decl
) == INDIRECT_REF
)
3784 decl
= TREE_OPERAND (decl
, 0);
3787 decl
= sym
->backend_decl
;
3789 else if (sym
->ts
.type
== BT_CLASS
)
3792 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3796 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3797 LOOP_DIM dimension (if any) to array's offset. */
3800 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3801 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3804 gfc_array_info
*info
;
3807 info
= &ss
->info
->data
.array
;
3809 gfc_init_se (&se
, NULL
);
3811 se
.expr
= info
->descriptor
;
3812 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3813 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3814 gfc_add_block_to_block (pblock
, &se
.pre
);
3816 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3817 gfc_array_index_type
,
3818 info
->offset
, index
);
3819 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3823 /* Generate the code to be executed immediately before entering a
3824 scalarization loop. */
3827 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3828 stmtblock_t
* pblock
)
3831 gfc_ss_info
*ss_info
;
3832 gfc_array_info
*info
;
3833 gfc_ss_type ss_type
;
3835 gfc_loopinfo
*ploop
;
3839 /* This code will be executed before entering the scalarization loop
3840 for this dimension. */
3841 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3845 if ((ss_info
->useflags
& flag
) == 0)
3848 ss_type
= ss_info
->type
;
3849 if (ss_type
!= GFC_SS_SECTION
3850 && ss_type
!= GFC_SS_FUNCTION
3851 && ss_type
!= GFC_SS_CONSTRUCTOR
3852 && ss_type
!= GFC_SS_COMPONENT
)
3855 info
= &ss_info
->data
.array
;
3857 gcc_assert (dim
< ss
->dimen
);
3858 gcc_assert (ss
->dimen
== loop
->dimen
);
3861 ar
= &info
->ref
->u
.ar
;
3865 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3867 /* If we are in the outermost dimension of this loop, the previous
3868 dimension shall be in the parent loop. */
3869 gcc_assert (ss
->parent
!= NULL
);
3872 ploop
= loop
->parent
;
3874 /* ss and ss->parent are about the same array. */
3875 gcc_assert (ss_info
== pss
->info
);
3883 if (dim
== loop
->dimen
- 1)
3888 /* For the time being, there is no loop reordering. */
3889 gcc_assert (i
== ploop
->order
[i
]);
3890 i
= ploop
->order
[i
];
3892 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3894 stride
= gfc_conv_array_stride (info
->descriptor
,
3895 innermost_ss (ss
)->dim
[i
]);
3897 /* Calculate the stride of the innermost loop. Hopefully this will
3898 allow the backend optimizers to do their stuff more effectively.
3900 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3902 /* For the outermost loop calculate the offset due to any
3903 elemental dimensions. It will have been initialized with the
3904 base offset of the array. */
3907 for (i
= 0; i
< ar
->dimen
; i
++)
3909 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3912 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3917 /* Add the offset for the previous loop dimension. */
3918 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3920 /* Remember this offset for the second loop. */
3921 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3922 info
->saved_offset
= info
->offset
;
3927 /* Start a scalarized expression. Creates a scope and declares loop
3931 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3937 gcc_assert (!loop
->array_parameter
);
3939 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3941 n
= loop
->order
[dim
];
3943 gfc_start_block (&loop
->code
[n
]);
3945 /* Create the loop variable. */
3946 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3948 if (dim
< loop
->temp_dim
)
3952 /* Calculate values that will be constant within this loop. */
3953 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3955 gfc_start_block (pbody
);
3959 /* Generates the actual loop code for a scalarization loop. */
3962 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3963 stmtblock_t
* pbody
)
3974 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3975 | OMPWS_SCALARIZER_BODY
))
3976 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3977 && n
== loop
->dimen
- 1)
3979 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3980 init
= make_tree_vec (1);
3981 cond
= make_tree_vec (1);
3982 incr
= make_tree_vec (1);
3984 /* Cycle statement is implemented with a goto. Exit statement must not
3985 be present for this loop. */
3986 exit_label
= gfc_build_label_decl (NULL_TREE
);
3987 TREE_USED (exit_label
) = 1;
3989 /* Label for cycle statements (if needed). */
3990 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3991 gfc_add_expr_to_block (pbody
, tmp
);
3993 stmt
= make_node (OMP_FOR
);
3995 TREE_TYPE (stmt
) = void_type_node
;
3996 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3998 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3999 OMP_CLAUSE_SCHEDULE
);
4000 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
4001 = OMP_CLAUSE_SCHEDULE_STATIC
;
4002 if (ompws_flags
& OMPWS_NOWAIT
)
4003 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
4004 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
4006 /* Initialize the loopvar. */
4007 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
4009 OMP_FOR_INIT (stmt
) = init
;
4010 /* The exit condition. */
4011 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
4013 loop
->loopvar
[n
], loop
->to
[n
]);
4014 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
4015 OMP_FOR_COND (stmt
) = cond
;
4016 /* Increment the loopvar. */
4017 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4018 loop
->loopvar
[n
], gfc_index_one_node
);
4019 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
4020 void_type_node
, loop
->loopvar
[n
], tmp
);
4021 OMP_FOR_INCR (stmt
) = incr
;
4023 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
4024 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
4028 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
4029 && (loop
->temp_ss
== NULL
);
4031 loopbody
= gfc_finish_block (pbody
);
4034 std::swap (loop
->from
[n
], loop
->to
[n
]);
4036 /* Initialize the loopvar. */
4037 if (loop
->loopvar
[n
] != loop
->from
[n
])
4038 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
4040 exit_label
= gfc_build_label_decl (NULL_TREE
);
4042 /* Generate the loop body. */
4043 gfc_init_block (&block
);
4045 /* The exit condition. */
4046 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
4047 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
4048 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4049 TREE_USED (exit_label
) = 1;
4050 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4051 gfc_add_expr_to_block (&block
, tmp
);
4053 /* The main body. */
4054 gfc_add_expr_to_block (&block
, loopbody
);
4056 /* Increment the loopvar. */
4057 tmp
= fold_build2_loc (input_location
,
4058 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
4059 gfc_array_index_type
, loop
->loopvar
[n
],
4060 gfc_index_one_node
);
4062 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
4064 /* Build the loop. */
4065 tmp
= gfc_finish_block (&block
);
4066 tmp
= build1_v (LOOP_EXPR
, tmp
);
4067 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4069 /* Add the exit label. */
4070 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4071 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
4077 /* Finishes and generates the loops for a scalarized expression. */
4080 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4085 stmtblock_t
*pblock
;
4089 /* Generate the loops. */
4090 for (dim
= 0; dim
< loop
->dimen
; dim
++)
4092 n
= loop
->order
[dim
];
4093 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4094 loop
->loopvar
[n
] = NULL_TREE
;
4095 pblock
= &loop
->code
[n
];
4098 tmp
= gfc_finish_block (pblock
);
4099 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4101 /* Clear all the used flags. */
4102 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4103 if (ss
->parent
== NULL
)
4104 ss
->info
->useflags
= 0;
4108 /* Finish the main body of a scalarized expression, and start the secondary
4112 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4116 stmtblock_t
*pblock
;
4120 /* We finish as many loops as are used by the temporary. */
4121 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4123 n
= loop
->order
[dim
];
4124 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4125 loop
->loopvar
[n
] = NULL_TREE
;
4126 pblock
= &loop
->code
[n
];
4129 /* We don't want to finish the outermost loop entirely. */
4130 n
= loop
->order
[loop
->temp_dim
- 1];
4131 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4133 /* Restore the initial offsets. */
4134 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4136 gfc_ss_type ss_type
;
4137 gfc_ss_info
*ss_info
;
4141 if ((ss_info
->useflags
& 2) == 0)
4144 ss_type
= ss_info
->type
;
4145 if (ss_type
!= GFC_SS_SECTION
4146 && ss_type
!= GFC_SS_FUNCTION
4147 && ss_type
!= GFC_SS_CONSTRUCTOR
4148 && ss_type
!= GFC_SS_COMPONENT
)
4151 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4154 /* Restart all the inner loops we just finished. */
4155 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4157 n
= loop
->order
[dim
];
4159 gfc_start_block (&loop
->code
[n
]);
4161 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4163 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4166 /* Start a block for the secondary copying code. */
4167 gfc_start_block (body
);
4171 /* Precalculate (either lower or upper) bound of an array section.
4172 BLOCK: Block in which the (pre)calculation code will go.
4173 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4174 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4175 DESC: Array descriptor from which the bound will be picked if unspecified
4176 (either lower or upper bound according to LBOUND). */
4179 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4180 tree desc
, int dim
, bool lbound
, bool deferred
)
4183 gfc_expr
* input_val
= values
[dim
];
4184 tree
*output
= &bounds
[dim
];
4189 /* Specified section bound. */
4190 gfc_init_se (&se
, NULL
);
4191 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4192 gfc_add_block_to_block (block
, &se
.pre
);
4195 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4197 /* The gfc_conv_array_lbound () routine returns a constant zero for
4198 deferred length arrays, which in the scalarizer wreaks havoc, when
4199 copying to a (newly allocated) one-based array.
4200 Keep returning the actual result in sync for both bounds. */
4201 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4203 gfc_conv_descriptor_ubound_get (desc
,
4208 /* No specific bound specified so use the bound of the array. */
4209 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4210 gfc_conv_array_ubound (desc
, dim
);
4212 *output
= gfc_evaluate_now (*output
, block
);
4216 /* Calculate the lower bound of an array section. */
4219 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4221 gfc_expr
*stride
= NULL
;
4224 gfc_array_info
*info
;
4227 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4229 info
= &ss
->info
->data
.array
;
4230 ar
= &info
->ref
->u
.ar
;
4232 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4234 /* We use a zero-based index to access the vector. */
4235 info
->start
[dim
] = gfc_index_zero_node
;
4236 info
->end
[dim
] = NULL
;
4237 info
->stride
[dim
] = gfc_index_one_node
;
4241 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4242 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4243 desc
= info
->descriptor
;
4244 stride
= ar
->stride
[dim
];
4247 /* Calculate the start of the range. For vector subscripts this will
4248 be the range of the vector. */
4249 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4250 ar
->as
->type
== AS_DEFERRED
);
4252 /* Similarly calculate the end. Although this is not used in the
4253 scalarizer, it is needed when checking bounds and where the end
4254 is an expression with side-effects. */
4255 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4256 ar
->as
->type
== AS_DEFERRED
);
4259 /* Calculate the stride. */
4261 info
->stride
[dim
] = gfc_index_one_node
;
4264 gfc_init_se (&se
, NULL
);
4265 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4266 gfc_add_block_to_block (block
, &se
.pre
);
4267 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4272 /* Calculates the range start and stride for a SS chain. Also gets the
4273 descriptor and data pointer. The range of vector subscripts is the size
4274 of the vector. Array bounds are also checked. */
4277 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4284 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4287 /* Determine the rank of the loop. */
4288 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4290 switch (ss
->info
->type
)
4292 case GFC_SS_SECTION
:
4293 case GFC_SS_CONSTRUCTOR
:
4294 case GFC_SS_FUNCTION
:
4295 case GFC_SS_COMPONENT
:
4296 loop
->dimen
= ss
->dimen
;
4299 /* As usual, lbound and ubound are exceptions!. */
4300 case GFC_SS_INTRINSIC
:
4301 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4303 case GFC_ISYM_LBOUND
:
4304 case GFC_ISYM_UBOUND
:
4305 case GFC_ISYM_LCOBOUND
:
4306 case GFC_ISYM_UCOBOUND
:
4307 case GFC_ISYM_THIS_IMAGE
:
4308 loop
->dimen
= ss
->dimen
;
4320 /* We should have determined the rank of the expression by now. If
4321 not, that's bad news. */
4325 /* Loop over all the SS in the chain. */
4326 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4328 gfc_ss_info
*ss_info
;
4329 gfc_array_info
*info
;
4333 expr
= ss_info
->expr
;
4334 info
= &ss_info
->data
.array
;
4336 if (expr
&& expr
->shape
&& !info
->shape
)
4337 info
->shape
= expr
->shape
;
4339 switch (ss_info
->type
)
4341 case GFC_SS_SECTION
:
4342 /* Get the descriptor for the array. If it is a cross loops array,
4343 we got the descriptor already in the outermost loop. */
4344 if (ss
->parent
== NULL
)
4345 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4346 !loop
->array_parameter
);
4348 for (n
= 0; n
< ss
->dimen
; n
++)
4349 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4352 case GFC_SS_INTRINSIC
:
4353 switch (expr
->value
.function
.isym
->id
)
4355 /* Fall through to supply start and stride. */
4356 case GFC_ISYM_LBOUND
:
4357 case GFC_ISYM_UBOUND
:
4361 /* This is the variant without DIM=... */
4362 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4364 arg
= expr
->value
.function
.actual
->expr
;
4365 if (arg
->rank
== -1)
4370 /* The rank (hence the return value's shape) is unknown,
4371 we have to retrieve it. */
4372 gfc_init_se (&se
, NULL
);
4373 se
.descriptor_only
= 1;
4374 gfc_conv_expr (&se
, arg
);
4375 /* This is a bare variable, so there is no preliminary
4377 gcc_assert (se
.pre
.head
== NULL_TREE
4378 && se
.post
.head
== NULL_TREE
);
4379 rank
= gfc_conv_descriptor_rank (se
.expr
);
4380 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4381 gfc_array_index_type
,
4382 fold_convert (gfc_array_index_type
,
4384 gfc_index_one_node
);
4385 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4386 info
->start
[0] = gfc_index_zero_node
;
4387 info
->stride
[0] = gfc_index_one_node
;
4390 /* Otherwise fall through GFC_SS_FUNCTION. */
4393 case GFC_ISYM_LCOBOUND
:
4394 case GFC_ISYM_UCOBOUND
:
4395 case GFC_ISYM_THIS_IMAGE
:
4403 case GFC_SS_CONSTRUCTOR
:
4404 case GFC_SS_FUNCTION
:
4405 for (n
= 0; n
< ss
->dimen
; n
++)
4407 int dim
= ss
->dim
[n
];
4409 info
->start
[dim
] = gfc_index_zero_node
;
4410 info
->end
[dim
] = gfc_index_zero_node
;
4411 info
->stride
[dim
] = gfc_index_one_node
;
4420 /* The rest is just runtime bounds checking. */
4421 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4424 tree lbound
, ubound
;
4426 tree size
[GFC_MAX_DIMENSIONS
];
4427 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4428 gfc_array_info
*info
;
4432 gfc_start_block (&block
);
4434 for (n
= 0; n
< loop
->dimen
; n
++)
4435 size
[n
] = NULL_TREE
;
4437 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4440 gfc_ss_info
*ss_info
;
4443 const char *expr_name
;
4446 if (ss_info
->type
!= GFC_SS_SECTION
)
4449 /* Catch allocatable lhs in f2003. */
4450 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4453 expr
= ss_info
->expr
;
4454 expr_loc
= &expr
->where
;
4455 expr_name
= expr
->symtree
->name
;
4457 gfc_start_block (&inner
);
4459 /* TODO: range checking for mapped dimensions. */
4460 info
= &ss_info
->data
.array
;
4462 /* This code only checks ranges. Elemental and vector
4463 dimensions are checked later. */
4464 for (n
= 0; n
< loop
->dimen
; n
++)
4469 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4472 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4473 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4474 check_upper
= false;
4478 /* Zero stride is not allowed. */
4479 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4480 info
->stride
[dim
], gfc_index_zero_node
);
4481 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4482 "of array '%s'", dim
+ 1, expr_name
);
4483 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4487 desc
= info
->descriptor
;
4489 /* This is the run-time equivalent of resolve.c's
4490 check_dimension(). The logical is more readable there
4491 than it is here, with all the trees. */
4492 lbound
= gfc_conv_array_lbound (desc
, dim
);
4493 end
= info
->end
[dim
];
4495 ubound
= gfc_conv_array_ubound (desc
, dim
);
4499 /* non_zerosized is true when the selected range is not
4501 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4502 logical_type_node
, info
->stride
[dim
],
4503 gfc_index_zero_node
);
4504 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4505 info
->start
[dim
], end
);
4506 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4507 logical_type_node
, stride_pos
, tmp
);
4509 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4511 info
->stride
[dim
], gfc_index_zero_node
);
4512 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4513 info
->start
[dim
], end
);
4514 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4517 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4519 stride_pos
, stride_neg
);
4521 /* Check the start of the range against the lower and upper
4522 bounds of the array, if the range is not empty.
4523 If upper bound is present, include both bounds in the
4527 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4529 info
->start
[dim
], lbound
);
4530 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4532 non_zerosized
, tmp
);
4533 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4535 info
->start
[dim
], ubound
);
4536 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4538 non_zerosized
, tmp2
);
4539 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4540 "outside of expected range (%%ld:%%ld)",
4541 dim
+ 1, expr_name
);
4542 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4544 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4545 fold_convert (long_integer_type_node
, lbound
),
4546 fold_convert (long_integer_type_node
, ubound
));
4547 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4549 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4550 fold_convert (long_integer_type_node
, lbound
),
4551 fold_convert (long_integer_type_node
, ubound
));
4556 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4558 info
->start
[dim
], lbound
);
4559 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4560 logical_type_node
, non_zerosized
, tmp
);
4561 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4562 "below lower bound of %%ld",
4563 dim
+ 1, expr_name
);
4564 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4566 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4567 fold_convert (long_integer_type_node
, lbound
));
4571 /* Compute the last element of the range, which is not
4572 necessarily "end" (think 0:5:3, which doesn't contain 5)
4573 and check it against both lower and upper bounds. */
4575 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4576 gfc_array_index_type
, end
,
4578 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4579 gfc_array_index_type
, tmp
,
4581 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4582 gfc_array_index_type
, end
, tmp
);
4583 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4584 logical_type_node
, tmp
, lbound
);
4585 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4586 logical_type_node
, non_zerosized
, tmp2
);
4589 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4590 logical_type_node
, tmp
, ubound
);
4591 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4592 logical_type_node
, non_zerosized
, tmp3
);
4593 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4594 "outside of expected range (%%ld:%%ld)",
4595 dim
+ 1, expr_name
);
4596 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4598 fold_convert (long_integer_type_node
, tmp
),
4599 fold_convert (long_integer_type_node
, ubound
),
4600 fold_convert (long_integer_type_node
, lbound
));
4601 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4603 fold_convert (long_integer_type_node
, tmp
),
4604 fold_convert (long_integer_type_node
, ubound
),
4605 fold_convert (long_integer_type_node
, lbound
));
4610 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4611 "below lower bound of %%ld",
4612 dim
+ 1, expr_name
);
4613 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4615 fold_convert (long_integer_type_node
, tmp
),
4616 fold_convert (long_integer_type_node
, lbound
));
4620 /* Check the section sizes match. */
4621 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4622 gfc_array_index_type
, end
,
4624 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4625 gfc_array_index_type
, tmp
,
4627 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4628 gfc_array_index_type
,
4629 gfc_index_one_node
, tmp
);
4630 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4631 gfc_array_index_type
, tmp
,
4632 build_int_cst (gfc_array_index_type
, 0));
4633 /* We remember the size of the first section, and check all the
4634 others against this. */
4637 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4638 logical_type_node
, tmp
, size
[n
]);
4639 msg
= xasprintf ("Array bound mismatch for dimension %d "
4640 "of array '%s' (%%ld/%%ld)",
4641 dim
+ 1, expr_name
);
4643 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4645 fold_convert (long_integer_type_node
, tmp
),
4646 fold_convert (long_integer_type_node
, size
[n
]));
4651 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4654 tmp
= gfc_finish_block (&inner
);
4656 /* For optional arguments, only check bounds if the argument is
4658 if (expr
->symtree
->n
.sym
->attr
.optional
4659 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4660 tmp
= build3_v (COND_EXPR
,
4661 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4662 tmp
, build_empty_stmt (input_location
));
4664 gfc_add_expr_to_block (&block
, tmp
);
4668 tmp
= gfc_finish_block (&block
);
4669 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4672 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4673 gfc_conv_ss_startstride (loop
);
4676 /* Return true if both symbols could refer to the same data object. Does
4677 not take account of aliasing due to equivalence statements. */
4680 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4681 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4683 /* Aliasing isn't possible if the symbols have different base types. */
4684 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4687 /* Pointers can point to other pointers and target objects. */
4689 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4690 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4693 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4694 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4696 if (lsym_target
&& rsym_target
4697 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4698 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4699 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4700 && (!rsym
->attr
.dimension
4701 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4708 /* Return true if the two SS could be aliased, i.e. both point to the same data
4710 /* TODO: resolve aliases based on frontend expressions. */
4713 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4717 gfc_expr
*lexpr
, *rexpr
;
4720 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4722 lexpr
= lss
->info
->expr
;
4723 rexpr
= rss
->info
->expr
;
4725 lsym
= lexpr
->symtree
->n
.sym
;
4726 rsym
= rexpr
->symtree
->n
.sym
;
4728 lsym_pointer
= lsym
->attr
.pointer
;
4729 lsym_target
= lsym
->attr
.target
;
4730 rsym_pointer
= rsym
->attr
.pointer
;
4731 rsym_target
= rsym
->attr
.target
;
4733 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4734 rsym_pointer
, rsym_target
))
4737 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4738 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4741 /* For derived types we must check all the component types. We can ignore
4742 array references as these will have the same base type as the previous
4744 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4746 if (lref
->type
!= REF_COMPONENT
)
4749 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4750 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4752 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4753 rsym_pointer
, rsym_target
))
4756 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4757 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4759 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4764 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4767 if (rref
->type
!= REF_COMPONENT
)
4770 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4771 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4773 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4774 lsym_pointer
, lsym_target
,
4775 rsym_pointer
, rsym_target
))
4778 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4779 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4781 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4782 &rref
->u
.c
.sym
->ts
))
4784 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4785 &rref
->u
.c
.component
->ts
))
4787 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4788 &rref
->u
.c
.component
->ts
))
4794 lsym_pointer
= lsym
->attr
.pointer
;
4795 lsym_target
= lsym
->attr
.target
;
4797 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4799 if (rref
->type
!= REF_COMPONENT
)
4802 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4803 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4805 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4806 lsym_pointer
, lsym_target
,
4807 rsym_pointer
, rsym_target
))
4810 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4811 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4813 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4822 /* Resolve array data dependencies. Creates a temporary if required. */
4823 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4827 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4833 gfc_ss_info
*ss_info
;
4834 gfc_expr
*dest_expr
;
4839 loop
->temp_ss
= NULL
;
4840 dest_expr
= dest
->info
->expr
;
4842 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4845 ss_expr
= ss_info
->expr
;
4847 if (ss_info
->array_outer_dependency
)
4853 if (ss_info
->type
!= GFC_SS_SECTION
)
4855 if (flag_realloc_lhs
4856 && dest_expr
!= ss_expr
4857 && gfc_is_reallocatable_lhs (dest_expr
)
4859 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4861 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4862 if (!nDepend
&& dest_expr
->rank
> 0
4863 && dest_expr
->ts
.type
== BT_CHARACTER
4864 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4866 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4868 if (ss_info
->type
== GFC_SS_REFERENCE
4869 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4870 ss_info
->data
.scalar
.needs_temporary
= 1;
4878 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4880 if (gfc_could_be_alias (dest
, ss
)
4881 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4889 lref
= dest_expr
->ref
;
4890 rref
= ss_expr
->ref
;
4892 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4897 for (i
= 0; i
< dest
->dimen
; i
++)
4898 for (j
= 0; j
< ss
->dimen
; j
++)
4900 && dest
->dim
[i
] == ss
->dim
[j
])
4902 /* If we don't access array elements in the same order,
4903 there is a dependency. */
4908 /* TODO : loop shifting. */
4911 /* Mark the dimensions for LOOP SHIFTING */
4912 for (n
= 0; n
< loop
->dimen
; n
++)
4914 int dim
= dest
->data
.info
.dim
[n
];
4916 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4918 else if (! gfc_is_same_range (&lref
->u
.ar
,
4919 &rref
->u
.ar
, dim
, 0))
4923 /* Put all the dimensions with dependencies in the
4926 for (n
= 0; n
< loop
->dimen
; n
++)
4928 gcc_assert (loop
->order
[n
] == n
);
4930 loop
->order
[dim
++] = n
;
4932 for (n
= 0; n
< loop
->dimen
; n
++)
4935 loop
->order
[dim
++] = n
;
4938 gcc_assert (dim
== loop
->dimen
);
4949 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4950 if (GFC_ARRAY_TYPE_P (base_type
)
4951 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4952 base_type
= gfc_get_element_type (base_type
);
4953 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4955 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4958 loop
->temp_ss
= NULL
;
4962 /* Browse through each array's information from the scalarizer and set the loop
4963 bounds according to the "best" one (per dimension), i.e. the one which
4964 provides the most information (constant bounds, shape, etc.). */
4967 set_loop_bounds (gfc_loopinfo
*loop
)
4969 int n
, dim
, spec_dim
;
4970 gfc_array_info
*info
;
4971 gfc_array_info
*specinfo
;
4975 bool dynamic
[GFC_MAX_DIMENSIONS
];
4978 bool nonoptional_arr
;
4980 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4982 loopspec
= loop
->specloop
;
4985 for (n
= 0; n
< loop
->dimen
; n
++)
4990 /* If there are both optional and nonoptional array arguments, scalarize
4991 over the nonoptional; otherwise, it does not matter as then all
4992 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4994 nonoptional_arr
= false;
4996 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4997 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4998 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
5000 nonoptional_arr
= true;
5004 /* We use one SS term, and use that to determine the bounds of the
5005 loop for this dimension. We try to pick the simplest term. */
5006 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5008 gfc_ss_type ss_type
;
5010 ss_type
= ss
->info
->type
;
5011 if (ss_type
== GFC_SS_SCALAR
5012 || ss_type
== GFC_SS_TEMP
5013 || ss_type
== GFC_SS_REFERENCE
5014 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
5017 info
= &ss
->info
->data
.array
;
5020 if (loopspec
[n
] != NULL
)
5022 specinfo
= &loopspec
[n
]->info
->data
.array
;
5023 spec_dim
= loopspec
[n
]->dim
[n
];
5027 /* Silence uninitialized warnings. */
5034 gcc_assert (info
->shape
[dim
]);
5035 /* The frontend has worked out the size for us. */
5038 || !integer_zerop (specinfo
->start
[spec_dim
]))
5039 /* Prefer zero-based descriptors if possible. */
5044 if (ss_type
== GFC_SS_CONSTRUCTOR
)
5046 gfc_constructor_base base
;
5047 /* An unknown size constructor will always be rank one.
5048 Higher rank constructors will either have known shape,
5049 or still be wrapped in a call to reshape. */
5050 gcc_assert (loop
->dimen
== 1);
5052 /* Always prefer to use the constructor bounds if the size
5053 can be determined at compile time. Prefer not to otherwise,
5054 since the general case involves realloc, and it's better to
5055 avoid that overhead if possible. */
5056 base
= ss
->info
->expr
->value
.constructor
;
5057 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
5058 if (!dynamic
[n
] || !loopspec
[n
])
5063 /* Avoid using an allocatable lhs in an assignment, since
5064 there might be a reallocation coming. */
5065 if (loopspec
[n
] && ss
->is_alloc_lhs
)
5070 /* Criteria for choosing a loop specifier (most important first):
5071 doesn't need realloc
5077 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
5079 else if (integer_onep (info
->stride
[dim
])
5080 && !integer_onep (specinfo
->stride
[spec_dim
]))
5082 else if (INTEGER_CST_P (info
->stride
[dim
])
5083 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5085 else if (INTEGER_CST_P (info
->start
[dim
])
5086 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
5087 && integer_onep (info
->stride
[dim
])
5088 == integer_onep (specinfo
->stride
[spec_dim
])
5089 && INTEGER_CST_P (info
->stride
[dim
])
5090 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5092 /* We don't work out the upper bound.
5093 else if (INTEGER_CST_P (info->finish[n])
5094 && ! INTEGER_CST_P (specinfo->finish[n]))
5095 loopspec[n] = ss; */
5098 /* We should have found the scalarization loop specifier. If not,
5100 gcc_assert (loopspec
[n
]);
5102 info
= &loopspec
[n
]->info
->data
.array
;
5103 dim
= loopspec
[n
]->dim
[n
];
5105 /* Set the extents of this range. */
5106 cshape
= info
->shape
;
5107 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5108 && INTEGER_CST_P (info
->stride
[dim
]))
5110 loop
->from
[n
] = info
->start
[dim
];
5111 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5112 mpz_sub_ui (i
, i
, 1);
5113 /* To = from + (size - 1) * stride. */
5114 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5115 if (!integer_onep (info
->stride
[dim
]))
5116 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5117 gfc_array_index_type
, tmp
,
5119 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5120 gfc_array_index_type
,
5121 loop
->from
[n
], tmp
);
5125 loop
->from
[n
] = info
->start
[dim
];
5126 switch (loopspec
[n
]->info
->type
)
5128 case GFC_SS_CONSTRUCTOR
:
5129 /* The upper bound is calculated when we expand the
5131 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5134 case GFC_SS_SECTION
:
5135 /* Use the end expression if it exists and is not constant,
5136 so that it is only evaluated once. */
5137 loop
->to
[n
] = info
->end
[dim
];
5140 case GFC_SS_FUNCTION
:
5141 /* The loop bound will be set when we generate the call. */
5142 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5145 case GFC_SS_INTRINSIC
:
5147 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5149 /* The {l,u}bound of an assumed rank. */
5150 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5151 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5152 && expr
->value
.function
.actual
->next
->expr
== NULL
5153 && expr
->value
.function
.actual
->expr
->rank
== -1);
5155 loop
->to
[n
] = info
->end
[dim
];
5159 case GFC_SS_COMPONENT
:
5161 if (info
->end
[dim
] != NULL_TREE
)
5163 loop
->to
[n
] = info
->end
[dim
];
5175 /* Transform everything so we have a simple incrementing variable. */
5176 if (integer_onep (info
->stride
[dim
]))
5177 info
->delta
[dim
] = gfc_index_zero_node
;
5180 /* Set the delta for this section. */
5181 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5182 /* Number of iterations is (end - start + step) / step.
5183 with start = 0, this simplifies to
5185 for (i = 0; i<=last; i++){...}; */
5186 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5187 gfc_array_index_type
, loop
->to
[n
],
5189 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5190 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5191 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5192 tmp
, build_int_cst (gfc_array_index_type
, -1));
5193 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5194 /* Make the loop variable start at 0. */
5195 loop
->from
[n
] = gfc_index_zero_node
;
5200 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5201 set_loop_bounds (loop
);
5205 /* Initialize the scalarization loop. Creates the loop variables. Determines
5206 the range of the loop variables. Creates a temporary if required.
5207 Also generates code for scalar expressions which have been
5208 moved outside the loop. */
5211 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5216 set_loop_bounds (loop
);
5218 /* Add all the scalar code that can be taken out of the loops.
5219 This may include calculating the loop bounds, so do it before
5220 allocating the temporary. */
5221 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5223 tmp_ss
= loop
->temp_ss
;
5224 /* If we want a temporary then create it. */
5227 gfc_ss_info
*tmp_ss_info
;
5229 tmp_ss_info
= tmp_ss
->info
;
5230 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5231 gcc_assert (loop
->parent
== NULL
);
5233 /* Make absolutely sure that this is a complete type. */
5234 if (tmp_ss_info
->string_length
)
5235 tmp_ss_info
->data
.temp
.type
5236 = gfc_get_character_type_len_for_eltype
5237 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5238 tmp_ss_info
->string_length
);
5240 tmp
= tmp_ss_info
->data
.temp
.type
;
5241 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5242 tmp_ss_info
->type
= GFC_SS_SECTION
;
5244 gcc_assert (tmp_ss
->dimen
!= 0);
5246 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5247 NULL_TREE
, false, true, false, where
);
5250 /* For array parameters we don't have loop variables, so don't calculate the
5252 if (!loop
->array_parameter
)
5253 gfc_set_delta (loop
);
5257 /* Calculates how to transform from loop variables to array indices for each
5258 array: once loop bounds are chosen, sets the difference (DELTA field) between
5259 loop bounds and array reference bounds, for each array info. */
5262 gfc_set_delta (gfc_loopinfo
*loop
)
5264 gfc_ss
*ss
, **loopspec
;
5265 gfc_array_info
*info
;
5269 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5271 loopspec
= loop
->specloop
;
5273 /* Calculate the translation from loop variables to array indices. */
5274 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5276 gfc_ss_type ss_type
;
5278 ss_type
= ss
->info
->type
;
5279 if (ss_type
!= GFC_SS_SECTION
5280 && ss_type
!= GFC_SS_COMPONENT
5281 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5284 info
= &ss
->info
->data
.array
;
5286 for (n
= 0; n
< ss
->dimen
; n
++)
5288 /* If we are specifying the range the delta is already set. */
5289 if (loopspec
[n
] != ss
)
5293 /* Calculate the offset relative to the loop variable.
5294 First multiply by the stride. */
5295 tmp
= loop
->from
[n
];
5296 if (!integer_onep (info
->stride
[dim
]))
5297 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5298 gfc_array_index_type
,
5299 tmp
, info
->stride
[dim
]);
5301 /* Then subtract this from our starting value. */
5302 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5303 gfc_array_index_type
,
5304 info
->start
[dim
], tmp
);
5306 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5311 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5312 gfc_set_delta (loop
);
5316 /* Calculate the size of a given array dimension from the bounds. This
5317 is simply (ubound - lbound + 1) if this expression is positive
5318 or 0 if it is negative (pick either one if it is zero). Optionally
5319 (if or_expr is present) OR the (expression != 0) condition to it. */
5322 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5327 /* Calculate (ubound - lbound + 1). */
5328 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5330 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5331 gfc_index_one_node
);
5333 /* Check whether the size for this dimension is negative. */
5334 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5335 gfc_index_zero_node
);
5336 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5337 gfc_index_zero_node
, res
);
5339 /* Build OR expression. */
5341 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5342 logical_type_node
, *or_expr
, cond
);
5348 /* For an array descriptor, get the total number of elements. This is just
5349 the product of the extents along from_dim to to_dim. */
5352 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5357 res
= gfc_index_one_node
;
5359 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5365 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5366 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5368 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5369 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5377 /* Full size of an array. */
5380 gfc_conv_descriptor_size (tree desc
, int rank
)
5382 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5386 /* Size of a coarray for all dimensions but the last. */
5389 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5391 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5395 /* Fills in an array descriptor, and returns the size of the array.
5396 The size will be a simple_val, ie a variable or a constant. Also
5397 calculates the offset of the base. The pointer argument overflow,
5398 which should be of integer type, will increase in value if overflow
5399 occurs during the size calculation. Returns the size of the array.
5403 for (n = 0; n < rank; n++)
5405 a.lbound[n] = specified_lower_bound;
5406 offset = offset + a.lbond[n] * stride;
5408 a.ubound[n] = specified_upper_bound;
5409 a.stride[n] = stride;
5410 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5411 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5412 stride = stride * size;
5414 for (n = rank; n < rank+corank; n++)
5415 (Set lcobound/ucobound as above.)
5416 element_size = sizeof (array element);
5419 stride = (size_t) stride;
5420 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5421 stride = stride * element_size;
5427 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5428 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5429 stmtblock_t
* descriptor_block
, tree
* overflow
,
5430 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5431 tree expr3_desc
, bool e3_has_nodescriptor
, gfc_expr
*expr
,
5444 stmtblock_t thenblock
;
5445 stmtblock_t elseblock
;
5450 type
= TREE_TYPE (descriptor
);
5452 stride
= gfc_index_one_node
;
5453 offset
= gfc_index_zero_node
;
5455 /* Set the dtype before the alloc, because registration of coarrays needs
5457 if (expr
->ts
.type
== BT_CHARACTER
5458 && expr
->ts
.deferred
5459 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5461 type
= gfc_typenode_for_spec (&expr
->ts
);
5462 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5463 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5465 else if (expr
->ts
.type
== BT_CHARACTER
5466 && expr
->ts
.deferred
5467 && TREE_CODE (descriptor
) == COMPONENT_REF
)
5469 /* Deferred character components have their string length tucked away
5470 in a hidden field of the derived type. Obtain that and use it to
5471 set the dtype. The charlen backend decl is zero because the field
5472 type is zero length. */
5475 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5476 if (ref
->type
== REF_COMPONENT
5477 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
5479 gcc_assert (tmp
!= NULL_TREE
);
5480 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
5481 TREE_OPERAND (descriptor
, 0), tmp
, NULL_TREE
);
5482 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
5483 type
= gfc_get_character_type_len (expr
->ts
.kind
, tmp
);
5484 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5485 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5489 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5490 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5493 or_expr
= logical_false_node
;
5495 for (n
= 0; n
< rank
; n
++)
5500 /* We have 3 possibilities for determining the size of the array:
5501 lower == NULL => lbound = 1, ubound = upper[n]
5502 upper[n] = NULL => lbound = 1, ubound = lower[n]
5503 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5506 /* Set lower bound. */
5507 gfc_init_se (&se
, NULL
);
5508 if (expr3_desc
!= NULL_TREE
)
5510 if (e3_has_nodescriptor
)
5511 /* The lbound of nondescriptor arrays like array constructors,
5512 nonallocatable/nonpointer function results/variables,
5513 start at zero, but when allocating it, the standard expects
5514 the array to start at one. */
5515 se
.expr
= gfc_index_one_node
;
5517 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5520 else if (lower
== NULL
)
5521 se
.expr
= gfc_index_one_node
;
5524 gcc_assert (lower
[n
]);
5527 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5528 gfc_add_block_to_block (pblock
, &se
.pre
);
5532 se
.expr
= gfc_index_one_node
;
5536 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5537 gfc_rank_cst
[n
], se
.expr
);
5538 conv_lbound
= se
.expr
;
5540 /* Work out the offset for this component. */
5541 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5543 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5544 gfc_array_index_type
, offset
, tmp
);
5546 /* Set upper bound. */
5547 gfc_init_se (&se
, NULL
);
5548 if (expr3_desc
!= NULL_TREE
)
5550 if (e3_has_nodescriptor
)
5552 /* The lbound of nondescriptor arrays like array constructors,
5553 nonallocatable/nonpointer function results/variables,
5554 start at zero, but when allocating it, the standard expects
5555 the array to start at one. Therefore fix the upper bound to be
5556 (desc.ubound - desc.lbound) + 1. */
5557 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5558 gfc_array_index_type
,
5559 gfc_conv_descriptor_ubound_get (
5560 expr3_desc
, gfc_rank_cst
[n
]),
5561 gfc_conv_descriptor_lbound_get (
5562 expr3_desc
, gfc_rank_cst
[n
]));
5563 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5564 gfc_array_index_type
, tmp
,
5565 gfc_index_one_node
);
5566 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5569 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5574 gcc_assert (ubound
);
5575 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5576 gfc_add_block_to_block (pblock
, &se
.pre
);
5577 if (ubound
->expr_type
== EXPR_FUNCTION
)
5578 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5580 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5581 gfc_rank_cst
[n
], se
.expr
);
5582 conv_ubound
= se
.expr
;
5584 /* Store the stride. */
5585 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5586 gfc_rank_cst
[n
], stride
);
5588 /* Calculate size and check whether extent is negative. */
5589 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5590 size
= gfc_evaluate_now (size
, pblock
);
5592 /* Check whether multiplying the stride by the number of
5593 elements in this dimension would overflow. We must also check
5594 whether the current dimension has zero size in order to avoid
5597 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5598 gfc_array_index_type
,
5599 fold_convert (gfc_array_index_type
,
5600 TYPE_MAX_VALUE (gfc_array_index_type
)),
5602 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5603 logical_type_node
, tmp
, stride
),
5604 PRED_FORTRAN_OVERFLOW
);
5605 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5606 integer_one_node
, integer_zero_node
);
5607 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5608 logical_type_node
, size
,
5609 gfc_index_zero_node
),
5610 PRED_FORTRAN_SIZE_ZERO
);
5611 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5612 integer_zero_node
, tmp
);
5613 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5615 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5617 /* Multiply the stride by the number of elements in this dimension. */
5618 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5619 gfc_array_index_type
, stride
, size
);
5620 stride
= gfc_evaluate_now (stride
, pblock
);
5623 for (n
= rank
; n
< rank
+ corank
; n
++)
5627 /* Set lower bound. */
5628 gfc_init_se (&se
, NULL
);
5629 if (lower
== NULL
|| lower
[n
] == NULL
)
5631 gcc_assert (n
== rank
+ corank
- 1);
5632 se
.expr
= gfc_index_one_node
;
5636 if (ubound
|| n
== rank
+ corank
- 1)
5638 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5639 gfc_add_block_to_block (pblock
, &se
.pre
);
5643 se
.expr
= gfc_index_one_node
;
5647 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5648 gfc_rank_cst
[n
], se
.expr
);
5650 if (n
< rank
+ corank
- 1)
5652 gfc_init_se (&se
, NULL
);
5653 gcc_assert (ubound
);
5654 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5655 gfc_add_block_to_block (pblock
, &se
.pre
);
5656 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5657 gfc_rank_cst
[n
], se
.expr
);
5661 /* The stride is the number of elements in the array, so multiply by the
5662 size of an element to get the total size. Obviously, if there is a
5663 SOURCE expression (expr3) we must use its element size. */
5664 if (expr3_elem_size
!= NULL_TREE
)
5665 tmp
= expr3_elem_size
;
5666 else if (expr3
!= NULL
)
5668 if (expr3
->ts
.type
== BT_CLASS
)
5671 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5672 gfc_add_vptr_component (sz
);
5673 gfc_add_size_component (sz
);
5674 gfc_init_se (&se_sz
, NULL
);
5675 gfc_conv_expr (&se_sz
, sz
);
5681 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5682 tmp
= TYPE_SIZE_UNIT (tmp
);
5686 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5688 /* Convert to size_t. */
5689 *element_size
= fold_convert (size_type_node
, tmp
);
5692 return *element_size
;
5694 *nelems
= gfc_evaluate_now (stride
, pblock
);
5695 stride
= fold_convert (size_type_node
, stride
);
5697 /* First check for overflow. Since an array of type character can
5698 have zero element_size, we must check for that before
5700 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5702 TYPE_MAX_VALUE (size_type_node
), *element_size
);
5703 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5704 logical_type_node
, tmp
, stride
),
5705 PRED_FORTRAN_OVERFLOW
);
5706 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5707 integer_one_node
, integer_zero_node
);
5708 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5709 logical_type_node
, *element_size
,
5710 build_int_cst (size_type_node
, 0)),
5711 PRED_FORTRAN_SIZE_ZERO
);
5712 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5713 integer_zero_node
, tmp
);
5714 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5716 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5718 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5719 stride
, *element_size
);
5721 if (poffset
!= NULL
)
5723 offset
= gfc_evaluate_now (offset
, pblock
);
5727 if (integer_zerop (or_expr
))
5729 if (integer_onep (or_expr
))
5730 return build_int_cst (size_type_node
, 0);
5732 var
= gfc_create_var (TREE_TYPE (size
), "size");
5733 gfc_start_block (&thenblock
);
5734 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5735 thencase
= gfc_finish_block (&thenblock
);
5737 gfc_start_block (&elseblock
);
5738 gfc_add_modify (&elseblock
, var
, size
);
5739 elsecase
= gfc_finish_block (&elseblock
);
5741 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5742 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5743 gfc_add_expr_to_block (pblock
, tmp
);
5749 /* Retrieve the last ref from the chain. This routine is specific to
5750 gfc_array_allocate ()'s needs. */
5753 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5755 gfc_ref
*ref
, *prev_ref
;
5758 /* Prevent warnings for uninitialized variables. */
5759 prev_ref
= *prev_ref_in
;
5760 while (ref
&& ref
->next
!= NULL
)
5762 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5763 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5768 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5772 *prev_ref_in
= prev_ref
;
5776 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5777 the work for an ALLOCATE statement. */
5781 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5782 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5783 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5784 bool e3_has_nodescriptor
)
5788 tree offset
= NULL_TREE
;
5789 tree token
= NULL_TREE
;
5792 tree error
= NULL_TREE
;
5793 tree overflow
; /* Boolean storing whether size calculation overflows. */
5794 tree var_overflow
= NULL_TREE
;
5796 tree set_descriptor
;
5797 tree not_prev_allocated
= NULL_TREE
;
5798 tree element_size
= NULL_TREE
;
5799 stmtblock_t set_descriptor_block
;
5800 stmtblock_t elseblock
;
5803 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5804 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5805 non_ulimate_coarray_ptr_comp
;
5809 /* Find the last reference in the chain. */
5810 if (!retrieve_last_ref (&ref
, &prev_ref
))
5813 /* Take the allocatable and coarray properties solely from the expr-ref's
5814 attributes and not from source=-expression. */
5817 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5818 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5819 non_ulimate_coarray_ptr_comp
= false;
5823 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5824 /* Pointer components in coarrayed derived types must be treated
5825 specially in that they are registered without a check if the are
5826 already associated. This does not hold for ultimate coarray
5828 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5829 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5830 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5833 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5834 a coarray. In this case it does not matter whether we are on this_image
5837 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5838 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5845 gcc_assert (coarray
);
5847 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5849 gfc_ref
*old_ref
= ref
;
5850 /* F08:C633: Array shape from expr3. */
5853 /* Find the last reference in the chain. */
5854 if (!retrieve_last_ref (&ref
, &prev_ref
))
5856 if (expr3
->expr_type
== EXPR_FUNCTION
5857 && gfc_expr_attr (expr3
).dimension
)
5862 alloc_w_e3_arr_spec
= true;
5865 /* Figure out the size of the array. */
5866 switch (ref
->u
.ar
.type
)
5872 upper
= ref
->u
.ar
.start
;
5878 lower
= ref
->u
.ar
.start
;
5879 upper
= ref
->u
.ar
.end
;
5883 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5884 || alloc_w_e3_arr_spec
);
5886 lower
= ref
->u
.ar
.as
->lower
;
5887 upper
= ref
->u
.ar
.as
->upper
;
5895 overflow
= integer_zero_node
;
5897 if (expr
->ts
.type
== BT_CHARACTER
5898 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5899 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
5900 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5901 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5902 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5903 se
->string_length
));
5905 gfc_init_block (&set_descriptor_block
);
5906 /* Take the corank only from the actual ref and not from the coref. The
5907 later will mislead the generation of the array dimensions for allocatable/
5908 pointer components in derived types. */
5909 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5910 : ref
->u
.ar
.as
->rank
,
5911 coarray
? ref
->u
.ar
.as
->corank
: 0,
5912 &offset
, lower
, upper
,
5913 &se
->pre
, &set_descriptor_block
, &overflow
,
5914 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5915 e3_has_nodescriptor
, expr
, &element_size
);
5919 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5920 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5922 if (status
== NULL_TREE
)
5924 /* Generate the block of code handling overflow. */
5925 msg
= gfc_build_addr_expr (pchar_type_node
,
5926 gfc_build_localized_cstring_const
5927 ("Integer overflow when calculating the amount of "
5928 "memory to allocate"));
5929 error
= build_call_expr_loc (input_location
,
5930 gfor_fndecl_runtime_error
, 1, msg
);
5934 tree status_type
= TREE_TYPE (status
);
5935 stmtblock_t set_status_block
;
5937 gfc_start_block (&set_status_block
);
5938 gfc_add_modify (&set_status_block
, status
,
5939 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5940 error
= gfc_finish_block (&set_status_block
);
5944 /* Allocate memory to store the data. */
5945 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5946 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5948 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5950 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5951 : gfc_conv_descriptor_data_get (se
->expr
);
5952 token
= gfc_conv_descriptor_token (se
->expr
);
5953 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5956 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5957 STRIP_NOPS (pointer
);
5961 not_prev_allocated
= gfc_create_var (logical_type_node
,
5962 "not_prev_allocated");
5963 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5964 logical_type_node
, pointer
,
5965 build_int_cst (TREE_TYPE (pointer
), 0));
5967 gfc_add_modify (&se
->pre
, not_prev_allocated
, tmp
);
5970 gfc_start_block (&elseblock
);
5972 /* The allocatable variant takes the old pointer as first argument. */
5974 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5975 status
, errmsg
, errlen
, label_finish
, expr
,
5976 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5977 else if (non_ulimate_coarray_ptr_comp
&& token
)
5978 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5979 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5981 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5983 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5987 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5988 logical_type_node
, var_overflow
, integer_zero_node
),
5989 PRED_FORTRAN_OVERFLOW
);
5990 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5991 error
, gfc_finish_block (&elseblock
));
5994 tmp
= gfc_finish_block (&elseblock
);
5996 gfc_add_expr_to_block (&se
->pre
, tmp
);
5998 /* Update the array descriptor with the offset and the span. */
6001 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
6002 tmp
= fold_convert (gfc_array_index_type
, element_size
);
6003 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
6006 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
6007 if (status
!= NULL_TREE
)
6009 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6010 logical_type_node
, status
,
6011 build_int_cst (TREE_TYPE (status
), 0));
6013 if (not_prev_allocated
!= NULL_TREE
)
6014 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6015 logical_type_node
, cond
, not_prev_allocated
);
6017 gfc_add_expr_to_block (&se
->pre
,
6018 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6021 build_empty_stmt (input_location
)));
6024 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
6030 /* Create an array constructor from an initialization expression.
6031 We assume the frontend already did any expansions and conversions. */
6034 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
6040 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6042 if (expr
->expr_type
== EXPR_VARIABLE
6043 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6044 && expr
->symtree
->n
.sym
->value
)
6045 expr
= expr
->symtree
->n
.sym
->value
;
6047 switch (expr
->expr_type
)
6050 case EXPR_STRUCTURE
:
6051 /* A single scalar or derived type value. Create an array with all
6052 elements equal to that value. */
6053 gfc_init_se (&se
, NULL
);
6055 if (expr
->expr_type
== EXPR_CONSTANT
)
6056 gfc_conv_constant (&se
, expr
);
6058 gfc_conv_structure (&se
, expr
, 1);
6060 CONSTRUCTOR_APPEND_ELT (v
, build2 (RANGE_EXPR
, gfc_array_index_type
,
6061 TYPE_MIN_VALUE (TYPE_DOMAIN (type
)),
6062 TYPE_MAX_VALUE (TYPE_DOMAIN (type
))),
6067 /* Create a vector of all the elements. */
6068 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6069 c
; c
= gfc_constructor_next (c
))
6073 /* Problems occur when we get something like
6074 integer :: a(lots) = (/(i, i=1, lots)/) */
6075 gfc_fatal_error ("The number of elements in the array "
6076 "constructor at %L requires an increase of "
6077 "the allowed %d upper limit. See "
6078 "%<-fmax-array-constructor%> option",
6079 &expr
->where
, flag_max_array_constructor
);
6082 if (mpz_cmp_si (c
->offset
, 0) != 0)
6083 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6087 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6093 mpz_add (maxval
, c
->offset
, c
->repeat
);
6094 mpz_sub_ui (maxval
, maxval
, 1);
6095 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6096 if (mpz_cmp_si (c
->offset
, 0) != 0)
6098 mpz_add_ui (maxval
, c
->offset
, 1);
6099 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6102 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6104 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6110 gfc_init_se (&se
, NULL
);
6111 switch (c
->expr
->expr_type
)
6114 gfc_conv_constant (&se
, c
->expr
);
6116 /* See gfortran.dg/charlen_15.f90 for instance. */
6117 if (TREE_CODE (se
.expr
) == STRING_CST
6118 && TREE_CODE (type
) == ARRAY_TYPE
)
6121 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6122 atype
= TREE_TYPE (atype
);
6123 gcc_checking_assert (TREE_CODE (TREE_TYPE (atype
))
6125 gcc_checking_assert (TREE_TYPE (TREE_TYPE (se
.expr
))
6126 == TREE_TYPE (atype
));
6127 if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6128 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6130 unsigned HOST_WIDE_INT size
6131 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6132 const char *p
= TREE_STRING_POINTER (se
.expr
);
6134 se
.expr
= build_string (size
, p
);
6136 TREE_TYPE (se
.expr
) = atype
;
6140 case EXPR_STRUCTURE
:
6141 gfc_conv_structure (&se
, c
->expr
, 1);
6145 /* Catch those occasional beasts that do not simplify
6146 for one reason or another, assuming that if they are
6147 standard defying the frontend will catch them. */
6148 gfc_conv_expr (&se
, c
->expr
);
6152 if (range
== NULL_TREE
)
6153 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6156 if (index
!= NULL_TREE
)
6157 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6158 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6164 return gfc_build_null_descriptor (type
);
6170 /* Create a constructor from the list of elements. */
6171 tmp
= build_constructor (type
, v
);
6172 TREE_CONSTANT (tmp
) = 1;
6177 /* Generate code to evaluate non-constant coarray cobounds. */
6180 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6181 const gfc_symbol
*sym
)
6189 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6191 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6193 /* Evaluate non-constant array bound expressions. */
6194 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6195 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6197 gfc_init_se (&se
, NULL
);
6198 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6199 gfc_add_block_to_block (pblock
, &se
.pre
);
6200 gfc_add_modify (pblock
, lbound
, se
.expr
);
6202 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6203 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6205 gfc_init_se (&se
, NULL
);
6206 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6207 gfc_add_block_to_block (pblock
, &se
.pre
);
6208 gfc_add_modify (pblock
, ubound
, se
.expr
);
6214 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6215 returns the size (in elements) of the array. */
6218 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6219 stmtblock_t
* pblock
)
6232 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6234 size
= gfc_index_one_node
;
6235 offset
= gfc_index_zero_node
;
6236 for (dim
= 0; dim
< as
->rank
; dim
++)
6238 /* Evaluate non-constant array bound expressions. */
6239 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6240 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6242 gfc_init_se (&se
, NULL
);
6243 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6244 gfc_add_block_to_block (pblock
, &se
.pre
);
6245 gfc_add_modify (pblock
, lbound
, se
.expr
);
6247 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6248 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6250 gfc_init_se (&se
, NULL
);
6251 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6252 gfc_add_block_to_block (pblock
, &se
.pre
);
6253 gfc_add_modify (pblock
, ubound
, se
.expr
);
6255 /* The offset of this dimension. offset = offset - lbound * stride. */
6256 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6258 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6261 /* The size of this dimension, and the stride of the next. */
6262 if (dim
+ 1 < as
->rank
)
6263 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6265 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6267 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6269 /* Calculate stride = size * (ubound + 1 - lbound). */
6270 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6271 gfc_array_index_type
,
6272 gfc_index_one_node
, lbound
);
6273 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6274 gfc_array_index_type
, ubound
, tmp
);
6275 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6276 gfc_array_index_type
, size
, tmp
);
6278 gfc_add_modify (pblock
, stride
, tmp
);
6280 stride
= gfc_evaluate_now (tmp
, pblock
);
6282 /* Make sure that negative size arrays are translated
6283 to being zero size. */
6284 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6285 stride
, gfc_index_zero_node
);
6286 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6287 gfc_array_index_type
, tmp
,
6288 stride
, gfc_index_zero_node
);
6289 gfc_add_modify (pblock
, stride
, tmp
);
6295 gfc_trans_array_cobounds (type
, pblock
, sym
);
6296 gfc_trans_vla_type_sizes (sym
, pblock
);
6303 /* Generate code to initialize/allocate an array variable. */
6306 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6307 gfc_wrapped_block
* block
)
6311 tree tmp
= NULL_TREE
;
6318 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6320 /* Do nothing for USEd variables. */
6321 if (sym
->attr
.use_assoc
)
6324 type
= TREE_TYPE (decl
);
6325 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6326 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6328 gfc_init_block (&init
);
6330 /* Evaluate character string length. */
6331 if (sym
->ts
.type
== BT_CHARACTER
6332 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6334 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6336 gfc_trans_vla_type_sizes (sym
, &init
);
6338 /* Emit a DECL_EXPR for this variable, which will cause the
6339 gimplifier to allocate storage, and all that good stuff. */
6340 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6341 gfc_add_expr_to_block (&init
, tmp
);
6346 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6350 type
= TREE_TYPE (type
);
6352 gcc_assert (!sym
->attr
.use_assoc
);
6353 gcc_assert (!TREE_STATIC (decl
));
6354 gcc_assert (!sym
->module
);
6356 if (sym
->ts
.type
== BT_CHARACTER
6357 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6358 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6360 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6362 /* Don't actually allocate space for Cray Pointees. */
6363 if (sym
->attr
.cray_pointee
)
6365 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6366 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6368 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6372 if (flag_stack_arrays
)
6374 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6375 space
= build_decl (gfc_get_location (&sym
->declared_at
),
6376 VAR_DECL
, create_tmp_var_name ("A"),
6377 TREE_TYPE (TREE_TYPE (decl
)));
6378 gfc_trans_vla_type_sizes (sym
, &init
);
6382 /* The size is the number of elements in the array, so multiply by the
6383 size of an element to get the total size. */
6384 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6385 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6386 size
, fold_convert (gfc_array_index_type
, tmp
));
6388 /* Allocate memory to hold the data. */
6389 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6390 gfc_add_modify (&init
, decl
, tmp
);
6392 /* Free the temporary. */
6393 tmp
= gfc_call_free (decl
);
6397 /* Set offset of the array. */
6398 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6399 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6401 /* Automatic arrays should not have initializers. */
6402 gcc_assert (!sym
->value
);
6404 inittree
= gfc_finish_block (&init
);
6411 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6412 where also space is located. */
6413 gfc_init_block (&init
);
6414 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6415 TREE_TYPE (space
), space
);
6416 gfc_add_expr_to_block (&init
, tmp
);
6417 addr
= fold_build1_loc (gfc_get_location (&sym
->declared_at
),
6418 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6419 gfc_add_modify (&init
, decl
, addr
);
6420 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6423 gfc_add_init_cleanup (block
, inittree
, tmp
);
6427 /* Generate entry and exit code for g77 calling convention arrays. */
6430 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6440 gfc_save_backend_locus (&loc
);
6441 gfc_set_backend_locus (&sym
->declared_at
);
6443 /* Descriptor type. */
6444 parm
= sym
->backend_decl
;
6445 type
= TREE_TYPE (parm
);
6446 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6448 gfc_start_block (&init
);
6450 if (sym
->ts
.type
== BT_CHARACTER
6451 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6452 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6454 /* Evaluate the bounds of the array. */
6455 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6457 /* Set the offset. */
6458 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6459 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6461 /* Set the pointer itself if we aren't using the parameter directly. */
6462 if (TREE_CODE (parm
) != PARM_DECL
)
6464 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6465 gfc_add_modify (&init
, parm
, tmp
);
6467 stmt
= gfc_finish_block (&init
);
6469 gfc_restore_backend_locus (&loc
);
6471 /* Add the initialization code to the start of the function. */
6473 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6476 if (TREE_CODE (parm
) != PARM_DECL
)
6477 nullify
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6478 parm
, null_pointer_node
);
6480 nullify
= build_empty_stmt (input_location
);
6481 tmp
= gfc_conv_expr_present (sym
, true);
6482 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, nullify
);
6485 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6489 /* Modify the descriptor of an array parameter so that it has the
6490 correct lower bound. Also move the upper bound accordingly.
6491 If the array is not packed, it will be copied into a temporary.
6492 For each dimension we set the new lower and upper bounds. Then we copy the
6493 stride and calculate the offset for this dimension. We also work out
6494 what the stride of a packed array would be, and see it the two match.
6495 If the array need repacking, we set the stride to the values we just
6496 calculated, recalculate the offset and copy the array data.
6497 Code is also added to copy the data back at the end of the function.
6501 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6502 gfc_wrapped_block
* block
)
6509 tree stmtInit
, stmtCleanup
;
6516 tree stride
, stride2
;
6526 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6528 /* Do nothing for pointer and allocatable arrays. */
6529 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6530 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6531 || sym
->attr
.allocatable
6532 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6535 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6537 gfc_trans_g77_array (sym
, block
);
6542 gfc_save_backend_locus (&loc
);
6543 /* loc.nextc is not set by save_backend_locus but the location routines
6545 if (loc
.nextc
== NULL
)
6546 loc
.nextc
= loc
.lb
->line
;
6547 gfc_set_backend_locus (&sym
->declared_at
);
6549 /* Descriptor type. */
6550 type
= TREE_TYPE (tmpdesc
);
6551 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6552 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6554 /* For a class array the dummy array descriptor is in the _class
6556 dumdesc
= gfc_class_data_get (dumdesc
);
6558 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6559 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6560 gfc_start_block (&init
);
6562 if (sym
->ts
.type
== BT_CHARACTER
6563 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6564 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6566 checkparm
= (as
->type
== AS_EXPLICIT
6567 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6569 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6570 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6572 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6574 /* For non-constant shape arrays we only check if the first dimension
6575 is contiguous. Repacking higher dimensions wouldn't gain us
6576 anything as we still don't know the array stride. */
6577 partial
= gfc_create_var (logical_type_node
, "partial");
6578 TREE_USED (partial
) = 1;
6579 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6580 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6581 gfc_index_one_node
);
6582 gfc_add_modify (&init
, partial
, tmp
);
6585 partial
= NULL_TREE
;
6587 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6588 here, however I think it does the right thing. */
6591 /* Set the first stride. */
6592 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6593 stride
= gfc_evaluate_now (stride
, &init
);
6595 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6596 stride
, gfc_index_zero_node
);
6597 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6598 tmp
, gfc_index_one_node
, stride
);
6599 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6600 gfc_add_modify (&init
, stride
, tmp
);
6602 /* Allow the user to disable array repacking. */
6603 stmt_unpacked
= NULL_TREE
;
6607 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6608 /* A library call to repack the array if necessary. */
6609 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6610 stmt_unpacked
= build_call_expr_loc (input_location
,
6611 gfor_fndecl_in_pack
, 1, tmp
);
6613 stride
= gfc_index_one_node
;
6615 if (warn_array_temporaries
)
6616 gfc_warning (OPT_Warray_temporaries
,
6617 "Creating array temporary at %L", &loc
);
6620 /* This is for the case where the array data is used directly without
6621 calling the repack function. */
6622 if (no_repack
|| partial
!= NULL_TREE
)
6623 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6625 stmt_packed
= NULL_TREE
;
6627 /* Assign the data pointer. */
6628 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6630 /* Don't repack unknown shape arrays when the first stride is 1. */
6631 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6632 partial
, stmt_packed
, stmt_unpacked
);
6635 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6636 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6638 offset
= gfc_index_zero_node
;
6639 size
= gfc_index_one_node
;
6641 /* Evaluate the bounds of the array. */
6642 for (n
= 0; n
< as
->rank
; n
++)
6644 if (checkparm
|| !as
->upper
[n
])
6646 /* Get the bounds of the actual parameter. */
6647 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6648 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6652 dubound
= NULL_TREE
;
6653 dlbound
= NULL_TREE
;
6656 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6657 if (!INTEGER_CST_P (lbound
))
6659 gfc_init_se (&se
, NULL
);
6660 gfc_conv_expr_type (&se
, as
->lower
[n
],
6661 gfc_array_index_type
);
6662 gfc_add_block_to_block (&init
, &se
.pre
);
6663 gfc_add_modify (&init
, lbound
, se
.expr
);
6666 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6667 /* Set the desired upper bound. */
6670 /* We know what we want the upper bound to be. */
6671 if (!INTEGER_CST_P (ubound
))
6673 gfc_init_se (&se
, NULL
);
6674 gfc_conv_expr_type (&se
, as
->upper
[n
],
6675 gfc_array_index_type
);
6676 gfc_add_block_to_block (&init
, &se
.pre
);
6677 gfc_add_modify (&init
, ubound
, se
.expr
);
6680 /* Check the sizes match. */
6683 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6687 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6688 gfc_array_index_type
, ubound
, lbound
);
6689 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6690 gfc_array_index_type
,
6691 gfc_index_one_node
, temp
);
6692 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6693 gfc_array_index_type
, dubound
,
6695 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6696 gfc_array_index_type
,
6697 gfc_index_one_node
, stride2
);
6698 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6699 gfc_array_index_type
, temp
, stride2
);
6700 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6701 "%%ld instead of %%ld", n
+1, sym
->name
);
6703 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6704 fold_convert (long_integer_type_node
, temp
),
6705 fold_convert (long_integer_type_node
, stride2
));
6712 /* For assumed shape arrays move the upper bound by the same amount
6713 as the lower bound. */
6714 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6715 gfc_array_index_type
, dubound
, dlbound
);
6716 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6717 gfc_array_index_type
, tmp
, lbound
);
6718 gfc_add_modify (&init
, ubound
, tmp
);
6720 /* The offset of this dimension. offset = offset - lbound * stride. */
6721 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6723 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6724 gfc_array_index_type
, offset
, tmp
);
6726 /* The size of this dimension, and the stride of the next. */
6727 if (n
+ 1 < as
->rank
)
6729 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6731 if (no_repack
|| partial
!= NULL_TREE
)
6733 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6735 /* Figure out the stride if not a known constant. */
6736 if (!INTEGER_CST_P (stride
))
6739 stmt_packed
= NULL_TREE
;
6742 /* Calculate stride = size * (ubound + 1 - lbound). */
6743 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6744 gfc_array_index_type
,
6745 gfc_index_one_node
, lbound
);
6746 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6747 gfc_array_index_type
, ubound
, tmp
);
6748 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6749 gfc_array_index_type
, size
, tmp
);
6753 /* Assign the stride. */
6754 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6755 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6756 gfc_array_index_type
, partial
,
6757 stmt_unpacked
, stmt_packed
);
6759 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6760 gfc_add_modify (&init
, stride
, tmp
);
6765 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6767 if (stride
&& !INTEGER_CST_P (stride
))
6769 /* Calculate size = stride * (ubound + 1 - lbound). */
6770 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6771 gfc_array_index_type
,
6772 gfc_index_one_node
, lbound
);
6773 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6774 gfc_array_index_type
,
6776 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6777 gfc_array_index_type
,
6778 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6779 gfc_add_modify (&init
, stride
, tmp
);
6784 gfc_trans_array_cobounds (type
, &init
, sym
);
6786 /* Set the offset. */
6787 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6788 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6790 gfc_trans_vla_type_sizes (sym
, &init
);
6792 stmtInit
= gfc_finish_block (&init
);
6794 /* Only do the entry/initialization code if the arg is present. */
6795 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6796 optional_arg
= (sym
->attr
.optional
6797 || (sym
->ns
->proc_name
->attr
.entry_master
6798 && sym
->attr
.dummy
));
6801 tree zero_init
= fold_convert (TREE_TYPE (tmpdesc
), null_pointer_node
);
6802 zero_init
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6803 tmpdesc
, zero_init
);
6804 tmp
= gfc_conv_expr_present (sym
, true);
6805 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
, zero_init
);
6810 stmtCleanup
= NULL_TREE
;
6813 stmtblock_t cleanup
;
6814 gfc_start_block (&cleanup
);
6816 if (sym
->attr
.intent
!= INTENT_IN
)
6818 /* Copy the data back. */
6819 tmp
= build_call_expr_loc (input_location
,
6820 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6821 gfc_add_expr_to_block (&cleanup
, tmp
);
6824 /* Free the temporary. */
6825 tmp
= gfc_call_free (tmpdesc
);
6826 gfc_add_expr_to_block (&cleanup
, tmp
);
6828 stmtCleanup
= gfc_finish_block (&cleanup
);
6830 /* Only do the cleanup if the array was repacked. */
6832 /* For a class array the dummy array descriptor is in the _class
6834 tmp
= gfc_class_data_get (dumdesc
);
6836 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6837 tmp
= gfc_conv_descriptor_data_get (tmp
);
6838 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6840 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6841 build_empty_stmt (input_location
));
6845 tmp
= gfc_conv_expr_present (sym
);
6846 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6847 build_empty_stmt (input_location
));
6851 /* We don't need to free any memory allocated by internal_pack as it will
6852 be freed at the end of the function by pop_context. */
6853 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6855 gfc_restore_backend_locus (&loc
);
6859 /* Calculate the overall offset, including subreferences. */
6861 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6862 bool subref
, gfc_expr
*expr
)
6872 /* If offset is NULL and this is not a subreferenced array, there is
6874 if (offset
== NULL_TREE
)
6877 offset
= gfc_index_zero_node
;
6882 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6884 /* Offset the data pointer for pointer assignments from arrays with
6885 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6888 /* Go past the array reference. */
6889 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6890 if (ref
->type
== REF_ARRAY
&&
6891 ref
->u
.ar
.type
!= AR_ELEMENT
)
6897 /* Calculate the offset for each subsequent subreference. */
6898 for (; ref
; ref
= ref
->next
)
6903 field
= ref
->u
.c
.component
->backend_decl
;
6904 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6905 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6907 tmp
, field
, NULL_TREE
);
6911 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6912 gfc_init_se (&start
, NULL
);
6913 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6914 gfc_add_block_to_block (block
, &start
.pre
);
6915 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6919 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6920 && ref
->u
.ar
.type
== AR_ELEMENT
);
6922 /* TODO - Add bounds checking. */
6923 stride
= gfc_index_one_node
;
6924 index
= gfc_index_zero_node
;
6925 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6930 /* Update the index. */
6931 gfc_init_se (&start
, NULL
);
6932 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6933 itmp
= gfc_evaluate_now (start
.expr
, block
);
6934 gfc_init_se (&start
, NULL
);
6935 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6936 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6937 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6938 gfc_array_index_type
, itmp
, jtmp
);
6939 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6940 gfc_array_index_type
, itmp
, stride
);
6941 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6942 gfc_array_index_type
, itmp
, index
);
6943 index
= gfc_evaluate_now (index
, block
);
6945 /* Update the stride. */
6946 gfc_init_se (&start
, NULL
);
6947 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6948 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6949 gfc_array_index_type
, start
.expr
,
6951 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6952 gfc_array_index_type
,
6953 gfc_index_one_node
, itmp
);
6954 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6955 gfc_array_index_type
, stride
, itmp
);
6956 stride
= gfc_evaluate_now (stride
, block
);
6959 /* Apply the index to obtain the array element. */
6960 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6967 tmp
= fold_build1_loc (input_location
, REALPART_EXPR
,
6968 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
6972 tmp
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
6973 TREE_TYPE (TREE_TYPE (tmp
)), tmp
);
6988 /* Set the target data pointer. */
6989 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6990 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6994 /* gfc_conv_expr_descriptor needs the string length an expression
6995 so that the size of the temporary can be obtained. This is done
6996 by adding up the string lengths of all the elements in the
6997 expression. Function with non-constant expressions have their
6998 string lengths mapped onto the actual arguments using the
6999 interface mapping machinery in trans-expr.c. */
7001 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
7003 gfc_interface_mapping mapping
;
7004 gfc_formal_arglist
*formal
;
7005 gfc_actual_arglist
*arg
;
7009 if (expr
->ts
.u
.cl
->length
7010 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
7012 if (!expr
->ts
.u
.cl
->backend_decl
)
7013 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7017 switch (expr
->expr_type
)
7021 /* This is somewhat brutal. The expression for the first
7022 element of the array is evaluated and assigned to a
7023 new string length for the original expression. */
7024 e
= gfc_constructor_first (expr
->value
.constructor
)->expr
;
7026 gfc_init_se (&tse
, NULL
);
7028 /* Avoid evaluating trailing array references since all we need is
7029 the string length. */
7031 tse
.descriptor_only
= 1;
7032 if (e
->rank
&& e
->expr_type
!= EXPR_VARIABLE
)
7033 gfc_conv_expr_descriptor (&tse
, e
);
7035 gfc_conv_expr (&tse
, e
);
7037 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7038 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7040 if (!expr
->ts
.u
.cl
->backend_decl
|| !VAR_P (expr
->ts
.u
.cl
->backend_decl
))
7042 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
7043 expr
->ts
.u
.cl
->backend_decl
=
7044 gfc_create_var (gfc_charlen_type_node
, "sln");
7047 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7050 /* Make sure that deferred length components point to the hidden
7051 string_length component. */
7052 if (TREE_CODE (tse
.expr
) == COMPONENT_REF
7053 && TREE_CODE (tse
.string_length
) == COMPONENT_REF
7054 && TREE_OPERAND (tse
.expr
, 0) == TREE_OPERAND (tse
.string_length
, 0))
7055 e
->ts
.u
.cl
->backend_decl
= expr
->ts
.u
.cl
->backend_decl
;
7060 get_array_charlen (expr
->value
.op
.op1
, se
);
7062 /* For parentheses the expression ts.u.cl should be identical. */
7063 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
7065 if (expr
->value
.op
.op1
->ts
.u
.cl
!= expr
->ts
.u
.cl
)
7066 expr
->ts
.u
.cl
->backend_decl
7067 = expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
;
7071 expr
->ts
.u
.cl
->backend_decl
=
7072 gfc_create_var (gfc_charlen_type_node
, "sln");
7074 if (expr
->value
.op
.op2
)
7076 get_array_charlen (expr
->value
.op
.op2
, se
);
7078 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
7080 /* Add the string lengths and assign them to the expression
7081 string length backend declaration. */
7082 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7083 fold_build2_loc (input_location
, PLUS_EXPR
,
7084 gfc_charlen_type_node
,
7085 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
7086 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
7089 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
7090 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
7094 if (expr
->value
.function
.esym
== NULL
7095 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7097 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7101 /* Map expressions involving the dummy arguments onto the actual
7102 argument expressions. */
7103 gfc_init_interface_mapping (&mapping
);
7104 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
7105 arg
= expr
->value
.function
.actual
;
7107 /* Set se = NULL in the calls to the interface mapping, to suppress any
7109 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
7114 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
7117 gfc_init_se (&tse
, NULL
);
7119 /* Build the expression for the character length and convert it. */
7120 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
7122 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
7123 gfc_add_block_to_block (&se
->post
, &tse
.post
);
7124 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
7125 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7126 TREE_TYPE (tse
.expr
), tse
.expr
,
7127 build_zero_cst (TREE_TYPE (tse
.expr
)));
7128 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
7129 gfc_free_interface_mapping (&mapping
);
7133 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
7139 /* Helper function to check dimensions. */
7141 transposed_dims (gfc_ss
*ss
)
7145 for (n
= 0; n
< ss
->dimen
; n
++)
7146 if (ss
->dim
[n
] != n
)
7152 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
7153 AR_FULL, suitable for the scalarizer. */
7156 walk_coarray (gfc_expr
*e
)
7160 gcc_assert (gfc_get_corank (e
) > 0);
7162 ss
= gfc_walk_expr (e
);
7164 /* Fix scalar coarray. */
7165 if (ss
== gfc_ss_terminator
)
7172 if (ref
->type
== REF_ARRAY
7173 && ref
->u
.ar
.codimen
> 0)
7179 gcc_assert (ref
!= NULL
);
7180 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7181 ref
->u
.ar
.type
= AR_SECTION
;
7182 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7189 /* Convert an array for passing as an actual argument. Expressions and
7190 vector subscripts are evaluated and stored in a temporary, which is then
7191 passed. For whole arrays the descriptor is passed. For array sections
7192 a modified copy of the descriptor is passed, but using the original data.
7194 This function is also used for array pointer assignments, and there
7197 - se->want_pointer && !se->direct_byref
7198 EXPR is an actual argument. On exit, se->expr contains a
7199 pointer to the array descriptor.
7201 - !se->want_pointer && !se->direct_byref
7202 EXPR is an actual argument to an intrinsic function or the
7203 left-hand side of a pointer assignment. On exit, se->expr
7204 contains the descriptor for EXPR.
7206 - !se->want_pointer && se->direct_byref
7207 EXPR is the right-hand side of a pointer assignment and
7208 se->expr is the descriptor for the previously-evaluated
7209 left-hand side. The function creates an assignment from
7213 The se->force_tmp flag disables the non-copying descriptor optimization
7214 that is used for transpose. It may be used in cases where there is an
7215 alias between the transpose argument and another argument in the same
7219 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7222 gfc_ss_type ss_type
;
7223 gfc_ss_info
*ss_info
;
7225 gfc_array_info
*info
;
7233 bool subref_array_target
= false;
7234 bool deferred_array_component
= false;
7235 gfc_expr
*arg
, *ss_expr
;
7237 if (se
->want_coarray
)
7238 ss
= walk_coarray (expr
);
7240 ss
= gfc_walk_expr (expr
);
7242 gcc_assert (ss
!= NULL
);
7243 gcc_assert (ss
!= gfc_ss_terminator
);
7246 ss_type
= ss_info
->type
;
7247 ss_expr
= ss_info
->expr
;
7249 /* Special case: TRANSPOSE which needs no temporary. */
7250 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7251 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7253 /* This is a call to transpose which has already been handled by the
7254 scalarizer, so that we just need to get its argument's descriptor. */
7255 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7256 expr
= expr
->value
.function
.actual
->expr
;
7259 /* Special case things we know we can pass easily. */
7260 switch (expr
->expr_type
)
7263 /* If we have a linear array section, we can pass it directly.
7264 Otherwise we need to copy it into a temporary. */
7266 gcc_assert (ss_type
== GFC_SS_SECTION
);
7267 gcc_assert (ss_expr
== expr
);
7268 info
= &ss_info
->data
.array
;
7270 /* Get the descriptor for the array. */
7271 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7272 desc
= info
->descriptor
;
7274 /* The charlen backend decl for deferred character components cannot
7275 be used because it is fixed at zero. Instead, the hidden string
7276 length component is used. */
7277 if (expr
->ts
.type
== BT_CHARACTER
7278 && expr
->ts
.deferred
7279 && TREE_CODE (desc
) == COMPONENT_REF
)
7280 deferred_array_component
= true;
7282 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7283 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7284 && !subref_array_target
;
7288 else if (se
->force_no_tmp
)
7293 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7295 /* Create a new descriptor if the array doesn't have one. */
7298 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7300 else if (se
->direct_byref
)
7302 else if (info
->ref
->u
.ar
.dimen
== 0 && !info
->ref
->next
)
7304 else if (info
->ref
->u
.ar
.type
== AR_SECTION
&& se
->want_pointer
)
7307 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7309 if (full
&& !transposed_dims (ss
))
7311 if (se
->direct_byref
&& !se
->byref_noassign
)
7313 /* Copy the descriptor for pointer assignments. */
7314 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7316 /* Add any offsets from subreferences. */
7317 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7318 subref_array_target
, expr
);
7320 /* ....and set the span field. */
7321 tmp
= gfc_get_array_span (desc
, expr
);
7322 if (tmp
!= NULL_TREE
&& !integer_zerop (tmp
))
7323 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7325 else if (se
->want_pointer
)
7327 /* We pass full arrays directly. This means that pointers and
7328 allocatable arrays should also work. */
7329 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7336 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7337 se
->string_length
= gfc_get_expr_charlen (expr
);
7338 /* The ss_info string length is returned set to the value of the
7339 hidden string length component. */
7340 else if (deferred_array_component
)
7341 se
->string_length
= ss_info
->string_length
;
7343 gfc_free_ss_chain (ss
);
7349 /* A transformational function return value will be a temporary
7350 array descriptor. We still need to go through the scalarizer
7351 to create the descriptor. Elemental functions are handled as
7352 arbitrary expressions, i.e. copy to a temporary. */
7354 if (se
->direct_byref
)
7356 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7358 /* For pointer assignments pass the descriptor directly. */
7362 gcc_assert (se
->ss
== ss
);
7364 if (!is_pointer_array (se
->expr
))
7366 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7367 tmp
= fold_convert (gfc_array_index_type
,
7368 size_in_bytes (tmp
));
7369 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7372 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7373 gfc_conv_expr (se
, expr
);
7375 gfc_free_ss_chain (ss
);
7379 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7381 if (ss_expr
!= expr
)
7382 /* Elemental function. */
7383 gcc_assert ((expr
->value
.function
.esym
!= NULL
7384 && expr
->value
.function
.esym
->attr
.elemental
)
7385 || (expr
->value
.function
.isym
!= NULL
7386 && expr
->value
.function
.isym
->elemental
)
7387 || gfc_inline_intrinsic_function_p (expr
));
7389 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7392 if (expr
->ts
.type
== BT_CHARACTER
7393 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7394 get_array_charlen (expr
, se
);
7400 /* Transformational function. */
7401 info
= &ss_info
->data
.array
;
7407 /* Constant array constructors don't need a temporary. */
7408 if (ss_type
== GFC_SS_CONSTRUCTOR
7409 && expr
->ts
.type
!= BT_CHARACTER
7410 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7413 info
= &ss_info
->data
.array
;
7423 /* Something complicated. Copy it into a temporary. */
7429 /* If we are creating a temporary, we don't need to bother about aliases
7434 gfc_init_loopinfo (&loop
);
7436 /* Associate the SS with the loop. */
7437 gfc_add_ss_to_loop (&loop
, ss
);
7439 /* Tell the scalarizer not to bother creating loop variables, etc. */
7441 loop
.array_parameter
= 1;
7443 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7444 gcc_assert (!se
->direct_byref
);
7446 /* Do we need bounds checking or not? */
7447 ss
->no_bounds_check
= expr
->no_bounds_check
;
7449 /* Setup the scalarizing loops and bounds. */
7450 gfc_conv_ss_startstride (&loop
);
7454 if (expr
->ts
.type
== BT_CHARACTER
7455 && (!expr
->ts
.u
.cl
->backend_decl
|| expr
->expr_type
== EXPR_ARRAY
))
7456 get_array_charlen (expr
, se
);
7458 /* Tell the scalarizer to make a temporary. */
7459 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7460 ((expr
->ts
.type
== BT_CHARACTER
)
7461 ? expr
->ts
.u
.cl
->backend_decl
7465 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7466 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7467 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7470 gfc_conv_loop_setup (&loop
, & expr
->where
);
7474 /* Copy into a temporary and pass that. We don't need to copy the data
7475 back because expressions and vector subscripts must be INTENT_IN. */
7476 /* TODO: Optimize passing function return values. */
7481 /* Start the copying loops. */
7482 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7483 gfc_mark_ss_chain_used (ss
, 1);
7484 gfc_start_scalarized_body (&loop
, &block
);
7486 /* Copy each data element. */
7487 gfc_init_se (&lse
, NULL
);
7488 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7489 gfc_init_se (&rse
, NULL
);
7490 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7492 lse
.ss
= loop
.temp_ss
;
7495 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7496 if (expr
->ts
.type
== BT_CHARACTER
)
7498 gfc_conv_expr (&rse
, expr
);
7499 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7500 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7504 gfc_conv_expr_val (&rse
, expr
);
7506 gfc_add_block_to_block (&block
, &rse
.pre
);
7507 gfc_add_block_to_block (&block
, &lse
.pre
);
7509 lse
.string_length
= rse
.string_length
;
7511 deep_copy
= !se
->data_not_needed
7512 && (expr
->expr_type
== EXPR_VARIABLE
7513 || expr
->expr_type
== EXPR_ARRAY
);
7514 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7516 gfc_add_expr_to_block (&block
, tmp
);
7518 /* Finish the copying loops. */
7519 gfc_trans_scalarizing_loops (&loop
, &block
);
7521 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7523 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7525 desc
= info
->descriptor
;
7526 se
->string_length
= ss_info
->string_length
;
7530 /* We pass sections without copying to a temporary. Make a new
7531 descriptor and point it at the section we want. The loop variable
7532 limits will be the limits of the section.
7533 A function may decide to repack the array to speed up access, but
7534 we're not bothered about that here. */
7535 int dim
, ndim
, codim
;
7544 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7546 if (se
->want_coarray
)
7548 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7550 codim
= gfc_get_corank (expr
);
7551 for (n
= 0; n
< codim
- 1; n
++)
7553 /* Make sure we are not lost somehow. */
7554 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7556 /* Make sure the call to gfc_conv_section_startstride won't
7557 generate unnecessary code to calculate stride. */
7558 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7560 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7561 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7562 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7565 gcc_assert (n
== codim
- 1);
7566 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7567 info
->descriptor
, n
+ ndim
, true,
7568 ar
->as
->type
== AS_DEFERRED
);
7569 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7574 /* Set the string_length for a character array. */
7575 if (expr
->ts
.type
== BT_CHARACTER
)
7577 se
->string_length
= gfc_get_expr_charlen (expr
);
7578 if (VAR_P (se
->string_length
)
7579 && expr
->ts
.u
.cl
->backend_decl
== se
->string_length
)
7580 tmp
= ss_info
->string_length
;
7582 tmp
= se
->string_length
;
7584 if (expr
->ts
.deferred
)
7585 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
, tmp
);
7588 /* If we have an array section, are assigning or passing an array
7589 section argument make sure that the lower bound is 1. References
7590 to the full array should otherwise keep the original bounds. */
7591 if (!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
)
7592 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7593 if (!integer_onep (loop
.from
[dim
]))
7595 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7596 gfc_array_index_type
, gfc_index_one_node
,
7598 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7599 gfc_array_index_type
,
7601 loop
.from
[dim
] = gfc_index_one_node
;
7604 desc
= info
->descriptor
;
7605 if (se
->direct_byref
&& !se
->byref_noassign
)
7607 /* For pointer assignments we fill in the destination. */
7609 parmtype
= TREE_TYPE (parm
);
7613 /* Otherwise make a new one. */
7614 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7615 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7617 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7619 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7620 loop
.from
, loop
.to
, 0,
7621 GFC_ARRAY_UNKNOWN
, false);
7622 parm
= gfc_create_var (parmtype
, "parm");
7624 /* When expression is a class object, then add the class' handle to
7626 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7628 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7631 /* class_expr can be NULL, when no _class ref is in expr.
7632 We must not fix this here with a gfc_fix_class_ref (). */
7635 gfc_init_se (&classse
, NULL
);
7636 gfc_conv_expr (&classse
, class_expr
);
7637 gfc_free_expr (class_expr
);
7639 gcc_assert (classse
.pre
.head
== NULL_TREE
7640 && classse
.post
.head
== NULL_TREE
);
7641 gfc_allocate_lang_decl (parm
);
7642 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7647 /* Set the span field. */
7648 if (expr
->ts
.type
== BT_CHARACTER
&& ss_info
->string_length
)
7649 tmp
= ss_info
->string_length
;
7651 tmp
= gfc_get_array_span (desc
, expr
);
7652 if (tmp
!= NULL_TREE
)
7653 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7655 /* The following can be somewhat confusing. We have two
7656 descriptors, a new one and the original array.
7657 {parm, parmtype, dim} refer to the new one.
7658 {desc, type, n, loop} refer to the original, which maybe
7659 a descriptorless array.
7660 The bounds of the scalarization are the bounds of the section.
7661 We don't have to worry about numeric overflows when calculating
7662 the offsets because all elements are within the array data. */
7664 /* Set the dtype. */
7665 tmp
= gfc_conv_descriptor_dtype (parm
);
7666 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7668 /* The 1st element in the section. */
7669 base
= gfc_index_zero_node
;
7671 /* The offset from the 1st element in the section. */
7672 offset
= gfc_index_zero_node
;
7674 for (n
= 0; n
< ndim
; n
++)
7676 stride
= gfc_conv_array_stride (desc
, n
);
7678 /* Work out the 1st element in the section. */
7680 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7682 gcc_assert (info
->subscript
[n
]
7683 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7684 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7688 /* Evaluate and remember the start of the section. */
7689 start
= info
->start
[n
];
7690 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7693 tmp
= gfc_conv_array_lbound (desc
, n
);
7694 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7696 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7698 base
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7702 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7704 /* For elemental dimensions, we only need the 1st
7705 element in the section. */
7709 /* Vector subscripts need copying and are handled elsewhere. */
7711 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7713 /* look for the corresponding scalarizer dimension: dim. */
7714 for (dim
= 0; dim
< ndim
; dim
++)
7715 if (ss
->dim
[dim
] == n
)
7718 /* loop exited early: the DIM being looked for has been found. */
7719 gcc_assert (dim
< ndim
);
7721 /* Set the new lower bound. */
7722 from
= loop
.from
[dim
];
7725 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7726 gfc_rank_cst
[dim
], from
);
7728 /* Set the new upper bound. */
7729 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7730 gfc_rank_cst
[dim
], to
);
7732 /* Multiply the stride by the section stride to get the
7734 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7735 gfc_array_index_type
,
7736 stride
, info
->stride
[n
]);
7738 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7739 TREE_TYPE (offset
), stride
, from
);
7740 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7741 TREE_TYPE (offset
), offset
, tmp
);
7743 /* Store the new stride. */
7744 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7745 gfc_rank_cst
[dim
], stride
);
7748 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7750 from
= loop
.from
[n
];
7752 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7753 gfc_rank_cst
[n
], from
);
7754 if (n
< loop
.dimen
+ codim
- 1)
7755 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7756 gfc_rank_cst
[n
], to
);
7759 if (se
->data_not_needed
)
7760 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7761 gfc_index_zero_node
);
7763 /* Point the data pointer at the 1st element in the section. */
7764 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, base
,
7765 subref_array_target
, expr
);
7767 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, offset
);
7772 /* For class arrays add the class tree into the saved descriptor to
7773 enable getting of _vptr and the like. */
7774 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7775 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7777 gfc_allocate_lang_decl (desc
);
7778 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7779 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7780 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7781 : expr
->symtree
->n
.sym
->backend_decl
;
7783 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7784 && IS_CLASS_ARRAY (expr
))
7787 gfc_allocate_lang_decl (desc
);
7788 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7789 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7790 vtype
= gfc_class_vptr_get (tmp
);
7791 gfc_add_modify (&se
->pre
, vtype
,
7792 gfc_build_addr_expr (TREE_TYPE (vtype
),
7793 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7795 if (!se
->direct_byref
|| se
->byref_noassign
)
7797 /* Get a pointer to the new descriptor. */
7798 if (se
->want_pointer
)
7799 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7804 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7805 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7807 /* Cleanup the scalarizer. */
7808 gfc_cleanup_loop (&loop
);
7811 /* Helper function for gfc_conv_array_parameter if array size needs to be
7815 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7818 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7819 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7820 else if (expr
->rank
> 1)
7821 *size
= build_call_expr_loc (input_location
,
7822 gfor_fndecl_size0
, 1,
7823 gfc_build_addr_expr (NULL
, desc
));
7826 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7827 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7829 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7830 gfc_array_index_type
, ubound
, lbound
);
7831 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7832 *size
, gfc_index_one_node
);
7833 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7834 *size
, gfc_index_zero_node
);
7836 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7837 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7838 *size
, fold_convert (gfc_array_index_type
, elem
));
7841 /* Helper function - return true if the argument is a pointer. */
7844 is_pointer (gfc_expr
*e
)
7848 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->symtree
== NULL
)
7851 sym
= e
->symtree
->n
.sym
;
7855 return sym
->attr
.pointer
|| sym
->attr
.proc_pointer
;
7858 /* Convert an array for passing as an actual parameter. */
7861 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7862 const gfc_symbol
*fsym
, const char *proc_name
,
7867 tree tmp
= NULL_TREE
;
7869 tree parent
= DECL_CONTEXT (current_function_decl
);
7870 bool full_array_var
;
7871 bool this_array_result
;
7874 bool array_constructor
;
7875 bool good_allocatable
;
7876 bool ultimate_ptr_comp
;
7877 bool ultimate_alloc_comp
;
7882 ultimate_ptr_comp
= false;
7883 ultimate_alloc_comp
= false;
7885 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7887 if (ref
->next
== NULL
)
7890 if (ref
->type
== REF_COMPONENT
)
7892 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7893 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7897 full_array_var
= false;
7900 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7901 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7903 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7905 /* The symbol should have an array specification. */
7906 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7908 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7910 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7911 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7912 se
->string_length
= tmp
;
7915 /* Is this the result of the enclosing procedure? */
7916 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7917 if (this_array_result
7918 && (sym
->backend_decl
!= current_function_decl
)
7919 && (sym
->backend_decl
!= parent
))
7920 this_array_result
= false;
7922 /* Passing address of the array if it is not pointer or assumed-shape. */
7923 if (full_array_var
&& g77
&& !this_array_result
7924 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7926 tmp
= gfc_get_symbol_decl (sym
);
7928 if (sym
->ts
.type
== BT_CHARACTER
)
7929 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7931 if (!sym
->attr
.pointer
7933 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7934 && sym
->as
->type
!= AS_DEFERRED
7935 && sym
->as
->type
!= AS_ASSUMED_RANK
7936 && !sym
->attr
.allocatable
)
7938 /* Some variables are declared directly, others are declared as
7939 pointers and allocated on the heap. */
7940 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7943 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7945 array_parameter_size (tmp
, expr
, size
);
7949 if (sym
->attr
.allocatable
)
7951 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7953 gfc_conv_expr_descriptor (se
, expr
);
7957 array_parameter_size (tmp
, expr
, size
);
7958 se
->expr
= gfc_conv_array_data (tmp
);
7963 /* A convenient reduction in scope. */
7964 contiguous
= g77
&& !this_array_result
&& contiguous
;
7966 /* There is no need to pack and unpack the array, if it is contiguous
7967 and not a deferred- or assumed-shape array, or if it is simply
7969 no_pack
= ((sym
&& sym
->as
7970 && !sym
->attr
.pointer
7971 && sym
->as
->type
!= AS_DEFERRED
7972 && sym
->as
->type
!= AS_ASSUMED_RANK
7973 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7975 (ref
&& ref
->u
.ar
.as
7976 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7977 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7978 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7980 gfc_is_simply_contiguous (expr
, false, true));
7982 no_pack
= contiguous
&& no_pack
;
7984 /* If we have an EXPR_OP or a function returning an explicit-shaped
7985 or allocatable array, an array temporary will be generated which
7986 does not need to be packed / unpacked if passed to an
7987 explicit-shape dummy array. */
7991 if (expr
->expr_type
== EXPR_OP
)
7993 else if (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.esym
)
7995 gfc_symbol
*result
= expr
->value
.function
.esym
->result
;
7996 if (result
->attr
.dimension
7997 && (result
->as
->type
== AS_EXPLICIT
7998 || result
->attr
.allocatable
7999 || result
->attr
.contiguous
))
8004 /* Array constructors are always contiguous and do not need packing. */
8005 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
8007 /* Same is true of contiguous sections from allocatable variables. */
8008 good_allocatable
= contiguous
8010 && expr
->symtree
->n
.sym
->attr
.allocatable
;
8012 /* Or ultimate allocatable components. */
8013 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
8015 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
8017 gfc_conv_expr_descriptor (se
, expr
);
8018 /* Deallocate the allocatable components of structures that are
8020 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8021 && expr
->ts
.u
.derived
->attr
.alloc_comp
8022 && expr
->expr_type
!= EXPR_VARIABLE
)
8024 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
8026 /* The components shall be deallocated before their containing entity. */
8027 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8029 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->expr_type
!= EXPR_FUNCTION
)
8030 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
8032 array_parameter_size (se
->expr
, expr
, size
);
8033 se
->expr
= gfc_conv_array_data (se
->expr
);
8037 if (this_array_result
)
8039 /* Result of the enclosing function. */
8040 gfc_conv_expr_descriptor (se
, expr
);
8042 array_parameter_size (se
->expr
, expr
, size
);
8043 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8045 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
8046 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
8047 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
8054 /* Every other type of array. */
8055 se
->want_pointer
= 1;
8056 gfc_conv_expr_descriptor (se
, expr
);
8059 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
8064 /* Deallocate the allocatable components of structures that are
8065 not variable, for descriptorless arguments.
8066 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
8067 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
8068 && expr
->ts
.u
.derived
->attr
.alloc_comp
8069 && expr
->expr_type
!= EXPR_VARIABLE
)
8071 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8072 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
8074 /* The components shall be deallocated before their containing entity. */
8075 gfc_prepend_expr_to_block (&se
->post
, tmp
);
8078 if (g77
|| (fsym
&& fsym
->attr
.contiguous
8079 && !gfc_is_simply_contiguous (expr
, false, true)))
8081 tree origptr
= NULL_TREE
;
8085 /* For contiguous arrays, save the original value of the descriptor. */
8088 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
8089 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8090 tmp
= gfc_conv_array_data (tmp
);
8091 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8092 TREE_TYPE (origptr
), origptr
,
8093 fold_convert (TREE_TYPE (origptr
), tmp
));
8094 gfc_add_expr_to_block (&se
->pre
, tmp
);
8097 /* Repack the array. */
8098 if (warn_array_temporaries
)
8101 gfc_warning (OPT_Warray_temporaries
,
8102 "Creating array temporary at %L for argument %qs",
8103 &expr
->where
, fsym
->name
);
8105 gfc_warning (OPT_Warray_temporaries
,
8106 "Creating array temporary at %L", &expr
->where
);
8109 /* When optmizing, we can use gfc_conv_subref_array_arg for
8110 making the packing and unpacking operation visible to the
8113 if (g77
&& flag_inline_arg_packing
&& expr
->expr_type
== EXPR_VARIABLE
8114 && !is_pointer (expr
) && ! gfc_has_dimen_vector_ref (expr
)
8115 && !(expr
->symtree
->n
.sym
->as
8116 && expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_RANK
)
8117 && (fsym
== NULL
|| fsym
->ts
.type
!= BT_ASSUMED
))
8119 gfc_conv_subref_array_arg (se
, expr
, g77
,
8120 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
8121 false, fsym
, proc_name
, sym
, true);
8125 ptr
= build_call_expr_loc (input_location
,
8126 gfor_fndecl_in_pack
, 1, desc
);
8128 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8130 tmp
= gfc_conv_expr_present (sym
);
8131 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
8132 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
8133 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
8136 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
8138 /* Use the packed data for the actual argument, except for contiguous arrays,
8139 where the descriptor's data component is set. */
8144 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8146 gfc_ss
* ss
= gfc_walk_expr (expr
);
8147 if (!transposed_dims (ss
))
8148 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
8151 tree old_field
, new_field
;
8153 /* The original descriptor has transposed dims so we can't reuse
8154 it directly; we have to create a new one. */
8155 tree old_desc
= tmp
;
8156 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8158 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8159 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8160 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8162 old_field
= gfc_conv_descriptor_offset (old_desc
);
8163 new_field
= gfc_conv_descriptor_offset (new_desc
);
8164 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8166 for (int i
= 0; i
< expr
->rank
; i
++)
8168 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8169 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8170 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8172 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8175 if (flag_coarray
== GFC_FCOARRAY_LIB
8176 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8177 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8178 == GFC_ARRAY_ALLOCATABLE
)
8180 old_field
= gfc_conv_descriptor_token (old_desc
);
8181 new_field
= gfc_conv_descriptor_token (new_desc
);
8182 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8185 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8186 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8191 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8195 if (fsym
&& proc_name
)
8196 msg
= xasprintf ("An array temporary was created for argument "
8197 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8199 msg
= xasprintf ("An array temporary was created");
8201 tmp
= build_fold_indirect_ref_loc (input_location
,
8203 tmp
= gfc_conv_array_data (tmp
);
8204 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8205 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8207 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8208 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8210 gfc_conv_expr_present (sym
), tmp
);
8212 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8217 gfc_start_block (&block
);
8219 /* Copy the data back. */
8220 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8222 tmp
= build_call_expr_loc (input_location
,
8223 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8224 gfc_add_expr_to_block (&block
, tmp
);
8227 /* Free the temporary. */
8228 tmp
= gfc_call_free (ptr
);
8229 gfc_add_expr_to_block (&block
, tmp
);
8231 stmt
= gfc_finish_block (&block
);
8233 gfc_init_block (&block
);
8234 /* Only if it was repacked. This code needs to be executed before the
8235 loop cleanup code. */
8236 tmp
= build_fold_indirect_ref_loc (input_location
,
8238 tmp
= gfc_conv_array_data (tmp
);
8239 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8240 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8242 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8243 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8245 gfc_conv_expr_present (sym
), tmp
);
8247 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8249 gfc_add_expr_to_block (&block
, tmp
);
8250 gfc_add_block_to_block (&block
, &se
->post
);
8252 gfc_init_block (&se
->post
);
8254 /* Reset the descriptor pointer. */
8257 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8258 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8261 gfc_add_block_to_block (&se
->post
, &block
);
8266 /* This helper function calculates the size in words of a full array. */
8269 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8274 idx
= gfc_rank_cst
[rank
- 1];
8275 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8276 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8277 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8279 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8280 tmp
, gfc_index_one_node
);
8281 tmp
= gfc_evaluate_now (tmp
, block
);
8283 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8284 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8286 return gfc_evaluate_now (tmp
, block
);
8290 /* Allocate dest to the same size as src, and copy src -> dest.
8291 If no_malloc is set, only the copy is done. */
8294 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8295 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8296 tree add_when_allocated
)
8305 /* If the source is null, set the destination to null. Then,
8306 allocate memory to the destination. */
8307 gfc_init_block (&block
);
8309 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8311 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8312 null_data
= gfc_finish_block (&block
);
8314 gfc_init_block (&block
);
8315 if (str_sz
!= NULL_TREE
)
8318 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8322 tmp
= gfc_call_malloc (&block
, type
, size
);
8323 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8328 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8329 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8330 fold_convert (size_type_node
, size
));
8331 gfc_add_expr_to_block (&block
, tmp
);
8336 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8337 null_data
= gfc_finish_block (&block
);
8339 gfc_init_block (&block
);
8341 nelems
= gfc_full_array_size (&block
, src
, rank
);
8343 nelems
= gfc_index_one_node
;
8345 if (str_sz
!= NULL_TREE
)
8346 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8348 tmp
= fold_convert (gfc_array_index_type
,
8349 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8350 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8354 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8355 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8356 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8359 /* We know the temporary and the value will be the same length,
8360 so can use memcpy. */
8363 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8364 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8365 gfc_conv_descriptor_data_get (dest
),
8366 gfc_conv_descriptor_data_get (src
),
8367 fold_convert (size_type_node
, size
));
8368 gfc_add_expr_to_block (&block
, tmp
);
8372 gfc_add_expr_to_block (&block
, add_when_allocated
);
8373 tmp
= gfc_finish_block (&block
);
8375 /* Null the destination if the source is null; otherwise do
8376 the allocate and copy. */
8377 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8380 null_cond
= gfc_conv_descriptor_data_get (src
);
8382 null_cond
= convert (pvoid_type_node
, null_cond
);
8383 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8384 null_cond
, null_pointer_node
);
8385 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8389 /* Allocate dest to the same size as src, and copy data src -> dest. */
8392 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8393 tree add_when_allocated
)
8395 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8396 NULL_TREE
, add_when_allocated
);
8400 /* Copy data src -> dest. */
8403 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8405 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8406 NULL_TREE
, NULL_TREE
);
8409 /* Allocate dest to the same size as src, but don't copy anything. */
8412 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8414 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8415 NULL_TREE
, NULL_TREE
);
8420 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8421 tree type
, int rank
)
8428 stmtblock_t block
, globalblock
;
8430 /* If the source is null, set the destination to null. Then,
8431 allocate memory to the destination. */
8432 gfc_init_block (&block
);
8433 gfc_init_block (&globalblock
);
8435 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8438 symbol_attribute attr
;
8441 gfc_init_se (&se
, NULL
);
8442 gfc_clear_attr (&attr
);
8443 attr
.allocatable
= 1;
8444 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8445 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8446 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8448 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8449 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8450 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8451 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8452 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8453 null_data
= gfc_finish_block (&block
);
8455 gfc_init_block (&block
);
8457 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8458 fold_convert (size_type_node
, size
),
8459 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8460 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8461 GFC_CAF_COARRAY_ALLOC
);
8463 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8464 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8465 fold_convert (size_type_node
, size
));
8466 gfc_add_expr_to_block (&block
, tmp
);
8470 /* Set the rank or unitialized memory access may be reported. */
8471 tmp
= gfc_conv_descriptor_rank (dest
);
8472 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8475 nelems
= gfc_full_array_size (&block
, src
, rank
);
8477 nelems
= integer_one_node
;
8479 tmp
= fold_convert (size_type_node
,
8480 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8481 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8482 fold_convert (size_type_node
, nelems
), tmp
);
8484 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8485 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8487 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8488 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8489 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8490 null_data
= gfc_finish_block (&block
);
8492 gfc_init_block (&block
);
8493 gfc_allocate_using_caf_lib (&block
, dest
,
8494 fold_convert (size_type_node
, size
),
8495 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8496 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8497 GFC_CAF_COARRAY_ALLOC
);
8499 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8500 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8501 gfc_conv_descriptor_data_get (dest
),
8502 gfc_conv_descriptor_data_get (src
),
8503 fold_convert (size_type_node
, size
));
8504 gfc_add_expr_to_block (&block
, tmp
);
8507 tmp
= gfc_finish_block (&block
);
8509 /* Null the destination if the source is null; otherwise do
8510 the register and copy. */
8511 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8514 null_cond
= gfc_conv_descriptor_data_get (src
);
8516 null_cond
= convert (pvoid_type_node
, null_cond
);
8517 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8518 null_cond
, null_pointer_node
);
8519 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8521 return gfc_finish_block (&globalblock
);
8525 /* Helper function to abstract whether coarray processing is enabled. */
8528 caf_enabled (int caf_mode
)
8530 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8531 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8535 /* Helper function to abstract whether coarray processing is enabled
8536 and we are in a derived type coarray. */
8539 caf_in_coarray (int caf_mode
)
8541 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8542 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8543 return (caf_mode
& pat
) == pat
;
8547 /* Helper function to abstract whether coarray is to deallocate only. */
8550 gfc_caf_is_dealloc_only (int caf_mode
)
8552 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8553 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8557 /* Recursively traverse an object of derived type, generating code to
8558 deallocate, nullify or copy allocatable components. This is the work horse
8559 function for the functions named in this enum. */
8561 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8562 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8563 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
,
8566 static gfc_actual_arglist
*pdt_param_list
;
8569 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8570 tree dest
, int rank
, int purpose
, int caf_mode
,
8571 gfc_co_subroutines_args
*args
)
8575 stmtblock_t fnblock
;
8576 stmtblock_t loopbody
;
8577 stmtblock_t tmpblock
;
8588 tree null_cond
= NULL_TREE
;
8589 tree add_when_allocated
;
8590 tree dealloc_fndecl
;
8594 symbol_attribute
*attr
;
8595 bool deallocate_called
;
8597 gfc_init_block (&fnblock
);
8599 decl_type
= TREE_TYPE (decl
);
8601 if ((POINTER_TYPE_P (decl_type
))
8602 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8604 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8605 /* Deref dest in sync with decl, but only when it is not NULL. */
8607 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8609 /* Update the decl_type because it got dereferenced. */
8610 decl_type
= TREE_TYPE (decl
);
8613 /* If this is an array of derived types with allocatable components
8614 build a loop and recursively call this function. */
8615 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8616 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8618 tmp
= gfc_conv_array_data (decl
);
8619 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8621 /* Get the number of elements - 1 and set the counter. */
8622 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8624 /* Use the descriptor for an allocatable array. Since this
8625 is a full array reference, we only need the descriptor
8626 information from dimension = rank. */
8627 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8628 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8629 gfc_array_index_type
, tmp
,
8630 gfc_index_one_node
);
8632 null_cond
= gfc_conv_descriptor_data_get (decl
);
8633 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8634 logical_type_node
, null_cond
,
8635 build_int_cst (TREE_TYPE (null_cond
), 0));
8639 /* Otherwise use the TYPE_DOMAIN information. */
8640 tmp
= array_type_nelts (decl_type
);
8641 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8644 /* Remember that this is, in fact, the no. of elements - 1. */
8645 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8646 index
= gfc_create_var (gfc_array_index_type
, "S");
8648 /* Build the body of the loop. */
8649 gfc_init_block (&loopbody
);
8651 vref
= gfc_build_array_ref (var
, index
, NULL
);
8653 if (purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8655 tmp
= build_fold_indirect_ref_loc (input_location
,
8656 gfc_conv_array_data (dest
));
8657 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8658 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8659 COPY_ALLOC_COMP
, caf_mode
, args
);
8662 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8665 gfc_add_expr_to_block (&loopbody
, tmp
);
8667 /* Build the loop and return. */
8668 gfc_init_loopinfo (&loop
);
8670 loop
.from
[0] = gfc_index_zero_node
;
8671 loop
.loopvar
[0] = index
;
8672 loop
.to
[0] = nelems
;
8673 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8674 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8676 tmp
= gfc_finish_block (&fnblock
);
8677 /* When copying allocateable components, the above implements the
8678 deep copy. Nevertheless is a deep copy only allowed, when the current
8679 component is allocated, for which code will be generated in
8680 gfc_duplicate_allocatable (), where the deep copy code is just added
8681 into the if's body, by adding tmp (the deep copy code) as last
8682 argument to gfc_duplicate_allocatable (). */
8683 if (purpose
== COPY_ALLOC_COMP
8684 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8685 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8687 else if (null_cond
!= NULL_TREE
)
8688 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8689 build_empty_stmt (input_location
));
8694 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8696 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8697 DEALLOCATE_PDT_COMP
, 0, args
);
8698 gfc_add_expr_to_block (&fnblock
, tmp
);
8700 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8702 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8703 NULLIFY_ALLOC_COMP
, 0, args
);
8704 gfc_add_expr_to_block (&fnblock
, tmp
);
8707 /* Otherwise, act on the components or recursively call self to
8708 act on a chain of components. */
8709 for (c
= der_type
->components
; c
; c
= c
->next
)
8711 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8712 || c
->ts
.type
== BT_CLASS
)
8713 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8714 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8715 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8717 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8718 && c
->ts
.u
.derived
->attr
.pdt_type
;
8720 cdecl = c
->backend_decl
;
8721 ctype
= TREE_TYPE (cdecl);
8726 case BCAST_ALLOC_COMP
:
8730 stmtblock_t derived_type_block
;
8732 gfc_init_block (&tmpblock
);
8734 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8735 decl
, cdecl, NULL_TREE
);
8737 /* Shortcut to get the attributes of the component. */
8738 if (c
->ts
.type
== BT_CLASS
)
8740 attr
= &CLASS_DATA (c
)->attr
;
8741 if (attr
->class_pointer
)
8751 add_when_allocated
= NULL_TREE
;
8752 if (cmp_has_alloc_comps
8753 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
8755 if (c
->ts
.type
== BT_CLASS
)
8757 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8759 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8760 comp
, NULL_TREE
, rank
, purpose
,
8765 rank
= c
->as
? c
->as
->rank
: 0;
8766 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8773 gfc_init_block (&derived_type_block
);
8774 if (add_when_allocated
)
8775 gfc_add_expr_to_block (&derived_type_block
, add_when_allocated
);
8776 tmp
= gfc_finish_block (&derived_type_block
);
8777 gfc_add_expr_to_block (&tmpblock
, tmp
);
8779 /* Convert the component into a rank 1 descriptor type. */
8780 if (attr
->dimension
)
8782 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8783 ubound
= gfc_full_array_size (&tmpblock
, comp
,
8784 c
->ts
.type
== BT_CLASS
8785 ? CLASS_DATA (c
)->as
->rank
8790 tmp
= TREE_TYPE (comp
);
8791 ubound
= build_int_cst (gfc_array_index_type
, 1);
8794 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8796 GFC_ARRAY_ALLOCATABLE
, false);
8798 cdesc
= gfc_create_var (cdesc
, "cdesc");
8799 DECL_ARTIFICIAL (cdesc
) = 1;
8801 gfc_add_modify (&tmpblock
, gfc_conv_descriptor_dtype (cdesc
),
8802 gfc_get_dtype_rank_type (1, tmp
));
8803 gfc_conv_descriptor_lbound_set (&tmpblock
, cdesc
,
8804 gfc_index_zero_node
,
8805 gfc_index_one_node
);
8806 gfc_conv_descriptor_stride_set (&tmpblock
, cdesc
,
8807 gfc_index_zero_node
,
8808 gfc_index_one_node
);
8809 gfc_conv_descriptor_ubound_set (&tmpblock
, cdesc
,
8810 gfc_index_zero_node
, ubound
);
8812 if (attr
->dimension
)
8813 comp
= gfc_conv_descriptor_data_get (comp
);
8818 gfc_init_se (&se
, NULL
);
8820 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8821 c
->ts
.type
== BT_CLASS
8822 ? CLASS_DATA (c
)->attr
8824 comp
= gfc_build_addr_expr (NULL_TREE
, comp
);
8825 gfc_add_block_to_block (&tmpblock
, &se
.pre
);
8828 gfc_conv_descriptor_data_set (&tmpblock
, cdesc
, comp
);
8832 fndecl
= build_call_expr_loc (input_location
,
8833 gfor_fndecl_co_broadcast
, 5,
8834 gfc_build_addr_expr (pvoid_type_node
,cdesc
),
8836 null_pointer_node
, null_pointer_node
,
8839 gfc_add_expr_to_block (&tmpblock
, fndecl
);
8840 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8844 case DEALLOCATE_ALLOC_COMP
:
8846 gfc_init_block (&tmpblock
);
8848 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8849 decl
, cdecl, NULL_TREE
);
8851 /* Shortcut to get the attributes of the component. */
8852 if (c
->ts
.type
== BT_CLASS
)
8854 attr
= &CLASS_DATA (c
)->attr
;
8855 if (attr
->class_pointer
)
8865 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8866 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8867 /* Call the finalizer, which will free the memory and nullify the
8868 pointer of an array. */
8869 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8870 caf_enabled (caf_mode
))
8873 deallocate_called
= false;
8875 /* Add the _class ref for classes. */
8876 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8877 comp
= gfc_class_data_get (comp
);
8879 add_when_allocated
= NULL_TREE
;
8880 if (cmp_has_alloc_comps
8881 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8883 && !deallocate_called
)
8885 /* Add checked deallocation of the components. This code is
8886 obviously added because the finalizer is not trusted to free
8888 if (c
->ts
.type
== BT_CLASS
)
8890 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8892 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8893 comp
, NULL_TREE
, rank
, purpose
,
8898 rank
= c
->as
? c
->as
->rank
: 0;
8899 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8906 if (attr
->allocatable
&& !same_type
8907 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8909 /* Handle all types of components besides components of the
8910 same_type as the current one, because those would create an
8913 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8914 ? (gfc_caf_is_dealloc_only (caf_mode
)
8915 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8916 : GFC_CAF_COARRAY_DEREGISTER
)
8917 : GFC_CAF_COARRAY_NOCOARRAY
;
8919 caf_token
= NULL_TREE
;
8920 /* Coarray components are handled directly by
8921 deallocate_with_status. */
8922 if (!attr
->codimension
8923 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8926 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8927 TREE_TYPE (c
->caf_token
),
8928 decl
, c
->caf_token
, NULL_TREE
);
8929 else if (attr
->dimension
&& !attr
->proc_pointer
)
8930 caf_token
= gfc_conv_descriptor_token (comp
);
8932 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8933 /* When this is an array but not in conjunction with a coarray
8934 then add the data-ref. For coarray'ed arrays the data-ref
8935 is added by deallocate_with_status. */
8936 comp
= gfc_conv_descriptor_data_get (comp
);
8938 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8939 NULL_TREE
, NULL_TREE
, true,
8940 NULL
, caf_dereg_mode
,
8941 add_when_allocated
, caf_token
);
8943 gfc_add_expr_to_block (&tmpblock
, tmp
);
8945 else if (attr
->allocatable
&& !attr
->codimension
8946 && !deallocate_called
)
8948 /* Case of recursive allocatable derived types. */
8952 stmtblock_t dealloc_block
;
8954 gfc_init_block (&dealloc_block
);
8955 if (add_when_allocated
)
8956 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8958 /* Convert the component into a rank 1 descriptor type. */
8959 if (attr
->dimension
)
8961 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8962 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8963 c
->ts
.type
== BT_CLASS
8964 ? CLASS_DATA (c
)->as
->rank
8969 tmp
= TREE_TYPE (comp
);
8970 ubound
= build_int_cst (gfc_array_index_type
, 1);
8973 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8975 GFC_ARRAY_ALLOCATABLE
, false);
8977 cdesc
= gfc_create_var (cdesc
, "cdesc");
8978 DECL_ARTIFICIAL (cdesc
) = 1;
8980 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8981 gfc_get_dtype_rank_type (1, tmp
));
8982 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8983 gfc_index_zero_node
,
8984 gfc_index_one_node
);
8985 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8986 gfc_index_zero_node
,
8987 gfc_index_one_node
);
8988 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8989 gfc_index_zero_node
, ubound
);
8991 if (attr
->dimension
)
8992 comp
= gfc_conv_descriptor_data_get (comp
);
8994 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8996 /* Now call the deallocator. */
8997 vtab
= gfc_find_vtab (&c
->ts
);
8998 if (vtab
->backend_decl
== NULL
)
8999 gfc_get_symbol_decl (vtab
);
9000 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9001 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
9002 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
9004 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
9005 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
9006 logical_type_node
, tmp
,
9008 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
9010 tmp
= build_call_expr_loc (input_location
,
9013 gfc_add_expr_to_block (&dealloc_block
, tmp
);
9015 tmp
= gfc_finish_block (&dealloc_block
);
9017 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9018 void_type_node
, is_allocated
, tmp
,
9019 build_empty_stmt (input_location
));
9021 gfc_add_expr_to_block (&tmpblock
, tmp
);
9023 else if (add_when_allocated
)
9024 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
9026 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
9027 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
9029 /* Finally, reset the vptr to the declared type vtable and, if
9030 necessary reset the _len field.
9032 First recover the reference to the component and obtain
9034 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9035 decl
, cdecl, NULL_TREE
);
9036 tmp
= gfc_class_vptr_get (comp
);
9038 if (UNLIMITED_POLY (c
))
9040 /* Both vptr and _len field should be nulled. */
9041 gfc_add_modify (&tmpblock
, tmp
,
9042 build_int_cst (TREE_TYPE (tmp
), 0));
9043 tmp
= gfc_class_len_get (comp
);
9044 gfc_add_modify (&tmpblock
, tmp
,
9045 build_int_cst (TREE_TYPE (tmp
), 0));
9049 /* Build the vtable address and set the vptr with it. */
9052 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9053 vtab
= vtable
->backend_decl
;
9054 if (vtab
== NULL_TREE
)
9055 vtab
= gfc_get_symbol_decl (vtable
);
9056 vtab
= gfc_build_addr_expr (NULL
, vtab
);
9057 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
9058 gfc_add_modify (&tmpblock
, tmp
, vtab
);
9062 /* Now add the deallocation of this component. */
9063 gfc_add_block_to_block (&fnblock
, &tmpblock
);
9066 case NULLIFY_ALLOC_COMP
:
9068 - allocatable components (regular or in class)
9069 - components that have allocatable components
9070 - pointer components when in a coarray.
9071 Skip everything else especially proc_pointers, which may come
9072 coupled with the regular pointer attribute. */
9073 if (c
->attr
.proc_pointer
9074 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
9075 && CLASS_DATA (c
)->attr
.allocatable
)
9076 || (cmp_has_alloc_comps
9077 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
9078 || (c
->ts
.type
== BT_CLASS
9079 && !CLASS_DATA (c
)->attr
.class_pointer
)))
9080 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
9083 /* Process class components first, because they always have the
9084 pointer-attribute set which would be caught wrong else. */
9085 if (c
->ts
.type
== BT_CLASS
9086 && (CLASS_DATA (c
)->attr
.allocatable
9087 || CLASS_DATA (c
)->attr
.class_pointer
))
9091 /* Allocatable CLASS components. */
9092 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9093 decl
, cdecl, NULL_TREE
);
9095 vptr_decl
= gfc_class_vptr_get (comp
);
9097 comp
= gfc_class_data_get (comp
);
9098 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
9099 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9103 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9104 void_type_node
, comp
,
9105 build_int_cst (TREE_TYPE (comp
), 0));
9106 gfc_add_expr_to_block (&fnblock
, tmp
);
9109 /* The dynamic type of a disassociated pointer or unallocated
9110 allocatable variable is its declared type. An unlimited
9111 polymorphic entity has no declared type. */
9112 if (!UNLIMITED_POLY (c
))
9114 vtab
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
9115 if (!vtab
->backend_decl
)
9116 gfc_get_symbol_decl (vtab
);
9117 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
9120 tmp
= build_int_cst (TREE_TYPE (vptr_decl
), 0);
9122 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9123 void_type_node
, vptr_decl
, tmp
);
9124 gfc_add_expr_to_block (&fnblock
, tmp
);
9126 cmp_has_alloc_comps
= false;
9128 /* Coarrays need the component to be nulled before the api-call
9130 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
9132 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9133 decl
, cdecl, NULL_TREE
);
9134 if (c
->attr
.dimension
|| c
->attr
.codimension
)
9135 gfc_conv_descriptor_data_set (&fnblock
, comp
,
9138 gfc_add_modify (&fnblock
, comp
,
9139 build_int_cst (TREE_TYPE (comp
), 0));
9140 if (gfc_deferred_strlen (c
, &comp
))
9142 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9144 decl
, comp
, NULL_TREE
);
9145 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9146 TREE_TYPE (comp
), comp
,
9147 build_int_cst (TREE_TYPE (comp
), 0));
9148 gfc_add_expr_to_block (&fnblock
, tmp
);
9150 cmp_has_alloc_comps
= false;
9153 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
9155 /* Register a component of a derived type coarray with the
9156 coarray library. Do not register ultimate component
9157 coarrays here. They are treated like regular coarrays and
9158 are either allocated on all images or on none. */
9161 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9162 decl
, cdecl, NULL_TREE
);
9163 if (c
->attr
.dimension
)
9165 /* Set the dtype, because caf_register needs it. */
9166 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
9167 gfc_get_dtype (TREE_TYPE (comp
)));
9168 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9169 decl
, cdecl, NULL_TREE
);
9170 token
= gfc_conv_descriptor_token (tmp
);
9176 gfc_init_se (&se
, NULL
);
9177 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
9178 pvoid_type_node
, decl
, c
->caf_token
,
9180 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
9181 c
->ts
.type
== BT_CLASS
9182 ? CLASS_DATA (c
)->attr
9184 gfc_add_block_to_block (&fnblock
, &se
.pre
);
9187 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
9188 gfc_build_addr_expr (NULL_TREE
,
9190 NULL_TREE
, NULL_TREE
, NULL_TREE
,
9191 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
9194 if (cmp_has_alloc_comps
)
9196 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9197 decl
, cdecl, NULL_TREE
);
9198 rank
= c
->as
? c
->as
->rank
: 0;
9199 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
9200 rank
, purpose
, caf_mode
, args
);
9201 gfc_add_expr_to_block (&fnblock
, tmp
);
9205 case REASSIGN_CAF_COMP
:
9206 if (caf_enabled (caf_mode
)
9207 && (c
->attr
.codimension
9208 || (c
->ts
.type
== BT_CLASS
9209 && (CLASS_DATA (c
)->attr
.coarray_comp
9210 || caf_in_coarray (caf_mode
)))
9211 || (c
->ts
.type
== BT_DERIVED
9212 && (c
->ts
.u
.derived
->attr
.coarray_comp
9213 || caf_in_coarray (caf_mode
))))
9216 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9217 decl
, cdecl, NULL_TREE
);
9218 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9219 dest
, cdecl, NULL_TREE
);
9221 if (c
->attr
.codimension
)
9223 if (c
->ts
.type
== BT_CLASS
)
9225 comp
= gfc_class_data_get (comp
);
9226 dcmp
= gfc_class_data_get (dcmp
);
9228 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
9229 gfc_conv_descriptor_data_get (comp
));
9233 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
9234 rank
, purpose
, caf_mode
9235 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
,
9237 gfc_add_expr_to_block (&fnblock
, tmp
);
9242 case COPY_ALLOC_COMP
:
9243 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
9246 /* We need source and destination components. */
9247 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
9249 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
9251 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
9253 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
9261 dst_data
= gfc_class_data_get (dcmp
);
9262 src_data
= gfc_class_data_get (comp
);
9263 size
= fold_convert (size_type_node
,
9264 gfc_class_vtab_size_get (comp
));
9266 if (CLASS_DATA (c
)->attr
.dimension
)
9268 nelems
= gfc_conv_descriptor_size (src_data
,
9269 CLASS_DATA (c
)->as
->rank
);
9270 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9271 size_type_node
, size
,
9272 fold_convert (size_type_node
,
9276 nelems
= build_int_cst (size_type_node
, 1);
9278 if (CLASS_DATA (c
)->attr
.dimension
9279 || CLASS_DATA (c
)->attr
.codimension
)
9281 src_data
= gfc_conv_descriptor_data_get (src_data
);
9282 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
9285 gfc_init_block (&tmpblock
);
9287 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
9288 gfc_class_vptr_get (comp
));
9290 /* Copy the unlimited '_len' field. If it is greater than zero
9291 (ie. a character(_len)), multiply it by size and use this
9292 for the malloc call. */
9293 if (UNLIMITED_POLY (c
))
9296 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
9297 gfc_class_len_get (comp
));
9299 size
= gfc_evaluate_now (size
, &tmpblock
);
9300 tmp
= gfc_class_len_get (comp
);
9301 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9302 size_type_node
, size
,
9303 fold_convert (size_type_node
, tmp
));
9304 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9305 logical_type_node
, tmp
,
9306 build_zero_cst (TREE_TYPE (tmp
)));
9307 size
= fold_build3_loc (input_location
, COND_EXPR
,
9308 size_type_node
, tmp
, ctmp
, size
);
9309 size
= gfc_evaluate_now (size
, &tmpblock
);
9312 /* Coarray component have to have the same allocation status and
9313 shape/type-parameter/effective-type on the LHS and RHS of an
9314 intrinsic assignment. Hence, we did not deallocated them - and
9315 do not allocate them here. */
9316 if (!CLASS_DATA (c
)->attr
.codimension
)
9318 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9319 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9320 gfc_add_modify (&tmpblock
, dst_data
,
9321 fold_convert (TREE_TYPE (dst_data
), tmp
));
9324 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9325 UNLIMITED_POLY (c
));
9326 gfc_add_expr_to_block (&tmpblock
, tmp
);
9327 tmp
= gfc_finish_block (&tmpblock
);
9329 gfc_init_block (&tmpblock
);
9330 gfc_add_modify (&tmpblock
, dst_data
,
9331 fold_convert (TREE_TYPE (dst_data
),
9332 null_pointer_node
));
9333 null_data
= gfc_finish_block (&tmpblock
);
9335 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9336 logical_type_node
, src_data
,
9339 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9344 /* To implement guarded deep copy, i.e., deep copy only allocatable
9345 components that are really allocated, the deep copy code has to
9346 be generated first and then added to the if-block in
9347 gfc_duplicate_allocatable (). */
9348 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9350 rank
= c
->as
? c
->as
->rank
: 0;
9351 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9352 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9353 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9359 add_when_allocated
= NULL_TREE
;
9361 if (gfc_deferred_strlen (c
, &tmp
))
9365 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9367 decl
, len
, NULL_TREE
);
9368 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9370 dest
, len
, NULL_TREE
);
9371 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9372 TREE_TYPE (len
), len
, tmp
);
9373 gfc_add_expr_to_block (&fnblock
, tmp
);
9374 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9375 /* This component cannot have allocatable components,
9376 therefore add_when_allocated of duplicate_allocatable ()
9378 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9379 false, false, size
, NULL_TREE
);
9380 gfc_add_expr_to_block (&fnblock
, tmp
);
9382 else if (c
->attr
.pdt_array
)
9384 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9385 c
->as
? c
->as
->rank
: 0,
9386 false, false, NULL_TREE
, NULL_TREE
);
9387 gfc_add_expr_to_block (&fnblock
, tmp
);
9389 else if ((c
->attr
.allocatable
)
9390 && !c
->attr
.proc_pointer
&& !same_type
9391 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9392 || caf_in_coarray (caf_mode
)))
9394 rank
= c
->as
? c
->as
->rank
: 0;
9395 if (c
->attr
.codimension
)
9396 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9397 else if (flag_coarray
== GFC_FCOARRAY_LIB
9398 && caf_in_coarray (caf_mode
))
9402 dst_tok
= gfc_conv_descriptor_token (dcmp
);
9405 /* For a scalar allocatable component the caf_token is
9406 the next component. */
9408 c
->caf_token
= c
->next
->backend_decl
;
9409 dst_tok
= fold_build3_loc (input_location
,
9411 pvoid_type_node
, dest
,
9415 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9419 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9420 add_when_allocated
);
9421 gfc_add_expr_to_block (&fnblock
, tmp
);
9424 if (cmp_has_alloc_comps
|| is_pdt_type
)
9425 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9429 case ALLOCATE_PDT_COMP
:
9431 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9432 decl
, cdecl, NULL_TREE
);
9434 /* Set the PDT KIND and LEN fields. */
9435 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9438 gfc_expr
*c_expr
= NULL
;
9439 gfc_actual_arglist
*param
= pdt_param_list
;
9440 gfc_init_se (&tse
, NULL
);
9441 for (; param
; param
= param
->next
)
9442 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9443 c_expr
= param
->expr
;
9446 c_expr
= c
->initializer
;
9450 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9451 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9455 if (c
->attr
.pdt_string
)
9458 gfc_init_se (&tse
, NULL
);
9459 tree strlen
= NULL_TREE
;
9460 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9461 /* Convert the parameterized string length to its value. The
9462 string length is stored in a hidden field in the same way as
9463 deferred string lengths. */
9464 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9465 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9467 gfc_conv_expr_type (&tse
, e
,
9468 TREE_TYPE (strlen
));
9469 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9471 decl
, strlen
, NULL_TREE
);
9472 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9473 c
->ts
.u
.cl
->backend_decl
= strlen
;
9477 /* Scalar parameterized strings can be allocated now. */
9480 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9481 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9482 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9483 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9484 gfc_add_modify (&fnblock
, comp
, tmp
);
9488 /* Allocate parameterized arrays of parameterized derived types. */
9489 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9490 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9491 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9494 if (c
->ts
.type
== BT_CLASS
)
9495 comp
= gfc_class_data_get (comp
);
9497 if (c
->attr
.pdt_array
)
9501 tree size
= gfc_index_one_node
;
9502 tree offset
= gfc_index_zero_node
;
9506 /* This chunk takes the expressions for 'lower' and 'upper'
9507 in the arrayspec and substitutes in the expressions for
9508 the parameters from 'pdt_param_list'. The descriptor
9509 fields can then be filled from the values so obtained. */
9510 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9511 for (i
= 0; i
< c
->as
->rank
; i
++)
9513 gfc_init_se (&tse
, NULL
);
9514 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9515 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9516 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9519 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9522 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9523 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9524 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9527 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9530 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9533 size
= gfc_evaluate_now (size
, &fnblock
);
9534 offset
= fold_build2_loc (input_location
,
9536 gfc_array_index_type
,
9538 offset
= gfc_evaluate_now (offset
, &fnblock
);
9539 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9540 gfc_array_index_type
,
9542 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9543 gfc_array_index_type
,
9544 tmp
, gfc_index_one_node
);
9545 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9546 gfc_array_index_type
, size
, tmp
);
9548 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9549 if (c
->ts
.type
== BT_CLASS
)
9551 tmp
= gfc_get_vptr_from_expr (comp
);
9552 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9553 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9554 tmp
= gfc_vptr_size_get (tmp
);
9557 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9558 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9559 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9560 gfc_array_index_type
, size
, tmp
);
9561 size
= gfc_evaluate_now (size
, &fnblock
);
9562 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9563 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9564 tmp
= gfc_conv_descriptor_dtype (comp
);
9565 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9567 if (c
->initializer
&& c
->initializer
->rank
)
9569 gfc_init_se (&tse
, NULL
);
9570 e
= gfc_copy_expr (c
->initializer
);
9571 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9572 gfc_conv_expr_descriptor (&tse
, e
);
9573 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9575 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9576 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9577 gfc_conv_descriptor_data_get (comp
),
9578 gfc_conv_descriptor_data_get (tse
.expr
),
9579 fold_convert (size_type_node
, size
));
9580 gfc_add_expr_to_block (&fnblock
, tmp
);
9581 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9585 /* Recurse in to PDT components. */
9586 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9587 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9588 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9590 bool is_deferred
= false;
9591 gfc_actual_arglist
*tail
= c
->param_list
;
9593 for (; tail
; tail
= tail
->next
)
9597 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9598 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9599 c
->as
? c
->as
->rank
: 0,
9601 gfc_add_expr_to_block (&fnblock
, tmp
);
9606 case DEALLOCATE_PDT_COMP
:
9607 /* Deallocate array or parameterized string length components
9608 of parameterized derived types. */
9609 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9610 && !c
->attr
.pdt_string
9611 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9612 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9615 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9616 decl
, cdecl, NULL_TREE
);
9617 if (c
->ts
.type
== BT_CLASS
)
9618 comp
= gfc_class_data_get (comp
);
9620 /* Recurse in to PDT components. */
9621 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9622 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9623 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9625 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9626 c
->as
? c
->as
->rank
: 0);
9627 gfc_add_expr_to_block (&fnblock
, tmp
);
9630 if (c
->attr
.pdt_array
)
9632 tmp
= gfc_conv_descriptor_data_get (comp
);
9633 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9634 logical_type_node
, tmp
,
9635 build_int_cst (TREE_TYPE (tmp
), 0));
9636 tmp
= gfc_call_free (tmp
);
9637 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9638 build_empty_stmt (input_location
));
9639 gfc_add_expr_to_block (&fnblock
, tmp
);
9640 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9642 else if (c
->attr
.pdt_string
)
9644 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9645 logical_type_node
, comp
,
9646 build_int_cst (TREE_TYPE (comp
), 0));
9647 tmp
= gfc_call_free (comp
);
9648 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9649 build_empty_stmt (input_location
));
9650 gfc_add_expr_to_block (&fnblock
, tmp
);
9651 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9652 gfc_add_modify (&fnblock
, comp
, tmp
);
9657 case CHECK_PDT_DUMMY
:
9659 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9660 decl
, cdecl, NULL_TREE
);
9661 if (c
->ts
.type
== BT_CLASS
)
9662 comp
= gfc_class_data_get (comp
);
9664 /* Recurse in to PDT components. */
9665 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9666 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9668 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9669 c
->as
? c
->as
->rank
: 0,
9671 gfc_add_expr_to_block (&fnblock
, tmp
);
9674 if (!c
->attr
.pdt_len
)
9679 gfc_expr
*c_expr
= NULL
;
9680 gfc_actual_arglist
*param
= pdt_param_list
;
9682 gfc_init_se (&tse
, NULL
);
9683 for (; param
; param
= param
->next
)
9684 if (!strcmp (c
->name
, param
->name
)
9685 && param
->spec_type
== SPEC_EXPLICIT
)
9686 c_expr
= param
->expr
;
9690 tree error
, cond
, cname
;
9691 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9692 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9695 cname
= gfc_build_cstring_const (c
->name
);
9696 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9697 error
= gfc_trans_runtime_error (true, NULL
,
9698 "The value of the PDT LEN "
9699 "parameter '%s' does not "
9700 "agree with that in the "
9701 "dummy declaration",
9703 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9704 void_type_node
, cond
, error
,
9705 build_empty_stmt (input_location
));
9706 gfc_add_expr_to_block (&fnblock
, tmp
);
9717 return gfc_finish_block (&fnblock
);
9720 /* Recursively traverse an object of derived type, generating code to
9721 nullify allocatable components. */
9724 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9727 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9729 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9733 /* Recursively traverse an object of derived type, generating code to
9734 deallocate allocatable components. */
9737 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9740 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9741 DEALLOCATE_ALLOC_COMP
,
9742 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
, NULL
);
9746 gfc_bcast_alloc_comp (gfc_symbol
*derived
, gfc_expr
*expr
, int rank
,
9747 tree image_index
, tree stat
, tree errmsg
,
9752 stmtblock_t block
, post_block
;
9753 gfc_co_subroutines_args args
;
9755 args
.image_index
= image_index
;
9757 args
.errmsg
= errmsg
;
9758 args
.errmsg_len
= errmsg_len
;
9762 gfc_start_block (&block
);
9763 gfc_init_block (&post_block
);
9764 gfc_init_se (&argse
, NULL
);
9765 gfc_conv_expr (&argse
, expr
);
9766 gfc_add_block_to_block (&block
, &argse
.pre
);
9767 gfc_add_block_to_block (&post_block
, &argse
.post
);
9772 gfc_init_se (&argse
, NULL
);
9773 argse
.want_pointer
= 1;
9774 gfc_conv_expr_descriptor (&argse
, expr
);
9778 tmp
= structure_alloc_comps (derived
, array
, NULL_TREE
, rank
,
9780 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, &args
);
9784 /* Recursively traverse an object of derived type, generating code to
9785 deallocate allocatable components. But do not deallocate coarrays.
9786 To be used for intrinsic assignment, which may not change the allocation
9787 status of coarrays. */
9790 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9792 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9793 DEALLOCATE_ALLOC_COMP
, 0, NULL
);
9798 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9800 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9801 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
, NULL
);
9805 /* Recursively traverse an object of derived type, generating code to
9806 copy it and its allocatable components. */
9809 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9812 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9817 /* Recursively traverse an object of derived type, generating code to
9818 copy only its allocatable components. */
9821 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9823 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9824 COPY_ONLY_ALLOC_COMP
, 0, NULL
);
9828 /* Recursively traverse an object of parameterized derived type, generating
9829 code to allocate parameterized components. */
9832 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9833 gfc_actual_arglist
*param_list
)
9836 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9837 pdt_param_list
= param_list
;
9838 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9839 ALLOCATE_PDT_COMP
, 0, NULL
);
9840 pdt_param_list
= old_param_list
;
9844 /* Recursively traverse an object of parameterized derived type, generating
9845 code to deallocate parameterized components. */
9848 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9850 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9851 DEALLOCATE_PDT_COMP
, 0, NULL
);
9855 /* Recursively traverse a dummy of parameterized derived type to check the
9856 values of LEN parameters. */
9859 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9860 gfc_actual_arglist
*param_list
)
9863 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9864 pdt_param_list
= param_list
;
9865 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9866 CHECK_PDT_DUMMY
, 0, NULL
);
9867 pdt_param_list
= old_param_list
;
9872 /* Returns the value of LBOUND for an expression. This could be broken out
9873 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9874 called by gfc_alloc_allocatable_for_assignment. */
9876 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9881 tree cond
, cond1
, cond3
, cond4
;
9885 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9887 tmp
= gfc_rank_cst
[dim
];
9888 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9889 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9890 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9891 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9893 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9894 stride
, gfc_index_zero_node
);
9895 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9896 logical_type_node
, cond3
, cond1
);
9897 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9898 stride
, gfc_index_zero_node
);
9900 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9901 tmp
, build_int_cst (gfc_array_index_type
,
9904 cond
= logical_false_node
;
9906 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9907 logical_type_node
, cond3
, cond4
);
9908 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9909 logical_type_node
, cond
, cond1
);
9911 return fold_build3_loc (input_location
, COND_EXPR
,
9912 gfc_array_index_type
, cond
,
9913 lbound
, gfc_index_one_node
);
9916 if (expr
->expr_type
== EXPR_FUNCTION
)
9918 /* A conversion function, so use the argument. */
9919 gcc_assert (expr
->value
.function
.isym
9920 && expr
->value
.function
.isym
->conversion
);
9921 expr
= expr
->value
.function
.actual
->expr
;
9924 if (expr
->expr_type
== EXPR_VARIABLE
)
9926 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9927 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9929 if (ref
->type
== REF_COMPONENT
9930 && ref
->u
.c
.component
->as
9932 && ref
->next
->u
.ar
.type
== AR_FULL
)
9933 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9935 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9938 return gfc_index_one_node
;
9942 /* Returns true if an expression represents an lhs that can be reallocated
9946 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9954 sym
= expr
->symtree
->n
.sym
;
9956 if (sym
->attr
.associate_var
&& !expr
->ref
)
9959 /* An allocatable class variable with no reference. */
9960 if (sym
->ts
.type
== BT_CLASS
9961 && !sym
->attr
.associate_var
9962 && CLASS_DATA (sym
)->attr
.allocatable
9964 && ((expr
->ref
->type
== REF_ARRAY
&& expr
->ref
->u
.ar
.type
== AR_FULL
9965 && expr
->ref
->next
== NULL
)
9966 || (expr
->ref
->type
== REF_COMPONENT
9967 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9968 && (expr
->ref
->next
== NULL
9969 || (expr
->ref
->next
->type
== REF_ARRAY
9970 && expr
->ref
->next
->u
.ar
.type
== AR_FULL
9971 && expr
->ref
->next
->next
== NULL
)))))
9974 /* An allocatable variable. */
9975 if (sym
->attr
.allocatable
9976 && !sym
->attr
.associate_var
9978 && expr
->ref
->type
== REF_ARRAY
9979 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9982 /* All that can be left are allocatable components. */
9983 if ((sym
->ts
.type
!= BT_DERIVED
9984 && sym
->ts
.type
!= BT_CLASS
)
9985 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9988 /* Find a component ref followed by an array reference. */
9989 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9991 && ref
->type
== REF_COMPONENT
9992 && ref
->next
->type
== REF_ARRAY
9993 && !ref
->next
->next
)
9999 /* Return true if valid reallocatable lhs. */
10000 if (ref
->u
.c
.component
->attr
.allocatable
10001 && ref
->next
->u
.ar
.type
== AR_FULL
)
10009 concat_str_length (gfc_expr
* expr
)
10016 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
10017 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10018 if (len1
== NULL_TREE
)
10020 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
10021 len1
= concat_str_length (expr
->value
.op
.op1
);
10022 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
10023 len1
= build_int_cst (gfc_charlen_type_node
,
10024 expr
->value
.op
.op1
->value
.character
.length
);
10025 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
10027 gfc_init_se (&se
, NULL
);
10028 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
10034 gfc_init_se (&se
, NULL
);
10035 se
.want_pointer
= 1;
10036 se
.descriptor_only
= 1;
10037 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
10038 len1
= se
.string_length
;
10042 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
10043 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
10044 if (len2
== NULL_TREE
)
10046 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
10047 len2
= concat_str_length (expr
->value
.op
.op2
);
10048 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
10049 len2
= build_int_cst (gfc_charlen_type_node
,
10050 expr
->value
.op
.op2
->value
.character
.length
);
10051 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
10053 gfc_init_se (&se
, NULL
);
10054 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
10060 gfc_init_se (&se
, NULL
);
10061 se
.want_pointer
= 1;
10062 se
.descriptor_only
= 1;
10063 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
10064 len2
= se
.string_length
;
10068 gcc_assert(len1
&& len2
);
10069 len1
= fold_convert (gfc_charlen_type_node
, len1
);
10070 len2
= fold_convert (gfc_charlen_type_node
, len2
);
10072 return fold_build2_loc (input_location
, PLUS_EXPR
,
10073 gfc_charlen_type_node
, len1
, len2
);
10077 /* Allocate the lhs of an assignment to an allocatable array, otherwise
10081 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
10085 stmtblock_t realloc_block
;
10086 stmtblock_t alloc_block
;
10087 stmtblock_t fblock
;
10090 gfc_array_info
*linfo
;
10112 gfc_array_spec
* as
;
10113 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
10114 && gfc_caf_attr (expr1
, true).codimension
);
10118 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
10119 Find the lhs expression in the loop chain and set expr1 and
10120 expr2 accordingly. */
10121 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
10124 /* Find the ss for the lhs. */
10126 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10127 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
10129 if (lss
== gfc_ss_terminator
)
10131 expr1
= lss
->info
->expr
;
10134 /* Bail out if this is not a valid allocate on assignment. */
10135 if (!gfc_is_reallocatable_lhs (expr1
)
10136 || (expr2
&& !expr2
->rank
))
10139 /* Find the ss for the lhs. */
10141 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
10142 if (lss
->info
->expr
== expr1
)
10145 if (lss
== gfc_ss_terminator
)
10148 linfo
= &lss
->info
->data
.array
;
10150 /* Find an ss for the rhs. For operator expressions, we see the
10151 ss's for the operands. Any one of these will do. */
10153 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
10154 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
10157 if (expr2
&& rss
== gfc_ss_terminator
)
10160 /* Ensure that the string length from the current scope is used. */
10161 if (expr2
->ts
.type
== BT_CHARACTER
10162 && expr2
->expr_type
== EXPR_FUNCTION
10163 && !expr2
->value
.function
.isym
)
10164 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
10166 gfc_start_block (&fblock
);
10168 /* Since the lhs is allocatable, this must be a descriptor type.
10169 Get the data and array size. */
10170 desc
= linfo
->descriptor
;
10171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
10172 array1
= gfc_conv_descriptor_data_get (desc
);
10174 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
10175 deallocated if expr is an array of different shape or any of the
10176 corresponding length type parameter values of variable and expr
10177 differ." This assures F95 compatibility. */
10178 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10179 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10181 /* Allocate if data is NULL. */
10182 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10183 array1
, build_int_cst (TREE_TYPE (array1
), 0));
10185 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10187 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10189 lss
->info
->string_length
,
10190 rss
->info
->string_length
);
10191 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10192 logical_type_node
, tmp
, cond_null
);
10195 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
10197 tmp
= build3_v (COND_EXPR
, cond_null
,
10198 build1_v (GOTO_EXPR
, jump_label1
),
10199 build_empty_stmt (input_location
));
10200 gfc_add_expr_to_block (&fblock
, tmp
);
10202 /* Get arrayspec if expr is a full array. */
10203 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
10204 && expr2
->value
.function
.isym
10205 && expr2
->value
.function
.isym
->conversion
)
10207 /* For conversion functions, take the arg. */
10208 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
10209 as
= gfc_get_full_arrayspec_from_expr (arg
);
10212 as
= gfc_get_full_arrayspec_from_expr (expr2
);
10216 /* If the lhs shape is not the same as the rhs jump to setting the
10217 bounds and doing the reallocation....... */
10218 for (n
= 0; n
< expr1
->rank
; n
++)
10220 /* Check the shape. */
10221 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10222 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10223 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10224 gfc_array_index_type
,
10225 loop
->to
[n
], loop
->from
[n
]);
10226 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10227 gfc_array_index_type
,
10229 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10230 gfc_array_index_type
,
10232 cond
= fold_build2_loc (input_location
, NE_EXPR
,
10234 tmp
, gfc_index_zero_node
);
10235 tmp
= build3_v (COND_EXPR
, cond
,
10236 build1_v (GOTO_EXPR
, jump_label1
),
10237 build_empty_stmt (input_location
));
10238 gfc_add_expr_to_block (&fblock
, tmp
);
10241 /* ....else jump past the (re)alloc code. */
10242 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10243 gfc_add_expr_to_block (&fblock
, tmp
);
10245 /* Add the label to start automatic (re)allocation. */
10246 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10247 gfc_add_expr_to_block (&fblock
, tmp
);
10249 /* If the lhs has not been allocated, its bounds will not have been
10250 initialized and so its size is set to zero. */
10251 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
10252 gfc_init_block (&alloc_block
);
10253 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
10254 gfc_init_block (&realloc_block
);
10255 gfc_add_modify (&realloc_block
, size1
,
10256 gfc_conv_descriptor_size (desc
, expr1
->rank
));
10257 tmp
= build3_v (COND_EXPR
, cond_null
,
10258 gfc_finish_block (&alloc_block
),
10259 gfc_finish_block (&realloc_block
));
10260 gfc_add_expr_to_block (&fblock
, tmp
);
10262 /* Get the rhs size and fix it. */
10264 desc2
= rss
->info
->data
.array
.descriptor
;
10268 size2
= gfc_index_one_node
;
10269 for (n
= 0; n
< expr2
->rank
; n
++)
10271 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10272 gfc_array_index_type
,
10273 loop
->to
[n
], loop
->from
[n
]);
10274 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10275 gfc_array_index_type
,
10276 tmp
, gfc_index_one_node
);
10277 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10278 gfc_array_index_type
,
10281 size2
= gfc_evaluate_now (size2
, &fblock
);
10283 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10286 /* If the lhs is deferred length, assume that the element size
10287 changes and force a reallocation. */
10288 if (expr1
->ts
.deferred
)
10289 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
10291 neq_size
= gfc_evaluate_now (cond
, &fblock
);
10293 /* Deallocation of allocatable components will have to occur on
10294 reallocation. Fix the old descriptor now. */
10295 if ((expr1
->ts
.type
== BT_DERIVED
)
10296 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10297 old_desc
= gfc_evaluate_now (desc
, &fblock
);
10299 old_desc
= NULL_TREE
;
10301 /* Now modify the lhs descriptor and the associated scalarizer
10302 variables. F2003 7.4.1.3: "If variable is or becomes an
10303 unallocated allocatable variable, then it is allocated with each
10304 deferred type parameter equal to the corresponding type parameters
10305 of expr , with the shape of expr , and with each lower bound equal
10306 to the corresponding element of LBOUND(expr)."
10307 Reuse size1 to keep a dimension-by-dimension track of the
10308 stride of the new array. */
10309 size1
= gfc_index_one_node
;
10310 offset
= gfc_index_zero_node
;
10312 for (n
= 0; n
< expr2
->rank
; n
++)
10314 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10315 gfc_array_index_type
,
10316 loop
->to
[n
], loop
->from
[n
]);
10317 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10318 gfc_array_index_type
,
10319 tmp
, gfc_index_one_node
);
10321 lbound
= gfc_index_one_node
;
10326 lbd
= get_std_lbound (expr2
, desc2
, n
,
10327 as
->type
== AS_ASSUMED_SIZE
);
10328 ubound
= fold_build2_loc (input_location
,
10330 gfc_array_index_type
,
10332 ubound
= fold_build2_loc (input_location
,
10334 gfc_array_index_type
,
10339 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
10342 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
10345 gfc_conv_descriptor_stride_set (&fblock
, desc
,
10348 lbound
= gfc_conv_descriptor_lbound_get (desc
,
10350 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
10351 gfc_array_index_type
,
10353 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10354 gfc_array_index_type
,
10356 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10357 gfc_array_index_type
,
10361 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10362 the array offset is saved and the info.offset is used for a
10363 running offset. Use the saved_offset instead. */
10364 tmp
= gfc_conv_descriptor_offset (desc
);
10365 gfc_add_modify (&fblock
, tmp
, offset
);
10366 if (linfo
->saved_offset
10367 && VAR_P (linfo
->saved_offset
))
10368 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10370 /* Now set the deltas for the lhs. */
10371 for (n
= 0; n
< expr1
->rank
; n
++)
10373 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10375 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10376 gfc_array_index_type
, tmp
,
10378 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10379 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10382 /* Get the new lhs size in bytes. */
10383 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10385 if (expr2
->ts
.deferred
)
10387 if (expr2
->ts
.u
.cl
->backend_decl
10388 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10389 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10391 tmp
= rss
->info
->string_length
;
10395 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10396 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10397 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10399 tmp
= concat_str_length (expr2
);
10400 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10402 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10405 gfc_init_se (&tmpse
, NULL
);
10406 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10407 gfc_charlen_type_node
);
10409 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10411 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10414 if (expr1
->ts
.u
.cl
->backend_decl
10415 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10416 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10418 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10420 if (expr1
->ts
.kind
> 1)
10421 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10423 tmp
, build_int_cst (TREE_TYPE (tmp
),
10426 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10428 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10429 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10430 gfc_array_index_type
, tmp
,
10431 expr1
->ts
.u
.cl
->backend_decl
);
10433 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10434 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10436 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10437 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10439 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10440 gfc_conv_descriptor_span_set (&fblock
, desc
, tmp
);
10442 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10443 gfc_array_index_type
,
10445 size2
= fold_convert (size_type_node
, size2
);
10446 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10447 size2
, size_one_node
);
10448 size2
= gfc_evaluate_now (size2
, &fblock
);
10450 /* For deferred character length, the 'size' field of the dtype might
10451 have changed so set the dtype. */
10452 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10453 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10456 tmp
= gfc_conv_descriptor_dtype (desc
);
10457 if (expr2
->ts
.u
.cl
->backend_decl
)
10458 type
= gfc_typenode_for_spec (&expr2
->ts
);
10460 type
= gfc_typenode_for_spec (&expr1
->ts
);
10462 gfc_add_modify (&fblock
, tmp
,
10463 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10465 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10468 tmp
= gfc_conv_descriptor_dtype (desc
);
10469 type
= gfc_typenode_for_spec (&expr2
->ts
);
10470 gfc_add_modify (&fblock
, tmp
,
10471 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10472 /* Set the _len field as well... */
10473 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10474 if (expr2
->ts
.type
== BT_CHARACTER
)
10475 gfc_add_modify (&fblock
, tmp
,
10476 fold_convert (TREE_TYPE (tmp
),
10477 TYPE_SIZE_UNIT (type
)));
10479 gfc_add_modify (&fblock
, tmp
,
10480 build_int_cst (TREE_TYPE (tmp
), 0));
10481 /* ...and the vptr. */
10482 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10483 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10484 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10485 gfc_add_modify (&fblock
, tmp
, tmp2
);
10487 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10489 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10490 gfc_get_dtype (TREE_TYPE (desc
)));
10493 /* Realloc expression. Note that the scalarizer uses desc.data
10494 in the array reference - (*desc.data)[<element>]. */
10495 gfc_init_block (&realloc_block
);
10496 gfc_init_se (&caf_se
, NULL
);
10500 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10501 if (token
== NULL_TREE
)
10503 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10504 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10505 tmp
= build_fold_indirect_ref (tmp
);
10506 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10508 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10511 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10513 if ((expr1
->ts
.type
== BT_DERIVED
)
10514 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10516 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10518 gfc_add_expr_to_block (&realloc_block
, tmp
);
10523 tmp
= build_call_expr_loc (input_location
,
10524 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10525 fold_convert (pvoid_type_node
, array1
),
10527 gfc_conv_descriptor_data_set (&realloc_block
,
10532 tmp
= build_call_expr_loc (input_location
,
10533 gfor_fndecl_caf_deregister
, 5, token
,
10534 build_int_cst (integer_type_node
,
10535 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10536 null_pointer_node
, null_pointer_node
,
10537 integer_zero_node
);
10538 gfc_add_expr_to_block (&realloc_block
, tmp
);
10539 tmp
= build_call_expr_loc (input_location
,
10540 gfor_fndecl_caf_register
,
10542 build_int_cst (integer_type_node
,
10543 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10544 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10545 null_pointer_node
, null_pointer_node
,
10546 integer_zero_node
);
10547 gfc_add_expr_to_block (&realloc_block
, tmp
);
10550 if ((expr1
->ts
.type
== BT_DERIVED
)
10551 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10553 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10555 gfc_add_expr_to_block (&realloc_block
, tmp
);
10558 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10559 realloc_expr
= gfc_finish_block (&realloc_block
);
10561 /* Only reallocate if sizes are different. */
10562 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10563 build_empty_stmt (input_location
));
10564 realloc_expr
= tmp
;
10567 /* Malloc expression. */
10568 gfc_init_block (&alloc_block
);
10571 tmp
= build_call_expr_loc (input_location
,
10572 builtin_decl_explicit (BUILT_IN_MALLOC
),
10574 gfc_conv_descriptor_data_set (&alloc_block
,
10579 tmp
= build_call_expr_loc (input_location
,
10580 gfor_fndecl_caf_register
,
10582 build_int_cst (integer_type_node
,
10583 GFC_CAF_COARRAY_ALLOC
),
10584 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10585 null_pointer_node
, null_pointer_node
,
10586 integer_zero_node
);
10587 gfc_add_expr_to_block (&alloc_block
, tmp
);
10591 /* We already set the dtype in the case of deferred character
10592 length arrays and unlimited polymorphic arrays. */
10593 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10594 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10596 && !UNLIMITED_POLY (expr1
))
10598 tmp
= gfc_conv_descriptor_dtype (desc
);
10599 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10602 if ((expr1
->ts
.type
== BT_DERIVED
)
10603 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10605 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10607 gfc_add_expr_to_block (&alloc_block
, tmp
);
10609 alloc_expr
= gfc_finish_block (&alloc_block
);
10611 /* Malloc if not allocated; realloc otherwise. */
10612 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10613 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10616 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10617 gfc_add_expr_to_block (&fblock
, tmp
);
10619 /* Make sure that the scalarizer data pointer is updated. */
10620 if (linfo
->data
&& VAR_P (linfo
->data
))
10622 tmp
= gfc_conv_descriptor_data_get (desc
);
10623 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10626 /* Add the exit label. */
10627 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10628 gfc_add_expr_to_block (&fblock
, tmp
);
10630 return gfc_finish_block (&fblock
);
10634 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10635 Do likewise, recursively if necessary, with the allocatable components of
10636 derived types. This function is also called for assumed-rank arrays, which
10637 are always dummy arguments. */
10640 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10646 stmtblock_t cleanup
;
10649 bool sym_has_alloc_comp
, has_finalizer
;
10651 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10652 || sym
->ts
.type
== BT_CLASS
)
10653 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10654 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10655 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10657 /* Make sure the frontend gets these right. */
10658 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10660 || (sym
->as
->type
== AS_ASSUMED_RANK
&& sym
->attr
.dummy
));
10662 gfc_save_backend_locus (&loc
);
10663 gfc_set_backend_locus (&sym
->declared_at
);
10664 gfc_init_block (&init
);
10666 gcc_assert (VAR_P (sym
->backend_decl
)
10667 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10669 if (sym
->ts
.type
== BT_CHARACTER
10670 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10672 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10673 gfc_trans_vla_type_sizes (sym
, &init
);
10676 /* Dummy, use associated and result variables don't need anything special. */
10677 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10679 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10680 gfc_restore_backend_locus (&loc
);
10684 descriptor
= sym
->backend_decl
;
10686 /* Although static, derived types with default initializers and
10687 allocatable components must not be nulled wholesale; instead they
10688 are treated component by component. */
10689 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10691 /* SAVEd variables are not freed on exit. */
10692 gfc_trans_static_array_pointer (sym
);
10694 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10695 gfc_restore_backend_locus (&loc
);
10699 /* Get the descriptor type. */
10700 type
= TREE_TYPE (sym
->backend_decl
);
10702 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10703 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10705 if (!sym
->attr
.save
10706 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10708 if (sym
->value
== NULL
10709 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10711 rank
= sym
->as
? sym
->as
->rank
: 0;
10712 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10714 gfc_add_expr_to_block (&init
, tmp
);
10717 gfc_init_default_dt (sym
, &init
, false);
10720 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10722 /* If the backend_decl is not a descriptor, we must have a pointer
10724 descriptor
= build_fold_indirect_ref_loc (input_location
,
10725 sym
->backend_decl
);
10726 type
= TREE_TYPE (descriptor
);
10729 /* NULLIFY the data pointer, for non-saved allocatables. */
10730 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10732 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10733 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10735 /* Declare the variable static so its array descriptor stays present
10736 after leaving the scope. It may still be accessed through another
10737 image. This may happen, for example, with the caf_mpi
10739 TREE_STATIC (descriptor
) = 1;
10740 tmp
= gfc_conv_descriptor_token (descriptor
);
10741 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10742 null_pointer_node
));
10746 gfc_restore_backend_locus (&loc
);
10747 gfc_init_block (&cleanup
);
10749 /* Allocatable arrays need to be freed when they go out of scope.
10750 The allocatable components of pointers must not be touched. */
10751 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10752 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10753 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10756 sym
->attr
.referenced
= 1;
10757 e
= gfc_lval_expr_from_sym (sym
);
10758 gfc_add_finalizer_call (&cleanup
, e
);
10761 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10762 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10763 && !sym
->attr
.pointer
&& !sym
->attr
.save
10764 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10767 rank
= sym
->as
? sym
->as
->rank
: 0;
10768 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10769 gfc_add_expr_to_block (&cleanup
, tmp
);
10772 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10773 && !sym
->attr
.save
&& !sym
->attr
.result
10774 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10777 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10778 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10779 NULL_TREE
, NULL_TREE
, true, e
,
10780 sym
->attr
.codimension
10781 ? GFC_CAF_COARRAY_DEREGISTER
10782 : GFC_CAF_COARRAY_NOCOARRAY
);
10785 gfc_add_expr_to_block (&cleanup
, tmp
);
10788 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10789 gfc_finish_block (&cleanup
));
10792 /************ Expression Walking Functions ******************/
10794 /* Walk a variable reference.
10796 Possible extension - multiple component subscripts.
10797 x(:,:) = foo%a(:)%b(:)
10799 forall (i=..., j=...)
10800 x(i,j) = foo%a(j)%b(i)
10802 This adds a fair amount of complexity because you need to deal with more
10803 than one ref. Maybe handle in a similar manner to vector subscripts.
10804 Maybe not worth the effort. */
10808 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10812 gfc_fix_class_refs (expr
);
10814 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10815 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10818 return gfc_walk_array_ref (ss
, expr
, ref
);
10823 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10829 for (; ref
; ref
= ref
->next
)
10831 if (ref
->type
== REF_SUBSTRING
)
10833 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10835 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10838 /* We're only interested in array sections from now on. */
10839 if (ref
->type
!= REF_ARRAY
)
10847 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10848 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10852 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10853 newss
->info
->data
.array
.ref
= ref
;
10855 /* Make sure array is the same as array(:,:), this way
10856 we don't need to special case all the time. */
10857 ar
->dimen
= ar
->as
->rank
;
10858 for (n
= 0; n
< ar
->dimen
; n
++)
10860 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10862 gcc_assert (ar
->start
[n
] == NULL
);
10863 gcc_assert (ar
->end
[n
] == NULL
);
10864 gcc_assert (ar
->stride
[n
] == NULL
);
10870 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10871 newss
->info
->data
.array
.ref
= ref
;
10873 /* We add SS chains for all the subscripts in the section. */
10874 for (n
= 0; n
< ar
->dimen
; n
++)
10878 switch (ar
->dimen_type
[n
])
10880 case DIMEN_ELEMENT
:
10881 /* Add SS for elemental (scalar) subscripts. */
10882 gcc_assert (ar
->start
[n
]);
10883 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10884 indexss
->loop_chain
= gfc_ss_terminator
;
10885 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10889 /* We don't add anything for sections, just remember this
10890 dimension for later. */
10891 newss
->dim
[newss
->dimen
] = n
;
10896 /* Create a GFC_SS_VECTOR index in which we can store
10897 the vector's descriptor. */
10898 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10900 indexss
->loop_chain
= gfc_ss_terminator
;
10901 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10902 newss
->dim
[newss
->dimen
] = n
;
10907 /* We should know what sort of section it is by now. */
10908 gcc_unreachable ();
10911 /* We should have at least one non-elemental dimension,
10912 unless we are creating a descriptor for a (scalar) coarray. */
10913 gcc_assert (newss
->dimen
> 0
10914 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10919 /* We should know what sort of section it is by now. */
10920 gcc_unreachable ();
10928 /* Walk an expression operator. If only one operand of a binary expression is
10929 scalar, we must also add the scalar term to the SS chain. */
10932 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10937 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10938 if (expr
->value
.op
.op2
== NULL
)
10941 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10943 /* All operands are scalar. Pass back and let the caller deal with it. */
10947 /* All operands require scalarization. */
10948 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10951 /* One of the operands needs scalarization, the other is scalar.
10952 Create a gfc_ss for the scalar expression. */
10955 /* First operand is scalar. We build the chain in reverse order, so
10956 add the scalar SS after the second operand. */
10958 while (head
&& head
->next
!= ss
)
10960 /* Check we haven't somehow broken the chain. */
10962 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10964 else /* head2 == head */
10966 gcc_assert (head2
== head
);
10967 /* Second operand is scalar. */
10968 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10975 /* Reverse a SS chain. */
10978 gfc_reverse_ss (gfc_ss
* ss
)
10983 gcc_assert (ss
!= NULL
);
10985 head
= gfc_ss_terminator
;
10986 while (ss
!= gfc_ss_terminator
)
10989 /* Check we didn't somehow break the chain. */
10990 gcc_assert (next
!= NULL
);
11000 /* Given an expression referring to a procedure, return the symbol of its
11001 interface. We can't get the procedure symbol directly as we have to handle
11002 the case of (deferred) type-bound procedures. */
11005 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
11010 if (procedure_ref
== NULL
)
11013 /* Normal procedure case. */
11014 if (procedure_ref
->expr_type
== EXPR_FUNCTION
11015 && procedure_ref
->value
.function
.esym
)
11016 sym
= procedure_ref
->value
.function
.esym
;
11018 sym
= procedure_ref
->symtree
->n
.sym
;
11020 /* Typebound procedure case. */
11021 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
11023 if (ref
->type
== REF_COMPONENT
11024 && ref
->u
.c
.component
->attr
.proc_pointer
)
11025 sym
= ref
->u
.c
.component
->ts
.interface
;
11034 /* Walk the arguments of an elemental function.
11035 PROC_EXPR is used to check whether an argument is permitted to be absent. If
11036 it is NULL, we don't do the check and the argument is assumed to be present.
11040 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
11041 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
11043 gfc_formal_arglist
*dummy_arg
;
11049 head
= gfc_ss_terminator
;
11053 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
11058 for (; arg
; arg
= arg
->next
)
11060 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
11061 goto loop_continue
;
11063 newss
= gfc_walk_subexpr (head
, arg
->expr
);
11066 /* Scalar argument. */
11067 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
11068 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
11069 newss
->info
->type
= type
;
11071 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
11076 if (dummy_arg
!= NULL
11077 && dummy_arg
->sym
->attr
.optional
11078 && arg
->expr
->expr_type
== EXPR_VARIABLE
11079 && (gfc_expr_attr (arg
->expr
).optional
11080 || gfc_expr_attr (arg
->expr
).allocatable
11081 || gfc_expr_attr (arg
->expr
).pointer
))
11082 newss
->info
->can_be_null_ref
= true;
11088 while (tail
->next
!= gfc_ss_terminator
)
11093 if (dummy_arg
!= NULL
)
11094 dummy_arg
= dummy_arg
->next
;
11099 /* If all the arguments are scalar we don't need the argument SS. */
11100 gfc_free_ss_chain (head
);
11101 /* Pass it back. */
11105 /* Add it onto the existing chain. */
11111 /* Walk a function call. Scalar functions are passed back, and taken out of
11112 scalarization loops. For elemental functions we walk their arguments.
11113 The result of functions returning arrays is stored in a temporary outside
11114 the loop, so that the function is only called once. Hence we do not need
11115 to walk their arguments. */
11118 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
11120 gfc_intrinsic_sym
*isym
;
11122 gfc_component
*comp
= NULL
;
11124 isym
= expr
->value
.function
.isym
;
11126 /* Handle intrinsic functions separately. */
11128 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
11130 sym
= expr
->value
.function
.esym
;
11132 sym
= expr
->symtree
->n
.sym
;
11134 if (gfc_is_class_array_function (expr
))
11135 return gfc_get_array_ss (ss
, expr
,
11136 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
11139 /* A function that returns arrays. */
11140 comp
= gfc_get_proc_ptr_comp (expr
);
11141 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
11142 || (comp
&& comp
->attr
.dimension
))
11143 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
11145 /* Walk the parameters of an elemental function. For now we always pass
11147 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
11149 gfc_ss
*old_ss
= ss
;
11151 ss
= gfc_walk_elemental_function_args (old_ss
,
11152 expr
->value
.function
.actual
,
11153 gfc_get_proc_ifc_for_expr (expr
),
11157 || sym
->attr
.proc_pointer
11158 || sym
->attr
.if_source
!= IFSRC_DECL
11159 || sym
->attr
.array_outer_dependency
))
11160 ss
->info
->array_outer_dependency
= 1;
11163 /* Scalar functions are OK as these are evaluated outside the scalarization
11164 loop. Pass back and let the caller deal with it. */
11169 /* An array temporary is constructed for array constructors. */
11172 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
11174 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
11178 /* Walk an expression. Add walked expressions to the head of the SS chain.
11179 A wholly scalar expression will not be added. */
11182 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
11186 switch (expr
->expr_type
)
11188 case EXPR_VARIABLE
:
11189 head
= gfc_walk_variable_expr (ss
, expr
);
11193 head
= gfc_walk_op_expr (ss
, expr
);
11196 case EXPR_FUNCTION
:
11197 head
= gfc_walk_function_expr (ss
, expr
);
11200 case EXPR_CONSTANT
:
11202 case EXPR_STRUCTURE
:
11203 /* Pass back and let the caller deal with it. */
11207 head
= gfc_walk_array_constructor (ss
, expr
);
11210 case EXPR_SUBSTRING
:
11211 /* Pass back and let the caller deal with it. */
11215 gfc_internal_error ("bad expression type during walk (%d)",
11222 /* Entry point for expression walking.
11223 A return value equal to the passed chain means this is
11224 a scalar expression. It is up to the caller to take whatever action is
11225 necessary to translate these. */
11228 gfc_walk_expr (gfc_expr
* expr
)
11232 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
11233 return gfc_reverse_ss (res
);