1 /* Array translation routines
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
80 #include "coretypes.h"
84 #include "gimple-expr.h"
86 #include "fold-const.h"
87 #include "constructor.h"
88 #include "trans-types.h"
89 #include "trans-array.h"
90 #include "trans-const.h"
91 #include "dependency.h"
93 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
95 /* The contents of this structure aren't actually used, just the address. */
96 static gfc_ss gfc_ss_terminator_var
;
97 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
101 gfc_array_dataptr_type (tree desc
)
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
107 /* Build expressions to access the members of an array descriptor.
108 It's surprisingly easy to mess up here, so never access
109 an array descriptor by "brute force", always use these
110 functions. This also avoids problems if we change the format
111 of an array descriptor.
113 To understand these magic numbers, look at the comments
114 before gfc_build_array_type() in trans-types.c.
116 The code within these defines should be the only code which knows the format
117 of an array descriptor.
119 Any code just needing to read obtain the bounds of an array should use
120 gfc_conv_array_* rather than the following functions as these will return
121 know constant values, and work with arrays which do not have descriptors.
123 Don't forget to #undef these! */
126 #define OFFSET_FIELD 1
127 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 4
130 #define CAF_TOKEN_FIELD 5
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc
)
144 type
= TREE_TYPE (desc
);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
147 field
= TYPE_FIELDS (type
);
148 gcc_assert (DATA_FIELD
== 0);
150 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
152 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
157 /* This provides WRITE access to the data field.
159 TUPLES_P is true if we are generating tuples.
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
166 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
170 type
= TREE_TYPE (desc
);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
173 field
= TYPE_FIELDS (type
);
174 gcc_assert (DATA_FIELD
== 0);
176 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
178 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc
)
190 type
= TREE_TYPE (desc
);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
193 field
= TYPE_FIELDS (type
);
194 gcc_assert (DATA_FIELD
== 0);
196 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
198 return gfc_build_addr_expr (NULL_TREE
, t
);
202 gfc_conv_descriptor_offset (tree desc
)
207 type
= TREE_TYPE (desc
);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
210 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
211 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
213 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
214 desc
, field
, NULL_TREE
);
218 gfc_conv_descriptor_offset_get (tree desc
)
220 return gfc_conv_descriptor_offset (desc
);
224 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
227 tree t
= gfc_conv_descriptor_offset (desc
);
228 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
233 gfc_conv_descriptor_dtype (tree desc
)
238 type
= TREE_TYPE (desc
);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
241 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
242 gcc_assert (field
!= NULL_TREE
243 && TREE_TYPE (field
) == get_dtype_type_node ());
245 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
246 desc
, field
, NULL_TREE
);
250 gfc_conv_descriptor_span (tree desc
)
255 type
= TREE_TYPE (desc
);
256 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
258 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
259 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
261 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
262 desc
, field
, NULL_TREE
);
266 gfc_conv_descriptor_span_get (tree desc
)
268 return gfc_conv_descriptor_span (desc
);
272 gfc_conv_descriptor_span_set (stmtblock_t
*block
, tree desc
,
275 tree t
= gfc_conv_descriptor_span (desc
);
276 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
281 gfc_conv_descriptor_rank (tree desc
)
286 dtype
= gfc_conv_descriptor_dtype (desc
);
287 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)), GFC_DTYPE_RANK
);
288 gcc_assert (tmp
!= NULL_TREE
289 && TREE_TYPE (tmp
) == signed_char_type_node
);
290 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
291 dtype
, tmp
, NULL_TREE
);
296 gfc_get_descriptor_dimension (tree desc
)
300 type
= TREE_TYPE (desc
);
301 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
303 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
304 gcc_assert (field
!= NULL_TREE
305 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
306 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
308 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
309 desc
, field
, NULL_TREE
);
314 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
318 tmp
= gfc_get_descriptor_dimension (desc
);
320 return gfc_build_array_ref (tmp
, dim
, NULL
);
325 gfc_conv_descriptor_token (tree desc
)
330 type
= TREE_TYPE (desc
);
331 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
332 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
333 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
335 /* Should be a restricted pointer - except in the finalization wrapper. */
336 gcc_assert (field
!= NULL_TREE
337 && (TREE_TYPE (field
) == prvoid_type_node
338 || TREE_TYPE (field
) == pvoid_type_node
));
340 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
341 desc
, field
, NULL_TREE
);
346 gfc_conv_descriptor_stride (tree desc
, tree dim
)
351 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
352 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
353 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
354 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
356 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
357 tmp
, field
, NULL_TREE
);
362 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
364 tree type
= TREE_TYPE (desc
);
365 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
366 if (integer_zerop (dim
)
367 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
368 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
369 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
370 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
371 return gfc_index_one_node
;
373 return gfc_conv_descriptor_stride (desc
, dim
);
377 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
378 tree dim
, tree value
)
380 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
381 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
385 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
390 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
391 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
392 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
393 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
395 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
396 tmp
, field
, NULL_TREE
);
401 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
403 return gfc_conv_descriptor_lbound (desc
, dim
);
407 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
408 tree dim
, tree value
)
410 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
411 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
415 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
420 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
421 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
422 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
423 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
425 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
426 tmp
, field
, NULL_TREE
);
431 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
433 return gfc_conv_descriptor_ubound (desc
, dim
);
437 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
438 tree dim
, tree value
)
440 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
441 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
444 /* Build a null array descriptor constructor. */
447 gfc_build_null_descriptor (tree type
)
452 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
453 gcc_assert (DATA_FIELD
== 0);
454 field
= TYPE_FIELDS (type
);
456 /* Set a NULL data pointer. */
457 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
458 TREE_CONSTANT (tmp
) = 1;
459 /* All other fields are ignored. */
465 /* Modify a descriptor such that the lbound of a given dimension is the value
466 specified. This also updates ubound and offset accordingly. */
469 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
470 int dim
, tree new_lbound
)
472 tree offs
, ubound
, lbound
, stride
;
473 tree diff
, offs_diff
;
475 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
477 offs
= gfc_conv_descriptor_offset_get (desc
);
478 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
479 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
480 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
482 /* Get difference (new - old) by which to shift stuff. */
483 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
486 /* Shift ubound and offset accordingly. This has to be done before
487 updating the lbound, as they depend on the lbound expression! */
488 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
490 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
491 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
493 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
495 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
497 /* Finally set lbound to value we want. */
498 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
502 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
505 gfc_get_descriptor_offsets_for_info (const_tree desc_type
, tree
*data_off
,
506 tree
*dtype_off
, tree
*dim_off
,
507 tree
*dim_size
, tree
*stride_suboff
,
508 tree
*lower_suboff
, tree
*upper_suboff
)
513 type
= TYPE_MAIN_VARIANT (desc_type
);
514 field
= gfc_advance_chain (TYPE_FIELDS (type
), DATA_FIELD
);
515 *data_off
= byte_position (field
);
516 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
517 *dtype_off
= byte_position (field
);
518 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
519 *dim_off
= byte_position (field
);
520 type
= TREE_TYPE (TREE_TYPE (field
));
521 *dim_size
= TYPE_SIZE_UNIT (type
);
522 field
= gfc_advance_chain (TYPE_FIELDS (type
), STRIDE_SUBFIELD
);
523 *stride_suboff
= byte_position (field
);
524 field
= gfc_advance_chain (TYPE_FIELDS (type
), LBOUND_SUBFIELD
);
525 *lower_suboff
= byte_position (field
);
526 field
= gfc_advance_chain (TYPE_FIELDS (type
), UBOUND_SUBFIELD
);
527 *upper_suboff
= byte_position (field
);
531 /* Cleanup those #defines. */
537 #undef DIMENSION_FIELD
538 #undef CAF_TOKEN_FIELD
539 #undef STRIDE_SUBFIELD
540 #undef LBOUND_SUBFIELD
541 #undef UBOUND_SUBFIELD
544 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
545 flags & 1 = Main loop body.
546 flags & 2 = temp copy loop. */
549 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
551 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
552 ss
->info
->useflags
= flags
;
556 /* Free a gfc_ss chain. */
559 gfc_free_ss_chain (gfc_ss
* ss
)
563 while (ss
!= gfc_ss_terminator
)
565 gcc_assert (ss
!= NULL
);
574 free_ss_info (gfc_ss_info
*ss_info
)
579 if (ss_info
->refcount
> 0)
582 gcc_assert (ss_info
->refcount
== 0);
584 switch (ss_info
->type
)
587 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
588 if (ss_info
->data
.array
.subscript
[n
])
589 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
603 gfc_free_ss (gfc_ss
* ss
)
605 free_ss_info (ss
->info
);
610 /* Creates and initializes an array type gfc_ss struct. */
613 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
616 gfc_ss_info
*ss_info
;
619 ss_info
= gfc_get_ss_info ();
621 ss_info
->type
= type
;
622 ss_info
->expr
= expr
;
628 for (i
= 0; i
< ss
->dimen
; i
++)
635 /* Creates and initializes a temporary type gfc_ss struct. */
638 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
641 gfc_ss_info
*ss_info
;
644 ss_info
= gfc_get_ss_info ();
646 ss_info
->type
= GFC_SS_TEMP
;
647 ss_info
->string_length
= string_length
;
648 ss_info
->data
.temp
.type
= type
;
652 ss
->next
= gfc_ss_terminator
;
654 for (i
= 0; i
< ss
->dimen
; i
++)
661 /* Creates and initializes a scalar type gfc_ss struct. */
664 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
667 gfc_ss_info
*ss_info
;
669 ss_info
= gfc_get_ss_info ();
671 ss_info
->type
= GFC_SS_SCALAR
;
672 ss_info
->expr
= expr
;
682 /* Free all the SS associated with a loop. */
685 gfc_cleanup_loop (gfc_loopinfo
* loop
)
687 gfc_loopinfo
*loop_next
, **ploop
;
692 while (ss
!= gfc_ss_terminator
)
694 gcc_assert (ss
!= NULL
);
695 next
= ss
->loop_chain
;
700 /* Remove reference to self in the parent loop. */
702 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
709 /* Free non-freed nested loops. */
710 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
712 loop_next
= loop
->next
;
713 gfc_cleanup_loop (loop
);
720 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
724 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
728 if (ss
->info
->type
== GFC_SS_SCALAR
729 || ss
->info
->type
== GFC_SS_REFERENCE
730 || ss
->info
->type
== GFC_SS_TEMP
)
733 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
734 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
735 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
740 /* Associate a SS chain with a loop. */
743 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
746 gfc_loopinfo
*nested_loop
;
748 if (head
== gfc_ss_terminator
)
751 set_ss_loop (head
, loop
);
754 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
758 nested_loop
= ss
->nested_ss
->loop
;
760 /* More than one ss can belong to the same loop. Hence, we add the
761 loop to the chain only if it is different from the previously
762 added one, to avoid duplicate nested loops. */
763 if (nested_loop
!= loop
->nested
)
765 gcc_assert (nested_loop
->parent
== NULL
);
766 nested_loop
->parent
= loop
;
768 gcc_assert (nested_loop
->next
== NULL
);
769 nested_loop
->next
= loop
->nested
;
770 loop
->nested
= nested_loop
;
773 gcc_assert (nested_loop
->parent
== loop
);
776 if (ss
->next
== gfc_ss_terminator
)
777 ss
->loop_chain
= loop
->ss
;
779 ss
->loop_chain
= ss
->next
;
781 gcc_assert (ss
== gfc_ss_terminator
);
786 /* Returns true if the expression is an array pointer. */
789 is_pointer_array (tree expr
)
791 if (expr
== NULL_TREE
792 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr
))
793 || GFC_CLASS_TYPE_P (TREE_TYPE (expr
)))
796 if (TREE_CODE (expr
) == VAR_DECL
797 && GFC_DECL_PTR_ARRAY_P (expr
))
800 if (TREE_CODE (expr
) == PARM_DECL
801 && GFC_DECL_PTR_ARRAY_P (expr
))
804 if (TREE_CODE (expr
) == INDIRECT_REF
805 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 0)))
808 /* The field declaration is marked as an pointer array. */
809 if (TREE_CODE (expr
) == COMPONENT_REF
810 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 1))
811 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr
, 1))))
818 /* Return the span of an array. */
821 gfc_get_array_span (tree desc
, gfc_expr
*expr
)
825 if (is_pointer_array (desc
))
826 /* This will have the span field set. */
827 tmp
= gfc_conv_descriptor_span_get (desc
);
828 else if (TREE_CODE (desc
) == COMPONENT_REF
829 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
830 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
832 /* The descriptor is a class _data field and so use the vtable
833 size for the receiving span field. */
834 tmp
= gfc_get_vptr_from_expr (desc
);
835 tmp
= gfc_vptr_size_get (tmp
);
837 else if (expr
&& expr
->expr_type
== EXPR_VARIABLE
838 && expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
839 && expr
->ref
->type
== REF_COMPONENT
840 && expr
->ref
->next
->type
== REF_ARRAY
841 && expr
->ref
->next
->next
== NULL
842 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.dimension
)
844 /* Dummys come in sometimes with the descriptor detached from
845 the class field or declaration. */
846 tmp
= gfc_class_vptr_get (expr
->symtree
->n
.sym
->backend_decl
);
847 tmp
= gfc_vptr_size_get (tmp
);
851 /* If none of the fancy stuff works, the span is the element
852 size of the array. Attempt to deal with unbounded character
853 types if possible. Otherwise, return NULL_TREE. */
854 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
855 if (tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
856 && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) == NULL_TREE
857 || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)))))
859 if (expr
->expr_type
== EXPR_VARIABLE
860 && expr
->ts
.type
== BT_CHARACTER
)
861 tmp
= fold_convert (gfc_array_index_type
,
862 gfc_get_expr_charlen (expr
));
867 tmp
= fold_convert (gfc_array_index_type
,
868 size_in_bytes (tmp
));
874 /* Generate an initializer for a static pointer or allocatable array. */
877 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
881 gcc_assert (TREE_STATIC (sym
->backend_decl
));
882 /* Just zero the data member. */
883 type
= TREE_TYPE (sym
->backend_decl
);
884 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
888 /* If the bounds of SE's loop have not yet been set, see if they can be
889 determined from array spec AS, which is the array spec of a called
890 function. MAPPING maps the callee's dummy arguments to the values
891 that the caller is passing. Add any initialization and finalization
895 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
896 gfc_se
* se
, gfc_array_spec
* as
)
898 int n
, dim
, total_dim
;
907 if (!as
|| as
->type
!= AS_EXPLICIT
)
910 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
912 total_dim
+= ss
->loop
->dimen
;
913 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
915 /* The bound is known, nothing to do. */
916 if (ss
->loop
->to
[n
] != NULL_TREE
)
920 gcc_assert (dim
< as
->rank
);
921 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
923 /* Evaluate the lower bound. */
924 gfc_init_se (&tmpse
, NULL
);
925 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
926 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
927 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
928 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
930 /* ...and the upper bound. */
931 gfc_init_se (&tmpse
, NULL
);
932 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
933 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
934 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
935 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
937 /* Set the upper bound of the loop to UPPER - LOWER. */
938 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
939 gfc_array_index_type
, upper
, lower
);
940 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
941 ss
->loop
->to
[n
] = tmp
;
945 gcc_assert (total_dim
== as
->rank
);
949 /* Generate code to allocate an array temporary, or create a variable to
950 hold the data. If size is NULL, zero the descriptor so that the
951 callee will allocate the array. If DEALLOC is true, also generate code to
952 free the array afterwards.
954 If INITIAL is not NULL, it is packed using internal_pack and the result used
955 as data instead of allocating a fresh, unitialized area of memory.
957 Initialization code is added to PRE and finalization code to POST.
958 DYNAMIC is true if the caller may want to extend the array later
959 using realloc. This prevents us from putting the array on the stack. */
962 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
963 gfc_array_info
* info
, tree size
, tree nelem
,
964 tree initial
, bool dynamic
, bool dealloc
)
970 desc
= info
->descriptor
;
971 info
->offset
= gfc_index_zero_node
;
972 if (size
== NULL_TREE
|| integer_zerop (size
))
974 /* A callee allocated array. */
975 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
980 /* Allocate the temporary. */
981 onstack
= !dynamic
&& initial
== NULL_TREE
982 && (flag_stack_arrays
983 || gfc_can_put_var_on_stack (size
));
987 /* Make a temporary variable to hold the data. */
988 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
989 nelem
, gfc_index_one_node
);
990 tmp
= gfc_evaluate_now (tmp
, pre
);
991 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
993 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
995 tmp
= gfc_create_var (tmp
, "A");
996 /* If we're here only because of -fstack-arrays we have to
997 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
998 if (!gfc_can_put_var_on_stack (size
))
999 gfc_add_expr_to_block (pre
,
1000 fold_build1_loc (input_location
,
1001 DECL_EXPR
, TREE_TYPE (tmp
),
1003 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1004 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1008 /* Allocate memory to hold the data or call internal_pack. */
1009 if (initial
== NULL_TREE
)
1011 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1012 tmp
= gfc_evaluate_now (tmp
, pre
);
1019 stmtblock_t do_copying
;
1021 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1022 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1023 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1024 tmp
= gfc_get_element_type (tmp
);
1025 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1026 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1028 tmp
= build_call_expr_loc (input_location
,
1029 gfor_fndecl_in_pack
, 1, initial
);
1030 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1031 gfc_add_modify (pre
, packed
, tmp
);
1033 tmp
= build_fold_indirect_ref_loc (input_location
,
1035 source_data
= gfc_conv_descriptor_data_get (tmp
);
1037 /* internal_pack may return source->data without any allocation
1038 or copying if it is already packed. If that's the case, we
1039 need to allocate and copy manually. */
1041 gfc_start_block (&do_copying
);
1042 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1043 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1044 gfc_add_modify (&do_copying
, packed
, tmp
);
1045 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1046 gfc_add_expr_to_block (&do_copying
, tmp
);
1048 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1049 logical_type_node
, packed
,
1051 tmp
= gfc_finish_block (&do_copying
);
1052 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1053 build_empty_stmt (input_location
));
1054 gfc_add_expr_to_block (pre
, tmp
);
1056 tmp
= fold_convert (pvoid_type_node
, packed
);
1059 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1062 info
->data
= gfc_conv_descriptor_data_get (desc
);
1064 /* The offset is zero because we create temporaries with a zero
1066 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1068 if (dealloc
&& !onstack
)
1070 /* Free the temporary. */
1071 tmp
= gfc_conv_descriptor_data_get (desc
);
1072 tmp
= gfc_call_free (tmp
);
1073 gfc_add_expr_to_block (post
, tmp
);
1078 /* Get the scalarizer array dimension corresponding to actual array dimension
1081 For example, if SS represents the array ref a(1,:,:,1), it is a
1082 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1083 and 1 for ARRAY_DIM=2.
1084 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1085 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1087 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1088 array. If called on the inner ss, the result would be respectively 0,1,2 for
1089 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1090 for ARRAY_DIM=1,2. */
1093 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1100 for (; ss
; ss
= ss
->parent
)
1101 for (n
= 0; n
< ss
->dimen
; n
++)
1102 if (ss
->dim
[n
] < array_dim
)
1105 return array_ref_dim
;
1110 innermost_ss (gfc_ss
*ss
)
1112 while (ss
->nested_ss
!= NULL
)
1120 /* Get the array reference dimension corresponding to the given loop dimension.
1121 It is different from the true array dimension given by the dim array in
1122 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1123 It is different from the loop dimension in the case of a transposed array.
1127 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1129 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1134 /* Generate code to create and initialize the descriptor for a temporary
1135 array. This is used for both temporaries needed by the scalarizer, and
1136 functions returning arrays. Adjusts the loop variables to be
1137 zero-based, and calculates the loop bounds for callee allocated arrays.
1138 Allocate the array unless it's callee allocated (we have a callee
1139 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1140 NULL_TREE for any n). Also fills in the descriptor, data and offset
1141 fields of info if known. Returns the size of the array, or NULL for a
1142 callee allocated array.
1144 'eltype' == NULL signals that the temporary should be a class object.
1145 The 'initial' expression is used to obtain the size of the dynamic
1146 type; otherwise the allocation and initialization proceeds as for any
1149 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1150 gfc_trans_allocate_array_storage. */
1153 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1154 tree eltype
, tree initial
, bool dynamic
,
1155 bool dealloc
, bool callee_alloc
, locus
* where
)
1159 gfc_array_info
*info
;
1160 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1168 tree class_expr
= NULL_TREE
;
1169 int n
, dim
, tmp_dim
;
1172 /* This signals a class array for which we need the size of the
1173 dynamic type. Generate an eltype and then the class expression. */
1174 if (eltype
== NULL_TREE
&& initial
)
1176 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1177 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1178 eltype
= TREE_TYPE (class_expr
);
1179 eltype
= gfc_get_element_type (eltype
);
1180 /* Obtain the structure (class) expression. */
1181 class_expr
= TREE_OPERAND (class_expr
, 0);
1182 gcc_assert (class_expr
);
1185 memset (from
, 0, sizeof (from
));
1186 memset (to
, 0, sizeof (to
));
1188 info
= &ss
->info
->data
.array
;
1190 gcc_assert (ss
->dimen
> 0);
1191 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1193 if (warn_array_temporaries
&& where
)
1194 gfc_warning (OPT_Warray_temporaries
,
1195 "Creating array temporary at %L", where
);
1197 /* Set the lower bound to zero. */
1198 for (s
= ss
; s
; s
= s
->parent
)
1202 total_dim
+= loop
->dimen
;
1203 for (n
= 0; n
< loop
->dimen
; n
++)
1207 /* Callee allocated arrays may not have a known bound yet. */
1209 loop
->to
[n
] = gfc_evaluate_now (
1210 fold_build2_loc (input_location
, MINUS_EXPR
,
1211 gfc_array_index_type
,
1212 loop
->to
[n
], loop
->from
[n
]),
1214 loop
->from
[n
] = gfc_index_zero_node
;
1216 /* We have just changed the loop bounds, we must clear the
1217 corresponding specloop, so that delta calculation is not skipped
1218 later in gfc_set_delta. */
1219 loop
->specloop
[n
] = NULL
;
1221 /* We are constructing the temporary's descriptor based on the loop
1222 dimensions. As the dimensions may be accessed in arbitrary order
1223 (think of transpose) the size taken from the n'th loop may not map
1224 to the n'th dimension of the array. We need to reconstruct loop
1225 infos in the right order before using it to set the descriptor
1227 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1228 from
[tmp_dim
] = loop
->from
[n
];
1229 to
[tmp_dim
] = loop
->to
[n
];
1231 info
->delta
[dim
] = gfc_index_zero_node
;
1232 info
->start
[dim
] = gfc_index_zero_node
;
1233 info
->end
[dim
] = gfc_index_zero_node
;
1234 info
->stride
[dim
] = gfc_index_one_node
;
1238 /* Initialize the descriptor. */
1240 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1241 GFC_ARRAY_UNKNOWN
, true);
1242 desc
= gfc_create_var (type
, "atmp");
1243 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1245 info
->descriptor
= desc
;
1246 size
= gfc_index_one_node
;
1248 /* Emit a DECL_EXPR for the variable sized array type in
1249 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1250 sizes works correctly. */
1251 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1252 if (! TYPE_NAME (arraytype
))
1253 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1254 NULL_TREE
, arraytype
);
1255 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1256 arraytype
, TYPE_NAME (arraytype
)));
1258 /* Fill in the array dtype. */
1259 tmp
= gfc_conv_descriptor_dtype (desc
);
1260 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1263 Fill in the bounds and stride. This is a packed array, so:
1266 for (n = 0; n < rank; n++)
1269 delta = ubound[n] + 1 - lbound[n];
1270 size = size * delta;
1272 size = size * sizeof(element);
1275 or_expr
= NULL_TREE
;
1277 /* If there is at least one null loop->to[n], it is a callee allocated
1279 for (n
= 0; n
< total_dim
; n
++)
1280 if (to
[n
] == NULL_TREE
)
1286 if (size
== NULL_TREE
)
1287 for (s
= ss
; s
; s
= s
->parent
)
1288 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1290 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1292 /* For a callee allocated array express the loop bounds in terms
1293 of the descriptor fields. */
1294 tmp
= fold_build2_loc (input_location
,
1295 MINUS_EXPR
, gfc_array_index_type
,
1296 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1297 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1298 s
->loop
->to
[n
] = tmp
;
1302 for (n
= 0; n
< total_dim
; n
++)
1304 /* Store the stride and bound components in the descriptor. */
1305 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1307 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1308 gfc_index_zero_node
);
1310 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1312 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1313 gfc_array_index_type
,
1314 to
[n
], gfc_index_one_node
);
1316 /* Check whether the size for this dimension is negative. */
1317 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1318 tmp
, gfc_index_zero_node
);
1319 cond
= gfc_evaluate_now (cond
, pre
);
1324 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1325 logical_type_node
, or_expr
, cond
);
1327 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1328 gfc_array_index_type
, size
, tmp
);
1329 size
= gfc_evaluate_now (size
, pre
);
1333 /* Get the size of the array. */
1334 if (size
&& !callee_alloc
)
1337 /* If or_expr is true, then the extent in at least one
1338 dimension is zero and the size is set to zero. */
1339 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1340 or_expr
, gfc_index_zero_node
, size
);
1343 if (class_expr
== NULL_TREE
)
1344 elemsize
= fold_convert (gfc_array_index_type
,
1345 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1347 elemsize
= gfc_class_vtab_size_get (class_expr
);
1349 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1358 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1364 if (ss
->dimen
> ss
->loop
->temp_dim
)
1365 ss
->loop
->temp_dim
= ss
->dimen
;
1371 /* Return the number of iterations in a loop that starts at START,
1372 ends at END, and has step STEP. */
1375 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1380 type
= TREE_TYPE (step
);
1381 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1382 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1383 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1384 build_int_cst (type
, 1));
1385 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1386 build_int_cst (type
, 0));
1387 return fold_convert (gfc_array_index_type
, tmp
);
1391 /* Extend the data in array DESC by EXTRA elements. */
1394 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1401 if (integer_zerop (extra
))
1404 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1406 /* Add EXTRA to the upper bound. */
1407 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1409 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1411 /* Get the value of the current data pointer. */
1412 arg0
= gfc_conv_descriptor_data_get (desc
);
1414 /* Calculate the new array size. */
1415 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1416 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1417 ubound
, gfc_index_one_node
);
1418 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1419 fold_convert (size_type_node
, tmp
),
1420 fold_convert (size_type_node
, size
));
1422 /* Call the realloc() function. */
1423 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1424 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1428 /* Return true if the bounds of iterator I can only be determined
1432 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1434 return (i
->start
->expr_type
!= EXPR_CONSTANT
1435 || i
->end
->expr_type
!= EXPR_CONSTANT
1436 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1440 /* Split the size of constructor element EXPR into the sum of two terms,
1441 one of which can be determined at compile time and one of which must
1442 be calculated at run time. Set *SIZE to the former and return true
1443 if the latter might be nonzero. */
1446 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1448 if (expr
->expr_type
== EXPR_ARRAY
)
1449 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1450 else if (expr
->rank
> 0)
1452 /* Calculate everything at run time. */
1453 mpz_set_ui (*size
, 0);
1458 /* A single element. */
1459 mpz_set_ui (*size
, 1);
1465 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1466 of array constructor C. */
1469 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1477 mpz_set_ui (*size
, 0);
1482 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1485 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1489 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1492 /* Multiply the static part of the element size by the
1493 number of iterations. */
1494 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1495 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1496 mpz_add_ui (val
, val
, 1);
1497 if (mpz_sgn (val
) > 0)
1498 mpz_mul (len
, len
, val
);
1500 mpz_set_ui (len
, 0);
1502 mpz_add (*size
, *size
, len
);
1511 /* Make sure offset is a variable. */
1514 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1517 /* We should have already created the offset variable. We cannot
1518 create it here because we may be in an inner scope. */
1519 gcc_assert (*offsetvar
!= NULL_TREE
);
1520 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1521 *poffset
= *offsetvar
;
1522 TREE_USED (*offsetvar
) = 1;
1526 /* Variables needed for bounds-checking. */
1527 static bool first_len
;
1528 static tree first_len_val
;
1529 static bool typespec_chararray_ctor
;
1532 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1533 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1537 gfc_conv_expr (se
, expr
);
1539 /* Store the value. */
1540 tmp
= build_fold_indirect_ref_loc (input_location
,
1541 gfc_conv_descriptor_data_get (desc
));
1542 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1544 if (expr
->ts
.type
== BT_CHARACTER
)
1546 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1549 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1550 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1551 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1552 TREE_TYPE (esize
), esize
,
1553 build_int_cst (TREE_TYPE (esize
),
1554 gfc_character_kinds
[i
].bit_size
/ 8));
1556 gfc_conv_string_parameter (se
);
1557 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1559 /* The temporary is an array of pointers. */
1560 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1561 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1565 /* The temporary is an array of string values. */
1566 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1567 /* We know the temporary and the value will be the same length,
1568 so can use memcpy. */
1569 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1570 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1572 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1576 gfc_add_modify (&se
->pre
, first_len_val
,
1577 fold_convert (TREE_TYPE (first_len_val
),
1578 se
->string_length
));
1583 /* Verify that all constructor elements are of the same
1585 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1587 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1588 logical_type_node
, first_len_val
,
1590 gfc_trans_runtime_check
1591 (true, false, cond
, &se
->pre
, &expr
->where
,
1592 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1593 fold_convert (long_integer_type_node
, first_len_val
),
1594 fold_convert (long_integer_type_node
, se
->string_length
));
1598 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1599 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1601 /* Assignment of a CLASS array constructor to a derived type array. */
1602 if (expr
->expr_type
== EXPR_FUNCTION
)
1603 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1604 se
->expr
= gfc_class_data_get (se
->expr
);
1605 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1606 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1607 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1611 /* TODO: Should the frontend already have done this conversion? */
1612 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1613 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1616 gfc_add_block_to_block (pblock
, &se
->pre
);
1617 gfc_add_block_to_block (pblock
, &se
->post
);
1621 /* Add the contents of an array to the constructor. DYNAMIC is as for
1622 gfc_trans_array_constructor_value. */
1625 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1626 tree type ATTRIBUTE_UNUSED
,
1627 tree desc
, gfc_expr
* expr
,
1628 tree
* poffset
, tree
* offsetvar
,
1639 /* We need this to be a variable so we can increment it. */
1640 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1642 gfc_init_se (&se
, NULL
);
1644 /* Walk the array expression. */
1645 ss
= gfc_walk_expr (expr
);
1646 gcc_assert (ss
!= gfc_ss_terminator
);
1648 /* Initialize the scalarizer. */
1649 gfc_init_loopinfo (&loop
);
1650 gfc_add_ss_to_loop (&loop
, ss
);
1652 /* Initialize the loop. */
1653 gfc_conv_ss_startstride (&loop
);
1654 gfc_conv_loop_setup (&loop
, &expr
->where
);
1656 /* Make sure the constructed array has room for the new data. */
1659 /* Set SIZE to the total number of elements in the subarray. */
1660 size
= gfc_index_one_node
;
1661 for (n
= 0; n
< loop
.dimen
; n
++)
1663 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1664 gfc_index_one_node
);
1665 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1666 gfc_array_index_type
, size
, tmp
);
1669 /* Grow the constructed array by SIZE elements. */
1670 gfc_grow_array (&loop
.pre
, desc
, size
);
1673 /* Make the loop body. */
1674 gfc_mark_ss_chain_used (ss
, 1);
1675 gfc_start_scalarized_body (&loop
, &body
);
1676 gfc_copy_loopinfo_to_se (&se
, &loop
);
1679 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1680 gcc_assert (se
.ss
== gfc_ss_terminator
);
1682 /* Increment the offset. */
1683 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1684 *poffset
, gfc_index_one_node
);
1685 gfc_add_modify (&body
, *poffset
, tmp
);
1687 /* Finish the loop. */
1688 gfc_trans_scalarizing_loops (&loop
, &body
);
1689 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1690 tmp
= gfc_finish_block (&loop
.pre
);
1691 gfc_add_expr_to_block (pblock
, tmp
);
1693 gfc_cleanup_loop (&loop
);
1697 /* Assign the values to the elements of an array constructor. DYNAMIC
1698 is true if descriptor DESC only contains enough data for the static
1699 size calculated by gfc_get_array_constructor_size. When true, memory
1700 for the dynamic parts must be allocated using realloc. */
1703 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1704 tree desc
, gfc_constructor_base base
,
1705 tree
* poffset
, tree
* offsetvar
,
1709 tree start
= NULL_TREE
;
1710 tree end
= NULL_TREE
;
1711 tree step
= NULL_TREE
;
1717 tree shadow_loopvar
= NULL_TREE
;
1718 gfc_saved_var saved_loopvar
;
1721 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1723 /* If this is an iterator or an array, the offset must be a variable. */
1724 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1725 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1727 /* Shadowing the iterator avoids changing its value and saves us from
1728 keeping track of it. Further, it makes sure that there's always a
1729 backend-decl for the symbol, even if there wasn't one before,
1730 e.g. in the case of an iterator that appears in a specification
1731 expression in an interface mapping. */
1737 /* Evaluate loop bounds before substituting the loop variable
1738 in case they depend on it. Such a case is invalid, but it is
1739 not more expensive to do the right thing here.
1741 gfc_init_se (&se
, NULL
);
1742 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1743 gfc_add_block_to_block (pblock
, &se
.pre
);
1744 start
= gfc_evaluate_now (se
.expr
, pblock
);
1746 gfc_init_se (&se
, NULL
);
1747 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1748 gfc_add_block_to_block (pblock
, &se
.pre
);
1749 end
= gfc_evaluate_now (se
.expr
, pblock
);
1751 gfc_init_se (&se
, NULL
);
1752 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1753 gfc_add_block_to_block (pblock
, &se
.pre
);
1754 step
= gfc_evaluate_now (se
.expr
, pblock
);
1756 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1757 type
= gfc_typenode_for_spec (&sym
->ts
);
1759 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1760 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1763 gfc_start_block (&body
);
1765 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1767 /* Array constructors can be nested. */
1768 gfc_trans_array_constructor_value (&body
, type
, desc
,
1769 c
->expr
->value
.constructor
,
1770 poffset
, offsetvar
, dynamic
);
1772 else if (c
->expr
->rank
> 0)
1774 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1775 poffset
, offsetvar
, dynamic
);
1779 /* This code really upsets the gimplifier so don't bother for now. */
1786 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1788 p
= gfc_constructor_next (p
);
1793 /* Scalar values. */
1794 gfc_init_se (&se
, NULL
);
1795 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1798 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1799 gfc_array_index_type
,
1800 *poffset
, gfc_index_one_node
);
1804 /* Collect multiple scalar constants into a constructor. */
1805 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1809 HOST_WIDE_INT idx
= 0;
1812 /* Count the number of consecutive scalar constants. */
1813 while (p
&& !(p
->iterator
1814 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1816 gfc_init_se (&se
, NULL
);
1817 gfc_conv_constant (&se
, p
->expr
);
1819 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1820 se
.expr
= fold_convert (type
, se
.expr
);
1821 /* For constant character array constructors we build
1822 an array of pointers. */
1823 else if (POINTER_TYPE_P (type
))
1824 se
.expr
= gfc_build_addr_expr
1825 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1828 CONSTRUCTOR_APPEND_ELT (v
,
1829 build_int_cst (gfc_array_index_type
,
1833 p
= gfc_constructor_next (p
);
1836 bound
= size_int (n
- 1);
1837 /* Create an array type to hold them. */
1838 tmptype
= build_range_type (gfc_array_index_type
,
1839 gfc_index_zero_node
, bound
);
1840 tmptype
= build_array_type (type
, tmptype
);
1842 init
= build_constructor (tmptype
, v
);
1843 TREE_CONSTANT (init
) = 1;
1844 TREE_STATIC (init
) = 1;
1845 /* Create a static variable to hold the data. */
1846 tmp
= gfc_create_var (tmptype
, "data");
1847 TREE_STATIC (tmp
) = 1;
1848 TREE_CONSTANT (tmp
) = 1;
1849 TREE_READONLY (tmp
) = 1;
1850 DECL_INITIAL (tmp
) = init
;
1853 /* Use BUILTIN_MEMCPY to assign the values. */
1854 tmp
= gfc_conv_descriptor_data_get (desc
);
1855 tmp
= build_fold_indirect_ref_loc (input_location
,
1857 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1858 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1859 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1861 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1862 bound
= build_int_cst (size_type_node
, n
* size
);
1863 tmp
= build_call_expr_loc (input_location
,
1864 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1865 3, tmp
, init
, bound
);
1866 gfc_add_expr_to_block (&body
, tmp
);
1868 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1869 gfc_array_index_type
, *poffset
,
1870 build_int_cst (gfc_array_index_type
, n
));
1872 if (!INTEGER_CST_P (*poffset
))
1874 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1875 *poffset
= *offsetvar
;
1879 /* The frontend should already have done any expansions
1883 /* Pass the code as is. */
1884 tmp
= gfc_finish_block (&body
);
1885 gfc_add_expr_to_block (pblock
, tmp
);
1889 /* Build the implied do-loop. */
1890 stmtblock_t implied_do_block
;
1896 loopbody
= gfc_finish_block (&body
);
1898 /* Create a new block that holds the implied-do loop. A temporary
1899 loop-variable is used. */
1900 gfc_start_block(&implied_do_block
);
1902 /* Initialize the loop. */
1903 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1905 /* If this array expands dynamically, and the number of iterations
1906 is not constant, we won't have allocated space for the static
1907 part of C->EXPR's size. Do that now. */
1908 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1910 /* Get the number of iterations. */
1911 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1913 /* Get the static part of C->EXPR's size. */
1914 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1915 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1917 /* Grow the array by TMP * TMP2 elements. */
1918 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1919 gfc_array_index_type
, tmp
, tmp2
);
1920 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1923 /* Generate the loop body. */
1924 exit_label
= gfc_build_label_decl (NULL_TREE
);
1925 gfc_start_block (&body
);
1927 /* Generate the exit condition. Depending on the sign of
1928 the step variable we have to generate the correct
1930 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1931 step
, build_int_cst (TREE_TYPE (step
), 0));
1932 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1933 logical_type_node
, tmp
,
1934 fold_build2_loc (input_location
, GT_EXPR
,
1935 logical_type_node
, shadow_loopvar
, end
),
1936 fold_build2_loc (input_location
, LT_EXPR
,
1937 logical_type_node
, shadow_loopvar
, end
));
1938 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1939 TREE_USED (exit_label
) = 1;
1940 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1941 build_empty_stmt (input_location
));
1942 gfc_add_expr_to_block (&body
, tmp
);
1944 /* The main loop body. */
1945 gfc_add_expr_to_block (&body
, loopbody
);
1947 /* Increase loop variable by step. */
1948 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1949 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1951 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1953 /* Finish the loop. */
1954 tmp
= gfc_finish_block (&body
);
1955 tmp
= build1_v (LOOP_EXPR
, tmp
);
1956 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1958 /* Add the exit label. */
1959 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1960 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1962 /* Finish the implied-do loop. */
1963 tmp
= gfc_finish_block(&implied_do_block
);
1964 gfc_add_expr_to_block(pblock
, tmp
);
1966 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1973 /* The array constructor code can create a string length with an operand
1974 in the form of a temporary variable. This variable will retain its
1975 context (current_function_decl). If we store this length tree in a
1976 gfc_charlen structure which is shared by a variable in another
1977 context, the resulting gfc_charlen structure with a variable in a
1978 different context, we could trip the assertion in expand_expr_real_1
1979 when it sees that a variable has been created in one context and
1980 referenced in another.
1982 If this might be the case, we create a new gfc_charlen structure and
1983 link it into the current namespace. */
1986 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1990 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1993 (*clp
)->backend_decl
= len
;
1996 /* A catch-all to obtain the string length for anything that is not
1997 a substring of non-constant length, a constant, array or variable. */
2000 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2004 /* Don't bother if we already know the length is a constant. */
2005 if (*len
&& INTEGER_CST_P (*len
))
2008 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2009 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2012 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2013 *len
= e
->ts
.u
.cl
->backend_decl
;
2017 /* Otherwise, be brutal even if inefficient. */
2018 gfc_init_se (&se
, NULL
);
2020 /* No function call, in case of side effects. */
2021 se
.no_function_call
= 1;
2023 gfc_conv_expr (&se
, e
);
2025 gfc_conv_expr_descriptor (&se
, e
);
2027 /* Fix the value. */
2028 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2030 gfc_add_block_to_block (block
, &se
.pre
);
2031 gfc_add_block_to_block (block
, &se
.post
);
2033 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2038 /* Figure out the string length of a variable reference expression.
2039 Used by get_array_ctor_strlen. */
2042 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2048 /* Don't bother if we already know the length is a constant. */
2049 if (*len
&& INTEGER_CST_P (*len
))
2052 ts
= &expr
->symtree
->n
.sym
->ts
;
2053 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2058 /* Array references don't change the string length. */
2062 /* Use the length of the component. */
2063 ts
= &ref
->u
.c
.component
->ts
;
2067 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2068 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2070 /* Note that this might evaluate expr. */
2071 get_array_ctor_all_strlen (block
, expr
, len
);
2074 mpz_init_set_ui (char_len
, 1);
2075 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2076 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2077 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2078 mpz_clear (char_len
);
2089 *len
= ts
->u
.cl
->backend_decl
;
2093 /* Figure out the string length of a character array constructor.
2094 If len is NULL, don't calculate the length; this happens for recursive calls
2095 when a sub-array-constructor is an element but not at the first position,
2096 so when we're not interested in the length.
2097 Returns TRUE if all elements are character constants. */
2100 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2107 if (gfc_constructor_first (base
) == NULL
)
2110 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2114 /* Loop over all constructor elements to find out is_const, but in len we
2115 want to store the length of the first, not the last, element. We can
2116 of course exit the loop as soon as is_const is found to be false. */
2117 for (c
= gfc_constructor_first (base
);
2118 c
&& is_const
; c
= gfc_constructor_next (c
))
2120 switch (c
->expr
->expr_type
)
2123 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2124 *len
= build_int_cstu (gfc_charlen_type_node
,
2125 c
->expr
->value
.character
.length
);
2129 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2136 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2142 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2146 /* After the first iteration, we don't want the length modified. */
2153 /* Check whether the array constructor C consists entirely of constant
2154 elements, and if so returns the number of those elements, otherwise
2155 return zero. Note, an empty or NULL array constructor returns zero. */
2157 unsigned HOST_WIDE_INT
2158 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2160 unsigned HOST_WIDE_INT nelem
= 0;
2162 gfc_constructor
*c
= gfc_constructor_first (base
);
2166 || c
->expr
->rank
> 0
2167 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2169 c
= gfc_constructor_next (c
);
2176 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2177 and the tree type of it's elements, TYPE, return a static constant
2178 variable that is compile-time initialized. */
2181 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2183 tree tmptype
, init
, tmp
;
2184 HOST_WIDE_INT nelem
;
2189 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2191 /* First traverse the constructor list, converting the constants
2192 to tree to build an initializer. */
2194 c
= gfc_constructor_first (expr
->value
.constructor
);
2197 gfc_init_se (&se
, NULL
);
2198 gfc_conv_constant (&se
, c
->expr
);
2199 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2200 se
.expr
= fold_convert (type
, se
.expr
);
2201 else if (POINTER_TYPE_P (type
))
2202 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2204 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2206 c
= gfc_constructor_next (c
);
2210 /* Next determine the tree type for the array. We use the gfortran
2211 front-end's gfc_get_nodesc_array_type in order to create a suitable
2212 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2214 memset (&as
, 0, sizeof (gfc_array_spec
));
2216 as
.rank
= expr
->rank
;
2217 as
.type
= AS_EXPLICIT
;
2220 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2221 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2225 for (i
= 0; i
< expr
->rank
; i
++)
2227 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2228 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2229 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2233 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2235 /* as is not needed anymore. */
2236 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2238 gfc_free_expr (as
.lower
[i
]);
2239 gfc_free_expr (as
.upper
[i
]);
2242 init
= build_constructor (tmptype
, v
);
2244 TREE_CONSTANT (init
) = 1;
2245 TREE_STATIC (init
) = 1;
2247 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2249 DECL_ARTIFICIAL (tmp
) = 1;
2250 DECL_IGNORED_P (tmp
) = 1;
2251 TREE_STATIC (tmp
) = 1;
2252 TREE_CONSTANT (tmp
) = 1;
2253 TREE_READONLY (tmp
) = 1;
2254 DECL_INITIAL (tmp
) = init
;
2261 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2262 This mostly initializes the scalarizer state info structure with the
2263 appropriate values to directly use the array created by the function
2264 gfc_build_constant_array_constructor. */
2267 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2269 gfc_array_info
*info
;
2273 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2275 info
= &ss
->info
->data
.array
;
2277 info
->descriptor
= tmp
;
2278 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2279 info
->offset
= gfc_index_zero_node
;
2281 for (i
= 0; i
< ss
->dimen
; i
++)
2283 info
->delta
[i
] = gfc_index_zero_node
;
2284 info
->start
[i
] = gfc_index_zero_node
;
2285 info
->end
[i
] = gfc_index_zero_node
;
2286 info
->stride
[i
] = gfc_index_one_node
;
2292 get_rank (gfc_loopinfo
*loop
)
2297 for (; loop
; loop
= loop
->parent
)
2298 rank
+= loop
->dimen
;
2304 /* Helper routine of gfc_trans_array_constructor to determine if the
2305 bounds of the loop specified by LOOP are constant and simple enough
2306 to use with trans_constant_array_constructor. Returns the
2307 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2310 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2313 tree size
= gfc_index_one_node
;
2317 total_dim
= get_rank (l
);
2319 for (loop
= l
; loop
; loop
= loop
->parent
)
2321 for (i
= 0; i
< loop
->dimen
; i
++)
2323 /* If the bounds aren't constant, return NULL_TREE. */
2324 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2326 if (!integer_zerop (loop
->from
[i
]))
2328 /* Only allow nonzero "from" in one-dimensional arrays. */
2331 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2332 gfc_array_index_type
,
2333 loop
->to
[i
], loop
->from
[i
]);
2337 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2338 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2339 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2340 gfc_array_index_type
, size
, tmp
);
2349 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2354 gcc_assert (array
->nested_ss
== NULL
);
2356 for (ss
= array
; ss
; ss
= ss
->parent
)
2357 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2358 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2359 return &(ss
->loop
->to
[n
]);
2365 static gfc_loopinfo
*
2366 outermost_loop (gfc_loopinfo
* loop
)
2368 while (loop
->parent
!= NULL
)
2369 loop
= loop
->parent
;
2375 /* Array constructors are handled by constructing a temporary, then using that
2376 within the scalarization loop. This is not optimal, but seems by far the
2380 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2382 gfc_constructor_base c
;
2390 bool old_first_len
, old_typespec_chararray_ctor
;
2391 tree old_first_len_val
;
2392 gfc_loopinfo
*loop
, *outer_loop
;
2393 gfc_ss_info
*ss_info
;
2399 /* Save the old values for nested checking. */
2400 old_first_len
= first_len
;
2401 old_first_len_val
= first_len_val
;
2402 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2405 outer_loop
= outermost_loop (loop
);
2407 expr
= ss_info
->expr
;
2409 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2410 typespec was given for the array constructor. */
2411 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2413 && expr
->ts
.u
.cl
->length_from_typespec
);
2415 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2416 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2418 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2422 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2424 c
= expr
->value
.constructor
;
2425 if (expr
->ts
.type
== BT_CHARACTER
)
2428 bool force_new_cl
= false;
2430 /* get_array_ctor_strlen walks the elements of the constructor, if a
2431 typespec was given, we already know the string length and want the one
2433 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2434 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2438 const_string
= false;
2439 gfc_init_se (&length_se
, NULL
);
2440 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2441 gfc_charlen_type_node
);
2442 ss_info
->string_length
= length_se
.expr
;
2444 /* Check if the character length is negative. If it is, then
2446 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2447 logical_type_node
, ss_info
->string_length
,
2448 build_zero_cst (TREE_TYPE
2449 (ss_info
->string_length
)));
2450 /* Print a warning if bounds checking is enabled. */
2451 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2453 msg
= xasprintf ("Negative character length treated as LEN = 0");
2454 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2459 ss_info
->string_length
2460 = fold_build3_loc (input_location
, COND_EXPR
,
2461 gfc_charlen_type_node
, neg_len
,
2463 (TREE_TYPE (ss_info
->string_length
)),
2464 ss_info
->string_length
);
2465 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2468 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2469 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2473 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2474 &ss_info
->string_length
);
2475 force_new_cl
= true;
2478 /* Complex character array constructors should have been taken care of
2479 and not end up here. */
2480 gcc_assert (ss_info
->string_length
);
2482 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2484 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2486 type
= build_pointer_type (type
);
2489 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2490 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2492 /* See if the constructor determines the loop bounds. */
2495 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2497 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2499 /* We have a multidimensional parameter. */
2500 for (s
= ss
; s
; s
= s
->parent
)
2503 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2505 s
->loop
->from
[n
] = gfc_index_zero_node
;
2506 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2507 gfc_index_integer_kind
);
2508 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2509 gfc_array_index_type
,
2511 gfc_index_one_node
);
2516 if (*loop_ubound0
== NULL_TREE
)
2520 /* We should have a 1-dimensional, zero-based loop. */
2521 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2522 gcc_assert (loop
->dimen
== 1);
2523 gcc_assert (integer_zerop (loop
->from
[0]));
2525 /* Split the constructor size into a static part and a dynamic part.
2526 Allocate the static size up-front and record whether the dynamic
2527 size might be nonzero. */
2529 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2530 mpz_sub_ui (size
, size
, 1);
2531 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2535 /* Special case constant array constructors. */
2538 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2541 tree size
= constant_array_constructor_loop_size (loop
);
2542 if (size
&& compare_tree_int (size
, nelem
) == 0)
2544 trans_constant_array_constructor (ss
, type
);
2550 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2551 NULL_TREE
, dynamic
, true, false, where
);
2553 desc
= ss_info
->data
.array
.descriptor
;
2554 offset
= gfc_index_zero_node
;
2555 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2556 TREE_NO_WARNING (offsetvar
) = 1;
2557 TREE_USED (offsetvar
) = 0;
2558 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2559 &offset
, &offsetvar
, dynamic
);
2561 /* If the array grows dynamically, the upper bound of the loop variable
2562 is determined by the array's final upper bound. */
2565 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2566 gfc_array_index_type
,
2567 offsetvar
, gfc_index_one_node
);
2568 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2569 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2570 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2571 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2573 *loop_ubound0
= tmp
;
2576 if (TREE_USED (offsetvar
))
2577 pushdecl (offsetvar
);
2579 gcc_assert (INTEGER_CST_P (offset
));
2582 /* Disable bound checking for now because it's probably broken. */
2583 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2590 /* Restore old values of globals. */
2591 first_len
= old_first_len
;
2592 first_len_val
= old_first_len_val
;
2593 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2597 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2598 called after evaluating all of INFO's vector dimensions. Go through
2599 each such vector dimension and see if we can now fill in any missing
2603 set_vector_loop_bounds (gfc_ss
* ss
)
2605 gfc_loopinfo
*loop
, *outer_loop
;
2606 gfc_array_info
*info
;
2614 outer_loop
= outermost_loop (ss
->loop
);
2616 info
= &ss
->info
->data
.array
;
2618 for (; ss
; ss
= ss
->parent
)
2622 for (n
= 0; n
< loop
->dimen
; n
++)
2625 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2626 || loop
->to
[n
] != NULL
)
2629 /* Loop variable N indexes vector dimension DIM, and we don't
2630 yet know the upper bound of loop variable N. Set it to the
2631 difference between the vector's upper and lower bounds. */
2632 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2633 gcc_assert (info
->subscript
[dim
]
2634 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2636 gfc_init_se (&se
, NULL
);
2637 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2638 zero
= gfc_rank_cst
[0];
2639 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2640 gfc_array_index_type
,
2641 gfc_conv_descriptor_ubound_get (desc
, zero
),
2642 gfc_conv_descriptor_lbound_get (desc
, zero
));
2643 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2650 /* Tells whether a scalar argument to an elemental procedure is saved out
2651 of a scalarization loop as a value or as a reference. */
2654 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2656 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2659 /* If the actual argument can be absent (in other words, it can
2660 be a NULL reference), don't try to evaluate it; pass instead
2661 the reference directly. */
2662 if (ss_info
->can_be_null_ref
)
2665 /* If the expression is of polymorphic type, it's actual size is not known,
2666 so we avoid copying it anywhere. */
2667 if (ss_info
->data
.scalar
.dummy_arg
2668 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2669 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2672 /* If the expression is a data reference of aggregate type,
2673 and the data reference is not used on the left hand side,
2674 avoid a copy by saving a reference to the content. */
2675 if (!ss_info
->data
.scalar
.needs_temporary
2676 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2677 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2678 && gfc_expr_is_variable (ss_info
->expr
))
2681 /* Otherwise the expression is evaluated to a temporary variable before the
2682 scalarization loop. */
2687 /* Add the pre and post chains for all the scalar expressions in a SS chain
2688 to loop. This is called after the loop parameters have been calculated,
2689 but before the actual scalarizing loops. */
2692 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2695 gfc_loopinfo
*nested_loop
, *outer_loop
;
2697 gfc_ss_info
*ss_info
;
2698 gfc_array_info
*info
;
2702 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2703 arguments could get evaluated multiple times. */
2704 if (ss
->is_alloc_lhs
)
2707 outer_loop
= outermost_loop (loop
);
2709 /* TODO: This can generate bad code if there are ordering dependencies,
2710 e.g., a callee allocated function and an unknown size constructor. */
2711 gcc_assert (ss
!= NULL
);
2713 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2717 /* Cross loop arrays are handled from within the most nested loop. */
2718 if (ss
->nested_ss
!= NULL
)
2722 expr
= ss_info
->expr
;
2723 info
= &ss_info
->data
.array
;
2725 switch (ss_info
->type
)
2728 /* Scalar expression. Evaluate this now. This includes elemental
2729 dimension indices, but not array section bounds. */
2730 gfc_init_se (&se
, NULL
);
2731 gfc_conv_expr (&se
, expr
);
2732 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2734 if (expr
->ts
.type
!= BT_CHARACTER
2735 && !gfc_is_alloc_class_scalar_function (expr
))
2737 /* Move the evaluation of scalar expressions outside the
2738 scalarization loop, except for WHERE assignments. */
2740 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2741 if (!ss_info
->where
)
2742 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2743 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2746 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2748 ss_info
->data
.scalar
.value
= se
.expr
;
2749 ss_info
->string_length
= se
.string_length
;
2752 case GFC_SS_REFERENCE
:
2753 /* Scalar argument to elemental procedure. */
2754 gfc_init_se (&se
, NULL
);
2755 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2756 gfc_conv_expr_reference (&se
, expr
);
2759 /* Evaluate the argument outside the loop and pass
2760 a reference to the value. */
2761 gfc_conv_expr (&se
, expr
);
2764 /* Ensure that a pointer to the string is stored. */
2765 if (expr
->ts
.type
== BT_CHARACTER
)
2766 gfc_conv_string_parameter (&se
);
2768 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2769 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2770 if (gfc_is_class_scalar_expr (expr
))
2771 /* This is necessary because the dynamic type will always be
2772 large than the declared type. In consequence, assigning
2773 the value to a temporary could segfault.
2774 OOP-TODO: see if this is generally correct or is the value
2775 has to be written to an allocated temporary, whose address
2776 is passed via ss_info. */
2777 ss_info
->data
.scalar
.value
= se
.expr
;
2779 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2782 ss_info
->string_length
= se
.string_length
;
2785 case GFC_SS_SECTION
:
2786 /* Add the expressions for scalar and vector subscripts. */
2787 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2788 if (info
->subscript
[n
])
2789 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2791 set_vector_loop_bounds (ss
);
2795 /* Get the vector's descriptor and store it in SS. */
2796 gfc_init_se (&se
, NULL
);
2797 gfc_conv_expr_descriptor (&se
, expr
);
2798 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2799 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2800 info
->descriptor
= se
.expr
;
2803 case GFC_SS_INTRINSIC
:
2804 gfc_add_intrinsic_ss_code (loop
, ss
);
2807 case GFC_SS_FUNCTION
:
2808 /* Array function return value. We call the function and save its
2809 result in a temporary for use inside the loop. */
2810 gfc_init_se (&se
, NULL
);
2813 if (gfc_is_class_array_function (expr
))
2814 expr
->must_finalize
= 1;
2815 gfc_conv_expr (&se
, expr
);
2816 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2817 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2818 ss_info
->string_length
= se
.string_length
;
2821 case GFC_SS_CONSTRUCTOR
:
2822 if (expr
->ts
.type
== BT_CHARACTER
2823 && ss_info
->string_length
== NULL
2825 && expr
->ts
.u
.cl
->length
2826 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2828 gfc_init_se (&se
, NULL
);
2829 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2830 gfc_charlen_type_node
);
2831 ss_info
->string_length
= se
.expr
;
2832 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2833 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2835 trans_array_constructor (ss
, where
);
2839 case GFC_SS_COMPONENT
:
2840 /* Do nothing. These are handled elsewhere. */
2849 for (nested_loop
= loop
->nested
; nested_loop
;
2850 nested_loop
= nested_loop
->next
)
2851 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2855 /* Translate expressions for the descriptor and data pointer of a SS. */
2859 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2862 gfc_ss_info
*ss_info
;
2863 gfc_array_info
*info
;
2867 info
= &ss_info
->data
.array
;
2869 /* Get the descriptor for the array to be scalarized. */
2870 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2871 gfc_init_se (&se
, NULL
);
2872 se
.descriptor_only
= 1;
2873 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2874 gfc_add_block_to_block (block
, &se
.pre
);
2875 info
->descriptor
= se
.expr
;
2876 ss_info
->string_length
= se
.string_length
;
2880 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2881 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2883 /* Emit a DECL_EXPR for the variable sized array type in
2884 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2885 sizes works correctly. */
2886 tree arraytype
= TREE_TYPE (
2887 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2888 if (! TYPE_NAME (arraytype
))
2889 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2890 NULL_TREE
, arraytype
);
2891 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2892 TYPE_NAME (arraytype
)));
2894 /* Also the data pointer. */
2895 tmp
= gfc_conv_array_data (se
.expr
);
2896 /* If this is a variable or address of a variable we use it directly.
2897 Otherwise we must evaluate it now to avoid breaking dependency
2898 analysis by pulling the expressions for elemental array indices
2901 || (TREE_CODE (tmp
) == ADDR_EXPR
2902 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2903 tmp
= gfc_evaluate_now (tmp
, block
);
2906 tmp
= gfc_conv_array_offset (se
.expr
);
2907 info
->offset
= gfc_evaluate_now (tmp
, block
);
2909 /* Make absolutely sure that the saved_offset is indeed saved
2910 so that the variable is still accessible after the loops
2912 info
->saved_offset
= info
->offset
;
2917 /* Initialize a gfc_loopinfo structure. */
2920 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2924 memset (loop
, 0, sizeof (gfc_loopinfo
));
2925 gfc_init_block (&loop
->pre
);
2926 gfc_init_block (&loop
->post
);
2928 /* Initially scalarize in order and default to no loop reversal. */
2929 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2932 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2935 loop
->ss
= gfc_ss_terminator
;
2939 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2943 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2949 /* Return an expression for the data pointer of an array. */
2952 gfc_conv_array_data (tree descriptor
)
2956 type
= TREE_TYPE (descriptor
);
2957 if (GFC_ARRAY_TYPE_P (type
))
2959 if (TREE_CODE (type
) == POINTER_TYPE
)
2963 /* Descriptorless arrays. */
2964 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2968 return gfc_conv_descriptor_data_get (descriptor
);
2972 /* Return an expression for the base offset of an array. */
2975 gfc_conv_array_offset (tree descriptor
)
2979 type
= TREE_TYPE (descriptor
);
2980 if (GFC_ARRAY_TYPE_P (type
))
2981 return GFC_TYPE_ARRAY_OFFSET (type
);
2983 return gfc_conv_descriptor_offset_get (descriptor
);
2987 /* Get an expression for the array stride. */
2990 gfc_conv_array_stride (tree descriptor
, int dim
)
2995 type
= TREE_TYPE (descriptor
);
2997 /* For descriptorless arrays use the array size. */
2998 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2999 if (tmp
!= NULL_TREE
)
3002 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3007 /* Like gfc_conv_array_stride, but for the lower bound. */
3010 gfc_conv_array_lbound (tree descriptor
, int dim
)
3015 type
= TREE_TYPE (descriptor
);
3017 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3018 if (tmp
!= NULL_TREE
)
3021 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3026 /* Like gfc_conv_array_stride, but for the upper bound. */
3029 gfc_conv_array_ubound (tree descriptor
, int dim
)
3034 type
= TREE_TYPE (descriptor
);
3036 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3037 if (tmp
!= NULL_TREE
)
3040 /* This should only ever happen when passing an assumed shape array
3041 as an actual parameter. The value will never be used. */
3042 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3043 return gfc_index_zero_node
;
3045 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3050 /* Generate code to perform an array index bound check. */
3053 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3054 locus
* where
, bool check_upper
)
3057 tree tmp_lo
, tmp_up
;
3060 const char * name
= NULL
;
3062 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3065 descriptor
= ss
->info
->data
.array
.descriptor
;
3067 index
= gfc_evaluate_now (index
, &se
->pre
);
3069 /* We find a name for the error message. */
3070 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3071 gcc_assert (name
!= NULL
);
3073 if (VAR_P (descriptor
))
3074 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3076 /* If upper bound is present, include both bounds in the error message. */
3079 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3080 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3083 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3084 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3086 msg
= xasprintf ("Index '%%ld' of dimension %d "
3087 "outside of expected range (%%ld:%%ld)", n
+1);
3089 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3091 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3092 fold_convert (long_integer_type_node
, index
),
3093 fold_convert (long_integer_type_node
, tmp_lo
),
3094 fold_convert (long_integer_type_node
, tmp_up
));
3095 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3097 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3098 fold_convert (long_integer_type_node
, index
),
3099 fold_convert (long_integer_type_node
, tmp_lo
),
3100 fold_convert (long_integer_type_node
, tmp_up
));
3105 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3108 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3109 "below lower bound of %%ld", n
+1, name
);
3111 msg
= xasprintf ("Index '%%ld' of dimension %d "
3112 "below lower bound of %%ld", n
+1);
3114 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3116 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3117 fold_convert (long_integer_type_node
, index
),
3118 fold_convert (long_integer_type_node
, tmp_lo
));
3126 /* Return the offset for an index. Performs bound checking for elemental
3127 dimensions. Single element references are processed separately.
3128 DIM is the array dimension, I is the loop dimension. */
3131 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3132 gfc_array_ref
* ar
, tree stride
)
3134 gfc_array_info
*info
;
3139 info
= &ss
->info
->data
.array
;
3141 /* Get the index into the array for this dimension. */
3144 gcc_assert (ar
->type
!= AR_ELEMENT
);
3145 switch (ar
->dimen_type
[dim
])
3147 case DIMEN_THIS_IMAGE
:
3151 /* Elemental dimension. */
3152 gcc_assert (info
->subscript
[dim
]
3153 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3154 /* We've already translated this value outside the loop. */
3155 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3157 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3158 ar
->as
->type
!= AS_ASSUMED_SIZE
3159 || dim
< ar
->dimen
- 1);
3163 gcc_assert (info
&& se
->loop
);
3164 gcc_assert (info
->subscript
[dim
]
3165 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3166 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3168 /* Get a zero-based index into the vector. */
3169 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3170 gfc_array_index_type
,
3171 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3173 /* Multiply the index by the stride. */
3174 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3175 gfc_array_index_type
,
3176 index
, gfc_conv_array_stride (desc
, 0));
3178 /* Read the vector to get an index into info->descriptor. */
3179 data
= build_fold_indirect_ref_loc (input_location
,
3180 gfc_conv_array_data (desc
));
3181 index
= gfc_build_array_ref (data
, index
, NULL
);
3182 index
= gfc_evaluate_now (index
, &se
->pre
);
3183 index
= fold_convert (gfc_array_index_type
, index
);
3185 /* Do any bounds checking on the final info->descriptor index. */
3186 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3187 ar
->as
->type
!= AS_ASSUMED_SIZE
3188 || dim
< ar
->dimen
- 1);
3192 /* Scalarized dimension. */
3193 gcc_assert (info
&& se
->loop
);
3195 /* Multiply the loop variable by the stride and delta. */
3196 index
= se
->loop
->loopvar
[i
];
3197 if (!integer_onep (info
->stride
[dim
]))
3198 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3199 gfc_array_index_type
, index
,
3201 if (!integer_zerop (info
->delta
[dim
]))
3202 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3203 gfc_array_index_type
, index
,
3213 /* Temporary array or derived type component. */
3214 gcc_assert (se
->loop
);
3215 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3217 /* Pointer functions can have stride[0] different from unity.
3218 Use the stride returned by the function call and stored in
3219 the descriptor for the temporary. */
3220 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3221 && se
->ss
->info
->expr
3222 && se
->ss
->info
->expr
->symtree
3223 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3224 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3225 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3228 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3229 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3230 gfc_array_index_type
, index
, info
->delta
[dim
]);
3233 /* Multiply by the stride. */
3234 if (stride
!= NULL
&& !integer_onep (stride
))
3235 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3242 /* Build a scalarized array reference using the vptr 'size'. */
3245 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3250 tree decl
= NULL_TREE
;
3252 gfc_expr
*expr
= se
->ss
->info
->expr
;
3254 gfc_ref
*class_ref
= NULL
;
3257 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3258 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3259 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3264 || (expr
->ts
.type
!= BT_CLASS
3265 && !gfc_is_class_array_function (expr
)
3266 && !gfc_is_class_array_ref (expr
, NULL
)))
3269 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3270 ts
= &expr
->symtree
->n
.sym
->ts
;
3274 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3276 if (ref
->type
== REF_COMPONENT
3277 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3278 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3279 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3281 && ref
->next
->next
->type
== REF_ARRAY
3282 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3284 ts
= &ref
->u
.c
.component
->ts
;
3294 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3295 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3296 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3298 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3300 else if (expr
&& gfc_is_class_array_function (expr
))
3304 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3307 type
= TREE_TYPE (tmp
);
3310 if (GFC_CLASS_TYPE_P (type
))
3312 if (type
!= TYPE_CANONICAL (type
))
3313 type
= TYPE_CANONICAL (type
);
3321 if (decl
== NULL_TREE
)
3324 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3326 else if (class_ref
== NULL
)
3328 if (decl
== NULL_TREE
)
3329 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3330 /* For class arrays the tree containing the class is stored in
3331 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3332 For all others it's sym's backend_decl directly. */
3333 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3334 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3338 /* Remove everything after the last class reference, convert the
3339 expression and then recover its tailend once more. */
3341 ref
= class_ref
->next
;
3342 class_ref
->next
= NULL
;
3343 gfc_init_se (&tmpse
, NULL
);
3344 gfc_conv_expr (&tmpse
, expr
);
3345 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3347 class_ref
->next
= ref
;
3350 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3351 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3353 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3356 size
= gfc_class_vtab_size_get (decl
);
3358 /* For unlimited polymorphic entities then _len component needs to be
3359 multiplied with the size. If no _len component is present, then
3360 gfc_class_len_or_zero_get () return a zero_node. */
3361 tmp
= gfc_class_len_or_zero_get (decl
);
3362 if (!integer_zerop (tmp
))
3363 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3364 fold_convert (TREE_TYPE (index
), size
),
3365 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3366 fold_convert (TREE_TYPE (index
), tmp
),
3367 fold_convert (TREE_TYPE (index
),
3368 integer_one_node
)));
3370 size
= fold_convert (TREE_TYPE (index
), size
);
3372 /* Build the address of the element. */
3373 type
= TREE_TYPE (TREE_TYPE (base
));
3374 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3375 gfc_array_index_type
,
3377 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3378 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3379 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3381 /* Return the element in the se expression. */
3382 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3387 /* Build a scalarized reference to an array. */
3390 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3392 gfc_array_info
*info
;
3393 tree decl
= NULL_TREE
;
3401 expr
= ss
->info
->expr
;
3402 info
= &ss
->info
->data
.array
;
3404 n
= se
->loop
->order
[0];
3408 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3409 /* Add the offset for this dimension to the stored offset for all other
3411 if (info
->offset
&& !integer_zerop (info
->offset
))
3412 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3413 index
, info
->offset
);
3415 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3417 /* Use the vptr 'size' field to access the element of a class array. */
3418 if (build_class_array_ref (se
, base
, index
))
3421 if (expr
&& ((is_subref_array (expr
)
3422 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
)))
3423 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3424 || expr
->expr_type
== EXPR_FUNCTION
))))
3425 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3427 /* A pointer array component can be detected from its field decl. Fix
3428 the descriptor, mark the resulting variable decl and pass it to
3429 gfc_build_array_ref. */
3430 if (is_pointer_array (info
->descriptor
)
3431 || (expr
&& expr
->ts
.deferred
&& info
->descriptor
3432 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
))))
3434 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3435 decl
= info
->descriptor
;
3436 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3437 decl
= TREE_OPERAND (info
->descriptor
, 0);
3439 if (decl
== NULL_TREE
)
3440 decl
= info
->descriptor
;
3443 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3447 /* Translate access of temporary array. */
3450 gfc_conv_tmp_array_ref (gfc_se
* se
)
3452 se
->string_length
= se
->ss
->info
->string_length
;
3453 gfc_conv_scalarized_array_ref (se
, NULL
);
3454 gfc_advance_se_ss_chain (se
);
3457 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3460 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3462 if (TREE_CODE (t
) == INTEGER_CST
)
3463 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3466 if (!integer_zerop (*offset
))
3467 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3468 gfc_array_index_type
, *offset
, t
);
3476 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3482 /* For class arrays the class declaration is stored in the saved
3484 if (INDIRECT_REF_P (desc
)
3485 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3486 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3487 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3488 TREE_OPERAND (desc
, 0)));
3492 /* Class container types do not always have the GFC_CLASS_TYPE_P
3493 but the canonical type does. */
3494 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3495 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3497 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3498 if (TYPE_CANONICAL (type
)
3499 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3500 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3503 tmp
= gfc_conv_array_data (desc
);
3504 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3505 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3510 /* Build an array reference. se->expr already holds the array descriptor.
3511 This should be either a variable, indirect variable reference or component
3512 reference. For arrays which do not have a descriptor, se->expr will be
3514 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3517 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3521 tree offset
, cst_offset
;
3524 tree decl
= NULL_TREE
;
3527 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3528 char *var_name
= NULL
;
3532 gcc_assert (ar
->codimen
);
3534 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3535 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3538 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3539 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3540 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3542 /* Use the actual tree type and not the wrapped coarray. */
3543 if (!se
->want_pointer
)
3544 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3551 /* Handle scalarized references separately. */
3552 if (ar
->type
!= AR_ELEMENT
)
3554 gfc_conv_scalarized_array_ref (se
, ar
);
3555 gfc_advance_se_ss_chain (se
);
3559 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3564 len
= strlen (sym
->name
) + 1;
3565 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3567 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3569 if (ref
->type
== REF_COMPONENT
)
3570 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3573 var_name
= XALLOCAVEC (char, len
);
3574 strcpy (var_name
, sym
->name
);
3576 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3578 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3580 if (ref
->type
== REF_COMPONENT
)
3582 strcat (var_name
, "%%");
3583 strcat (var_name
, ref
->u
.c
.component
->name
);
3588 cst_offset
= offset
= gfc_index_zero_node
;
3589 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3591 /* Calculate the offsets from all the dimensions. Make sure to associate
3592 the final offset so that we form a chain of loop invariant summands. */
3593 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3595 /* Calculate the index for this dimension. */
3596 gfc_init_se (&indexse
, se
);
3597 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3598 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3600 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3602 /* Check array bounds. */
3606 /* Evaluate the indexse.expr only once. */
3607 indexse
.expr
= save_expr (indexse
.expr
);
3610 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3611 if (sym
->attr
.temporary
)
3613 gfc_init_se (&tmpse
, se
);
3614 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3615 gfc_array_index_type
);
3616 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3620 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3622 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3623 "below lower bound of %%ld", n
+1, var_name
);
3624 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3625 fold_convert (long_integer_type_node
,
3627 fold_convert (long_integer_type_node
, tmp
));
3630 /* Upper bound, but not for the last dimension of assumed-size
3632 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3634 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3635 if (sym
->attr
.temporary
)
3637 gfc_init_se (&tmpse
, se
);
3638 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3639 gfc_array_index_type
);
3640 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3644 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3645 logical_type_node
, indexse
.expr
, tmp
);
3646 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3647 "above upper bound of %%ld", n
+1, var_name
);
3648 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3649 fold_convert (long_integer_type_node
,
3651 fold_convert (long_integer_type_node
, tmp
));
3656 /* Multiply the index by the stride. */
3657 stride
= gfc_conv_array_stride (se
->expr
, n
);
3658 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3659 indexse
.expr
, stride
);
3661 /* And add it to the total. */
3662 add_to_offset (&cst_offset
, &offset
, tmp
);
3665 if (!integer_zerop (cst_offset
))
3666 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3667 gfc_array_index_type
, offset
, cst_offset
);
3669 /* A pointer array component can be detected from its field decl. Fix
3670 the descriptor, mark the resulting variable decl and pass it to
3672 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3673 && is_pointer_array (se
->expr
))
3675 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3677 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3678 decl
= TREE_OPERAND (se
->expr
, 0);
3682 else if (expr
->ts
.deferred
3683 || (sym
->ts
.type
== BT_CHARACTER
3684 && sym
->attr
.select_type_temporary
))
3686 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3689 if (TREE_CODE (decl
) == INDIRECT_REF
)
3690 decl
= TREE_OPERAND (decl
, 0);
3693 decl
= sym
->backend_decl
;
3695 else if (sym
->ts
.type
== BT_CLASS
)
3698 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3702 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3703 LOOP_DIM dimension (if any) to array's offset. */
3706 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3707 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3710 gfc_array_info
*info
;
3713 info
= &ss
->info
->data
.array
;
3715 gfc_init_se (&se
, NULL
);
3717 se
.expr
= info
->descriptor
;
3718 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3719 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3720 gfc_add_block_to_block (pblock
, &se
.pre
);
3722 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3723 gfc_array_index_type
,
3724 info
->offset
, index
);
3725 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3729 /* Generate the code to be executed immediately before entering a
3730 scalarization loop. */
3733 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3734 stmtblock_t
* pblock
)
3737 gfc_ss_info
*ss_info
;
3738 gfc_array_info
*info
;
3739 gfc_ss_type ss_type
;
3741 gfc_loopinfo
*ploop
;
3745 /* This code will be executed before entering the scalarization loop
3746 for this dimension. */
3747 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3751 if ((ss_info
->useflags
& flag
) == 0)
3754 ss_type
= ss_info
->type
;
3755 if (ss_type
!= GFC_SS_SECTION
3756 && ss_type
!= GFC_SS_FUNCTION
3757 && ss_type
!= GFC_SS_CONSTRUCTOR
3758 && ss_type
!= GFC_SS_COMPONENT
)
3761 info
= &ss_info
->data
.array
;
3763 gcc_assert (dim
< ss
->dimen
);
3764 gcc_assert (ss
->dimen
== loop
->dimen
);
3767 ar
= &info
->ref
->u
.ar
;
3771 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3773 /* If we are in the outermost dimension of this loop, the previous
3774 dimension shall be in the parent loop. */
3775 gcc_assert (ss
->parent
!= NULL
);
3778 ploop
= loop
->parent
;
3780 /* ss and ss->parent are about the same array. */
3781 gcc_assert (ss_info
== pss
->info
);
3789 if (dim
== loop
->dimen
- 1)
3794 /* For the time being, there is no loop reordering. */
3795 gcc_assert (i
== ploop
->order
[i
]);
3796 i
= ploop
->order
[i
];
3798 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3800 stride
= gfc_conv_array_stride (info
->descriptor
,
3801 innermost_ss (ss
)->dim
[i
]);
3803 /* Calculate the stride of the innermost loop. Hopefully this will
3804 allow the backend optimizers to do their stuff more effectively.
3806 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3808 /* For the outermost loop calculate the offset due to any
3809 elemental dimensions. It will have been initialized with the
3810 base offset of the array. */
3813 for (i
= 0; i
< ar
->dimen
; i
++)
3815 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3818 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3823 /* Add the offset for the previous loop dimension. */
3824 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3826 /* Remember this offset for the second loop. */
3827 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3828 info
->saved_offset
= info
->offset
;
3833 /* Start a scalarized expression. Creates a scope and declares loop
3837 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3843 gcc_assert (!loop
->array_parameter
);
3845 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3847 n
= loop
->order
[dim
];
3849 gfc_start_block (&loop
->code
[n
]);
3851 /* Create the loop variable. */
3852 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3854 if (dim
< loop
->temp_dim
)
3858 /* Calculate values that will be constant within this loop. */
3859 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3861 gfc_start_block (pbody
);
3865 /* Generates the actual loop code for a scalarization loop. */
3868 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3869 stmtblock_t
* pbody
)
3880 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3881 | OMPWS_SCALARIZER_BODY
))
3882 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3883 && n
== loop
->dimen
- 1)
3885 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3886 init
= make_tree_vec (1);
3887 cond
= make_tree_vec (1);
3888 incr
= make_tree_vec (1);
3890 /* Cycle statement is implemented with a goto. Exit statement must not
3891 be present for this loop. */
3892 exit_label
= gfc_build_label_decl (NULL_TREE
);
3893 TREE_USED (exit_label
) = 1;
3895 /* Label for cycle statements (if needed). */
3896 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3897 gfc_add_expr_to_block (pbody
, tmp
);
3899 stmt
= make_node (OMP_FOR
);
3901 TREE_TYPE (stmt
) = void_type_node
;
3902 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3904 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3905 OMP_CLAUSE_SCHEDULE
);
3906 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3907 = OMP_CLAUSE_SCHEDULE_STATIC
;
3908 if (ompws_flags
& OMPWS_NOWAIT
)
3909 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3910 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3912 /* Initialize the loopvar. */
3913 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3915 OMP_FOR_INIT (stmt
) = init
;
3916 /* The exit condition. */
3917 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3919 loop
->loopvar
[n
], loop
->to
[n
]);
3920 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3921 OMP_FOR_COND (stmt
) = cond
;
3922 /* Increment the loopvar. */
3923 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3924 loop
->loopvar
[n
], gfc_index_one_node
);
3925 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3926 void_type_node
, loop
->loopvar
[n
], tmp
);
3927 OMP_FOR_INCR (stmt
) = incr
;
3929 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3930 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3934 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3935 && (loop
->temp_ss
== NULL
);
3937 loopbody
= gfc_finish_block (pbody
);
3940 std::swap (loop
->from
[n
], loop
->to
[n
]);
3942 /* Initialize the loopvar. */
3943 if (loop
->loopvar
[n
] != loop
->from
[n
])
3944 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3946 exit_label
= gfc_build_label_decl (NULL_TREE
);
3948 /* Generate the loop body. */
3949 gfc_init_block (&block
);
3951 /* The exit condition. */
3952 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3953 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3954 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3955 TREE_USED (exit_label
) = 1;
3956 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3957 gfc_add_expr_to_block (&block
, tmp
);
3959 /* The main body. */
3960 gfc_add_expr_to_block (&block
, loopbody
);
3962 /* Increment the loopvar. */
3963 tmp
= fold_build2_loc (input_location
,
3964 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3965 gfc_array_index_type
, loop
->loopvar
[n
],
3966 gfc_index_one_node
);
3968 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3970 /* Build the loop. */
3971 tmp
= gfc_finish_block (&block
);
3972 tmp
= build1_v (LOOP_EXPR
, tmp
);
3973 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3975 /* Add the exit label. */
3976 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3977 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3983 /* Finishes and generates the loops for a scalarized expression. */
3986 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3991 stmtblock_t
*pblock
;
3995 /* Generate the loops. */
3996 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3998 n
= loop
->order
[dim
];
3999 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4000 loop
->loopvar
[n
] = NULL_TREE
;
4001 pblock
= &loop
->code
[n
];
4004 tmp
= gfc_finish_block (pblock
);
4005 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4007 /* Clear all the used flags. */
4008 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4009 if (ss
->parent
== NULL
)
4010 ss
->info
->useflags
= 0;
4014 /* Finish the main body of a scalarized expression, and start the secondary
4018 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4022 stmtblock_t
*pblock
;
4026 /* We finish as many loops as are used by the temporary. */
4027 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4029 n
= loop
->order
[dim
];
4030 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4031 loop
->loopvar
[n
] = NULL_TREE
;
4032 pblock
= &loop
->code
[n
];
4035 /* We don't want to finish the outermost loop entirely. */
4036 n
= loop
->order
[loop
->temp_dim
- 1];
4037 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4039 /* Restore the initial offsets. */
4040 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4042 gfc_ss_type ss_type
;
4043 gfc_ss_info
*ss_info
;
4047 if ((ss_info
->useflags
& 2) == 0)
4050 ss_type
= ss_info
->type
;
4051 if (ss_type
!= GFC_SS_SECTION
4052 && ss_type
!= GFC_SS_FUNCTION
4053 && ss_type
!= GFC_SS_CONSTRUCTOR
4054 && ss_type
!= GFC_SS_COMPONENT
)
4057 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4060 /* Restart all the inner loops we just finished. */
4061 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4063 n
= loop
->order
[dim
];
4065 gfc_start_block (&loop
->code
[n
]);
4067 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4069 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4072 /* Start a block for the secondary copying code. */
4073 gfc_start_block (body
);
4077 /* Precalculate (either lower or upper) bound of an array section.
4078 BLOCK: Block in which the (pre)calculation code will go.
4079 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4080 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4081 DESC: Array descriptor from which the bound will be picked if unspecified
4082 (either lower or upper bound according to LBOUND). */
4085 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4086 tree desc
, int dim
, bool lbound
, bool deferred
)
4089 gfc_expr
* input_val
= values
[dim
];
4090 tree
*output
= &bounds
[dim
];
4095 /* Specified section bound. */
4096 gfc_init_se (&se
, NULL
);
4097 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4098 gfc_add_block_to_block (block
, &se
.pre
);
4101 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4103 /* The gfc_conv_array_lbound () routine returns a constant zero for
4104 deferred length arrays, which in the scalarizer wreaks havoc, when
4105 copying to a (newly allocated) one-based array.
4106 Keep returning the actual result in sync for both bounds. */
4107 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4109 gfc_conv_descriptor_ubound_get (desc
,
4114 /* No specific bound specified so use the bound of the array. */
4115 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4116 gfc_conv_array_ubound (desc
, dim
);
4118 *output
= gfc_evaluate_now (*output
, block
);
4122 /* Calculate the lower bound of an array section. */
4125 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4127 gfc_expr
*stride
= NULL
;
4130 gfc_array_info
*info
;
4133 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4135 info
= &ss
->info
->data
.array
;
4136 ar
= &info
->ref
->u
.ar
;
4138 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4140 /* We use a zero-based index to access the vector. */
4141 info
->start
[dim
] = gfc_index_zero_node
;
4142 info
->end
[dim
] = NULL
;
4143 info
->stride
[dim
] = gfc_index_one_node
;
4147 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4148 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4149 desc
= info
->descriptor
;
4150 stride
= ar
->stride
[dim
];
4153 /* Calculate the start of the range. For vector subscripts this will
4154 be the range of the vector. */
4155 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4156 ar
->as
->type
== AS_DEFERRED
);
4158 /* Similarly calculate the end. Although this is not used in the
4159 scalarizer, it is needed when checking bounds and where the end
4160 is an expression with side-effects. */
4161 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4162 ar
->as
->type
== AS_DEFERRED
);
4165 /* Calculate the stride. */
4167 info
->stride
[dim
] = gfc_index_one_node
;
4170 gfc_init_se (&se
, NULL
);
4171 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4172 gfc_add_block_to_block (block
, &se
.pre
);
4173 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4178 /* Calculates the range start and stride for a SS chain. Also gets the
4179 descriptor and data pointer. The range of vector subscripts is the size
4180 of the vector. Array bounds are also checked. */
4183 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4190 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4193 /* Determine the rank of the loop. */
4194 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4196 switch (ss
->info
->type
)
4198 case GFC_SS_SECTION
:
4199 case GFC_SS_CONSTRUCTOR
:
4200 case GFC_SS_FUNCTION
:
4201 case GFC_SS_COMPONENT
:
4202 loop
->dimen
= ss
->dimen
;
4205 /* As usual, lbound and ubound are exceptions!. */
4206 case GFC_SS_INTRINSIC
:
4207 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4209 case GFC_ISYM_LBOUND
:
4210 case GFC_ISYM_UBOUND
:
4211 case GFC_ISYM_LCOBOUND
:
4212 case GFC_ISYM_UCOBOUND
:
4213 case GFC_ISYM_THIS_IMAGE
:
4214 loop
->dimen
= ss
->dimen
;
4226 /* We should have determined the rank of the expression by now. If
4227 not, that's bad news. */
4231 /* Loop over all the SS in the chain. */
4232 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4234 gfc_ss_info
*ss_info
;
4235 gfc_array_info
*info
;
4239 expr
= ss_info
->expr
;
4240 info
= &ss_info
->data
.array
;
4242 if (expr
&& expr
->shape
&& !info
->shape
)
4243 info
->shape
= expr
->shape
;
4245 switch (ss_info
->type
)
4247 case GFC_SS_SECTION
:
4248 /* Get the descriptor for the array. If it is a cross loops array,
4249 we got the descriptor already in the outermost loop. */
4250 if (ss
->parent
== NULL
)
4251 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4252 !loop
->array_parameter
);
4254 for (n
= 0; n
< ss
->dimen
; n
++)
4255 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4258 case GFC_SS_INTRINSIC
:
4259 switch (expr
->value
.function
.isym
->id
)
4261 /* Fall through to supply start and stride. */
4262 case GFC_ISYM_LBOUND
:
4263 case GFC_ISYM_UBOUND
:
4267 /* This is the variant without DIM=... */
4268 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4270 arg
= expr
->value
.function
.actual
->expr
;
4271 if (arg
->rank
== -1)
4276 /* The rank (hence the return value's shape) is unknown,
4277 we have to retrieve it. */
4278 gfc_init_se (&se
, NULL
);
4279 se
.descriptor_only
= 1;
4280 gfc_conv_expr (&se
, arg
);
4281 /* This is a bare variable, so there is no preliminary
4283 gcc_assert (se
.pre
.head
== NULL_TREE
4284 && se
.post
.head
== NULL_TREE
);
4285 rank
= gfc_conv_descriptor_rank (se
.expr
);
4286 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4287 gfc_array_index_type
,
4288 fold_convert (gfc_array_index_type
,
4290 gfc_index_one_node
);
4291 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4292 info
->start
[0] = gfc_index_zero_node
;
4293 info
->stride
[0] = gfc_index_one_node
;
4296 /* Otherwise fall through GFC_SS_FUNCTION. */
4299 case GFC_ISYM_LCOBOUND
:
4300 case GFC_ISYM_UCOBOUND
:
4301 case GFC_ISYM_THIS_IMAGE
:
4309 case GFC_SS_CONSTRUCTOR
:
4310 case GFC_SS_FUNCTION
:
4311 for (n
= 0; n
< ss
->dimen
; n
++)
4313 int dim
= ss
->dim
[n
];
4315 info
->start
[dim
] = gfc_index_zero_node
;
4316 info
->end
[dim
] = gfc_index_zero_node
;
4317 info
->stride
[dim
] = gfc_index_one_node
;
4326 /* The rest is just runtime bounds checking. */
4327 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4330 tree lbound
, ubound
;
4332 tree size
[GFC_MAX_DIMENSIONS
];
4333 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4334 gfc_array_info
*info
;
4338 gfc_start_block (&block
);
4340 for (n
= 0; n
< loop
->dimen
; n
++)
4341 size
[n
] = NULL_TREE
;
4343 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4346 gfc_ss_info
*ss_info
;
4349 const char *expr_name
;
4352 if (ss_info
->type
!= GFC_SS_SECTION
)
4355 /* Catch allocatable lhs in f2003. */
4356 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4359 expr
= ss_info
->expr
;
4360 expr_loc
= &expr
->where
;
4361 expr_name
= expr
->symtree
->name
;
4363 gfc_start_block (&inner
);
4365 /* TODO: range checking for mapped dimensions. */
4366 info
= &ss_info
->data
.array
;
4368 /* This code only checks ranges. Elemental and vector
4369 dimensions are checked later. */
4370 for (n
= 0; n
< loop
->dimen
; n
++)
4375 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4378 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4379 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4380 check_upper
= false;
4384 /* Zero stride is not allowed. */
4385 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4386 info
->stride
[dim
], gfc_index_zero_node
);
4387 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4388 "of array '%s'", dim
+ 1, expr_name
);
4389 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4393 desc
= info
->descriptor
;
4395 /* This is the run-time equivalent of resolve.c's
4396 check_dimension(). The logical is more readable there
4397 than it is here, with all the trees. */
4398 lbound
= gfc_conv_array_lbound (desc
, dim
);
4399 end
= info
->end
[dim
];
4401 ubound
= gfc_conv_array_ubound (desc
, dim
);
4405 /* non_zerosized is true when the selected range is not
4407 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4408 logical_type_node
, info
->stride
[dim
],
4409 gfc_index_zero_node
);
4410 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4411 info
->start
[dim
], end
);
4412 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4413 logical_type_node
, stride_pos
, tmp
);
4415 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4417 info
->stride
[dim
], gfc_index_zero_node
);
4418 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4419 info
->start
[dim
], end
);
4420 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4423 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4425 stride_pos
, stride_neg
);
4427 /* Check the start of the range against the lower and upper
4428 bounds of the array, if the range is not empty.
4429 If upper bound is present, include both bounds in the
4433 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4435 info
->start
[dim
], lbound
);
4436 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4438 non_zerosized
, tmp
);
4439 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4441 info
->start
[dim
], ubound
);
4442 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4444 non_zerosized
, tmp2
);
4445 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4446 "outside of expected range (%%ld:%%ld)",
4447 dim
+ 1, expr_name
);
4448 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4450 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4451 fold_convert (long_integer_type_node
, lbound
),
4452 fold_convert (long_integer_type_node
, ubound
));
4453 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4455 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4456 fold_convert (long_integer_type_node
, lbound
),
4457 fold_convert (long_integer_type_node
, ubound
));
4462 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4464 info
->start
[dim
], lbound
);
4465 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4466 logical_type_node
, non_zerosized
, tmp
);
4467 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4468 "below lower bound of %%ld",
4469 dim
+ 1, expr_name
);
4470 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4472 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4473 fold_convert (long_integer_type_node
, lbound
));
4477 /* Compute the last element of the range, which is not
4478 necessarily "end" (think 0:5:3, which doesn't contain 5)
4479 and check it against both lower and upper bounds. */
4481 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4482 gfc_array_index_type
, end
,
4484 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4485 gfc_array_index_type
, tmp
,
4487 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4488 gfc_array_index_type
, end
, tmp
);
4489 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4490 logical_type_node
, tmp
, lbound
);
4491 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4492 logical_type_node
, non_zerosized
, tmp2
);
4495 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4496 logical_type_node
, tmp
, ubound
);
4497 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4498 logical_type_node
, non_zerosized
, tmp3
);
4499 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4500 "outside of expected range (%%ld:%%ld)",
4501 dim
+ 1, expr_name
);
4502 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4504 fold_convert (long_integer_type_node
, tmp
),
4505 fold_convert (long_integer_type_node
, ubound
),
4506 fold_convert (long_integer_type_node
, lbound
));
4507 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4509 fold_convert (long_integer_type_node
, tmp
),
4510 fold_convert (long_integer_type_node
, ubound
),
4511 fold_convert (long_integer_type_node
, lbound
));
4516 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4517 "below lower bound of %%ld",
4518 dim
+ 1, expr_name
);
4519 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4521 fold_convert (long_integer_type_node
, tmp
),
4522 fold_convert (long_integer_type_node
, lbound
));
4526 /* Check the section sizes match. */
4527 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4528 gfc_array_index_type
, end
,
4530 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4531 gfc_array_index_type
, tmp
,
4533 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4534 gfc_array_index_type
,
4535 gfc_index_one_node
, tmp
);
4536 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4537 gfc_array_index_type
, tmp
,
4538 build_int_cst (gfc_array_index_type
, 0));
4539 /* We remember the size of the first section, and check all the
4540 others against this. */
4543 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4544 logical_type_node
, tmp
, size
[n
]);
4545 msg
= xasprintf ("Array bound mismatch for dimension %d "
4546 "of array '%s' (%%ld/%%ld)",
4547 dim
+ 1, expr_name
);
4549 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4551 fold_convert (long_integer_type_node
, tmp
),
4552 fold_convert (long_integer_type_node
, size
[n
]));
4557 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4560 tmp
= gfc_finish_block (&inner
);
4562 /* For optional arguments, only check bounds if the argument is
4564 if (expr
->symtree
->n
.sym
->attr
.optional
4565 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4566 tmp
= build3_v (COND_EXPR
,
4567 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4568 tmp
, build_empty_stmt (input_location
));
4570 gfc_add_expr_to_block (&block
, tmp
);
4574 tmp
= gfc_finish_block (&block
);
4575 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4578 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4579 gfc_conv_ss_startstride (loop
);
4582 /* Return true if both symbols could refer to the same data object. Does
4583 not take account of aliasing due to equivalence statements. */
4586 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4587 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4589 /* Aliasing isn't possible if the symbols have different base types. */
4590 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4593 /* Pointers can point to other pointers and target objects. */
4595 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4596 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4599 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4600 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4602 if (lsym_target
&& rsym_target
4603 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4604 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4605 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4606 && (!rsym
->attr
.dimension
4607 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4614 /* Return true if the two SS could be aliased, i.e. both point to the same data
4616 /* TODO: resolve aliases based on frontend expressions. */
4619 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4623 gfc_expr
*lexpr
, *rexpr
;
4626 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4628 lexpr
= lss
->info
->expr
;
4629 rexpr
= rss
->info
->expr
;
4631 lsym
= lexpr
->symtree
->n
.sym
;
4632 rsym
= rexpr
->symtree
->n
.sym
;
4634 lsym_pointer
= lsym
->attr
.pointer
;
4635 lsym_target
= lsym
->attr
.target
;
4636 rsym_pointer
= rsym
->attr
.pointer
;
4637 rsym_target
= rsym
->attr
.target
;
4639 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4640 rsym_pointer
, rsym_target
))
4643 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4644 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4647 /* For derived types we must check all the component types. We can ignore
4648 array references as these will have the same base type as the previous
4650 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4652 if (lref
->type
!= REF_COMPONENT
)
4655 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4656 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4658 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4659 rsym_pointer
, rsym_target
))
4662 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4663 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4665 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4670 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4673 if (rref
->type
!= REF_COMPONENT
)
4676 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4677 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4679 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4680 lsym_pointer
, lsym_target
,
4681 rsym_pointer
, rsym_target
))
4684 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4685 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4687 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4688 &rref
->u
.c
.sym
->ts
))
4690 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4691 &rref
->u
.c
.component
->ts
))
4693 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4694 &rref
->u
.c
.component
->ts
))
4700 lsym_pointer
= lsym
->attr
.pointer
;
4701 lsym_target
= lsym
->attr
.target
;
4702 lsym_pointer
= lsym
->attr
.pointer
;
4703 lsym_target
= lsym
->attr
.target
;
4705 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4707 if (rref
->type
!= REF_COMPONENT
)
4710 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4711 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4713 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4714 lsym_pointer
, lsym_target
,
4715 rsym_pointer
, rsym_target
))
4718 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4719 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4721 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4730 /* Resolve array data dependencies. Creates a temporary if required. */
4731 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4735 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4741 gfc_ss_info
*ss_info
;
4742 gfc_expr
*dest_expr
;
4747 loop
->temp_ss
= NULL
;
4748 dest_expr
= dest
->info
->expr
;
4750 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4753 ss_expr
= ss_info
->expr
;
4755 if (ss_info
->array_outer_dependency
)
4761 if (ss_info
->type
!= GFC_SS_SECTION
)
4763 if (flag_realloc_lhs
4764 && dest_expr
!= ss_expr
4765 && gfc_is_reallocatable_lhs (dest_expr
)
4767 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4769 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4770 if (!nDepend
&& dest_expr
->rank
> 0
4771 && dest_expr
->ts
.type
== BT_CHARACTER
4772 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4774 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4776 if (ss_info
->type
== GFC_SS_REFERENCE
4777 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4778 ss_info
->data
.scalar
.needs_temporary
= 1;
4786 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4788 if (gfc_could_be_alias (dest
, ss
)
4789 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4797 lref
= dest_expr
->ref
;
4798 rref
= ss_expr
->ref
;
4800 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4805 for (i
= 0; i
< dest
->dimen
; i
++)
4806 for (j
= 0; j
< ss
->dimen
; j
++)
4808 && dest
->dim
[i
] == ss
->dim
[j
])
4810 /* If we don't access array elements in the same order,
4811 there is a dependency. */
4816 /* TODO : loop shifting. */
4819 /* Mark the dimensions for LOOP SHIFTING */
4820 for (n
= 0; n
< loop
->dimen
; n
++)
4822 int dim
= dest
->data
.info
.dim
[n
];
4824 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4826 else if (! gfc_is_same_range (&lref
->u
.ar
,
4827 &rref
->u
.ar
, dim
, 0))
4831 /* Put all the dimensions with dependencies in the
4834 for (n
= 0; n
< loop
->dimen
; n
++)
4836 gcc_assert (loop
->order
[n
] == n
);
4838 loop
->order
[dim
++] = n
;
4840 for (n
= 0; n
< loop
->dimen
; n
++)
4843 loop
->order
[dim
++] = n
;
4846 gcc_assert (dim
== loop
->dimen
);
4857 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4858 if (GFC_ARRAY_TYPE_P (base_type
)
4859 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4860 base_type
= gfc_get_element_type (base_type
);
4861 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4863 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4866 loop
->temp_ss
= NULL
;
4870 /* Browse through each array's information from the scalarizer and set the loop
4871 bounds according to the "best" one (per dimension), i.e. the one which
4872 provides the most information (constant bounds, shape, etc.). */
4875 set_loop_bounds (gfc_loopinfo
*loop
)
4877 int n
, dim
, spec_dim
;
4878 gfc_array_info
*info
;
4879 gfc_array_info
*specinfo
;
4883 bool dynamic
[GFC_MAX_DIMENSIONS
];
4886 bool nonoptional_arr
;
4888 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4890 loopspec
= loop
->specloop
;
4893 for (n
= 0; n
< loop
->dimen
; n
++)
4898 /* If there are both optional and nonoptional array arguments, scalarize
4899 over the nonoptional; otherwise, it does not matter as then all
4900 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4902 nonoptional_arr
= false;
4904 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4905 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4906 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4908 nonoptional_arr
= true;
4912 /* We use one SS term, and use that to determine the bounds of the
4913 loop for this dimension. We try to pick the simplest term. */
4914 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4916 gfc_ss_type ss_type
;
4918 ss_type
= ss
->info
->type
;
4919 if (ss_type
== GFC_SS_SCALAR
4920 || ss_type
== GFC_SS_TEMP
4921 || ss_type
== GFC_SS_REFERENCE
4922 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4925 info
= &ss
->info
->data
.array
;
4928 if (loopspec
[n
] != NULL
)
4930 specinfo
= &loopspec
[n
]->info
->data
.array
;
4931 spec_dim
= loopspec
[n
]->dim
[n
];
4935 /* Silence uninitialized warnings. */
4942 gcc_assert (info
->shape
[dim
]);
4943 /* The frontend has worked out the size for us. */
4946 || !integer_zerop (specinfo
->start
[spec_dim
]))
4947 /* Prefer zero-based descriptors if possible. */
4952 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4954 gfc_constructor_base base
;
4955 /* An unknown size constructor will always be rank one.
4956 Higher rank constructors will either have known shape,
4957 or still be wrapped in a call to reshape. */
4958 gcc_assert (loop
->dimen
== 1);
4960 /* Always prefer to use the constructor bounds if the size
4961 can be determined at compile time. Prefer not to otherwise,
4962 since the general case involves realloc, and it's better to
4963 avoid that overhead if possible. */
4964 base
= ss
->info
->expr
->value
.constructor
;
4965 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4966 if (!dynamic
[n
] || !loopspec
[n
])
4971 /* Avoid using an allocatable lhs in an assignment, since
4972 there might be a reallocation coming. */
4973 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4978 /* Criteria for choosing a loop specifier (most important first):
4979 doesn't need realloc
4985 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4987 else if (integer_onep (info
->stride
[dim
])
4988 && !integer_onep (specinfo
->stride
[spec_dim
]))
4990 else if (INTEGER_CST_P (info
->stride
[dim
])
4991 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4993 else if (INTEGER_CST_P (info
->start
[dim
])
4994 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4995 && integer_onep (info
->stride
[dim
])
4996 == integer_onep (specinfo
->stride
[spec_dim
])
4997 && INTEGER_CST_P (info
->stride
[dim
])
4998 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
5000 /* We don't work out the upper bound.
5001 else if (INTEGER_CST_P (info->finish[n])
5002 && ! INTEGER_CST_P (specinfo->finish[n]))
5003 loopspec[n] = ss; */
5006 /* We should have found the scalarization loop specifier. If not,
5008 gcc_assert (loopspec
[n
]);
5010 info
= &loopspec
[n
]->info
->data
.array
;
5011 dim
= loopspec
[n
]->dim
[n
];
5013 /* Set the extents of this range. */
5014 cshape
= info
->shape
;
5015 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5016 && INTEGER_CST_P (info
->stride
[dim
]))
5018 loop
->from
[n
] = info
->start
[dim
];
5019 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5020 mpz_sub_ui (i
, i
, 1);
5021 /* To = from + (size - 1) * stride. */
5022 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5023 if (!integer_onep (info
->stride
[dim
]))
5024 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5025 gfc_array_index_type
, tmp
,
5027 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5028 gfc_array_index_type
,
5029 loop
->from
[n
], tmp
);
5033 loop
->from
[n
] = info
->start
[dim
];
5034 switch (loopspec
[n
]->info
->type
)
5036 case GFC_SS_CONSTRUCTOR
:
5037 /* The upper bound is calculated when we expand the
5039 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5042 case GFC_SS_SECTION
:
5043 /* Use the end expression if it exists and is not constant,
5044 so that it is only evaluated once. */
5045 loop
->to
[n
] = info
->end
[dim
];
5048 case GFC_SS_FUNCTION
:
5049 /* The loop bound will be set when we generate the call. */
5050 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5053 case GFC_SS_INTRINSIC
:
5055 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5057 /* The {l,u}bound of an assumed rank. */
5058 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5059 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5060 && expr
->value
.function
.actual
->next
->expr
== NULL
5061 && expr
->value
.function
.actual
->expr
->rank
== -1);
5063 loop
->to
[n
] = info
->end
[dim
];
5067 case GFC_SS_COMPONENT
:
5069 if (info
->end
[dim
] != NULL_TREE
)
5071 loop
->to
[n
] = info
->end
[dim
];
5083 /* Transform everything so we have a simple incrementing variable. */
5084 if (integer_onep (info
->stride
[dim
]))
5085 info
->delta
[dim
] = gfc_index_zero_node
;
5088 /* Set the delta for this section. */
5089 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5090 /* Number of iterations is (end - start + step) / step.
5091 with start = 0, this simplifies to
5093 for (i = 0; i<=last; i++){...}; */
5094 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5095 gfc_array_index_type
, loop
->to
[n
],
5097 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5098 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5099 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5100 tmp
, build_int_cst (gfc_array_index_type
, -1));
5101 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5102 /* Make the loop variable start at 0. */
5103 loop
->from
[n
] = gfc_index_zero_node
;
5108 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5109 set_loop_bounds (loop
);
5113 /* Initialize the scalarization loop. Creates the loop variables. Determines
5114 the range of the loop variables. Creates a temporary if required.
5115 Also generates code for scalar expressions which have been
5116 moved outside the loop. */
5119 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5124 set_loop_bounds (loop
);
5126 /* Add all the scalar code that can be taken out of the loops.
5127 This may include calculating the loop bounds, so do it before
5128 allocating the temporary. */
5129 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5131 tmp_ss
= loop
->temp_ss
;
5132 /* If we want a temporary then create it. */
5135 gfc_ss_info
*tmp_ss_info
;
5137 tmp_ss_info
= tmp_ss
->info
;
5138 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5139 gcc_assert (loop
->parent
== NULL
);
5141 /* Make absolutely sure that this is a complete type. */
5142 if (tmp_ss_info
->string_length
)
5143 tmp_ss_info
->data
.temp
.type
5144 = gfc_get_character_type_len_for_eltype
5145 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5146 tmp_ss_info
->string_length
);
5148 tmp
= tmp_ss_info
->data
.temp
.type
;
5149 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5150 tmp_ss_info
->type
= GFC_SS_SECTION
;
5152 gcc_assert (tmp_ss
->dimen
!= 0);
5154 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5155 NULL_TREE
, false, true, false, where
);
5158 /* For array parameters we don't have loop variables, so don't calculate the
5160 if (!loop
->array_parameter
)
5161 gfc_set_delta (loop
);
5165 /* Calculates how to transform from loop variables to array indices for each
5166 array: once loop bounds are chosen, sets the difference (DELTA field) between
5167 loop bounds and array reference bounds, for each array info. */
5170 gfc_set_delta (gfc_loopinfo
*loop
)
5172 gfc_ss
*ss
, **loopspec
;
5173 gfc_array_info
*info
;
5177 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5179 loopspec
= loop
->specloop
;
5181 /* Calculate the translation from loop variables to array indices. */
5182 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5184 gfc_ss_type ss_type
;
5186 ss_type
= ss
->info
->type
;
5187 if (ss_type
!= GFC_SS_SECTION
5188 && ss_type
!= GFC_SS_COMPONENT
5189 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5192 info
= &ss
->info
->data
.array
;
5194 for (n
= 0; n
< ss
->dimen
; n
++)
5196 /* If we are specifying the range the delta is already set. */
5197 if (loopspec
[n
] != ss
)
5201 /* Calculate the offset relative to the loop variable.
5202 First multiply by the stride. */
5203 tmp
= loop
->from
[n
];
5204 if (!integer_onep (info
->stride
[dim
]))
5205 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5206 gfc_array_index_type
,
5207 tmp
, info
->stride
[dim
]);
5209 /* Then subtract this from our starting value. */
5210 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5211 gfc_array_index_type
,
5212 info
->start
[dim
], tmp
);
5214 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5219 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5220 gfc_set_delta (loop
);
5224 /* Calculate the size of a given array dimension from the bounds. This
5225 is simply (ubound - lbound + 1) if this expression is positive
5226 or 0 if it is negative (pick either one if it is zero). Optionally
5227 (if or_expr is present) OR the (expression != 0) condition to it. */
5230 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5235 /* Calculate (ubound - lbound + 1). */
5236 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5238 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5239 gfc_index_one_node
);
5241 /* Check whether the size for this dimension is negative. */
5242 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5243 gfc_index_zero_node
);
5244 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5245 gfc_index_zero_node
, res
);
5247 /* Build OR expression. */
5249 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5250 logical_type_node
, *or_expr
, cond
);
5256 /* For an array descriptor, get the total number of elements. This is just
5257 the product of the extents along from_dim to to_dim. */
5260 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5265 res
= gfc_index_one_node
;
5267 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5273 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5274 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5276 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5277 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5285 /* Full size of an array. */
5288 gfc_conv_descriptor_size (tree desc
, int rank
)
5290 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5294 /* Size of a coarray for all dimensions but the last. */
5297 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5299 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5303 /* Fills in an array descriptor, and returns the size of the array.
5304 The size will be a simple_val, ie a variable or a constant. Also
5305 calculates the offset of the base. The pointer argument overflow,
5306 which should be of integer type, will increase in value if overflow
5307 occurs during the size calculation. Returns the size of the array.
5311 for (n = 0; n < rank; n++)
5313 a.lbound[n] = specified_lower_bound;
5314 offset = offset + a.lbond[n] * stride;
5316 a.ubound[n] = specified_upper_bound;
5317 a.stride[n] = stride;
5318 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5319 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5320 stride = stride * size;
5322 for (n = rank; n < rank+corank; n++)
5323 (Set lcobound/ucobound as above.)
5324 element_size = sizeof (array element);
5327 stride = (size_t) stride;
5328 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5329 stride = stride * element_size;
5335 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5336 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5337 stmtblock_t
* descriptor_block
, tree
* overflow
,
5338 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5339 tree expr3_desc
, bool e3_has_nodescriptor
, gfc_expr
*expr
)
5352 stmtblock_t thenblock
;
5353 stmtblock_t elseblock
;
5358 type
= TREE_TYPE (descriptor
);
5360 stride
= gfc_index_one_node
;
5361 offset
= gfc_index_zero_node
;
5363 /* Set the dtype before the alloc, because registration of coarrays needs
5365 if (expr
->ts
.type
== BT_CHARACTER
5366 && expr
->ts
.deferred
5367 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5369 type
= gfc_typenode_for_spec (&expr
->ts
);
5370 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5371 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5373 else if (expr
->ts
.type
== BT_CHARACTER
5374 && expr
->ts
.deferred
5375 && TREE_CODE (descriptor
) == COMPONENT_REF
)
5377 /* Deferred character components have their string length tucked away
5378 in a hidden field of the derived type. Obtain that and use it to
5379 set the dtype. The charlen backend decl is zero because the field
5380 type is zero length. */
5383 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5384 if (ref
->type
== REF_COMPONENT
5385 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
5387 gcc_assert (tmp
!= NULL_TREE
);
5388 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
5389 TREE_OPERAND (descriptor
, 0), tmp
, NULL_TREE
);
5390 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
5391 type
= gfc_get_character_type_len (expr
->ts
.kind
, tmp
);
5392 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5393 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5397 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5398 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5401 or_expr
= logical_false_node
;
5403 for (n
= 0; n
< rank
; n
++)
5408 /* We have 3 possibilities for determining the size of the array:
5409 lower == NULL => lbound = 1, ubound = upper[n]
5410 upper[n] = NULL => lbound = 1, ubound = lower[n]
5411 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5414 /* Set lower bound. */
5415 gfc_init_se (&se
, NULL
);
5416 if (expr3_desc
!= NULL_TREE
)
5418 if (e3_has_nodescriptor
)
5419 /* The lbound of nondescriptor arrays like array constructors,
5420 nonallocatable/nonpointer function results/variables,
5421 start at zero, but when allocating it, the standard expects
5422 the array to start at one. */
5423 se
.expr
= gfc_index_one_node
;
5425 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5428 else if (lower
== NULL
)
5429 se
.expr
= gfc_index_one_node
;
5432 gcc_assert (lower
[n
]);
5435 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5436 gfc_add_block_to_block (pblock
, &se
.pre
);
5440 se
.expr
= gfc_index_one_node
;
5444 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5445 gfc_rank_cst
[n
], se
.expr
);
5446 conv_lbound
= se
.expr
;
5448 /* Work out the offset for this component. */
5449 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5451 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5452 gfc_array_index_type
, offset
, tmp
);
5454 /* Set upper bound. */
5455 gfc_init_se (&se
, NULL
);
5456 if (expr3_desc
!= NULL_TREE
)
5458 if (e3_has_nodescriptor
)
5460 /* The lbound of nondescriptor arrays like array constructors,
5461 nonallocatable/nonpointer function results/variables,
5462 start at zero, but when allocating it, the standard expects
5463 the array to start at one. Therefore fix the upper bound to be
5464 (desc.ubound - desc.lbound) + 1. */
5465 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5466 gfc_array_index_type
,
5467 gfc_conv_descriptor_ubound_get (
5468 expr3_desc
, gfc_rank_cst
[n
]),
5469 gfc_conv_descriptor_lbound_get (
5470 expr3_desc
, gfc_rank_cst
[n
]));
5471 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5472 gfc_array_index_type
, tmp
,
5473 gfc_index_one_node
);
5474 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5477 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5482 gcc_assert (ubound
);
5483 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5484 gfc_add_block_to_block (pblock
, &se
.pre
);
5485 if (ubound
->expr_type
== EXPR_FUNCTION
)
5486 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5488 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5489 gfc_rank_cst
[n
], se
.expr
);
5490 conv_ubound
= se
.expr
;
5492 /* Store the stride. */
5493 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5494 gfc_rank_cst
[n
], stride
);
5496 /* Calculate size and check whether extent is negative. */
5497 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5498 size
= gfc_evaluate_now (size
, pblock
);
5500 /* Check whether multiplying the stride by the number of
5501 elements in this dimension would overflow. We must also check
5502 whether the current dimension has zero size in order to avoid
5505 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5506 gfc_array_index_type
,
5507 fold_convert (gfc_array_index_type
,
5508 TYPE_MAX_VALUE (gfc_array_index_type
)),
5510 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5511 logical_type_node
, tmp
, stride
),
5512 PRED_FORTRAN_OVERFLOW
);
5513 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5514 integer_one_node
, integer_zero_node
);
5515 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5516 logical_type_node
, size
,
5517 gfc_index_zero_node
),
5518 PRED_FORTRAN_SIZE_ZERO
);
5519 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5520 integer_zero_node
, tmp
);
5521 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5523 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5525 /* Multiply the stride by the number of elements in this dimension. */
5526 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5527 gfc_array_index_type
, stride
, size
);
5528 stride
= gfc_evaluate_now (stride
, pblock
);
5531 for (n
= rank
; n
< rank
+ corank
; n
++)
5535 /* Set lower bound. */
5536 gfc_init_se (&se
, NULL
);
5537 if (lower
== NULL
|| lower
[n
] == NULL
)
5539 gcc_assert (n
== rank
+ corank
- 1);
5540 se
.expr
= gfc_index_one_node
;
5544 if (ubound
|| n
== rank
+ corank
- 1)
5546 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5547 gfc_add_block_to_block (pblock
, &se
.pre
);
5551 se
.expr
= gfc_index_one_node
;
5555 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5556 gfc_rank_cst
[n
], se
.expr
);
5558 if (n
< rank
+ corank
- 1)
5560 gfc_init_se (&se
, NULL
);
5561 gcc_assert (ubound
);
5562 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5563 gfc_add_block_to_block (pblock
, &se
.pre
);
5564 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5565 gfc_rank_cst
[n
], se
.expr
);
5569 /* The stride is the number of elements in the array, so multiply by the
5570 size of an element to get the total size. Obviously, if there is a
5571 SOURCE expression (expr3) we must use its element size. */
5572 if (expr3_elem_size
!= NULL_TREE
)
5573 tmp
= expr3_elem_size
;
5574 else if (expr3
!= NULL
)
5576 if (expr3
->ts
.type
== BT_CLASS
)
5579 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5580 gfc_add_vptr_component (sz
);
5581 gfc_add_size_component (sz
);
5582 gfc_init_se (&se_sz
, NULL
);
5583 gfc_conv_expr (&se_sz
, sz
);
5589 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5590 tmp
= TYPE_SIZE_UNIT (tmp
);
5594 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5596 /* Convert to size_t. */
5597 element_size
= fold_convert (size_type_node
, tmp
);
5600 return element_size
;
5602 *nelems
= gfc_evaluate_now (stride
, pblock
);
5603 stride
= fold_convert (size_type_node
, stride
);
5605 /* First check for overflow. Since an array of type character can
5606 have zero element_size, we must check for that before
5608 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5610 TYPE_MAX_VALUE (size_type_node
), element_size
);
5611 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5612 logical_type_node
, tmp
, stride
),
5613 PRED_FORTRAN_OVERFLOW
);
5614 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5615 integer_one_node
, integer_zero_node
);
5616 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5617 logical_type_node
, element_size
,
5618 build_int_cst (size_type_node
, 0)),
5619 PRED_FORTRAN_SIZE_ZERO
);
5620 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5621 integer_zero_node
, tmp
);
5622 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5624 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5626 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5627 stride
, element_size
);
5629 if (poffset
!= NULL
)
5631 offset
= gfc_evaluate_now (offset
, pblock
);
5635 if (integer_zerop (or_expr
))
5637 if (integer_onep (or_expr
))
5638 return build_int_cst (size_type_node
, 0);
5640 var
= gfc_create_var (TREE_TYPE (size
), "size");
5641 gfc_start_block (&thenblock
);
5642 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5643 thencase
= gfc_finish_block (&thenblock
);
5645 gfc_start_block (&elseblock
);
5646 gfc_add_modify (&elseblock
, var
, size
);
5647 elsecase
= gfc_finish_block (&elseblock
);
5649 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5650 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5651 gfc_add_expr_to_block (pblock
, tmp
);
5657 /* Retrieve the last ref from the chain. This routine is specific to
5658 gfc_array_allocate ()'s needs. */
5661 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5663 gfc_ref
*ref
, *prev_ref
;
5666 /* Prevent warnings for uninitialized variables. */
5667 prev_ref
= *prev_ref_in
;
5668 while (ref
&& ref
->next
!= NULL
)
5670 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5671 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5676 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5680 *prev_ref_in
= prev_ref
;
5684 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5685 the work for an ALLOCATE statement. */
5689 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5690 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5691 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5692 bool e3_has_nodescriptor
)
5696 tree offset
= NULL_TREE
;
5697 tree token
= NULL_TREE
;
5700 tree error
= NULL_TREE
;
5701 tree overflow
; /* Boolean storing whether size calculation overflows. */
5702 tree var_overflow
= NULL_TREE
;
5704 tree set_descriptor
;
5705 stmtblock_t set_descriptor_block
;
5706 stmtblock_t elseblock
;
5709 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5710 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5711 non_ulimate_coarray_ptr_comp
;
5715 /* Find the last reference in the chain. */
5716 if (!retrieve_last_ref (&ref
, &prev_ref
))
5719 /* Take the allocatable and coarray properties solely from the expr-ref's
5720 attributes and not from source=-expression. */
5723 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5724 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5725 non_ulimate_coarray_ptr_comp
= false;
5729 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5730 /* Pointer components in coarrayed derived types must be treated
5731 specially in that they are registered without a check if the are
5732 already associated. This does not hold for ultimate coarray
5734 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5735 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5736 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5739 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5740 a coarray. In this case it does not matter whether we are on this_image
5743 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5744 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5751 gcc_assert (coarray
);
5753 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5755 gfc_ref
*old_ref
= ref
;
5756 /* F08:C633: Array shape from expr3. */
5759 /* Find the last reference in the chain. */
5760 if (!retrieve_last_ref (&ref
, &prev_ref
))
5762 if (expr3
->expr_type
== EXPR_FUNCTION
5763 && gfc_expr_attr (expr3
).dimension
)
5768 alloc_w_e3_arr_spec
= true;
5771 /* Figure out the size of the array. */
5772 switch (ref
->u
.ar
.type
)
5778 upper
= ref
->u
.ar
.start
;
5784 lower
= ref
->u
.ar
.start
;
5785 upper
= ref
->u
.ar
.end
;
5789 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5790 || alloc_w_e3_arr_spec
);
5792 lower
= ref
->u
.ar
.as
->lower
;
5793 upper
= ref
->u
.ar
.as
->upper
;
5801 overflow
= integer_zero_node
;
5803 if (expr
->ts
.type
== BT_CHARACTER
5804 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5805 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
5806 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5807 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5808 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5809 se
->string_length
));
5811 gfc_init_block (&set_descriptor_block
);
5812 /* Take the corank only from the actual ref and not from the coref. The
5813 later will mislead the generation of the array dimensions for allocatable/
5814 pointer components in derived types. */
5815 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5816 : ref
->u
.ar
.as
->rank
,
5817 coarray
? ref
->u
.ar
.as
->corank
: 0,
5818 &offset
, lower
, upper
,
5819 &se
->pre
, &set_descriptor_block
, &overflow
,
5820 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5821 e3_has_nodescriptor
, expr
);
5825 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5826 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5828 if (status
== NULL_TREE
)
5830 /* Generate the block of code handling overflow. */
5831 msg
= gfc_build_addr_expr (pchar_type_node
,
5832 gfc_build_localized_cstring_const
5833 ("Integer overflow when calculating the amount of "
5834 "memory to allocate"));
5835 error
= build_call_expr_loc (input_location
,
5836 gfor_fndecl_runtime_error
, 1, msg
);
5840 tree status_type
= TREE_TYPE (status
);
5841 stmtblock_t set_status_block
;
5843 gfc_start_block (&set_status_block
);
5844 gfc_add_modify (&set_status_block
, status
,
5845 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5846 error
= gfc_finish_block (&set_status_block
);
5850 gfc_start_block (&elseblock
);
5852 /* Allocate memory to store the data. */
5853 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5854 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5856 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5858 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5859 : gfc_conv_descriptor_data_get (se
->expr
);
5860 token
= gfc_conv_descriptor_token (se
->expr
);
5861 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5864 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5865 STRIP_NOPS (pointer
);
5867 /* The allocatable variant takes the old pointer as first argument. */
5869 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5870 status
, errmsg
, errlen
, label_finish
, expr
,
5871 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5872 else if (non_ulimate_coarray_ptr_comp
&& token
)
5873 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5874 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5876 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5878 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5882 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5883 logical_type_node
, var_overflow
, integer_zero_node
),
5884 PRED_FORTRAN_OVERFLOW
);
5885 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5886 error
, gfc_finish_block (&elseblock
));
5889 tmp
= gfc_finish_block (&elseblock
);
5891 gfc_add_expr_to_block (&se
->pre
, tmp
);
5893 /* Update the array descriptors. */
5895 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5897 /* Set the span field for pointer and deferred length character arrays. */
5898 if ((is_pointer_array (se
->expr
)
5899 || (expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (expr
)->attr
.class_pointer
)
5900 || (expr
->ts
.type
== BT_CHARACTER
&& TREE_CODE (se
->string_length
)
5902 || (expr
->ts
.type
== BT_CHARACTER
5903 && (expr
->ts
.deferred
|| VAR_P (expr
->ts
.u
.cl
->backend_decl
))))
5905 if (expr3
&& expr3_elem_size
!= NULL_TREE
)
5906 tmp
= expr3_elem_size
;
5907 else if (se
->string_length
5908 && (TREE_CODE (se
->string_length
) == COMPONENT_REF
5909 || (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)))
5911 if (expr
->ts
.kind
!= 1)
5913 tmp
= build_int_cst (gfc_array_index_type
, expr
->ts
.kind
);
5914 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5915 gfc_array_index_type
, tmp
,
5916 fold_convert (gfc_array_index_type
,
5917 se
->string_length
));
5920 tmp
= se
->string_length
;
5923 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se
->expr
)));
5924 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5925 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5928 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5929 if (status
!= NULL_TREE
)
5931 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5932 logical_type_node
, status
,
5933 build_int_cst (TREE_TYPE (status
), 0));
5934 gfc_add_expr_to_block (&se
->pre
,
5935 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5938 build_empty_stmt (input_location
)));
5941 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5947 /* Create an array constructor from an initialization expression.
5948 We assume the frontend already did any expansions and conversions. */
5951 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5958 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5960 if (expr
->expr_type
== EXPR_VARIABLE
5961 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5962 && expr
->symtree
->n
.sym
->value
)
5963 expr
= expr
->symtree
->n
.sym
->value
;
5965 switch (expr
->expr_type
)
5968 case EXPR_STRUCTURE
:
5969 /* A single scalar or derived type value. Create an array with all
5970 elements equal to that value. */
5971 gfc_init_se (&se
, NULL
);
5973 if (expr
->expr_type
== EXPR_CONSTANT
)
5974 gfc_conv_constant (&se
, expr
);
5976 gfc_conv_structure (&se
, expr
, 1);
5978 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5979 /* This will probably eat buckets of memory for large arrays. */
5982 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5988 /* Create a vector of all the elements. */
5989 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5990 c
; c
= gfc_constructor_next (c
))
5994 /* Problems occur when we get something like
5995 integer :: a(lots) = (/(i, i=1, lots)/) */
5996 gfc_fatal_error ("The number of elements in the array "
5997 "constructor at %L requires an increase of "
5998 "the allowed %d upper limit. See "
5999 "%<-fmax-array-constructor%> option",
6000 &expr
->where
, flag_max_array_constructor
);
6003 if (mpz_cmp_si (c
->offset
, 0) != 0)
6004 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6008 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6014 mpz_add (maxval
, c
->offset
, c
->repeat
);
6015 mpz_sub_ui (maxval
, maxval
, 1);
6016 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6017 if (mpz_cmp_si (c
->offset
, 0) != 0)
6019 mpz_add_ui (maxval
, c
->offset
, 1);
6020 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6023 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6025 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6031 gfc_init_se (&se
, NULL
);
6032 switch (c
->expr
->expr_type
)
6035 gfc_conv_constant (&se
, c
->expr
);
6037 /* See gfortran.dg/charlen_15.f90 for instance. */
6038 if (TREE_CODE (se
.expr
) == STRING_CST
6039 && TREE_CODE (type
) == ARRAY_TYPE
)
6042 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6043 atype
= TREE_TYPE (atype
);
6044 if (TREE_CODE (TREE_TYPE (atype
)) == INTEGER_TYPE
6045 && tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6046 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6048 unsigned HOST_WIDE_INT size
6049 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6050 const char *p
= TREE_STRING_POINTER (se
.expr
);
6052 se
.expr
= build_string (size
, p
);
6053 TREE_TYPE (se
.expr
) = atype
;
6058 case EXPR_STRUCTURE
:
6059 gfc_conv_structure (&se
, c
->expr
, 1);
6063 /* Catch those occasional beasts that do not simplify
6064 for one reason or another, assuming that if they are
6065 standard defying the frontend will catch them. */
6066 gfc_conv_expr (&se
, c
->expr
);
6070 if (range
== NULL_TREE
)
6071 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6074 if (index
!= NULL_TREE
)
6075 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6076 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6082 return gfc_build_null_descriptor (type
);
6088 /* Create a constructor from the list of elements. */
6089 tmp
= build_constructor (type
, v
);
6090 TREE_CONSTANT (tmp
) = 1;
6095 /* Generate code to evaluate non-constant coarray cobounds. */
6098 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6099 const gfc_symbol
*sym
)
6107 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6109 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6111 /* Evaluate non-constant array bound expressions. */
6112 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6113 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6115 gfc_init_se (&se
, NULL
);
6116 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6117 gfc_add_block_to_block (pblock
, &se
.pre
);
6118 gfc_add_modify (pblock
, lbound
, se
.expr
);
6120 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6121 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6123 gfc_init_se (&se
, NULL
);
6124 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6125 gfc_add_block_to_block (pblock
, &se
.pre
);
6126 gfc_add_modify (pblock
, ubound
, se
.expr
);
6132 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6133 returns the size (in elements) of the array. */
6136 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6137 stmtblock_t
* pblock
)
6150 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6152 size
= gfc_index_one_node
;
6153 offset
= gfc_index_zero_node
;
6154 for (dim
= 0; dim
< as
->rank
; dim
++)
6156 /* Evaluate non-constant array bound expressions. */
6157 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6158 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6160 gfc_init_se (&se
, NULL
);
6161 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6162 gfc_add_block_to_block (pblock
, &se
.pre
);
6163 gfc_add_modify (pblock
, lbound
, se
.expr
);
6165 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6166 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6168 gfc_init_se (&se
, NULL
);
6169 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6170 gfc_add_block_to_block (pblock
, &se
.pre
);
6171 gfc_add_modify (pblock
, ubound
, se
.expr
);
6173 /* The offset of this dimension. offset = offset - lbound * stride. */
6174 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6176 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6179 /* The size of this dimension, and the stride of the next. */
6180 if (dim
+ 1 < as
->rank
)
6181 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6183 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6185 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6187 /* Calculate stride = size * (ubound + 1 - lbound). */
6188 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6189 gfc_array_index_type
,
6190 gfc_index_one_node
, lbound
);
6191 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6192 gfc_array_index_type
, ubound
, tmp
);
6193 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6194 gfc_array_index_type
, size
, tmp
);
6196 gfc_add_modify (pblock
, stride
, tmp
);
6198 stride
= gfc_evaluate_now (tmp
, pblock
);
6200 /* Make sure that negative size arrays are translated
6201 to being zero size. */
6202 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6203 stride
, gfc_index_zero_node
);
6204 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6205 gfc_array_index_type
, tmp
,
6206 stride
, gfc_index_zero_node
);
6207 gfc_add_modify (pblock
, stride
, tmp
);
6213 gfc_trans_array_cobounds (type
, pblock
, sym
);
6214 gfc_trans_vla_type_sizes (sym
, pblock
);
6221 /* Generate code to initialize/allocate an array variable. */
6224 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6225 gfc_wrapped_block
* block
)
6229 tree tmp
= NULL_TREE
;
6236 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6238 /* Do nothing for USEd variables. */
6239 if (sym
->attr
.use_assoc
)
6242 type
= TREE_TYPE (decl
);
6243 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6244 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6246 gfc_init_block (&init
);
6248 /* Evaluate character string length. */
6249 if (sym
->ts
.type
== BT_CHARACTER
6250 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6252 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6254 gfc_trans_vla_type_sizes (sym
, &init
);
6256 /* Emit a DECL_EXPR for this variable, which will cause the
6257 gimplifier to allocate storage, and all that good stuff. */
6258 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6259 gfc_add_expr_to_block (&init
, tmp
);
6264 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6268 type
= TREE_TYPE (type
);
6270 gcc_assert (!sym
->attr
.use_assoc
);
6271 gcc_assert (!TREE_STATIC (decl
));
6272 gcc_assert (!sym
->module
);
6274 if (sym
->ts
.type
== BT_CHARACTER
6275 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6276 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6278 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6280 /* Don't actually allocate space for Cray Pointees. */
6281 if (sym
->attr
.cray_pointee
)
6283 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6284 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6286 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6290 if (flag_stack_arrays
)
6292 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6293 space
= build_decl (sym
->declared_at
.lb
->location
,
6294 VAR_DECL
, create_tmp_var_name ("A"),
6295 TREE_TYPE (TREE_TYPE (decl
)));
6296 gfc_trans_vla_type_sizes (sym
, &init
);
6300 /* The size is the number of elements in the array, so multiply by the
6301 size of an element to get the total size. */
6302 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6303 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6304 size
, fold_convert (gfc_array_index_type
, tmp
));
6306 /* Allocate memory to hold the data. */
6307 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6308 gfc_add_modify (&init
, decl
, tmp
);
6310 /* Free the temporary. */
6311 tmp
= gfc_call_free (decl
);
6315 /* Set offset of the array. */
6316 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6317 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6319 /* Automatic arrays should not have initializers. */
6320 gcc_assert (!sym
->value
);
6322 inittree
= gfc_finish_block (&init
);
6329 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6330 where also space is located. */
6331 gfc_init_block (&init
);
6332 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6333 TREE_TYPE (space
), space
);
6334 gfc_add_expr_to_block (&init
, tmp
);
6335 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6336 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6337 gfc_add_modify (&init
, decl
, addr
);
6338 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6341 gfc_add_init_cleanup (block
, inittree
, tmp
);
6345 /* Generate entry and exit code for g77 calling convention arrays. */
6348 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6358 gfc_save_backend_locus (&loc
);
6359 gfc_set_backend_locus (&sym
->declared_at
);
6361 /* Descriptor type. */
6362 parm
= sym
->backend_decl
;
6363 type
= TREE_TYPE (parm
);
6364 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6366 gfc_start_block (&init
);
6368 if (sym
->ts
.type
== BT_CHARACTER
6369 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6370 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6372 /* Evaluate the bounds of the array. */
6373 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6375 /* Set the offset. */
6376 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6377 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6379 /* Set the pointer itself if we aren't using the parameter directly. */
6380 if (TREE_CODE (parm
) != PARM_DECL
)
6382 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6383 gfc_add_modify (&init
, parm
, tmp
);
6385 stmt
= gfc_finish_block (&init
);
6387 gfc_restore_backend_locus (&loc
);
6389 /* Add the initialization code to the start of the function. */
6391 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6393 tmp
= gfc_conv_expr_present (sym
);
6394 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6397 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6401 /* Modify the descriptor of an array parameter so that it has the
6402 correct lower bound. Also move the upper bound accordingly.
6403 If the array is not packed, it will be copied into a temporary.
6404 For each dimension we set the new lower and upper bounds. Then we copy the
6405 stride and calculate the offset for this dimension. We also work out
6406 what the stride of a packed array would be, and see it the two match.
6407 If the array need repacking, we set the stride to the values we just
6408 calculated, recalculate the offset and copy the array data.
6409 Code is also added to copy the data back at the end of the function.
6413 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6414 gfc_wrapped_block
* block
)
6421 tree stmtInit
, stmtCleanup
;
6428 tree stride
, stride2
;
6438 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6440 /* Do nothing for pointer and allocatable arrays. */
6441 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6442 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6443 || sym
->attr
.allocatable
6444 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6447 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6449 gfc_trans_g77_array (sym
, block
);
6454 gfc_save_backend_locus (&loc
);
6455 /* loc.nextc is not set by save_backend_locus but the location routines
6457 if (loc
.nextc
== NULL
)
6458 loc
.nextc
= loc
.lb
->line
;
6459 gfc_set_backend_locus (&sym
->declared_at
);
6461 /* Descriptor type. */
6462 type
= TREE_TYPE (tmpdesc
);
6463 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6464 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6466 /* For a class array the dummy array descriptor is in the _class
6468 dumdesc
= gfc_class_data_get (dumdesc
);
6470 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6471 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6472 gfc_start_block (&init
);
6474 if (sym
->ts
.type
== BT_CHARACTER
6475 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6476 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6478 checkparm
= (as
->type
== AS_EXPLICIT
6479 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6481 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6482 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6484 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6486 /* For non-constant shape arrays we only check if the first dimension
6487 is contiguous. Repacking higher dimensions wouldn't gain us
6488 anything as we still don't know the array stride. */
6489 partial
= gfc_create_var (logical_type_node
, "partial");
6490 TREE_USED (partial
) = 1;
6491 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6492 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6493 gfc_index_one_node
);
6494 gfc_add_modify (&init
, partial
, tmp
);
6497 partial
= NULL_TREE
;
6499 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6500 here, however I think it does the right thing. */
6503 /* Set the first stride. */
6504 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6505 stride
= gfc_evaluate_now (stride
, &init
);
6507 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6508 stride
, gfc_index_zero_node
);
6509 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6510 tmp
, gfc_index_one_node
, stride
);
6511 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6512 gfc_add_modify (&init
, stride
, tmp
);
6514 /* Allow the user to disable array repacking. */
6515 stmt_unpacked
= NULL_TREE
;
6519 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6520 /* A library call to repack the array if necessary. */
6521 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6522 stmt_unpacked
= build_call_expr_loc (input_location
,
6523 gfor_fndecl_in_pack
, 1, tmp
);
6525 stride
= gfc_index_one_node
;
6527 if (warn_array_temporaries
)
6528 gfc_warning (OPT_Warray_temporaries
,
6529 "Creating array temporary at %L", &loc
);
6532 /* This is for the case where the array data is used directly without
6533 calling the repack function. */
6534 if (no_repack
|| partial
!= NULL_TREE
)
6535 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6537 stmt_packed
= NULL_TREE
;
6539 /* Assign the data pointer. */
6540 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6542 /* Don't repack unknown shape arrays when the first stride is 1. */
6543 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6544 partial
, stmt_packed
, stmt_unpacked
);
6547 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6548 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6550 offset
= gfc_index_zero_node
;
6551 size
= gfc_index_one_node
;
6553 /* Evaluate the bounds of the array. */
6554 for (n
= 0; n
< as
->rank
; n
++)
6556 if (checkparm
|| !as
->upper
[n
])
6558 /* Get the bounds of the actual parameter. */
6559 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6560 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6564 dubound
= NULL_TREE
;
6565 dlbound
= NULL_TREE
;
6568 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6569 if (!INTEGER_CST_P (lbound
))
6571 gfc_init_se (&se
, NULL
);
6572 gfc_conv_expr_type (&se
, as
->lower
[n
],
6573 gfc_array_index_type
);
6574 gfc_add_block_to_block (&init
, &se
.pre
);
6575 gfc_add_modify (&init
, lbound
, se
.expr
);
6578 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6579 /* Set the desired upper bound. */
6582 /* We know what we want the upper bound to be. */
6583 if (!INTEGER_CST_P (ubound
))
6585 gfc_init_se (&se
, NULL
);
6586 gfc_conv_expr_type (&se
, as
->upper
[n
],
6587 gfc_array_index_type
);
6588 gfc_add_block_to_block (&init
, &se
.pre
);
6589 gfc_add_modify (&init
, ubound
, se
.expr
);
6592 /* Check the sizes match. */
6595 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6599 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6600 gfc_array_index_type
, ubound
, lbound
);
6601 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6602 gfc_array_index_type
,
6603 gfc_index_one_node
, temp
);
6604 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6605 gfc_array_index_type
, dubound
,
6607 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6608 gfc_array_index_type
,
6609 gfc_index_one_node
, stride2
);
6610 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6611 gfc_array_index_type
, temp
, stride2
);
6612 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6613 "%%ld instead of %%ld", n
+1, sym
->name
);
6615 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6616 fold_convert (long_integer_type_node
, temp
),
6617 fold_convert (long_integer_type_node
, stride2
));
6624 /* For assumed shape arrays move the upper bound by the same amount
6625 as the lower bound. */
6626 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6627 gfc_array_index_type
, dubound
, dlbound
);
6628 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6629 gfc_array_index_type
, tmp
, lbound
);
6630 gfc_add_modify (&init
, ubound
, tmp
);
6632 /* The offset of this dimension. offset = offset - lbound * stride. */
6633 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6635 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6636 gfc_array_index_type
, offset
, tmp
);
6638 /* The size of this dimension, and the stride of the next. */
6639 if (n
+ 1 < as
->rank
)
6641 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6643 if (no_repack
|| partial
!= NULL_TREE
)
6645 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6647 /* Figure out the stride if not a known constant. */
6648 if (!INTEGER_CST_P (stride
))
6651 stmt_packed
= NULL_TREE
;
6654 /* Calculate stride = size * (ubound + 1 - lbound). */
6655 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6656 gfc_array_index_type
,
6657 gfc_index_one_node
, lbound
);
6658 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6659 gfc_array_index_type
, ubound
, tmp
);
6660 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6661 gfc_array_index_type
, size
, tmp
);
6665 /* Assign the stride. */
6666 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6667 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6668 gfc_array_index_type
, partial
,
6669 stmt_unpacked
, stmt_packed
);
6671 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6672 gfc_add_modify (&init
, stride
, tmp
);
6677 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6679 if (stride
&& !INTEGER_CST_P (stride
))
6681 /* Calculate size = stride * (ubound + 1 - lbound). */
6682 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6683 gfc_array_index_type
,
6684 gfc_index_one_node
, lbound
);
6685 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6686 gfc_array_index_type
,
6688 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6689 gfc_array_index_type
,
6690 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6691 gfc_add_modify (&init
, stride
, tmp
);
6696 gfc_trans_array_cobounds (type
, &init
, sym
);
6698 /* Set the offset. */
6699 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6700 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6702 gfc_trans_vla_type_sizes (sym
, &init
);
6704 stmtInit
= gfc_finish_block (&init
);
6706 /* Only do the entry/initialization code if the arg is present. */
6707 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6708 optional_arg
= (sym
->attr
.optional
6709 || (sym
->ns
->proc_name
->attr
.entry_master
6710 && sym
->attr
.dummy
));
6713 tmp
= gfc_conv_expr_present (sym
);
6714 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6715 build_empty_stmt (input_location
));
6720 stmtCleanup
= NULL_TREE
;
6723 stmtblock_t cleanup
;
6724 gfc_start_block (&cleanup
);
6726 if (sym
->attr
.intent
!= INTENT_IN
)
6728 /* Copy the data back. */
6729 tmp
= build_call_expr_loc (input_location
,
6730 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6731 gfc_add_expr_to_block (&cleanup
, tmp
);
6734 /* Free the temporary. */
6735 tmp
= gfc_call_free (tmpdesc
);
6736 gfc_add_expr_to_block (&cleanup
, tmp
);
6738 stmtCleanup
= gfc_finish_block (&cleanup
);
6740 /* Only do the cleanup if the array was repacked. */
6742 /* For a class array the dummy array descriptor is in the _class
6744 tmp
= gfc_class_data_get (dumdesc
);
6746 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6747 tmp
= gfc_conv_descriptor_data_get (tmp
);
6748 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6750 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6751 build_empty_stmt (input_location
));
6755 tmp
= gfc_conv_expr_present (sym
);
6756 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6757 build_empty_stmt (input_location
));
6761 /* We don't need to free any memory allocated by internal_pack as it will
6762 be freed at the end of the function by pop_context. */
6763 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6765 gfc_restore_backend_locus (&loc
);
6769 /* Calculate the overall offset, including subreferences. */
6771 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6772 bool subref
, gfc_expr
*expr
)
6782 /* If offset is NULL and this is not a subreferenced array, there is
6784 if (offset
== NULL_TREE
)
6787 offset
= gfc_index_zero_node
;
6792 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6794 /* Offset the data pointer for pointer assignments from arrays with
6795 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6798 /* Go past the array reference. */
6799 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6800 if (ref
->type
== REF_ARRAY
&&
6801 ref
->u
.ar
.type
!= AR_ELEMENT
)
6807 /* Calculate the offset for each subsequent subreference. */
6808 for (; ref
; ref
= ref
->next
)
6813 field
= ref
->u
.c
.component
->backend_decl
;
6814 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6815 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6817 tmp
, field
, NULL_TREE
);
6821 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6822 gfc_init_se (&start
, NULL
);
6823 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6824 gfc_add_block_to_block (block
, &start
.pre
);
6825 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6829 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6830 && ref
->u
.ar
.type
== AR_ELEMENT
);
6832 /* TODO - Add bounds checking. */
6833 stride
= gfc_index_one_node
;
6834 index
= gfc_index_zero_node
;
6835 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6840 /* Update the index. */
6841 gfc_init_se (&start
, NULL
);
6842 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6843 itmp
= gfc_evaluate_now (start
.expr
, block
);
6844 gfc_init_se (&start
, NULL
);
6845 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6846 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6847 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6848 gfc_array_index_type
, itmp
, jtmp
);
6849 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6850 gfc_array_index_type
, itmp
, stride
);
6851 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6852 gfc_array_index_type
, itmp
, index
);
6853 index
= gfc_evaluate_now (index
, block
);
6855 /* Update the stride. */
6856 gfc_init_se (&start
, NULL
);
6857 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6858 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6859 gfc_array_index_type
, start
.expr
,
6861 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6862 gfc_array_index_type
,
6863 gfc_index_one_node
, itmp
);
6864 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6865 gfc_array_index_type
, stride
, itmp
);
6866 stride
= gfc_evaluate_now (stride
, block
);
6869 /* Apply the index to obtain the array element. */
6870 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6880 /* Set the target data pointer. */
6881 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6882 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6886 /* gfc_conv_expr_descriptor needs the string length an expression
6887 so that the size of the temporary can be obtained. This is done
6888 by adding up the string lengths of all the elements in the
6889 expression. Function with non-constant expressions have their
6890 string lengths mapped onto the actual arguments using the
6891 interface mapping machinery in trans-expr.c. */
6893 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6895 gfc_interface_mapping mapping
;
6896 gfc_formal_arglist
*formal
;
6897 gfc_actual_arglist
*arg
;
6900 if (expr
->ts
.u
.cl
->length
6901 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6903 if (!expr
->ts
.u
.cl
->backend_decl
)
6904 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6908 switch (expr
->expr_type
)
6911 get_array_charlen (expr
->value
.op
.op1
, se
);
6913 /* For parentheses the expression ts.u.cl is identical. */
6914 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6917 expr
->ts
.u
.cl
->backend_decl
=
6918 gfc_create_var (gfc_charlen_type_node
, "sln");
6920 if (expr
->value
.op
.op2
)
6922 get_array_charlen (expr
->value
.op
.op2
, se
);
6924 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6926 /* Add the string lengths and assign them to the expression
6927 string length backend declaration. */
6928 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6929 fold_build2_loc (input_location
, PLUS_EXPR
,
6930 gfc_charlen_type_node
,
6931 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6932 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6935 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6936 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6940 if (expr
->value
.function
.esym
== NULL
6941 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6943 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6947 /* Map expressions involving the dummy arguments onto the actual
6948 argument expressions. */
6949 gfc_init_interface_mapping (&mapping
);
6950 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6951 arg
= expr
->value
.function
.actual
;
6953 /* Set se = NULL in the calls to the interface mapping, to suppress any
6955 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6960 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6963 gfc_init_se (&tse
, NULL
);
6965 /* Build the expression for the character length and convert it. */
6966 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6968 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6969 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6970 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6971 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6972 TREE_TYPE (tse
.expr
), tse
.expr
,
6973 build_zero_cst (TREE_TYPE (tse
.expr
)));
6974 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6975 gfc_free_interface_mapping (&mapping
);
6979 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6985 /* Helper function to check dimensions. */
6987 transposed_dims (gfc_ss
*ss
)
6991 for (n
= 0; n
< ss
->dimen
; n
++)
6992 if (ss
->dim
[n
] != n
)
6998 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6999 AR_FULL, suitable for the scalarizer. */
7002 walk_coarray (gfc_expr
*e
)
7006 gcc_assert (gfc_get_corank (e
) > 0);
7008 ss
= gfc_walk_expr (e
);
7010 /* Fix scalar coarray. */
7011 if (ss
== gfc_ss_terminator
)
7018 if (ref
->type
== REF_ARRAY
7019 && ref
->u
.ar
.codimen
> 0)
7025 gcc_assert (ref
!= NULL
);
7026 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7027 ref
->u
.ar
.type
= AR_SECTION
;
7028 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7035 /* Convert an array for passing as an actual argument. Expressions and
7036 vector subscripts are evaluated and stored in a temporary, which is then
7037 passed. For whole arrays the descriptor is passed. For array sections
7038 a modified copy of the descriptor is passed, but using the original data.
7040 This function is also used for array pointer assignments, and there
7043 - se->want_pointer && !se->direct_byref
7044 EXPR is an actual argument. On exit, se->expr contains a
7045 pointer to the array descriptor.
7047 - !se->want_pointer && !se->direct_byref
7048 EXPR is an actual argument to an intrinsic function or the
7049 left-hand side of a pointer assignment. On exit, se->expr
7050 contains the descriptor for EXPR.
7052 - !se->want_pointer && se->direct_byref
7053 EXPR is the right-hand side of a pointer assignment and
7054 se->expr is the descriptor for the previously-evaluated
7055 left-hand side. The function creates an assignment from
7059 The se->force_tmp flag disables the non-copying descriptor optimization
7060 that is used for transpose. It may be used in cases where there is an
7061 alias between the transpose argument and another argument in the same
7065 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7068 gfc_ss_type ss_type
;
7069 gfc_ss_info
*ss_info
;
7071 gfc_array_info
*info
;
7080 bool subref_array_target
= false;
7081 bool deferred_array_component
= false;
7082 gfc_expr
*arg
, *ss_expr
;
7084 if (se
->want_coarray
)
7085 ss
= walk_coarray (expr
);
7087 ss
= gfc_walk_expr (expr
);
7089 gcc_assert (ss
!= NULL
);
7090 gcc_assert (ss
!= gfc_ss_terminator
);
7093 ss_type
= ss_info
->type
;
7094 ss_expr
= ss_info
->expr
;
7096 /* Special case: TRANSPOSE which needs no temporary. */
7097 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7098 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7100 /* This is a call to transpose which has already been handled by the
7101 scalarizer, so that we just need to get its argument's descriptor. */
7102 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7103 expr
= expr
->value
.function
.actual
->expr
;
7106 /* Special case things we know we can pass easily. */
7107 switch (expr
->expr_type
)
7110 /* If we have a linear array section, we can pass it directly.
7111 Otherwise we need to copy it into a temporary. */
7113 gcc_assert (ss_type
== GFC_SS_SECTION
);
7114 gcc_assert (ss_expr
== expr
);
7115 info
= &ss_info
->data
.array
;
7117 /* Get the descriptor for the array. */
7118 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7119 desc
= info
->descriptor
;
7121 /* The charlen backend decl for deferred character components cannot
7122 be used because it is fixed at zero. Instead, the hidden string
7123 length component is used. */
7124 if (expr
->ts
.type
== BT_CHARACTER
7125 && expr
->ts
.deferred
7126 && TREE_CODE (desc
) == COMPONENT_REF
)
7127 deferred_array_component
= true;
7129 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7130 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7131 && !subref_array_target
;
7138 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7140 /* Create a new descriptor if the array doesn't have one. */
7143 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7145 else if (se
->direct_byref
)
7148 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7150 if (full
&& !transposed_dims (ss
))
7152 if (se
->direct_byref
&& !se
->byref_noassign
)
7154 /* Copy the descriptor for pointer assignments. */
7155 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7157 /* Add any offsets from subreferences. */
7158 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7159 subref_array_target
, expr
);
7161 /* ....and set the span field. */
7162 tmp
= gfc_get_array_span (desc
, expr
);
7163 if (tmp
!= NULL_TREE
&& !integer_zerop (tmp
))
7164 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7166 else if (se
->want_pointer
)
7168 /* We pass full arrays directly. This means that pointers and
7169 allocatable arrays should also work. */
7170 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7177 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7178 se
->string_length
= gfc_get_expr_charlen (expr
);
7179 /* The ss_info string length is returned set to the value of the
7180 hidden string length component. */
7181 else if (deferred_array_component
)
7182 se
->string_length
= ss_info
->string_length
;
7184 gfc_free_ss_chain (ss
);
7190 /* A transformational function return value will be a temporary
7191 array descriptor. We still need to go through the scalarizer
7192 to create the descriptor. Elemental functions are handled as
7193 arbitrary expressions, i.e. copy to a temporary. */
7195 if (se
->direct_byref
)
7197 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7199 /* For pointer assignments pass the descriptor directly. */
7203 gcc_assert (se
->ss
== ss
);
7205 if (!is_pointer_array (se
->expr
))
7207 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7208 tmp
= fold_convert (gfc_array_index_type
,
7209 size_in_bytes (tmp
));
7210 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7213 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7214 gfc_conv_expr (se
, expr
);
7216 gfc_free_ss_chain (ss
);
7220 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7222 if (ss_expr
!= expr
)
7223 /* Elemental function. */
7224 gcc_assert ((expr
->value
.function
.esym
!= NULL
7225 && expr
->value
.function
.esym
->attr
.elemental
)
7226 || (expr
->value
.function
.isym
!= NULL
7227 && expr
->value
.function
.isym
->elemental
)
7228 || gfc_inline_intrinsic_function_p (expr
));
7230 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7233 if (expr
->ts
.type
== BT_CHARACTER
7234 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7235 get_array_charlen (expr
, se
);
7241 /* Transformational function. */
7242 info
= &ss_info
->data
.array
;
7248 /* Constant array constructors don't need a temporary. */
7249 if (ss_type
== GFC_SS_CONSTRUCTOR
7250 && expr
->ts
.type
!= BT_CHARACTER
7251 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7254 info
= &ss_info
->data
.array
;
7264 /* Something complicated. Copy it into a temporary. */
7270 /* If we are creating a temporary, we don't need to bother about aliases
7275 gfc_init_loopinfo (&loop
);
7277 /* Associate the SS with the loop. */
7278 gfc_add_ss_to_loop (&loop
, ss
);
7280 /* Tell the scalarizer not to bother creating loop variables, etc. */
7282 loop
.array_parameter
= 1;
7284 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7285 gcc_assert (!se
->direct_byref
);
7287 /* Do we need bounds checking or not? */
7288 ss
->no_bounds_check
= expr
->no_bounds_check
;
7290 /* Setup the scalarizing loops and bounds. */
7291 gfc_conv_ss_startstride (&loop
);
7295 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
7296 get_array_charlen (expr
, se
);
7298 /* Tell the scalarizer to make a temporary. */
7299 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7300 ((expr
->ts
.type
== BT_CHARACTER
)
7301 ? expr
->ts
.u
.cl
->backend_decl
7305 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7306 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7307 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7310 gfc_conv_loop_setup (&loop
, & expr
->where
);
7314 /* Copy into a temporary and pass that. We don't need to copy the data
7315 back because expressions and vector subscripts must be INTENT_IN. */
7316 /* TODO: Optimize passing function return values. */
7321 /* Start the copying loops. */
7322 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7323 gfc_mark_ss_chain_used (ss
, 1);
7324 gfc_start_scalarized_body (&loop
, &block
);
7326 /* Copy each data element. */
7327 gfc_init_se (&lse
, NULL
);
7328 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7329 gfc_init_se (&rse
, NULL
);
7330 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7332 lse
.ss
= loop
.temp_ss
;
7335 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7336 if (expr
->ts
.type
== BT_CHARACTER
)
7338 gfc_conv_expr (&rse
, expr
);
7339 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7340 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7344 gfc_conv_expr_val (&rse
, expr
);
7346 gfc_add_block_to_block (&block
, &rse
.pre
);
7347 gfc_add_block_to_block (&block
, &lse
.pre
);
7349 lse
.string_length
= rse
.string_length
;
7351 deep_copy
= !se
->data_not_needed
7352 && (expr
->expr_type
== EXPR_VARIABLE
7353 || expr
->expr_type
== EXPR_ARRAY
);
7354 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7356 gfc_add_expr_to_block (&block
, tmp
);
7358 /* Finish the copying loops. */
7359 gfc_trans_scalarizing_loops (&loop
, &block
);
7361 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7363 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7365 desc
= info
->descriptor
;
7366 se
->string_length
= ss_info
->string_length
;
7370 /* We pass sections without copying to a temporary. Make a new
7371 descriptor and point it at the section we want. The loop variable
7372 limits will be the limits of the section.
7373 A function may decide to repack the array to speed up access, but
7374 we're not bothered about that here. */
7375 int dim
, ndim
, codim
;
7382 bool onebased
= false, rank_remap
;
7384 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7385 rank_remap
= ss
->dimen
< ndim
;
7387 if (se
->want_coarray
)
7389 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7391 codim
= gfc_get_corank (expr
);
7392 for (n
= 0; n
< codim
- 1; n
++)
7394 /* Make sure we are not lost somehow. */
7395 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7397 /* Make sure the call to gfc_conv_section_startstride won't
7398 generate unnecessary code to calculate stride. */
7399 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7401 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7402 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7403 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7406 gcc_assert (n
== codim
- 1);
7407 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7408 info
->descriptor
, n
+ ndim
, true,
7409 ar
->as
->type
== AS_DEFERRED
);
7410 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7415 /* Set the string_length for a character array. */
7416 if (expr
->ts
.type
== BT_CHARACTER
)
7417 se
->string_length
= gfc_get_expr_charlen (expr
);
7419 /* If we have an array section or are assigning make sure that
7420 the lower bound is 1. References to the full
7421 array should otherwise keep the original bounds. */
7422 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7423 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7424 if (!integer_onep (loop
.from
[dim
]))
7426 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7427 gfc_array_index_type
, gfc_index_one_node
,
7429 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7430 gfc_array_index_type
,
7432 loop
.from
[dim
] = gfc_index_one_node
;
7435 desc
= info
->descriptor
;
7436 if (se
->direct_byref
&& !se
->byref_noassign
)
7438 /* For pointer assignments we fill in the destination. */
7440 parmtype
= TREE_TYPE (parm
);
7444 /* Otherwise make a new one. */
7445 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7446 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7448 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7450 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7451 loop
.from
, loop
.to
, 0,
7452 GFC_ARRAY_UNKNOWN
, false);
7453 parm
= gfc_create_var (parmtype
, "parm");
7455 /* When expression is a class object, then add the class' handle to
7457 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7459 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7462 /* class_expr can be NULL, when no _class ref is in expr.
7463 We must not fix this here with a gfc_fix_class_ref (). */
7466 gfc_init_se (&classse
, NULL
);
7467 gfc_conv_expr (&classse
, class_expr
);
7468 gfc_free_expr (class_expr
);
7470 gcc_assert (classse
.pre
.head
== NULL_TREE
7471 && classse
.post
.head
== NULL_TREE
);
7472 gfc_allocate_lang_decl (parm
);
7473 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7478 /* Set the span field. */
7479 tmp
= gfc_get_array_span (desc
, expr
);
7480 if (tmp
!= NULL_TREE
)
7481 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7483 offset
= gfc_index_zero_node
;
7485 /* The following can be somewhat confusing. We have two
7486 descriptors, a new one and the original array.
7487 {parm, parmtype, dim} refer to the new one.
7488 {desc, type, n, loop} refer to the original, which maybe
7489 a descriptorless array.
7490 The bounds of the scalarization are the bounds of the section.
7491 We don't have to worry about numeric overflows when calculating
7492 the offsets because all elements are within the array data. */
7494 /* Set the dtype. */
7495 tmp
= gfc_conv_descriptor_dtype (parm
);
7496 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7498 /* Set offset for assignments to pointer only to zero if it is not
7500 if ((se
->direct_byref
|| se
->use_offset
)
7501 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7502 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7503 base
= gfc_index_zero_node
;
7504 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7505 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7509 for (n
= 0; n
< ndim
; n
++)
7511 stride
= gfc_conv_array_stride (desc
, n
);
7513 /* Work out the offset. */
7515 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7517 gcc_assert (info
->subscript
[n
]
7518 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7519 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7523 /* Evaluate and remember the start of the section. */
7524 start
= info
->start
[n
];
7525 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7528 tmp
= gfc_conv_array_lbound (desc
, n
);
7529 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7531 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7533 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7537 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7539 /* For elemental dimensions, we only need the offset. */
7543 /* Vector subscripts need copying and are handled elsewhere. */
7545 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7547 /* look for the corresponding scalarizer dimension: dim. */
7548 for (dim
= 0; dim
< ndim
; dim
++)
7549 if (ss
->dim
[dim
] == n
)
7552 /* loop exited early: the DIM being looked for has been found. */
7553 gcc_assert (dim
< ndim
);
7555 /* Set the new lower bound. */
7556 from
= loop
.from
[dim
];
7559 onebased
= integer_onep (from
);
7560 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7561 gfc_rank_cst
[dim
], from
);
7563 /* Set the new upper bound. */
7564 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7565 gfc_rank_cst
[dim
], to
);
7567 /* Multiply the stride by the section stride to get the
7569 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7570 gfc_array_index_type
,
7571 stride
, info
->stride
[n
]);
7573 if ((se
->direct_byref
|| se
->use_offset
)
7574 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7575 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7577 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7578 TREE_TYPE (base
), base
, stride
);
7580 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7583 tmp
= gfc_conv_array_lbound (desc
, n
);
7584 toonebased
= integer_onep (tmp
);
7585 // lb(arr) - from (- start + 1)
7586 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7587 TREE_TYPE (base
), tmp
, from
);
7588 if (onebased
&& toonebased
)
7590 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7591 TREE_TYPE (base
), tmp
, start
);
7592 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7593 TREE_TYPE (base
), tmp
,
7594 gfc_index_one_node
);
7596 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7597 TREE_TYPE (base
), tmp
,
7598 gfc_conv_array_stride (desc
, n
));
7599 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7600 TREE_TYPE (base
), tmp
, base
);
7603 /* Store the new stride. */
7604 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7605 gfc_rank_cst
[dim
], stride
);
7608 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7610 from
= loop
.from
[n
];
7612 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7613 gfc_rank_cst
[n
], from
);
7614 if (n
< loop
.dimen
+ codim
- 1)
7615 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7616 gfc_rank_cst
[n
], to
);
7619 if (se
->data_not_needed
)
7620 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7621 gfc_index_zero_node
);
7623 /* Point the data pointer at the 1st element in the section. */
7624 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7625 subref_array_target
, expr
);
7627 /* Force the offset to be -1, when the lower bound of the highest
7628 dimension is one and the symbol is present and is not a
7629 pointer/allocatable or associated. */
7630 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7631 && !se
->data_not_needed
)
7632 || (se
->use_offset
&& base
!= NULL_TREE
))
7634 /* Set the offset depending on base. */
7635 tmp
= rank_remap
&& !se
->direct_byref
?
7636 fold_build2_loc (input_location
, PLUS_EXPR
,
7637 gfc_array_index_type
, base
,
7640 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7642 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7643 && !se
->data_not_needed
7644 && (!rank_remap
|| se
->use_offset
))
7646 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7647 gfc_conv_descriptor_offset_get (desc
));
7649 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7651 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7652 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7653 && !expr
->symtree
->n
.sym
->attr
.allocatable
7654 && !expr
->symtree
->n
.sym
->attr
.pointer
7655 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7656 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7658 /* Set the offset to -1. */
7660 mpz_init_set_si (minus_one
, -1);
7661 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7662 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7666 /* Only the callee knows what the correct offset it, so just set
7668 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7673 /* For class arrays add the class tree into the saved descriptor to
7674 enable getting of _vptr and the like. */
7675 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7676 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7678 gfc_allocate_lang_decl (desc
);
7679 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7680 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7681 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7682 : expr
->symtree
->n
.sym
->backend_decl
;
7684 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7685 && IS_CLASS_ARRAY (expr
))
7688 gfc_allocate_lang_decl (desc
);
7689 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7690 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7691 vtype
= gfc_class_vptr_get (tmp
);
7692 gfc_add_modify (&se
->pre
, vtype
,
7693 gfc_build_addr_expr (TREE_TYPE (vtype
),
7694 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7696 if (!se
->direct_byref
|| se
->byref_noassign
)
7698 /* Get a pointer to the new descriptor. */
7699 if (se
->want_pointer
)
7700 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7705 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7706 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7708 /* Cleanup the scalarizer. */
7709 gfc_cleanup_loop (&loop
);
7712 /* Helper function for gfc_conv_array_parameter if array size needs to be
7716 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7719 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7720 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7721 else if (expr
->rank
> 1)
7722 *size
= build_call_expr_loc (input_location
,
7723 gfor_fndecl_size0
, 1,
7724 gfc_build_addr_expr (NULL
, desc
));
7727 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7728 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7730 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7731 gfc_array_index_type
, ubound
, lbound
);
7732 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7733 *size
, gfc_index_one_node
);
7734 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7735 *size
, gfc_index_zero_node
);
7737 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7738 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7739 *size
, fold_convert (gfc_array_index_type
, elem
));
7742 /* Convert an array for passing as an actual parameter. */
7743 /* TODO: Optimize passing g77 arrays. */
7746 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7747 const gfc_symbol
*fsym
, const char *proc_name
,
7752 tree tmp
= NULL_TREE
;
7754 tree parent
= DECL_CONTEXT (current_function_decl
);
7755 bool full_array_var
;
7756 bool this_array_result
;
7759 bool array_constructor
;
7760 bool good_allocatable
;
7761 bool ultimate_ptr_comp
;
7762 bool ultimate_alloc_comp
;
7767 ultimate_ptr_comp
= false;
7768 ultimate_alloc_comp
= false;
7770 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7772 if (ref
->next
== NULL
)
7775 if (ref
->type
== REF_COMPONENT
)
7777 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7778 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7782 full_array_var
= false;
7785 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7786 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7788 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7790 /* The symbol should have an array specification. */
7791 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7793 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7795 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7796 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7797 se
->string_length
= tmp
;
7800 /* Is this the result of the enclosing procedure? */
7801 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7802 if (this_array_result
7803 && (sym
->backend_decl
!= current_function_decl
)
7804 && (sym
->backend_decl
!= parent
))
7805 this_array_result
= false;
7807 /* Passing address of the array if it is not pointer or assumed-shape. */
7808 if (full_array_var
&& g77
&& !this_array_result
7809 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7811 tmp
= gfc_get_symbol_decl (sym
);
7813 if (sym
->ts
.type
== BT_CHARACTER
)
7814 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7816 if (!sym
->attr
.pointer
7818 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7819 && sym
->as
->type
!= AS_DEFERRED
7820 && sym
->as
->type
!= AS_ASSUMED_RANK
7821 && !sym
->attr
.allocatable
)
7823 /* Some variables are declared directly, others are declared as
7824 pointers and allocated on the heap. */
7825 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7828 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7830 array_parameter_size (tmp
, expr
, size
);
7834 if (sym
->attr
.allocatable
)
7836 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7838 gfc_conv_expr_descriptor (se
, expr
);
7842 array_parameter_size (tmp
, expr
, size
);
7843 se
->expr
= gfc_conv_array_data (tmp
);
7848 /* A convenient reduction in scope. */
7849 contiguous
= g77
&& !this_array_result
&& contiguous
;
7851 /* There is no need to pack and unpack the array, if it is contiguous
7852 and not a deferred- or assumed-shape array, or if it is simply
7854 no_pack
= ((sym
&& sym
->as
7855 && !sym
->attr
.pointer
7856 && sym
->as
->type
!= AS_DEFERRED
7857 && sym
->as
->type
!= AS_ASSUMED_RANK
7858 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7860 (ref
&& ref
->u
.ar
.as
7861 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7862 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7863 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7865 gfc_is_simply_contiguous (expr
, false, true));
7867 no_pack
= contiguous
&& no_pack
;
7869 /* Array constructors are always contiguous and do not need packing. */
7870 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7872 /* Same is true of contiguous sections from allocatable variables. */
7873 good_allocatable
= contiguous
7875 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7877 /* Or ultimate allocatable components. */
7878 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7880 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7882 gfc_conv_expr_descriptor (se
, expr
);
7883 /* Deallocate the allocatable components of structures that are
7885 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7886 && expr
->ts
.u
.derived
->attr
.alloc_comp
7887 && expr
->expr_type
!= EXPR_VARIABLE
)
7889 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7891 /* The components shall be deallocated before their containing entity. */
7892 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7894 if (expr
->ts
.type
== BT_CHARACTER
)
7895 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7897 array_parameter_size (se
->expr
, expr
, size
);
7898 se
->expr
= gfc_conv_array_data (se
->expr
);
7902 if (this_array_result
)
7904 /* Result of the enclosing function. */
7905 gfc_conv_expr_descriptor (se
, expr
);
7907 array_parameter_size (se
->expr
, expr
, size
);
7908 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7910 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7911 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7912 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7919 /* Every other type of array. */
7920 se
->want_pointer
= 1;
7921 gfc_conv_expr_descriptor (se
, expr
);
7924 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7929 /* Deallocate the allocatable components of structures that are
7930 not variable, for descriptorless arguments.
7931 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7932 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7933 && expr
->ts
.u
.derived
->attr
.alloc_comp
7934 && expr
->expr_type
!= EXPR_VARIABLE
)
7936 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7937 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7939 /* The components shall be deallocated before their containing entity. */
7940 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7943 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7944 && !gfc_is_simply_contiguous (expr
, false, true)))
7946 tree origptr
= NULL_TREE
;
7950 /* For contiguous arrays, save the original value of the descriptor. */
7953 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7954 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7955 tmp
= gfc_conv_array_data (tmp
);
7956 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7957 TREE_TYPE (origptr
), origptr
,
7958 fold_convert (TREE_TYPE (origptr
), tmp
));
7959 gfc_add_expr_to_block (&se
->pre
, tmp
);
7962 /* Repack the array. */
7963 if (warn_array_temporaries
)
7966 gfc_warning (OPT_Warray_temporaries
,
7967 "Creating array temporary at %L for argument %qs",
7968 &expr
->where
, fsym
->name
);
7970 gfc_warning (OPT_Warray_temporaries
,
7971 "Creating array temporary at %L", &expr
->where
);
7974 ptr
= build_call_expr_loc (input_location
,
7975 gfor_fndecl_in_pack
, 1, desc
);
7977 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7979 tmp
= gfc_conv_expr_present (sym
);
7980 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7981 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7982 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7985 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7987 /* Use the packed data for the actual argument, except for contiguous arrays,
7988 where the descriptor's data component is set. */
7993 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7995 gfc_ss
* ss
= gfc_walk_expr (expr
);
7996 if (!transposed_dims (ss
))
7997 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
8000 tree old_field
, new_field
;
8002 /* The original descriptor has transposed dims so we can't reuse
8003 it directly; we have to create a new one. */
8004 tree old_desc
= tmp
;
8005 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8007 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8008 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8009 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8011 old_field
= gfc_conv_descriptor_offset (old_desc
);
8012 new_field
= gfc_conv_descriptor_offset (new_desc
);
8013 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8015 for (int i
= 0; i
< expr
->rank
; i
++)
8017 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8018 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8019 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8021 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8024 if (flag_coarray
== GFC_FCOARRAY_LIB
8025 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8026 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8027 == GFC_ARRAY_ALLOCATABLE
)
8029 old_field
= gfc_conv_descriptor_token (old_desc
);
8030 new_field
= gfc_conv_descriptor_token (new_desc
);
8031 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8034 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8035 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8040 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8044 if (fsym
&& proc_name
)
8045 msg
= xasprintf ("An array temporary was created for argument "
8046 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8048 msg
= xasprintf ("An array temporary was created");
8050 tmp
= build_fold_indirect_ref_loc (input_location
,
8052 tmp
= gfc_conv_array_data (tmp
);
8053 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8054 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8056 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8057 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8059 gfc_conv_expr_present (sym
), tmp
);
8061 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8066 gfc_start_block (&block
);
8068 /* Copy the data back. */
8069 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8071 tmp
= build_call_expr_loc (input_location
,
8072 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8073 gfc_add_expr_to_block (&block
, tmp
);
8076 /* Free the temporary. */
8077 tmp
= gfc_call_free (ptr
);
8078 gfc_add_expr_to_block (&block
, tmp
);
8080 stmt
= gfc_finish_block (&block
);
8082 gfc_init_block (&block
);
8083 /* Only if it was repacked. This code needs to be executed before the
8084 loop cleanup code. */
8085 tmp
= build_fold_indirect_ref_loc (input_location
,
8087 tmp
= gfc_conv_array_data (tmp
);
8088 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8089 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8091 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8092 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8094 gfc_conv_expr_present (sym
), tmp
);
8096 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8098 gfc_add_expr_to_block (&block
, tmp
);
8099 gfc_add_block_to_block (&block
, &se
->post
);
8101 gfc_init_block (&se
->post
);
8103 /* Reset the descriptor pointer. */
8106 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8107 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8110 gfc_add_block_to_block (&se
->post
, &block
);
8115 /* This helper function calculates the size in words of a full array. */
8118 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8123 idx
= gfc_rank_cst
[rank
- 1];
8124 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8125 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8126 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8128 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8129 tmp
, gfc_index_one_node
);
8130 tmp
= gfc_evaluate_now (tmp
, block
);
8132 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8133 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8135 return gfc_evaluate_now (tmp
, block
);
8139 /* Allocate dest to the same size as src, and copy src -> dest.
8140 If no_malloc is set, only the copy is done. */
8143 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8144 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8145 tree add_when_allocated
)
8154 /* If the source is null, set the destination to null. Then,
8155 allocate memory to the destination. */
8156 gfc_init_block (&block
);
8158 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8160 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8161 null_data
= gfc_finish_block (&block
);
8163 gfc_init_block (&block
);
8164 if (str_sz
!= NULL_TREE
)
8167 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8171 tmp
= gfc_call_malloc (&block
, type
, size
);
8172 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8177 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8178 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8179 fold_convert (size_type_node
, size
));
8180 gfc_add_expr_to_block (&block
, tmp
);
8185 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8186 null_data
= gfc_finish_block (&block
);
8188 gfc_init_block (&block
);
8190 nelems
= gfc_full_array_size (&block
, src
, rank
);
8192 nelems
= gfc_index_one_node
;
8194 if (str_sz
!= NULL_TREE
)
8195 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8197 tmp
= fold_convert (gfc_array_index_type
,
8198 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8199 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8203 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8204 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8205 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8208 /* We know the temporary and the value will be the same length,
8209 so can use memcpy. */
8212 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8213 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8214 gfc_conv_descriptor_data_get (dest
),
8215 gfc_conv_descriptor_data_get (src
),
8216 fold_convert (size_type_node
, size
));
8217 gfc_add_expr_to_block (&block
, tmp
);
8221 gfc_add_expr_to_block (&block
, add_when_allocated
);
8222 tmp
= gfc_finish_block (&block
);
8224 /* Null the destination if the source is null; otherwise do
8225 the allocate and copy. */
8226 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8229 null_cond
= gfc_conv_descriptor_data_get (src
);
8231 null_cond
= convert (pvoid_type_node
, null_cond
);
8232 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8233 null_cond
, null_pointer_node
);
8234 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8238 /* Allocate dest to the same size as src, and copy data src -> dest. */
8241 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8242 tree add_when_allocated
)
8244 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8245 NULL_TREE
, add_when_allocated
);
8249 /* Copy data src -> dest. */
8252 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8254 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8255 NULL_TREE
, NULL_TREE
);
8258 /* Allocate dest to the same size as src, but don't copy anything. */
8261 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8263 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8264 NULL_TREE
, NULL_TREE
);
8269 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8270 tree type
, int rank
)
8277 stmtblock_t block
, globalblock
;
8279 /* If the source is null, set the destination to null. Then,
8280 allocate memory to the destination. */
8281 gfc_init_block (&block
);
8282 gfc_init_block (&globalblock
);
8284 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8287 symbol_attribute attr
;
8290 gfc_init_se (&se
, NULL
);
8291 gfc_clear_attr (&attr
);
8292 attr
.allocatable
= 1;
8293 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8294 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8295 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8297 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8298 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8299 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8300 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8301 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8302 null_data
= gfc_finish_block (&block
);
8304 gfc_init_block (&block
);
8306 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8307 fold_convert (size_type_node
, size
),
8308 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8309 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8310 GFC_CAF_COARRAY_ALLOC
);
8312 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8313 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8314 fold_convert (size_type_node
, size
));
8315 gfc_add_expr_to_block (&block
, tmp
);
8319 /* Set the rank or unitialized memory access may be reported. */
8320 tmp
= gfc_conv_descriptor_rank (dest
);
8321 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8324 nelems
= gfc_full_array_size (&block
, src
, rank
);
8326 nelems
= integer_one_node
;
8328 tmp
= fold_convert (size_type_node
,
8329 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8330 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8331 fold_convert (size_type_node
, nelems
), tmp
);
8333 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8334 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8336 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8337 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8338 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8339 null_data
= gfc_finish_block (&block
);
8341 gfc_init_block (&block
);
8342 gfc_allocate_using_caf_lib (&block
, dest
,
8343 fold_convert (size_type_node
, size
),
8344 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8345 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8346 GFC_CAF_COARRAY_ALLOC
);
8348 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8349 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8350 gfc_conv_descriptor_data_get (dest
),
8351 gfc_conv_descriptor_data_get (src
),
8352 fold_convert (size_type_node
, size
));
8353 gfc_add_expr_to_block (&block
, tmp
);
8356 tmp
= gfc_finish_block (&block
);
8358 /* Null the destination if the source is null; otherwise do
8359 the register and copy. */
8360 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8363 null_cond
= gfc_conv_descriptor_data_get (src
);
8365 null_cond
= convert (pvoid_type_node
, null_cond
);
8366 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8367 null_cond
, null_pointer_node
);
8368 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8370 return gfc_finish_block (&globalblock
);
8374 /* Helper function to abstract whether coarray processing is enabled. */
8377 caf_enabled (int caf_mode
)
8379 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8380 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8384 /* Helper function to abstract whether coarray processing is enabled
8385 and we are in a derived type coarray. */
8388 caf_in_coarray (int caf_mode
)
8390 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8391 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8392 return (caf_mode
& pat
) == pat
;
8396 /* Helper function to abstract whether coarray is to deallocate only. */
8399 gfc_caf_is_dealloc_only (int caf_mode
)
8401 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8402 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8406 /* Recursively traverse an object of derived type, generating code to
8407 deallocate, nullify or copy allocatable components. This is the work horse
8408 function for the functions named in this enum. */
8410 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8411 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8412 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8414 static gfc_actual_arglist
*pdt_param_list
;
8417 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8418 tree dest
, int rank
, int purpose
, int caf_mode
)
8422 stmtblock_t fnblock
;
8423 stmtblock_t loopbody
;
8424 stmtblock_t tmpblock
;
8435 tree null_cond
= NULL_TREE
;
8436 tree add_when_allocated
;
8437 tree dealloc_fndecl
;
8441 symbol_attribute
*attr
;
8442 bool deallocate_called
;
8444 gfc_init_block (&fnblock
);
8446 decl_type
= TREE_TYPE (decl
);
8448 if ((POINTER_TYPE_P (decl_type
))
8449 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8451 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8452 /* Deref dest in sync with decl, but only when it is not NULL. */
8454 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8456 /* Update the decl_type because it got dereferenced. */
8457 decl_type
= TREE_TYPE (decl
);
8460 /* If this is an array of derived types with allocatable components
8461 build a loop and recursively call this function. */
8462 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8463 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8465 tmp
= gfc_conv_array_data (decl
);
8466 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8468 /* Get the number of elements - 1 and set the counter. */
8469 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8471 /* Use the descriptor for an allocatable array. Since this
8472 is a full array reference, we only need the descriptor
8473 information from dimension = rank. */
8474 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8475 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8476 gfc_array_index_type
, tmp
,
8477 gfc_index_one_node
);
8479 null_cond
= gfc_conv_descriptor_data_get (decl
);
8480 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8481 logical_type_node
, null_cond
,
8482 build_int_cst (TREE_TYPE (null_cond
), 0));
8486 /* Otherwise use the TYPE_DOMAIN information. */
8487 tmp
= array_type_nelts (decl_type
);
8488 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8491 /* Remember that this is, in fact, the no. of elements - 1. */
8492 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8493 index
= gfc_create_var (gfc_array_index_type
, "S");
8495 /* Build the body of the loop. */
8496 gfc_init_block (&loopbody
);
8498 vref
= gfc_build_array_ref (var
, index
, NULL
);
8500 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8501 && !caf_enabled (caf_mode
))
8503 tmp
= build_fold_indirect_ref_loc (input_location
,
8504 gfc_conv_array_data (dest
));
8505 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8506 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8507 COPY_ALLOC_COMP
, 0);
8510 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8513 gfc_add_expr_to_block (&loopbody
, tmp
);
8515 /* Build the loop and return. */
8516 gfc_init_loopinfo (&loop
);
8518 loop
.from
[0] = gfc_index_zero_node
;
8519 loop
.loopvar
[0] = index
;
8520 loop
.to
[0] = nelems
;
8521 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8522 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8524 tmp
= gfc_finish_block (&fnblock
);
8525 /* When copying allocateable components, the above implements the
8526 deep copy. Nevertheless is a deep copy only allowed, when the current
8527 component is allocated, for which code will be generated in
8528 gfc_duplicate_allocatable (), where the deep copy code is just added
8529 into the if's body, by adding tmp (the deep copy code) as last
8530 argument to gfc_duplicate_allocatable (). */
8531 if (purpose
== COPY_ALLOC_COMP
8532 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8533 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8535 else if (null_cond
!= NULL_TREE
)
8536 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8537 build_empty_stmt (input_location
));
8542 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8544 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8545 DEALLOCATE_PDT_COMP
, 0);
8546 gfc_add_expr_to_block (&fnblock
, tmp
);
8548 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8550 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8551 NULLIFY_ALLOC_COMP
, 0);
8552 gfc_add_expr_to_block (&fnblock
, tmp
);
8555 /* Otherwise, act on the components or recursively call self to
8556 act on a chain of components. */
8557 for (c
= der_type
->components
; c
; c
= c
->next
)
8559 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8560 || c
->ts
.type
== BT_CLASS
)
8561 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8562 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8563 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8565 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8566 && c
->ts
.u
.derived
->attr
.pdt_type
;
8568 cdecl = c
->backend_decl
;
8569 ctype
= TREE_TYPE (cdecl);
8573 case DEALLOCATE_ALLOC_COMP
:
8575 gfc_init_block (&tmpblock
);
8577 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8578 decl
, cdecl, NULL_TREE
);
8580 /* Shortcut to get the attributes of the component. */
8581 if (c
->ts
.type
== BT_CLASS
)
8583 attr
= &CLASS_DATA (c
)->attr
;
8584 if (attr
->class_pointer
)
8594 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8595 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8596 /* Call the finalizer, which will free the memory and nullify the
8597 pointer of an array. */
8598 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8599 caf_enabled (caf_mode
))
8602 deallocate_called
= false;
8604 /* Add the _class ref for classes. */
8605 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8606 comp
= gfc_class_data_get (comp
);
8608 add_when_allocated
= NULL_TREE
;
8609 if (cmp_has_alloc_comps
8610 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8612 && !deallocate_called
)
8614 /* Add checked deallocation of the components. This code is
8615 obviously added because the finalizer is not trusted to free
8617 if (c
->ts
.type
== BT_CLASS
)
8619 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8621 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8622 comp
, NULL_TREE
, rank
, purpose
,
8627 rank
= c
->as
? c
->as
->rank
: 0;
8628 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8635 if (attr
->allocatable
&& !same_type
8636 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8638 /* Handle all types of components besides components of the
8639 same_type as the current one, because those would create an
8642 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8643 ? (gfc_caf_is_dealloc_only (caf_mode
)
8644 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8645 : GFC_CAF_COARRAY_DEREGISTER
)
8646 : GFC_CAF_COARRAY_NOCOARRAY
;
8648 caf_token
= NULL_TREE
;
8649 /* Coarray components are handled directly by
8650 deallocate_with_status. */
8651 if (!attr
->codimension
8652 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8655 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8656 TREE_TYPE (c
->caf_token
),
8657 decl
, c
->caf_token
, NULL_TREE
);
8658 else if (attr
->dimension
&& !attr
->proc_pointer
)
8659 caf_token
= gfc_conv_descriptor_token (comp
);
8661 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8662 /* When this is an array but not in conjunction with a coarray
8663 then add the data-ref. For coarray'ed arrays the data-ref
8664 is added by deallocate_with_status. */
8665 comp
= gfc_conv_descriptor_data_get (comp
);
8667 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8668 NULL_TREE
, NULL_TREE
, true,
8669 NULL
, caf_dereg_mode
,
8670 add_when_allocated
, caf_token
);
8672 gfc_add_expr_to_block (&tmpblock
, tmp
);
8674 else if (attr
->allocatable
&& !attr
->codimension
8675 && !deallocate_called
)
8677 /* Case of recursive allocatable derived types. */
8681 stmtblock_t dealloc_block
;
8683 gfc_init_block (&dealloc_block
);
8684 if (add_when_allocated
)
8685 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8687 /* Convert the component into a rank 1 descriptor type. */
8688 if (attr
->dimension
)
8690 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8691 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8692 c
->ts
.type
== BT_CLASS
8693 ? CLASS_DATA (c
)->as
->rank
8698 tmp
= TREE_TYPE (comp
);
8699 ubound
= build_int_cst (gfc_array_index_type
, 1);
8702 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8704 GFC_ARRAY_ALLOCATABLE
, false);
8706 cdesc
= gfc_create_var (cdesc
, "cdesc");
8707 DECL_ARTIFICIAL (cdesc
) = 1;
8709 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8710 gfc_get_dtype_rank_type (1, tmp
));
8711 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8712 gfc_index_zero_node
,
8713 gfc_index_one_node
);
8714 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8715 gfc_index_zero_node
,
8716 gfc_index_one_node
);
8717 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8718 gfc_index_zero_node
, ubound
);
8720 if (attr
->dimension
)
8721 comp
= gfc_conv_descriptor_data_get (comp
);
8723 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8725 /* Now call the deallocator. */
8726 vtab
= gfc_find_vtab (&c
->ts
);
8727 if (vtab
->backend_decl
== NULL
)
8728 gfc_get_symbol_decl (vtab
);
8729 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8730 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8731 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8733 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8734 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8735 logical_type_node
, tmp
,
8737 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8739 tmp
= build_call_expr_loc (input_location
,
8742 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8744 tmp
= gfc_finish_block (&dealloc_block
);
8746 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8747 void_type_node
, is_allocated
, tmp
,
8748 build_empty_stmt (input_location
));
8750 gfc_add_expr_to_block (&tmpblock
, tmp
);
8752 else if (add_when_allocated
)
8753 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8755 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8756 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8758 /* Finally, reset the vptr to the declared type vtable and, if
8759 necessary reset the _len field.
8761 First recover the reference to the component and obtain
8763 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8764 decl
, cdecl, NULL_TREE
);
8765 tmp
= gfc_class_vptr_get (comp
);
8767 if (UNLIMITED_POLY (c
))
8769 /* Both vptr and _len field should be nulled. */
8770 gfc_add_modify (&tmpblock
, tmp
,
8771 build_int_cst (TREE_TYPE (tmp
), 0));
8772 tmp
= gfc_class_len_get (comp
);
8773 gfc_add_modify (&tmpblock
, tmp
,
8774 build_int_cst (TREE_TYPE (tmp
), 0));
8778 /* Build the vtable address and set the vptr with it. */
8781 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8782 vtab
= vtable
->backend_decl
;
8783 if (vtab
== NULL_TREE
)
8784 vtab
= gfc_get_symbol_decl (vtable
);
8785 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8786 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8787 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8791 /* Now add the deallocation of this component. */
8792 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8795 case NULLIFY_ALLOC_COMP
:
8797 - allocatable components (regular or in class)
8798 - components that have allocatable components
8799 - pointer components when in a coarray.
8800 Skip everything else especially proc_pointers, which may come
8801 coupled with the regular pointer attribute. */
8802 if (c
->attr
.proc_pointer
8803 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8804 && CLASS_DATA (c
)->attr
.allocatable
)
8805 || (cmp_has_alloc_comps
8806 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8807 || (c
->ts
.type
== BT_CLASS
8808 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8809 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8812 /* Process class components first, because they always have the
8813 pointer-attribute set which would be caught wrong else. */
8814 if (c
->ts
.type
== BT_CLASS
8815 && (CLASS_DATA (c
)->attr
.allocatable
8816 || CLASS_DATA (c
)->attr
.class_pointer
))
8818 /* Allocatable CLASS components. */
8819 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8820 decl
, cdecl, NULL_TREE
);
8822 comp
= gfc_class_data_get (comp
);
8823 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8824 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8828 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8829 void_type_node
, comp
,
8830 build_int_cst (TREE_TYPE (comp
), 0));
8831 gfc_add_expr_to_block (&fnblock
, tmp
);
8833 cmp_has_alloc_comps
= false;
8835 /* Coarrays need the component to be nulled before the api-call
8837 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8839 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8840 decl
, cdecl, NULL_TREE
);
8841 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8842 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8845 gfc_add_modify (&fnblock
, comp
,
8846 build_int_cst (TREE_TYPE (comp
), 0));
8847 if (gfc_deferred_strlen (c
, &comp
))
8849 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8851 decl
, comp
, NULL_TREE
);
8852 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8853 TREE_TYPE (comp
), comp
,
8854 build_int_cst (TREE_TYPE (comp
), 0));
8855 gfc_add_expr_to_block (&fnblock
, tmp
);
8857 cmp_has_alloc_comps
= false;
8860 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
8862 /* Register a component of a derived type coarray with the
8863 coarray library. Do not register ultimate component
8864 coarrays here. They are treated like regular coarrays and
8865 are either allocated on all images or on none. */
8868 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8869 decl
, cdecl, NULL_TREE
);
8870 if (c
->attr
.dimension
)
8872 /* Set the dtype, because caf_register needs it. */
8873 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8874 gfc_get_dtype (TREE_TYPE (comp
)));
8875 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8876 decl
, cdecl, NULL_TREE
);
8877 token
= gfc_conv_descriptor_token (tmp
);
8883 gfc_init_se (&se
, NULL
);
8884 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8885 pvoid_type_node
, decl
, c
->caf_token
,
8887 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8888 c
->ts
.type
== BT_CLASS
8889 ? CLASS_DATA (c
)->attr
8891 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8894 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8895 gfc_build_addr_expr (NULL_TREE
,
8897 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8898 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8901 if (cmp_has_alloc_comps
)
8903 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8904 decl
, cdecl, NULL_TREE
);
8905 rank
= c
->as
? c
->as
->rank
: 0;
8906 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8907 rank
, purpose
, caf_mode
);
8908 gfc_add_expr_to_block (&fnblock
, tmp
);
8912 case REASSIGN_CAF_COMP
:
8913 if (caf_enabled (caf_mode
)
8914 && (c
->attr
.codimension
8915 || (c
->ts
.type
== BT_CLASS
8916 && (CLASS_DATA (c
)->attr
.coarray_comp
8917 || caf_in_coarray (caf_mode
)))
8918 || (c
->ts
.type
== BT_DERIVED
8919 && (c
->ts
.u
.derived
->attr
.coarray_comp
8920 || caf_in_coarray (caf_mode
))))
8923 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8924 decl
, cdecl, NULL_TREE
);
8925 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8926 dest
, cdecl, NULL_TREE
);
8928 if (c
->attr
.codimension
)
8930 if (c
->ts
.type
== BT_CLASS
)
8932 comp
= gfc_class_data_get (comp
);
8933 dcmp
= gfc_class_data_get (dcmp
);
8935 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8936 gfc_conv_descriptor_data_get (comp
));
8940 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8941 rank
, purpose
, caf_mode
8942 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8943 gfc_add_expr_to_block (&fnblock
, tmp
);
8948 case COPY_ALLOC_COMP
:
8949 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
8952 /* We need source and destination components. */
8953 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8955 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8957 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8959 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8967 dst_data
= gfc_class_data_get (dcmp
);
8968 src_data
= gfc_class_data_get (comp
);
8969 size
= fold_convert (size_type_node
,
8970 gfc_class_vtab_size_get (comp
));
8972 if (CLASS_DATA (c
)->attr
.dimension
)
8974 nelems
= gfc_conv_descriptor_size (src_data
,
8975 CLASS_DATA (c
)->as
->rank
);
8976 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8977 size_type_node
, size
,
8978 fold_convert (size_type_node
,
8982 nelems
= build_int_cst (size_type_node
, 1);
8984 if (CLASS_DATA (c
)->attr
.dimension
8985 || CLASS_DATA (c
)->attr
.codimension
)
8987 src_data
= gfc_conv_descriptor_data_get (src_data
);
8988 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8991 gfc_init_block (&tmpblock
);
8993 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
8994 gfc_class_vptr_get (comp
));
8996 /* Copy the unlimited '_len' field. If it is greater than zero
8997 (ie. a character(_len)), multiply it by size and use this
8998 for the malloc call. */
8999 if (UNLIMITED_POLY (c
))
9002 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
9003 gfc_class_len_get (comp
));
9005 size
= gfc_evaluate_now (size
, &tmpblock
);
9006 tmp
= gfc_class_len_get (comp
);
9007 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9008 size_type_node
, size
,
9009 fold_convert (size_type_node
, tmp
));
9010 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9011 logical_type_node
, tmp
,
9012 build_zero_cst (TREE_TYPE (tmp
)));
9013 size
= fold_build3_loc (input_location
, COND_EXPR
,
9014 size_type_node
, tmp
, ctmp
, size
);
9015 size
= gfc_evaluate_now (size
, &tmpblock
);
9018 /* Coarray component have to have the same allocation status and
9019 shape/type-parameter/effective-type on the LHS and RHS of an
9020 intrinsic assignment. Hence, we did not deallocated them - and
9021 do not allocate them here. */
9022 if (!CLASS_DATA (c
)->attr
.codimension
)
9024 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9025 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9026 gfc_add_modify (&tmpblock
, dst_data
,
9027 fold_convert (TREE_TYPE (dst_data
), tmp
));
9030 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9031 UNLIMITED_POLY (c
));
9032 gfc_add_expr_to_block (&tmpblock
, tmp
);
9033 tmp
= gfc_finish_block (&tmpblock
);
9035 gfc_init_block (&tmpblock
);
9036 gfc_add_modify (&tmpblock
, dst_data
,
9037 fold_convert (TREE_TYPE (dst_data
),
9038 null_pointer_node
));
9039 null_data
= gfc_finish_block (&tmpblock
);
9041 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9042 logical_type_node
, src_data
,
9045 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9050 /* To implement guarded deep copy, i.e., deep copy only allocatable
9051 components that are really allocated, the deep copy code has to
9052 be generated first and then added to the if-block in
9053 gfc_duplicate_allocatable (). */
9054 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9056 rank
= c
->as
? c
->as
->rank
: 0;
9057 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9058 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9059 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9065 add_when_allocated
= NULL_TREE
;
9067 if (gfc_deferred_strlen (c
, &tmp
))
9071 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9073 decl
, len
, NULL_TREE
);
9074 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9076 dest
, len
, NULL_TREE
);
9077 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9078 TREE_TYPE (len
), len
, tmp
);
9079 gfc_add_expr_to_block (&fnblock
, tmp
);
9080 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9081 /* This component can not have allocatable components,
9082 therefore add_when_allocated of duplicate_allocatable ()
9084 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9085 false, false, size
, NULL_TREE
);
9086 gfc_add_expr_to_block (&fnblock
, tmp
);
9088 else if (c
->attr
.pdt_array
)
9090 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9091 c
->as
? c
->as
->rank
: 0,
9092 false, false, NULL_TREE
, NULL_TREE
);
9093 gfc_add_expr_to_block (&fnblock
, tmp
);
9095 else if ((c
->attr
.allocatable
)
9096 && !c
->attr
.proc_pointer
&& !same_type
9097 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9098 || caf_in_coarray (caf_mode
)))
9100 rank
= c
->as
? c
->as
->rank
: 0;
9101 if (c
->attr
.codimension
)
9102 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9103 else if (flag_coarray
== GFC_FCOARRAY_LIB
9104 && caf_in_coarray (caf_mode
))
9106 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
9107 : fold_build3_loc (input_location
,
9109 pvoid_type_node
, dest
,
9112 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9116 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9117 add_when_allocated
);
9118 gfc_add_expr_to_block (&fnblock
, tmp
);
9121 if (cmp_has_alloc_comps
|| is_pdt_type
)
9122 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9126 case ALLOCATE_PDT_COMP
:
9128 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9129 decl
, cdecl, NULL_TREE
);
9131 /* Set the PDT KIND and LEN fields. */
9132 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9135 gfc_expr
*c_expr
= NULL
;
9136 gfc_actual_arglist
*param
= pdt_param_list
;
9137 gfc_init_se (&tse
, NULL
);
9138 for (; param
; param
= param
->next
)
9139 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9140 c_expr
= param
->expr
;
9143 c_expr
= c
->initializer
;
9147 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9148 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9152 if (c
->attr
.pdt_string
)
9155 gfc_init_se (&tse
, NULL
);
9156 tree strlen
= NULL_TREE
;
9157 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9158 /* Convert the parameterized string length to its value. The
9159 string length is stored in a hidden field in the same way as
9160 deferred string lengths. */
9161 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9162 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9164 gfc_conv_expr_type (&tse
, e
,
9165 TREE_TYPE (strlen
));
9166 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9168 decl
, strlen
, NULL_TREE
);
9169 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9170 c
->ts
.u
.cl
->backend_decl
= strlen
;
9174 /* Scalar parameterized strings can be allocated now. */
9177 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9178 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9179 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9180 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9181 gfc_add_modify (&fnblock
, comp
, tmp
);
9185 /* Allocate parameterized arrays of parameterized derived types. */
9186 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9187 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9188 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9191 if (c
->ts
.type
== BT_CLASS
)
9192 comp
= gfc_class_data_get (comp
);
9194 if (c
->attr
.pdt_array
)
9198 tree size
= gfc_index_one_node
;
9199 tree offset
= gfc_index_zero_node
;
9203 /* This chunk takes the expressions for 'lower' and 'upper'
9204 in the arrayspec and substitutes in the expressions for
9205 the parameters from 'pdt_param_list'. The descriptor
9206 fields can then be filled from the values so obtained. */
9207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9208 for (i
= 0; i
< c
->as
->rank
; i
++)
9210 gfc_init_se (&tse
, NULL
);
9211 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9212 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9213 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9216 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9219 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9220 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9221 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9224 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9227 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9230 size
= gfc_evaluate_now (size
, &fnblock
);
9231 offset
= fold_build2_loc (input_location
,
9233 gfc_array_index_type
,
9235 offset
= gfc_evaluate_now (offset
, &fnblock
);
9236 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9237 gfc_array_index_type
,
9239 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9240 gfc_array_index_type
,
9241 tmp
, gfc_index_one_node
);
9242 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9243 gfc_array_index_type
, size
, tmp
);
9245 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9246 if (c
->ts
.type
== BT_CLASS
)
9248 tmp
= gfc_get_vptr_from_expr (comp
);
9249 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9250 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9251 tmp
= gfc_vptr_size_get (tmp
);
9254 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9255 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9256 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9257 gfc_array_index_type
, size
, tmp
);
9258 size
= gfc_evaluate_now (size
, &fnblock
);
9259 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9260 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9261 tmp
= gfc_conv_descriptor_dtype (comp
);
9262 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9264 if (c
->initializer
&& c
->initializer
->rank
)
9266 gfc_init_se (&tse
, NULL
);
9267 e
= gfc_copy_expr (c
->initializer
);
9268 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9269 gfc_conv_expr_descriptor (&tse
, e
);
9270 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9272 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9273 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9274 gfc_conv_descriptor_data_get (comp
),
9275 gfc_conv_descriptor_data_get (tse
.expr
),
9276 fold_convert (size_type_node
, size
));
9277 gfc_add_expr_to_block (&fnblock
, tmp
);
9278 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9282 /* Recurse in to PDT components. */
9283 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9284 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9285 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9287 bool is_deferred
= false;
9288 gfc_actual_arglist
*tail
= c
->param_list
;
9290 for (; tail
; tail
= tail
->next
)
9294 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9295 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9296 c
->as
? c
->as
->rank
: 0,
9298 gfc_add_expr_to_block (&fnblock
, tmp
);
9303 case DEALLOCATE_PDT_COMP
:
9304 /* Deallocate array or parameterized string length components
9305 of parameterized derived types. */
9306 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9307 && !c
->attr
.pdt_string
9308 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9309 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9312 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9313 decl
, cdecl, NULL_TREE
);
9314 if (c
->ts
.type
== BT_CLASS
)
9315 comp
= gfc_class_data_get (comp
);
9317 /* Recurse in to PDT components. */
9318 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9319 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9320 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9322 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9323 c
->as
? c
->as
->rank
: 0);
9324 gfc_add_expr_to_block (&fnblock
, tmp
);
9327 if (c
->attr
.pdt_array
)
9329 tmp
= gfc_conv_descriptor_data_get (comp
);
9330 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9331 logical_type_node
, tmp
,
9332 build_int_cst (TREE_TYPE (tmp
), 0));
9333 tmp
= gfc_call_free (tmp
);
9334 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9335 build_empty_stmt (input_location
));
9336 gfc_add_expr_to_block (&fnblock
, tmp
);
9337 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9339 else if (c
->attr
.pdt_string
)
9341 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9342 logical_type_node
, comp
,
9343 build_int_cst (TREE_TYPE (comp
), 0));
9344 tmp
= gfc_call_free (comp
);
9345 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9346 build_empty_stmt (input_location
));
9347 gfc_add_expr_to_block (&fnblock
, tmp
);
9348 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9349 gfc_add_modify (&fnblock
, comp
, tmp
);
9354 case CHECK_PDT_DUMMY
:
9356 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9357 decl
, cdecl, NULL_TREE
);
9358 if (c
->ts
.type
== BT_CLASS
)
9359 comp
= gfc_class_data_get (comp
);
9361 /* Recurse in to PDT components. */
9362 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9363 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9365 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9366 c
->as
? c
->as
->rank
: 0,
9368 gfc_add_expr_to_block (&fnblock
, tmp
);
9371 if (!c
->attr
.pdt_len
)
9376 gfc_expr
*c_expr
= NULL
;
9377 gfc_actual_arglist
*param
= pdt_param_list
;
9379 gfc_init_se (&tse
, NULL
);
9380 for (; param
; param
= param
->next
)
9381 if (!strcmp (c
->name
, param
->name
)
9382 && param
->spec_type
== SPEC_EXPLICIT
)
9383 c_expr
= param
->expr
;
9387 tree error
, cond
, cname
;
9388 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9389 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9392 cname
= gfc_build_cstring_const (c
->name
);
9393 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9394 error
= gfc_trans_runtime_error (true, NULL
,
9395 "The value of the PDT LEN "
9396 "parameter '%s' does not "
9397 "agree with that in the "
9398 "dummy declaration",
9400 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9401 void_type_node
, cond
, error
,
9402 build_empty_stmt (input_location
));
9403 gfc_add_expr_to_block (&fnblock
, tmp
);
9414 return gfc_finish_block (&fnblock
);
9417 /* Recursively traverse an object of derived type, generating code to
9418 nullify allocatable components. */
9421 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9424 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9426 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9430 /* Recursively traverse an object of derived type, generating code to
9431 deallocate allocatable components. */
9434 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9437 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9438 DEALLOCATE_ALLOC_COMP
,
9439 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9443 /* Recursively traverse an object of derived type, generating code to
9444 deallocate allocatable components. But do not deallocate coarrays.
9445 To be used for intrinsic assignment, which may not change the allocation
9446 status of coarrays. */
9449 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9451 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9452 DEALLOCATE_ALLOC_COMP
, 0);
9457 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9459 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9460 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9464 /* Recursively traverse an object of derived type, generating code to
9465 copy it and its allocatable components. */
9468 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9471 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9476 /* Recursively traverse an object of derived type, generating code to
9477 copy only its allocatable components. */
9480 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9482 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9483 COPY_ONLY_ALLOC_COMP
, 0);
9487 /* Recursively traverse an object of paramterized derived type, generating
9488 code to allocate parameterized components. */
9491 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9492 gfc_actual_arglist
*param_list
)
9495 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9496 pdt_param_list
= param_list
;
9497 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9498 ALLOCATE_PDT_COMP
, 0);
9499 pdt_param_list
= old_param_list
;
9503 /* Recursively traverse an object of paramterized derived type, generating
9504 code to deallocate parameterized components. */
9507 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9509 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9510 DEALLOCATE_PDT_COMP
, 0);
9514 /* Recursively traverse a dummy of paramterized derived type to check the
9515 values of LEN parameters. */
9518 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9519 gfc_actual_arglist
*param_list
)
9522 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9523 pdt_param_list
= param_list
;
9524 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9525 CHECK_PDT_DUMMY
, 0);
9526 pdt_param_list
= old_param_list
;
9531 /* Returns the value of LBOUND for an expression. This could be broken out
9532 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9533 called by gfc_alloc_allocatable_for_assignment. */
9535 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9540 tree cond
, cond1
, cond3
, cond4
;
9544 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9546 tmp
= gfc_rank_cst
[dim
];
9547 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9548 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9549 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9550 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9552 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9553 stride
, gfc_index_zero_node
);
9554 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9555 logical_type_node
, cond3
, cond1
);
9556 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9557 stride
, gfc_index_zero_node
);
9559 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9560 tmp
, build_int_cst (gfc_array_index_type
,
9563 cond
= logical_false_node
;
9565 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9566 logical_type_node
, cond3
, cond4
);
9567 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9568 logical_type_node
, cond
, cond1
);
9570 return fold_build3_loc (input_location
, COND_EXPR
,
9571 gfc_array_index_type
, cond
,
9572 lbound
, gfc_index_one_node
);
9575 if (expr
->expr_type
== EXPR_FUNCTION
)
9577 /* A conversion function, so use the argument. */
9578 gcc_assert (expr
->value
.function
.isym
9579 && expr
->value
.function
.isym
->conversion
);
9580 expr
= expr
->value
.function
.actual
->expr
;
9583 if (expr
->expr_type
== EXPR_VARIABLE
)
9585 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9586 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9588 if (ref
->type
== REF_COMPONENT
9589 && ref
->u
.c
.component
->as
9591 && ref
->next
->u
.ar
.type
== AR_FULL
)
9592 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9594 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9597 return gfc_index_one_node
;
9601 /* Returns true if an expression represents an lhs that can be reallocated
9605 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9613 sym
= expr
->symtree
->n
.sym
;
9615 if (sym
->attr
.associate_var
&& !expr
->ref
)
9618 /* An allocatable class variable with no reference. */
9619 if (sym
->ts
.type
== BT_CLASS
9620 && !sym
->attr
.associate_var
9621 && CLASS_DATA (sym
)->attr
.allocatable
9623 && ((expr
->ref
->type
== REF_ARRAY
&& expr
->ref
->u
.ar
.type
== AR_FULL
9624 && expr
->ref
->next
== NULL
)
9625 || (expr
->ref
->type
== REF_COMPONENT
9626 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9627 && (expr
->ref
->next
== NULL
9628 || (expr
->ref
->next
->type
== REF_ARRAY
9629 && expr
->ref
->next
->u
.ar
.type
== AR_FULL
9630 && expr
->ref
->next
->next
== NULL
)))))
9633 /* An allocatable variable. */
9634 if (sym
->attr
.allocatable
9635 && !sym
->attr
.associate_var
9637 && expr
->ref
->type
== REF_ARRAY
9638 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9641 /* All that can be left are allocatable components. */
9642 if ((sym
->ts
.type
!= BT_DERIVED
9643 && sym
->ts
.type
!= BT_CLASS
)
9644 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9647 /* Find a component ref followed by an array reference. */
9648 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9650 && ref
->type
== REF_COMPONENT
9651 && ref
->next
->type
== REF_ARRAY
9652 && !ref
->next
->next
)
9658 /* Return true if valid reallocatable lhs. */
9659 if (ref
->u
.c
.component
->attr
.allocatable
9660 && ref
->next
->u
.ar
.type
== AR_FULL
)
9668 concat_str_length (gfc_expr
* expr
)
9675 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9676 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9677 if (len1
== NULL_TREE
)
9679 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9680 len1
= concat_str_length (expr
->value
.op
.op1
);
9681 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9682 len1
= build_int_cst (gfc_charlen_type_node
,
9683 expr
->value
.op
.op1
->value
.character
.length
);
9684 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9686 gfc_init_se (&se
, NULL
);
9687 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9693 gfc_init_se (&se
, NULL
);
9694 se
.want_pointer
= 1;
9695 se
.descriptor_only
= 1;
9696 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9697 len1
= se
.string_length
;
9701 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9702 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9703 if (len2
== NULL_TREE
)
9705 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9706 len2
= concat_str_length (expr
->value
.op
.op2
);
9707 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9708 len2
= build_int_cst (gfc_charlen_type_node
,
9709 expr
->value
.op
.op2
->value
.character
.length
);
9710 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9712 gfc_init_se (&se
, NULL
);
9713 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9719 gfc_init_se (&se
, NULL
);
9720 se
.want_pointer
= 1;
9721 se
.descriptor_only
= 1;
9722 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9723 len2
= se
.string_length
;
9727 gcc_assert(len1
&& len2
);
9728 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9729 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9731 return fold_build2_loc (input_location
, PLUS_EXPR
,
9732 gfc_charlen_type_node
, len1
, len2
);
9736 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9740 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9744 stmtblock_t realloc_block
;
9745 stmtblock_t alloc_block
;
9749 gfc_array_info
*linfo
;
9771 gfc_array_spec
* as
;
9772 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9773 && gfc_caf_attr (expr1
, true).codimension
);
9777 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9778 Find the lhs expression in the loop chain and set expr1 and
9779 expr2 accordingly. */
9780 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9783 /* Find the ss for the lhs. */
9785 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9786 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9788 if (lss
== gfc_ss_terminator
)
9790 expr1
= lss
->info
->expr
;
9793 /* Bail out if this is not a valid allocate on assignment. */
9794 if (!gfc_is_reallocatable_lhs (expr1
)
9795 || (expr2
&& !expr2
->rank
))
9798 /* Find the ss for the lhs. */
9800 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9801 if (lss
->info
->expr
== expr1
)
9804 if (lss
== gfc_ss_terminator
)
9807 linfo
= &lss
->info
->data
.array
;
9809 /* Find an ss for the rhs. For operator expressions, we see the
9810 ss's for the operands. Any one of these will do. */
9812 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9813 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9816 if (expr2
&& rss
== gfc_ss_terminator
)
9819 /* Ensure that the string length from the current scope is used. */
9820 if (expr2
->ts
.type
== BT_CHARACTER
9821 && expr2
->expr_type
== EXPR_FUNCTION
9822 && !expr2
->value
.function
.isym
)
9823 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
9825 gfc_start_block (&fblock
);
9827 /* Since the lhs is allocatable, this must be a descriptor type.
9828 Get the data and array size. */
9829 desc
= linfo
->descriptor
;
9830 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9831 array1
= gfc_conv_descriptor_data_get (desc
);
9833 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9834 deallocated if expr is an array of different shape or any of the
9835 corresponding length type parameter values of variable and expr
9836 differ." This assures F95 compatibility. */
9837 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9838 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9840 /* Allocate if data is NULL. */
9841 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9842 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9844 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9846 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9848 lss
->info
->string_length
,
9849 rss
->info
->string_length
);
9850 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9851 logical_type_node
, tmp
, cond_null
);
9854 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9856 tmp
= build3_v (COND_EXPR
, cond_null
,
9857 build1_v (GOTO_EXPR
, jump_label1
),
9858 build_empty_stmt (input_location
));
9859 gfc_add_expr_to_block (&fblock
, tmp
);
9861 /* Get arrayspec if expr is a full array. */
9862 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9863 && expr2
->value
.function
.isym
9864 && expr2
->value
.function
.isym
->conversion
)
9866 /* For conversion functions, take the arg. */
9867 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9868 as
= gfc_get_full_arrayspec_from_expr (arg
);
9871 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9875 /* If the lhs shape is not the same as the rhs jump to setting the
9876 bounds and doing the reallocation....... */
9877 for (n
= 0; n
< expr1
->rank
; n
++)
9879 /* Check the shape. */
9880 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9881 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9882 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9883 gfc_array_index_type
,
9884 loop
->to
[n
], loop
->from
[n
]);
9885 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9886 gfc_array_index_type
,
9888 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9889 gfc_array_index_type
,
9891 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9893 tmp
, gfc_index_zero_node
);
9894 tmp
= build3_v (COND_EXPR
, cond
,
9895 build1_v (GOTO_EXPR
, jump_label1
),
9896 build_empty_stmt (input_location
));
9897 gfc_add_expr_to_block (&fblock
, tmp
);
9900 /* ....else jump past the (re)alloc code. */
9901 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9902 gfc_add_expr_to_block (&fblock
, tmp
);
9904 /* Add the label to start automatic (re)allocation. */
9905 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9906 gfc_add_expr_to_block (&fblock
, tmp
);
9908 /* If the lhs has not been allocated, its bounds will not have been
9909 initialized and so its size is set to zero. */
9910 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9911 gfc_init_block (&alloc_block
);
9912 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9913 gfc_init_block (&realloc_block
);
9914 gfc_add_modify (&realloc_block
, size1
,
9915 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9916 tmp
= build3_v (COND_EXPR
, cond_null
,
9917 gfc_finish_block (&alloc_block
),
9918 gfc_finish_block (&realloc_block
));
9919 gfc_add_expr_to_block (&fblock
, tmp
);
9921 /* Get the rhs size and fix it. */
9923 desc2
= rss
->info
->data
.array
.descriptor
;
9927 size2
= gfc_index_one_node
;
9928 for (n
= 0; n
< expr2
->rank
; n
++)
9930 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9931 gfc_array_index_type
,
9932 loop
->to
[n
], loop
->from
[n
]);
9933 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9934 gfc_array_index_type
,
9935 tmp
, gfc_index_one_node
);
9936 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9937 gfc_array_index_type
,
9940 size2
= gfc_evaluate_now (size2
, &fblock
);
9942 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9945 /* If the lhs is deferred length, assume that the element size
9946 changes and force a reallocation. */
9947 if (expr1
->ts
.deferred
)
9948 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
9950 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9952 /* Deallocation of allocatable components will have to occur on
9953 reallocation. Fix the old descriptor now. */
9954 if ((expr1
->ts
.type
== BT_DERIVED
)
9955 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9956 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9958 old_desc
= NULL_TREE
;
9960 /* Now modify the lhs descriptor and the associated scalarizer
9961 variables. F2003 7.4.1.3: "If variable is or becomes an
9962 unallocated allocatable variable, then it is allocated with each
9963 deferred type parameter equal to the corresponding type parameters
9964 of expr , with the shape of expr , and with each lower bound equal
9965 to the corresponding element of LBOUND(expr)."
9966 Reuse size1 to keep a dimension-by-dimension track of the
9967 stride of the new array. */
9968 size1
= gfc_index_one_node
;
9969 offset
= gfc_index_zero_node
;
9971 for (n
= 0; n
< expr2
->rank
; n
++)
9973 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9974 gfc_array_index_type
,
9975 loop
->to
[n
], loop
->from
[n
]);
9976 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9977 gfc_array_index_type
,
9978 tmp
, gfc_index_one_node
);
9980 lbound
= gfc_index_one_node
;
9985 lbd
= get_std_lbound (expr2
, desc2
, n
,
9986 as
->type
== AS_ASSUMED_SIZE
);
9987 ubound
= fold_build2_loc (input_location
,
9989 gfc_array_index_type
,
9991 ubound
= fold_build2_loc (input_location
,
9993 gfc_array_index_type
,
9998 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
10001 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
10004 gfc_conv_descriptor_stride_set (&fblock
, desc
,
10007 lbound
= gfc_conv_descriptor_lbound_get (desc
,
10009 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
10010 gfc_array_index_type
,
10012 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10013 gfc_array_index_type
,
10015 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10016 gfc_array_index_type
,
10020 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10021 the array offset is saved and the info.offset is used for a
10022 running offset. Use the saved_offset instead. */
10023 tmp
= gfc_conv_descriptor_offset (desc
);
10024 gfc_add_modify (&fblock
, tmp
, offset
);
10025 if (linfo
->saved_offset
10026 && VAR_P (linfo
->saved_offset
))
10027 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10029 /* Now set the deltas for the lhs. */
10030 for (n
= 0; n
< expr1
->rank
; n
++)
10032 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10034 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10035 gfc_array_index_type
, tmp
,
10037 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10038 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10041 /* Get the new lhs size in bytes. */
10042 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10044 if (expr2
->ts
.deferred
)
10046 if (expr2
->ts
.u
.cl
->backend_decl
10047 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10048 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10050 tmp
= rss
->info
->string_length
;
10054 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10055 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10056 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10058 tmp
= concat_str_length (expr2
);
10059 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10061 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10064 gfc_init_se (&tmpse
, NULL
);
10065 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10066 gfc_charlen_type_node
);
10068 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10070 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10073 if (expr1
->ts
.u
.cl
->backend_decl
10074 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10075 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10077 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10079 if (expr1
->ts
.kind
> 1)
10080 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10082 tmp
, build_int_cst (TREE_TYPE (tmp
),
10085 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10087 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10088 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10089 gfc_array_index_type
, tmp
,
10090 expr1
->ts
.u
.cl
->backend_decl
);
10092 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10093 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10095 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10096 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10098 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10099 gfc_conv_descriptor_span_set (&fblock
, desc
, tmp
);
10101 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10102 gfc_array_index_type
,
10104 size2
= fold_convert (size_type_node
, size2
);
10105 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10106 size2
, size_one_node
);
10107 size2
= gfc_evaluate_now (size2
, &fblock
);
10109 /* For deferred character length, the 'size' field of the dtype might
10110 have changed so set the dtype. */
10111 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10112 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10115 tmp
= gfc_conv_descriptor_dtype (desc
);
10116 if (expr2
->ts
.u
.cl
->backend_decl
)
10117 type
= gfc_typenode_for_spec (&expr2
->ts
);
10119 type
= gfc_typenode_for_spec (&expr1
->ts
);
10121 gfc_add_modify (&fblock
, tmp
,
10122 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10124 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10127 tmp
= gfc_conv_descriptor_dtype (desc
);
10128 type
= gfc_typenode_for_spec (&expr2
->ts
);
10129 gfc_add_modify (&fblock
, tmp
,
10130 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10131 /* Set the _len field as well... */
10132 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10133 if (expr2
->ts
.type
== BT_CHARACTER
)
10134 gfc_add_modify (&fblock
, tmp
,
10135 fold_convert (TREE_TYPE (tmp
),
10136 TYPE_SIZE_UNIT (type
)));
10138 gfc_add_modify (&fblock
, tmp
,
10139 build_int_cst (TREE_TYPE (tmp
), 0));
10140 /* ...and the vptr. */
10141 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10142 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10143 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10144 gfc_add_modify (&fblock
, tmp
, tmp2
);
10146 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10148 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10149 gfc_get_dtype (TREE_TYPE (desc
)));
10152 /* Realloc expression. Note that the scalarizer uses desc.data
10153 in the array reference - (*desc.data)[<element>]. */
10154 gfc_init_block (&realloc_block
);
10155 gfc_init_se (&caf_se
, NULL
);
10159 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10160 if (token
== NULL_TREE
)
10162 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10163 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10164 tmp
= build_fold_indirect_ref (tmp
);
10165 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10167 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10170 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10172 if ((expr1
->ts
.type
== BT_DERIVED
)
10173 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10175 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10177 gfc_add_expr_to_block (&realloc_block
, tmp
);
10182 tmp
= build_call_expr_loc (input_location
,
10183 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10184 fold_convert (pvoid_type_node
, array1
),
10186 gfc_conv_descriptor_data_set (&realloc_block
,
10191 tmp
= build_call_expr_loc (input_location
,
10192 gfor_fndecl_caf_deregister
, 5, token
,
10193 build_int_cst (integer_type_node
,
10194 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10195 null_pointer_node
, null_pointer_node
,
10196 integer_zero_node
);
10197 gfc_add_expr_to_block (&realloc_block
, tmp
);
10198 tmp
= build_call_expr_loc (input_location
,
10199 gfor_fndecl_caf_register
,
10201 build_int_cst (integer_type_node
,
10202 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10203 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10204 null_pointer_node
, null_pointer_node
,
10205 integer_zero_node
);
10206 gfc_add_expr_to_block (&realloc_block
, tmp
);
10209 if ((expr1
->ts
.type
== BT_DERIVED
)
10210 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10212 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10214 gfc_add_expr_to_block (&realloc_block
, tmp
);
10217 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10218 realloc_expr
= gfc_finish_block (&realloc_block
);
10220 /* Only reallocate if sizes are different. */
10221 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10222 build_empty_stmt (input_location
));
10223 realloc_expr
= tmp
;
10226 /* Malloc expression. */
10227 gfc_init_block (&alloc_block
);
10230 tmp
= build_call_expr_loc (input_location
,
10231 builtin_decl_explicit (BUILT_IN_MALLOC
),
10233 gfc_conv_descriptor_data_set (&alloc_block
,
10238 tmp
= build_call_expr_loc (input_location
,
10239 gfor_fndecl_caf_register
,
10241 build_int_cst (integer_type_node
,
10242 GFC_CAF_COARRAY_ALLOC
),
10243 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10244 null_pointer_node
, null_pointer_node
,
10245 integer_zero_node
);
10246 gfc_add_expr_to_block (&alloc_block
, tmp
);
10250 /* We already set the dtype in the case of deferred character
10251 length arrays and unlimited polymorphic arrays. */
10252 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10253 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10255 && !UNLIMITED_POLY (expr1
))
10257 tmp
= gfc_conv_descriptor_dtype (desc
);
10258 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10261 if ((expr1
->ts
.type
== BT_DERIVED
)
10262 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10264 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10266 gfc_add_expr_to_block (&alloc_block
, tmp
);
10268 alloc_expr
= gfc_finish_block (&alloc_block
);
10270 /* Malloc if not allocated; realloc otherwise. */
10271 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10272 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10275 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10276 gfc_add_expr_to_block (&fblock
, tmp
);
10278 /* Make sure that the scalarizer data pointer is updated. */
10279 if (linfo
->data
&& VAR_P (linfo
->data
))
10281 tmp
= gfc_conv_descriptor_data_get (desc
);
10282 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10285 /* Add the exit label. */
10286 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10287 gfc_add_expr_to_block (&fblock
, tmp
);
10289 return gfc_finish_block (&fblock
);
10293 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10294 Do likewise, recursively if necessary, with the allocatable components of
10298 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10304 stmtblock_t cleanup
;
10307 bool sym_has_alloc_comp
, has_finalizer
;
10309 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10310 || sym
->ts
.type
== BT_CLASS
)
10311 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10312 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10313 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10315 /* Make sure the frontend gets these right. */
10316 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10319 gfc_save_backend_locus (&loc
);
10320 gfc_set_backend_locus (&sym
->declared_at
);
10321 gfc_init_block (&init
);
10323 gcc_assert (VAR_P (sym
->backend_decl
)
10324 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10326 if (sym
->ts
.type
== BT_CHARACTER
10327 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10329 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10330 gfc_trans_vla_type_sizes (sym
, &init
);
10333 /* Dummy, use associated and result variables don't need anything special. */
10334 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10336 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10337 gfc_restore_backend_locus (&loc
);
10341 descriptor
= sym
->backend_decl
;
10343 /* Although static, derived types with default initializers and
10344 allocatable components must not be nulled wholesale; instead they
10345 are treated component by component. */
10346 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10348 /* SAVEd variables are not freed on exit. */
10349 gfc_trans_static_array_pointer (sym
);
10351 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10352 gfc_restore_backend_locus (&loc
);
10356 /* Get the descriptor type. */
10357 type
= TREE_TYPE (sym
->backend_decl
);
10359 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10360 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10362 if (!sym
->attr
.save
10363 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10365 if (sym
->value
== NULL
10366 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10368 rank
= sym
->as
? sym
->as
->rank
: 0;
10369 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10371 gfc_add_expr_to_block (&init
, tmp
);
10374 gfc_init_default_dt (sym
, &init
, false);
10377 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10379 /* If the backend_decl is not a descriptor, we must have a pointer
10381 descriptor
= build_fold_indirect_ref_loc (input_location
,
10382 sym
->backend_decl
);
10383 type
= TREE_TYPE (descriptor
);
10386 /* NULLIFY the data pointer, for non-saved allocatables. */
10387 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10389 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10390 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10392 /* Declare the variable static so its array descriptor stays present
10393 after leaving the scope. It may still be accessed through another
10394 image. This may happen, for example, with the caf_mpi
10396 TREE_STATIC (descriptor
) = 1;
10397 tmp
= gfc_conv_descriptor_token (descriptor
);
10398 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10399 null_pointer_node
));
10403 gfc_restore_backend_locus (&loc
);
10404 gfc_init_block (&cleanup
);
10406 /* Allocatable arrays need to be freed when they go out of scope.
10407 The allocatable components of pointers must not be touched. */
10408 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10409 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10410 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10413 sym
->attr
.referenced
= 1;
10414 e
= gfc_lval_expr_from_sym (sym
);
10415 gfc_add_finalizer_call (&cleanup
, e
);
10418 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10419 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10420 && !sym
->attr
.pointer
&& !sym
->attr
.save
10421 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10424 rank
= sym
->as
? sym
->as
->rank
: 0;
10425 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10426 gfc_add_expr_to_block (&cleanup
, tmp
);
10429 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10430 && !sym
->attr
.save
&& !sym
->attr
.result
10431 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10434 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10435 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10436 NULL_TREE
, NULL_TREE
, true, e
,
10437 sym
->attr
.codimension
10438 ? GFC_CAF_COARRAY_DEREGISTER
10439 : GFC_CAF_COARRAY_NOCOARRAY
);
10442 gfc_add_expr_to_block (&cleanup
, tmp
);
10445 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10446 gfc_finish_block (&cleanup
));
10449 /************ Expression Walking Functions ******************/
10451 /* Walk a variable reference.
10453 Possible extension - multiple component subscripts.
10454 x(:,:) = foo%a(:)%b(:)
10456 forall (i=..., j=...)
10457 x(i,j) = foo%a(j)%b(i)
10459 This adds a fair amount of complexity because you need to deal with more
10460 than one ref. Maybe handle in a similar manner to vector subscripts.
10461 Maybe not worth the effort. */
10465 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10469 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10470 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10473 return gfc_walk_array_ref (ss
, expr
, ref
);
10478 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10484 for (; ref
; ref
= ref
->next
)
10486 if (ref
->type
== REF_SUBSTRING
)
10488 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10489 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10492 /* We're only interested in array sections from now on. */
10493 if (ref
->type
!= REF_ARRAY
)
10501 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10502 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10506 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10507 newss
->info
->data
.array
.ref
= ref
;
10509 /* Make sure array is the same as array(:,:), this way
10510 we don't need to special case all the time. */
10511 ar
->dimen
= ar
->as
->rank
;
10512 for (n
= 0; n
< ar
->dimen
; n
++)
10514 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10516 gcc_assert (ar
->start
[n
] == NULL
);
10517 gcc_assert (ar
->end
[n
] == NULL
);
10518 gcc_assert (ar
->stride
[n
] == NULL
);
10524 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10525 newss
->info
->data
.array
.ref
= ref
;
10527 /* We add SS chains for all the subscripts in the section. */
10528 for (n
= 0; n
< ar
->dimen
; n
++)
10532 switch (ar
->dimen_type
[n
])
10534 case DIMEN_ELEMENT
:
10535 /* Add SS for elemental (scalar) subscripts. */
10536 gcc_assert (ar
->start
[n
]);
10537 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10538 indexss
->loop_chain
= gfc_ss_terminator
;
10539 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10543 /* We don't add anything for sections, just remember this
10544 dimension for later. */
10545 newss
->dim
[newss
->dimen
] = n
;
10550 /* Create a GFC_SS_VECTOR index in which we can store
10551 the vector's descriptor. */
10552 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10554 indexss
->loop_chain
= gfc_ss_terminator
;
10555 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10556 newss
->dim
[newss
->dimen
] = n
;
10561 /* We should know what sort of section it is by now. */
10562 gcc_unreachable ();
10565 /* We should have at least one non-elemental dimension,
10566 unless we are creating a descriptor for a (scalar) coarray. */
10567 gcc_assert (newss
->dimen
> 0
10568 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10573 /* We should know what sort of section it is by now. */
10574 gcc_unreachable ();
10582 /* Walk an expression operator. If only one operand of a binary expression is
10583 scalar, we must also add the scalar term to the SS chain. */
10586 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10591 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10592 if (expr
->value
.op
.op2
== NULL
)
10595 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10597 /* All operands are scalar. Pass back and let the caller deal with it. */
10601 /* All operands require scalarization. */
10602 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10605 /* One of the operands needs scalarization, the other is scalar.
10606 Create a gfc_ss for the scalar expression. */
10609 /* First operand is scalar. We build the chain in reverse order, so
10610 add the scalar SS after the second operand. */
10612 while (head
&& head
->next
!= ss
)
10614 /* Check we haven't somehow broken the chain. */
10616 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10618 else /* head2 == head */
10620 gcc_assert (head2
== head
);
10621 /* Second operand is scalar. */
10622 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10629 /* Reverse a SS chain. */
10632 gfc_reverse_ss (gfc_ss
* ss
)
10637 gcc_assert (ss
!= NULL
);
10639 head
= gfc_ss_terminator
;
10640 while (ss
!= gfc_ss_terminator
)
10643 /* Check we didn't somehow break the chain. */
10644 gcc_assert (next
!= NULL
);
10654 /* Given an expression referring to a procedure, return the symbol of its
10655 interface. We can't get the procedure symbol directly as we have to handle
10656 the case of (deferred) type-bound procedures. */
10659 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10664 if (procedure_ref
== NULL
)
10667 /* Normal procedure case. */
10668 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10669 && procedure_ref
->value
.function
.esym
)
10670 sym
= procedure_ref
->value
.function
.esym
;
10672 sym
= procedure_ref
->symtree
->n
.sym
;
10674 /* Typebound procedure case. */
10675 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10677 if (ref
->type
== REF_COMPONENT
10678 && ref
->u
.c
.component
->attr
.proc_pointer
)
10679 sym
= ref
->u
.c
.component
->ts
.interface
;
10688 /* Walk the arguments of an elemental function.
10689 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10690 it is NULL, we don't do the check and the argument is assumed to be present.
10694 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10695 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10697 gfc_formal_arglist
*dummy_arg
;
10703 head
= gfc_ss_terminator
;
10707 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10712 for (; arg
; arg
= arg
->next
)
10714 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10715 goto loop_continue
;
10717 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10720 /* Scalar argument. */
10721 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10722 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10723 newss
->info
->type
= type
;
10725 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10730 if (dummy_arg
!= NULL
10731 && dummy_arg
->sym
->attr
.optional
10732 && arg
->expr
->expr_type
== EXPR_VARIABLE
10733 && (gfc_expr_attr (arg
->expr
).optional
10734 || gfc_expr_attr (arg
->expr
).allocatable
10735 || gfc_expr_attr (arg
->expr
).pointer
))
10736 newss
->info
->can_be_null_ref
= true;
10742 while (tail
->next
!= gfc_ss_terminator
)
10747 if (dummy_arg
!= NULL
)
10748 dummy_arg
= dummy_arg
->next
;
10753 /* If all the arguments are scalar we don't need the argument SS. */
10754 gfc_free_ss_chain (head
);
10755 /* Pass it back. */
10759 /* Add it onto the existing chain. */
10765 /* Walk a function call. Scalar functions are passed back, and taken out of
10766 scalarization loops. For elemental functions we walk their arguments.
10767 The result of functions returning arrays is stored in a temporary outside
10768 the loop, so that the function is only called once. Hence we do not need
10769 to walk their arguments. */
10772 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10774 gfc_intrinsic_sym
*isym
;
10776 gfc_component
*comp
= NULL
;
10778 isym
= expr
->value
.function
.isym
;
10780 /* Handle intrinsic functions separately. */
10782 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10784 sym
= expr
->value
.function
.esym
;
10786 sym
= expr
->symtree
->n
.sym
;
10788 if (gfc_is_class_array_function (expr
))
10789 return gfc_get_array_ss (ss
, expr
,
10790 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10793 /* A function that returns arrays. */
10794 comp
= gfc_get_proc_ptr_comp (expr
);
10795 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10796 || (comp
&& comp
->attr
.dimension
))
10797 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10799 /* Walk the parameters of an elemental function. For now we always pass
10801 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10803 gfc_ss
*old_ss
= ss
;
10805 ss
= gfc_walk_elemental_function_args (old_ss
,
10806 expr
->value
.function
.actual
,
10807 gfc_get_proc_ifc_for_expr (expr
),
10811 || sym
->attr
.proc_pointer
10812 || sym
->attr
.if_source
!= IFSRC_DECL
10813 || sym
->attr
.array_outer_dependency
))
10814 ss
->info
->array_outer_dependency
= 1;
10817 /* Scalar functions are OK as these are evaluated outside the scalarization
10818 loop. Pass back and let the caller deal with it. */
10823 /* An array temporary is constructed for array constructors. */
10826 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10828 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10832 /* Walk an expression. Add walked expressions to the head of the SS chain.
10833 A wholly scalar expression will not be added. */
10836 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10840 switch (expr
->expr_type
)
10842 case EXPR_VARIABLE
:
10843 head
= gfc_walk_variable_expr (ss
, expr
);
10847 head
= gfc_walk_op_expr (ss
, expr
);
10850 case EXPR_FUNCTION
:
10851 head
= gfc_walk_function_expr (ss
, expr
);
10854 case EXPR_CONSTANT
:
10856 case EXPR_STRUCTURE
:
10857 /* Pass back and let the caller deal with it. */
10861 head
= gfc_walk_array_constructor (ss
, expr
);
10864 case EXPR_SUBSTRING
:
10865 /* Pass back and let the caller deal with it. */
10869 gfc_internal_error ("bad expression type during walk (%d)",
10876 /* Entry point for expression walking.
10877 A return value equal to the passed chain means this is
10878 a scalar expression. It is up to the caller to take whatever action is
10879 necessary to translate these. */
10882 gfc_walk_expr (gfc_expr
* expr
)
10886 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10887 return gfc_reverse_ss (res
);