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
)
858 if (expr
->expr_type
== EXPR_VARIABLE
859 && expr
->ts
.type
== BT_CHARACTER
)
860 tmp
= fold_convert (gfc_array_index_type
,
861 gfc_get_expr_charlen (expr
));
866 tmp
= fold_convert (gfc_array_index_type
,
867 size_in_bytes (tmp
));
873 /* Generate an initializer for a static pointer or allocatable array. */
876 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
880 gcc_assert (TREE_STATIC (sym
->backend_decl
));
881 /* Just zero the data member. */
882 type
= TREE_TYPE (sym
->backend_decl
);
883 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
887 /* If the bounds of SE's loop have not yet been set, see if they can be
888 determined from array spec AS, which is the array spec of a called
889 function. MAPPING maps the callee's dummy arguments to the values
890 that the caller is passing. Add any initialization and finalization
894 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
895 gfc_se
* se
, gfc_array_spec
* as
)
897 int n
, dim
, total_dim
;
906 if (!as
|| as
->type
!= AS_EXPLICIT
)
909 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
911 total_dim
+= ss
->loop
->dimen
;
912 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
914 /* The bound is known, nothing to do. */
915 if (ss
->loop
->to
[n
] != NULL_TREE
)
919 gcc_assert (dim
< as
->rank
);
920 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
922 /* Evaluate the lower bound. */
923 gfc_init_se (&tmpse
, NULL
);
924 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
925 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
926 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
927 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
929 /* ...and the upper bound. */
930 gfc_init_se (&tmpse
, NULL
);
931 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
932 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
933 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
934 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
936 /* Set the upper bound of the loop to UPPER - LOWER. */
937 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
938 gfc_array_index_type
, upper
, lower
);
939 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
940 ss
->loop
->to
[n
] = tmp
;
944 gcc_assert (total_dim
== as
->rank
);
948 /* Generate code to allocate an array temporary, or create a variable to
949 hold the data. If size is NULL, zero the descriptor so that the
950 callee will allocate the array. If DEALLOC is true, also generate code to
951 free the array afterwards.
953 If INITIAL is not NULL, it is packed using internal_pack and the result used
954 as data instead of allocating a fresh, unitialized area of memory.
956 Initialization code is added to PRE and finalization code to POST.
957 DYNAMIC is true if the caller may want to extend the array later
958 using realloc. This prevents us from putting the array on the stack. */
961 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
962 gfc_array_info
* info
, tree size
, tree nelem
,
963 tree initial
, bool dynamic
, bool dealloc
)
969 desc
= info
->descriptor
;
970 info
->offset
= gfc_index_zero_node
;
971 if (size
== NULL_TREE
|| integer_zerop (size
))
973 /* A callee allocated array. */
974 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
979 /* Allocate the temporary. */
980 onstack
= !dynamic
&& initial
== NULL_TREE
981 && (flag_stack_arrays
982 || gfc_can_put_var_on_stack (size
));
986 /* Make a temporary variable to hold the data. */
987 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
988 nelem
, gfc_index_one_node
);
989 tmp
= gfc_evaluate_now (tmp
, pre
);
990 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
992 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
994 tmp
= gfc_create_var (tmp
, "A");
995 /* If we're here only because of -fstack-arrays we have to
996 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
997 if (!gfc_can_put_var_on_stack (size
))
998 gfc_add_expr_to_block (pre
,
999 fold_build1_loc (input_location
,
1000 DECL_EXPR
, TREE_TYPE (tmp
),
1002 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1003 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1007 /* Allocate memory to hold the data or call internal_pack. */
1008 if (initial
== NULL_TREE
)
1010 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1011 tmp
= gfc_evaluate_now (tmp
, pre
);
1018 stmtblock_t do_copying
;
1020 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1021 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1022 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1023 tmp
= gfc_get_element_type (tmp
);
1024 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1025 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1027 tmp
= build_call_expr_loc (input_location
,
1028 gfor_fndecl_in_pack
, 1, initial
);
1029 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1030 gfc_add_modify (pre
, packed
, tmp
);
1032 tmp
= build_fold_indirect_ref_loc (input_location
,
1034 source_data
= gfc_conv_descriptor_data_get (tmp
);
1036 /* internal_pack may return source->data without any allocation
1037 or copying if it is already packed. If that's the case, we
1038 need to allocate and copy manually. */
1040 gfc_start_block (&do_copying
);
1041 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1042 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1043 gfc_add_modify (&do_copying
, packed
, tmp
);
1044 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1045 gfc_add_expr_to_block (&do_copying
, tmp
);
1047 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1048 logical_type_node
, packed
,
1050 tmp
= gfc_finish_block (&do_copying
);
1051 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1052 build_empty_stmt (input_location
));
1053 gfc_add_expr_to_block (pre
, tmp
);
1055 tmp
= fold_convert (pvoid_type_node
, packed
);
1058 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1061 info
->data
= gfc_conv_descriptor_data_get (desc
);
1063 /* The offset is zero because we create temporaries with a zero
1065 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1067 if (dealloc
&& !onstack
)
1069 /* Free the temporary. */
1070 tmp
= gfc_conv_descriptor_data_get (desc
);
1071 tmp
= gfc_call_free (tmp
);
1072 gfc_add_expr_to_block (post
, tmp
);
1077 /* Get the scalarizer array dimension corresponding to actual array dimension
1080 For example, if SS represents the array ref a(1,:,:,1), it is a
1081 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1082 and 1 for ARRAY_DIM=2.
1083 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1084 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1086 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1087 array. If called on the inner ss, the result would be respectively 0,1,2 for
1088 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1089 for ARRAY_DIM=1,2. */
1092 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1099 for (; ss
; ss
= ss
->parent
)
1100 for (n
= 0; n
< ss
->dimen
; n
++)
1101 if (ss
->dim
[n
] < array_dim
)
1104 return array_ref_dim
;
1109 innermost_ss (gfc_ss
*ss
)
1111 while (ss
->nested_ss
!= NULL
)
1119 /* Get the array reference dimension corresponding to the given loop dimension.
1120 It is different from the true array dimension given by the dim array in
1121 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1122 It is different from the loop dimension in the case of a transposed array.
1126 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1128 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1133 /* Generate code to create and initialize the descriptor for a temporary
1134 array. This is used for both temporaries needed by the scalarizer, and
1135 functions returning arrays. Adjusts the loop variables to be
1136 zero-based, and calculates the loop bounds for callee allocated arrays.
1137 Allocate the array unless it's callee allocated (we have a callee
1138 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1139 NULL_TREE for any n). Also fills in the descriptor, data and offset
1140 fields of info if known. Returns the size of the array, or NULL for a
1141 callee allocated array.
1143 'eltype' == NULL signals that the temporary should be a class object.
1144 The 'initial' expression is used to obtain the size of the dynamic
1145 type; otherwise the allocation and initialization proceeds as for any
1148 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1149 gfc_trans_allocate_array_storage. */
1152 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1153 tree eltype
, tree initial
, bool dynamic
,
1154 bool dealloc
, bool callee_alloc
, locus
* where
)
1158 gfc_array_info
*info
;
1159 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1167 tree class_expr
= NULL_TREE
;
1168 int n
, dim
, tmp_dim
;
1171 /* This signals a class array for which we need the size of the
1172 dynamic type. Generate an eltype and then the class expression. */
1173 if (eltype
== NULL_TREE
&& initial
)
1175 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1176 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1177 eltype
= TREE_TYPE (class_expr
);
1178 eltype
= gfc_get_element_type (eltype
);
1179 /* Obtain the structure (class) expression. */
1180 class_expr
= TREE_OPERAND (class_expr
, 0);
1181 gcc_assert (class_expr
);
1184 memset (from
, 0, sizeof (from
));
1185 memset (to
, 0, sizeof (to
));
1187 info
= &ss
->info
->data
.array
;
1189 gcc_assert (ss
->dimen
> 0);
1190 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1192 if (warn_array_temporaries
&& where
)
1193 gfc_warning (OPT_Warray_temporaries
,
1194 "Creating array temporary at %L", where
);
1196 /* Set the lower bound to zero. */
1197 for (s
= ss
; s
; s
= s
->parent
)
1201 total_dim
+= loop
->dimen
;
1202 for (n
= 0; n
< loop
->dimen
; n
++)
1206 /* Callee allocated arrays may not have a known bound yet. */
1208 loop
->to
[n
] = gfc_evaluate_now (
1209 fold_build2_loc (input_location
, MINUS_EXPR
,
1210 gfc_array_index_type
,
1211 loop
->to
[n
], loop
->from
[n
]),
1213 loop
->from
[n
] = gfc_index_zero_node
;
1215 /* We have just changed the loop bounds, we must clear the
1216 corresponding specloop, so that delta calculation is not skipped
1217 later in gfc_set_delta. */
1218 loop
->specloop
[n
] = NULL
;
1220 /* We are constructing the temporary's descriptor based on the loop
1221 dimensions. As the dimensions may be accessed in arbitrary order
1222 (think of transpose) the size taken from the n'th loop may not map
1223 to the n'th dimension of the array. We need to reconstruct loop
1224 infos in the right order before using it to set the descriptor
1226 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1227 from
[tmp_dim
] = loop
->from
[n
];
1228 to
[tmp_dim
] = loop
->to
[n
];
1230 info
->delta
[dim
] = gfc_index_zero_node
;
1231 info
->start
[dim
] = gfc_index_zero_node
;
1232 info
->end
[dim
] = gfc_index_zero_node
;
1233 info
->stride
[dim
] = gfc_index_one_node
;
1237 /* Initialize the descriptor. */
1239 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1240 GFC_ARRAY_UNKNOWN
, true);
1241 desc
= gfc_create_var (type
, "atmp");
1242 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1244 info
->descriptor
= desc
;
1245 size
= gfc_index_one_node
;
1247 /* Emit a DECL_EXPR for the variable sized array type in
1248 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1249 sizes works correctly. */
1250 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1251 if (! TYPE_NAME (arraytype
))
1252 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1253 NULL_TREE
, arraytype
);
1254 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1255 arraytype
, TYPE_NAME (arraytype
)));
1257 /* Fill in the array dtype. */
1258 tmp
= gfc_conv_descriptor_dtype (desc
);
1259 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1262 Fill in the bounds and stride. This is a packed array, so:
1265 for (n = 0; n < rank; n++)
1268 delta = ubound[n] + 1 - lbound[n];
1269 size = size * delta;
1271 size = size * sizeof(element);
1274 or_expr
= NULL_TREE
;
1276 /* If there is at least one null loop->to[n], it is a callee allocated
1278 for (n
= 0; n
< total_dim
; n
++)
1279 if (to
[n
] == NULL_TREE
)
1285 if (size
== NULL_TREE
)
1286 for (s
= ss
; s
; s
= s
->parent
)
1287 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1289 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1291 /* For a callee allocated array express the loop bounds in terms
1292 of the descriptor fields. */
1293 tmp
= fold_build2_loc (input_location
,
1294 MINUS_EXPR
, gfc_array_index_type
,
1295 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1296 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1297 s
->loop
->to
[n
] = tmp
;
1301 for (n
= 0; n
< total_dim
; n
++)
1303 /* Store the stride and bound components in the descriptor. */
1304 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1306 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1307 gfc_index_zero_node
);
1309 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1311 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1312 gfc_array_index_type
,
1313 to
[n
], gfc_index_one_node
);
1315 /* Check whether the size for this dimension is negative. */
1316 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1317 tmp
, gfc_index_zero_node
);
1318 cond
= gfc_evaluate_now (cond
, pre
);
1323 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1324 logical_type_node
, or_expr
, cond
);
1326 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1327 gfc_array_index_type
, size
, tmp
);
1328 size
= gfc_evaluate_now (size
, pre
);
1332 /* Get the size of the array. */
1333 if (size
&& !callee_alloc
)
1336 /* If or_expr is true, then the extent in at least one
1337 dimension is zero and the size is set to zero. */
1338 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1339 or_expr
, gfc_index_zero_node
, size
);
1342 if (class_expr
== NULL_TREE
)
1343 elemsize
= fold_convert (gfc_array_index_type
,
1344 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1346 elemsize
= gfc_class_vtab_size_get (class_expr
);
1348 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1357 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1363 if (ss
->dimen
> ss
->loop
->temp_dim
)
1364 ss
->loop
->temp_dim
= ss
->dimen
;
1370 /* Return the number of iterations in a loop that starts at START,
1371 ends at END, and has step STEP. */
1374 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1379 type
= TREE_TYPE (step
);
1380 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1381 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1382 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1383 build_int_cst (type
, 1));
1384 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1385 build_int_cst (type
, 0));
1386 return fold_convert (gfc_array_index_type
, tmp
);
1390 /* Extend the data in array DESC by EXTRA elements. */
1393 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1400 if (integer_zerop (extra
))
1403 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1405 /* Add EXTRA to the upper bound. */
1406 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1408 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1410 /* Get the value of the current data pointer. */
1411 arg0
= gfc_conv_descriptor_data_get (desc
);
1413 /* Calculate the new array size. */
1414 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1415 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1416 ubound
, gfc_index_one_node
);
1417 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1418 fold_convert (size_type_node
, tmp
),
1419 fold_convert (size_type_node
, size
));
1421 /* Call the realloc() function. */
1422 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1423 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1427 /* Return true if the bounds of iterator I can only be determined
1431 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1433 return (i
->start
->expr_type
!= EXPR_CONSTANT
1434 || i
->end
->expr_type
!= EXPR_CONSTANT
1435 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1439 /* Split the size of constructor element EXPR into the sum of two terms,
1440 one of which can be determined at compile time and one of which must
1441 be calculated at run time. Set *SIZE to the former and return true
1442 if the latter might be nonzero. */
1445 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1447 if (expr
->expr_type
== EXPR_ARRAY
)
1448 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1449 else if (expr
->rank
> 0)
1451 /* Calculate everything at run time. */
1452 mpz_set_ui (*size
, 0);
1457 /* A single element. */
1458 mpz_set_ui (*size
, 1);
1464 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1465 of array constructor C. */
1468 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1476 mpz_set_ui (*size
, 0);
1481 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1484 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1488 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1491 /* Multiply the static part of the element size by the
1492 number of iterations. */
1493 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1494 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1495 mpz_add_ui (val
, val
, 1);
1496 if (mpz_sgn (val
) > 0)
1497 mpz_mul (len
, len
, val
);
1499 mpz_set_ui (len
, 0);
1501 mpz_add (*size
, *size
, len
);
1510 /* Make sure offset is a variable. */
1513 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1516 /* We should have already created the offset variable. We cannot
1517 create it here because we may be in an inner scope. */
1518 gcc_assert (*offsetvar
!= NULL_TREE
);
1519 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1520 *poffset
= *offsetvar
;
1521 TREE_USED (*offsetvar
) = 1;
1525 /* Variables needed for bounds-checking. */
1526 static bool first_len
;
1527 static tree first_len_val
;
1528 static bool typespec_chararray_ctor
;
1531 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1532 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1536 gfc_conv_expr (se
, expr
);
1538 /* Store the value. */
1539 tmp
= build_fold_indirect_ref_loc (input_location
,
1540 gfc_conv_descriptor_data_get (desc
));
1541 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1543 if (expr
->ts
.type
== BT_CHARACTER
)
1545 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1548 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1549 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1550 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1551 TREE_TYPE (esize
), esize
,
1552 build_int_cst (TREE_TYPE (esize
),
1553 gfc_character_kinds
[i
].bit_size
/ 8));
1555 gfc_conv_string_parameter (se
);
1556 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1558 /* The temporary is an array of pointers. */
1559 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1560 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1564 /* The temporary is an array of string values. */
1565 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1566 /* We know the temporary and the value will be the same length,
1567 so can use memcpy. */
1568 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1569 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1571 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1575 gfc_add_modify (&se
->pre
, first_len_val
,
1576 fold_convert (TREE_TYPE (first_len_val
),
1577 se
->string_length
));
1582 /* Verify that all constructor elements are of the same
1584 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1586 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1587 logical_type_node
, first_len_val
,
1589 gfc_trans_runtime_check
1590 (true, false, cond
, &se
->pre
, &expr
->where
,
1591 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1592 fold_convert (long_integer_type_node
, first_len_val
),
1593 fold_convert (long_integer_type_node
, se
->string_length
));
1597 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1598 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1600 /* Assignment of a CLASS array constructor to a derived type array. */
1601 if (expr
->expr_type
== EXPR_FUNCTION
)
1602 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1603 se
->expr
= gfc_class_data_get (se
->expr
);
1604 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1605 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1606 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1610 /* TODO: Should the frontend already have done this conversion? */
1611 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1612 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1615 gfc_add_block_to_block (pblock
, &se
->pre
);
1616 gfc_add_block_to_block (pblock
, &se
->post
);
1620 /* Add the contents of an array to the constructor. DYNAMIC is as for
1621 gfc_trans_array_constructor_value. */
1624 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1625 tree type ATTRIBUTE_UNUSED
,
1626 tree desc
, gfc_expr
* expr
,
1627 tree
* poffset
, tree
* offsetvar
,
1638 /* We need this to be a variable so we can increment it. */
1639 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1641 gfc_init_se (&se
, NULL
);
1643 /* Walk the array expression. */
1644 ss
= gfc_walk_expr (expr
);
1645 gcc_assert (ss
!= gfc_ss_terminator
);
1647 /* Initialize the scalarizer. */
1648 gfc_init_loopinfo (&loop
);
1649 gfc_add_ss_to_loop (&loop
, ss
);
1651 /* Initialize the loop. */
1652 gfc_conv_ss_startstride (&loop
);
1653 gfc_conv_loop_setup (&loop
, &expr
->where
);
1655 /* Make sure the constructed array has room for the new data. */
1658 /* Set SIZE to the total number of elements in the subarray. */
1659 size
= gfc_index_one_node
;
1660 for (n
= 0; n
< loop
.dimen
; n
++)
1662 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1663 gfc_index_one_node
);
1664 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1665 gfc_array_index_type
, size
, tmp
);
1668 /* Grow the constructed array by SIZE elements. */
1669 gfc_grow_array (&loop
.pre
, desc
, size
);
1672 /* Make the loop body. */
1673 gfc_mark_ss_chain_used (ss
, 1);
1674 gfc_start_scalarized_body (&loop
, &body
);
1675 gfc_copy_loopinfo_to_se (&se
, &loop
);
1678 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1679 gcc_assert (se
.ss
== gfc_ss_terminator
);
1681 /* Increment the offset. */
1682 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1683 *poffset
, gfc_index_one_node
);
1684 gfc_add_modify (&body
, *poffset
, tmp
);
1686 /* Finish the loop. */
1687 gfc_trans_scalarizing_loops (&loop
, &body
);
1688 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1689 tmp
= gfc_finish_block (&loop
.pre
);
1690 gfc_add_expr_to_block (pblock
, tmp
);
1692 gfc_cleanup_loop (&loop
);
1696 /* Assign the values to the elements of an array constructor. DYNAMIC
1697 is true if descriptor DESC only contains enough data for the static
1698 size calculated by gfc_get_array_constructor_size. When true, memory
1699 for the dynamic parts must be allocated using realloc. */
1702 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1703 tree desc
, gfc_constructor_base base
,
1704 tree
* poffset
, tree
* offsetvar
,
1708 tree start
= NULL_TREE
;
1709 tree end
= NULL_TREE
;
1710 tree step
= NULL_TREE
;
1716 tree shadow_loopvar
= NULL_TREE
;
1717 gfc_saved_var saved_loopvar
;
1720 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1722 /* If this is an iterator or an array, the offset must be a variable. */
1723 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1724 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1726 /* Shadowing the iterator avoids changing its value and saves us from
1727 keeping track of it. Further, it makes sure that there's always a
1728 backend-decl for the symbol, even if there wasn't one before,
1729 e.g. in the case of an iterator that appears in a specification
1730 expression in an interface mapping. */
1736 /* Evaluate loop bounds before substituting the loop variable
1737 in case they depend on it. Such a case is invalid, but it is
1738 not more expensive to do the right thing here.
1740 gfc_init_se (&se
, NULL
);
1741 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1742 gfc_add_block_to_block (pblock
, &se
.pre
);
1743 start
= gfc_evaluate_now (se
.expr
, pblock
);
1745 gfc_init_se (&se
, NULL
);
1746 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1747 gfc_add_block_to_block (pblock
, &se
.pre
);
1748 end
= gfc_evaluate_now (se
.expr
, pblock
);
1750 gfc_init_se (&se
, NULL
);
1751 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1752 gfc_add_block_to_block (pblock
, &se
.pre
);
1753 step
= gfc_evaluate_now (se
.expr
, pblock
);
1755 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1756 type
= gfc_typenode_for_spec (&sym
->ts
);
1758 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1759 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1762 gfc_start_block (&body
);
1764 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1766 /* Array constructors can be nested. */
1767 gfc_trans_array_constructor_value (&body
, type
, desc
,
1768 c
->expr
->value
.constructor
,
1769 poffset
, offsetvar
, dynamic
);
1771 else if (c
->expr
->rank
> 0)
1773 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1774 poffset
, offsetvar
, dynamic
);
1778 /* This code really upsets the gimplifier so don't bother for now. */
1785 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1787 p
= gfc_constructor_next (p
);
1792 /* Scalar values. */
1793 gfc_init_se (&se
, NULL
);
1794 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1797 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1798 gfc_array_index_type
,
1799 *poffset
, gfc_index_one_node
);
1803 /* Collect multiple scalar constants into a constructor. */
1804 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1808 HOST_WIDE_INT idx
= 0;
1811 /* Count the number of consecutive scalar constants. */
1812 while (p
&& !(p
->iterator
1813 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1815 gfc_init_se (&se
, NULL
);
1816 gfc_conv_constant (&se
, p
->expr
);
1818 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1819 se
.expr
= fold_convert (type
, se
.expr
);
1820 /* For constant character array constructors we build
1821 an array of pointers. */
1822 else if (POINTER_TYPE_P (type
))
1823 se
.expr
= gfc_build_addr_expr
1824 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1827 CONSTRUCTOR_APPEND_ELT (v
,
1828 build_int_cst (gfc_array_index_type
,
1832 p
= gfc_constructor_next (p
);
1835 bound
= size_int (n
- 1);
1836 /* Create an array type to hold them. */
1837 tmptype
= build_range_type (gfc_array_index_type
,
1838 gfc_index_zero_node
, bound
);
1839 tmptype
= build_array_type (type
, tmptype
);
1841 init
= build_constructor (tmptype
, v
);
1842 TREE_CONSTANT (init
) = 1;
1843 TREE_STATIC (init
) = 1;
1844 /* Create a static variable to hold the data. */
1845 tmp
= gfc_create_var (tmptype
, "data");
1846 TREE_STATIC (tmp
) = 1;
1847 TREE_CONSTANT (tmp
) = 1;
1848 TREE_READONLY (tmp
) = 1;
1849 DECL_INITIAL (tmp
) = init
;
1852 /* Use BUILTIN_MEMCPY to assign the values. */
1853 tmp
= gfc_conv_descriptor_data_get (desc
);
1854 tmp
= build_fold_indirect_ref_loc (input_location
,
1856 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1857 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1858 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1860 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1861 bound
= build_int_cst (size_type_node
, n
* size
);
1862 tmp
= build_call_expr_loc (input_location
,
1863 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1864 3, tmp
, init
, bound
);
1865 gfc_add_expr_to_block (&body
, tmp
);
1867 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1868 gfc_array_index_type
, *poffset
,
1869 build_int_cst (gfc_array_index_type
, n
));
1871 if (!INTEGER_CST_P (*poffset
))
1873 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1874 *poffset
= *offsetvar
;
1878 /* The frontend should already have done any expansions
1882 /* Pass the code as is. */
1883 tmp
= gfc_finish_block (&body
);
1884 gfc_add_expr_to_block (pblock
, tmp
);
1888 /* Build the implied do-loop. */
1889 stmtblock_t implied_do_block
;
1895 loopbody
= gfc_finish_block (&body
);
1897 /* Create a new block that holds the implied-do loop. A temporary
1898 loop-variable is used. */
1899 gfc_start_block(&implied_do_block
);
1901 /* Initialize the loop. */
1902 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1904 /* If this array expands dynamically, and the number of iterations
1905 is not constant, we won't have allocated space for the static
1906 part of C->EXPR's size. Do that now. */
1907 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1909 /* Get the number of iterations. */
1910 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1912 /* Get the static part of C->EXPR's size. */
1913 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1914 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1916 /* Grow the array by TMP * TMP2 elements. */
1917 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1918 gfc_array_index_type
, tmp
, tmp2
);
1919 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1922 /* Generate the loop body. */
1923 exit_label
= gfc_build_label_decl (NULL_TREE
);
1924 gfc_start_block (&body
);
1926 /* Generate the exit condition. Depending on the sign of
1927 the step variable we have to generate the correct
1929 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1930 step
, build_int_cst (TREE_TYPE (step
), 0));
1931 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1932 logical_type_node
, tmp
,
1933 fold_build2_loc (input_location
, GT_EXPR
,
1934 logical_type_node
, shadow_loopvar
, end
),
1935 fold_build2_loc (input_location
, LT_EXPR
,
1936 logical_type_node
, shadow_loopvar
, end
));
1937 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1938 TREE_USED (exit_label
) = 1;
1939 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1940 build_empty_stmt (input_location
));
1941 gfc_add_expr_to_block (&body
, tmp
);
1943 /* The main loop body. */
1944 gfc_add_expr_to_block (&body
, loopbody
);
1946 /* Increase loop variable by step. */
1947 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1948 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1950 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1952 /* Finish the loop. */
1953 tmp
= gfc_finish_block (&body
);
1954 tmp
= build1_v (LOOP_EXPR
, tmp
);
1955 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1957 /* Add the exit label. */
1958 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1959 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1961 /* Finish the implied-do loop. */
1962 tmp
= gfc_finish_block(&implied_do_block
);
1963 gfc_add_expr_to_block(pblock
, tmp
);
1965 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1972 /* The array constructor code can create a string length with an operand
1973 in the form of a temporary variable. This variable will retain its
1974 context (current_function_decl). If we store this length tree in a
1975 gfc_charlen structure which is shared by a variable in another
1976 context, the resulting gfc_charlen structure with a variable in a
1977 different context, we could trip the assertion in expand_expr_real_1
1978 when it sees that a variable has been created in one context and
1979 referenced in another.
1981 If this might be the case, we create a new gfc_charlen structure and
1982 link it into the current namespace. */
1985 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1989 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1992 (*clp
)->backend_decl
= len
;
1995 /* A catch-all to obtain the string length for anything that is not
1996 a substring of non-constant length, a constant, array or variable. */
1999 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2003 /* Don't bother if we already know the length is a constant. */
2004 if (*len
&& INTEGER_CST_P (*len
))
2007 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2008 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2011 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2012 *len
= e
->ts
.u
.cl
->backend_decl
;
2016 /* Otherwise, be brutal even if inefficient. */
2017 gfc_init_se (&se
, NULL
);
2019 /* No function call, in case of side effects. */
2020 se
.no_function_call
= 1;
2022 gfc_conv_expr (&se
, e
);
2024 gfc_conv_expr_descriptor (&se
, e
);
2026 /* Fix the value. */
2027 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2029 gfc_add_block_to_block (block
, &se
.pre
);
2030 gfc_add_block_to_block (block
, &se
.post
);
2032 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2037 /* Figure out the string length of a variable reference expression.
2038 Used by get_array_ctor_strlen. */
2041 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2047 /* Don't bother if we already know the length is a constant. */
2048 if (*len
&& INTEGER_CST_P (*len
))
2051 ts
= &expr
->symtree
->n
.sym
->ts
;
2052 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2057 /* Array references don't change the string length. */
2061 /* Use the length of the component. */
2062 ts
= &ref
->u
.c
.component
->ts
;
2066 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2067 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2069 /* Note that this might evaluate expr. */
2070 get_array_ctor_all_strlen (block
, expr
, len
);
2073 mpz_init_set_ui (char_len
, 1);
2074 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2075 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2076 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2077 mpz_clear (char_len
);
2085 *len
= ts
->u
.cl
->backend_decl
;
2089 /* Figure out the string length of a character array constructor.
2090 If len is NULL, don't calculate the length; this happens for recursive calls
2091 when a sub-array-constructor is an element but not at the first position,
2092 so when we're not interested in the length.
2093 Returns TRUE if all elements are character constants. */
2096 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2103 if (gfc_constructor_first (base
) == NULL
)
2106 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2110 /* Loop over all constructor elements to find out is_const, but in len we
2111 want to store the length of the first, not the last, element. We can
2112 of course exit the loop as soon as is_const is found to be false. */
2113 for (c
= gfc_constructor_first (base
);
2114 c
&& is_const
; c
= gfc_constructor_next (c
))
2116 switch (c
->expr
->expr_type
)
2119 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2120 *len
= build_int_cstu (gfc_charlen_type_node
,
2121 c
->expr
->value
.character
.length
);
2125 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2132 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2138 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2142 /* After the first iteration, we don't want the length modified. */
2149 /* Check whether the array constructor C consists entirely of constant
2150 elements, and if so returns the number of those elements, otherwise
2151 return zero. Note, an empty or NULL array constructor returns zero. */
2153 unsigned HOST_WIDE_INT
2154 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2156 unsigned HOST_WIDE_INT nelem
= 0;
2158 gfc_constructor
*c
= gfc_constructor_first (base
);
2162 || c
->expr
->rank
> 0
2163 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2165 c
= gfc_constructor_next (c
);
2172 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2173 and the tree type of it's elements, TYPE, return a static constant
2174 variable that is compile-time initialized. */
2177 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2179 tree tmptype
, init
, tmp
;
2180 HOST_WIDE_INT nelem
;
2185 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2187 /* First traverse the constructor list, converting the constants
2188 to tree to build an initializer. */
2190 c
= gfc_constructor_first (expr
->value
.constructor
);
2193 gfc_init_se (&se
, NULL
);
2194 gfc_conv_constant (&se
, c
->expr
);
2195 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2196 se
.expr
= fold_convert (type
, se
.expr
);
2197 else if (POINTER_TYPE_P (type
))
2198 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2200 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2202 c
= gfc_constructor_next (c
);
2206 /* Next determine the tree type for the array. We use the gfortran
2207 front-end's gfc_get_nodesc_array_type in order to create a suitable
2208 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2210 memset (&as
, 0, sizeof (gfc_array_spec
));
2212 as
.rank
= expr
->rank
;
2213 as
.type
= AS_EXPLICIT
;
2216 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2217 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2221 for (i
= 0; i
< expr
->rank
; i
++)
2223 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2224 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2225 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2229 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2231 /* as is not needed anymore. */
2232 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2234 gfc_free_expr (as
.lower
[i
]);
2235 gfc_free_expr (as
.upper
[i
]);
2238 init
= build_constructor (tmptype
, v
);
2240 TREE_CONSTANT (init
) = 1;
2241 TREE_STATIC (init
) = 1;
2243 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2245 DECL_ARTIFICIAL (tmp
) = 1;
2246 DECL_IGNORED_P (tmp
) = 1;
2247 TREE_STATIC (tmp
) = 1;
2248 TREE_CONSTANT (tmp
) = 1;
2249 TREE_READONLY (tmp
) = 1;
2250 DECL_INITIAL (tmp
) = init
;
2257 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2258 This mostly initializes the scalarizer state info structure with the
2259 appropriate values to directly use the array created by the function
2260 gfc_build_constant_array_constructor. */
2263 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2265 gfc_array_info
*info
;
2269 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2271 info
= &ss
->info
->data
.array
;
2273 info
->descriptor
= tmp
;
2274 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2275 info
->offset
= gfc_index_zero_node
;
2277 for (i
= 0; i
< ss
->dimen
; i
++)
2279 info
->delta
[i
] = gfc_index_zero_node
;
2280 info
->start
[i
] = gfc_index_zero_node
;
2281 info
->end
[i
] = gfc_index_zero_node
;
2282 info
->stride
[i
] = gfc_index_one_node
;
2288 get_rank (gfc_loopinfo
*loop
)
2293 for (; loop
; loop
= loop
->parent
)
2294 rank
+= loop
->dimen
;
2300 /* Helper routine of gfc_trans_array_constructor to determine if the
2301 bounds of the loop specified by LOOP are constant and simple enough
2302 to use with trans_constant_array_constructor. Returns the
2303 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2306 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2309 tree size
= gfc_index_one_node
;
2313 total_dim
= get_rank (l
);
2315 for (loop
= l
; loop
; loop
= loop
->parent
)
2317 for (i
= 0; i
< loop
->dimen
; i
++)
2319 /* If the bounds aren't constant, return NULL_TREE. */
2320 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2322 if (!integer_zerop (loop
->from
[i
]))
2324 /* Only allow nonzero "from" in one-dimensional arrays. */
2327 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2328 gfc_array_index_type
,
2329 loop
->to
[i
], loop
->from
[i
]);
2333 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2334 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2335 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2336 gfc_array_index_type
, size
, tmp
);
2345 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2350 gcc_assert (array
->nested_ss
== NULL
);
2352 for (ss
= array
; ss
; ss
= ss
->parent
)
2353 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2354 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2355 return &(ss
->loop
->to
[n
]);
2361 static gfc_loopinfo
*
2362 outermost_loop (gfc_loopinfo
* loop
)
2364 while (loop
->parent
!= NULL
)
2365 loop
= loop
->parent
;
2371 /* Array constructors are handled by constructing a temporary, then using that
2372 within the scalarization loop. This is not optimal, but seems by far the
2376 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2378 gfc_constructor_base c
;
2386 bool old_first_len
, old_typespec_chararray_ctor
;
2387 tree old_first_len_val
;
2388 gfc_loopinfo
*loop
, *outer_loop
;
2389 gfc_ss_info
*ss_info
;
2395 /* Save the old values for nested checking. */
2396 old_first_len
= first_len
;
2397 old_first_len_val
= first_len_val
;
2398 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2401 outer_loop
= outermost_loop (loop
);
2403 expr
= ss_info
->expr
;
2405 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2406 typespec was given for the array constructor. */
2407 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2409 && expr
->ts
.u
.cl
->length_from_typespec
);
2411 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2412 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2414 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2418 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2420 c
= expr
->value
.constructor
;
2421 if (expr
->ts
.type
== BT_CHARACTER
)
2424 bool force_new_cl
= false;
2426 /* get_array_ctor_strlen walks the elements of the constructor, if a
2427 typespec was given, we already know the string length and want the one
2429 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2430 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2434 const_string
= false;
2435 gfc_init_se (&length_se
, NULL
);
2436 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2437 gfc_charlen_type_node
);
2438 ss_info
->string_length
= length_se
.expr
;
2440 /* Check if the character length is negative. If it is, then
2442 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2443 logical_type_node
, ss_info
->string_length
,
2444 build_zero_cst (TREE_TYPE
2445 (ss_info
->string_length
)));
2446 /* Print a warning if bounds checking is enabled. */
2447 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2449 msg
= xasprintf ("Negative character length treated as LEN = 0");
2450 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2455 ss_info
->string_length
2456 = fold_build3_loc (input_location
, COND_EXPR
,
2457 gfc_charlen_type_node
, neg_len
,
2459 (TREE_TYPE (ss_info
->string_length
)),
2460 ss_info
->string_length
);
2461 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2464 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2465 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2469 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2470 &ss_info
->string_length
);
2471 force_new_cl
= true;
2474 /* Complex character array constructors should have been taken care of
2475 and not end up here. */
2476 gcc_assert (ss_info
->string_length
);
2478 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2480 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2482 type
= build_pointer_type (type
);
2485 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2486 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2488 /* See if the constructor determines the loop bounds. */
2491 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2493 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2495 /* We have a multidimensional parameter. */
2496 for (s
= ss
; s
; s
= s
->parent
)
2499 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2501 s
->loop
->from
[n
] = gfc_index_zero_node
;
2502 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2503 gfc_index_integer_kind
);
2504 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2505 gfc_array_index_type
,
2507 gfc_index_one_node
);
2512 if (*loop_ubound0
== NULL_TREE
)
2516 /* We should have a 1-dimensional, zero-based loop. */
2517 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2518 gcc_assert (loop
->dimen
== 1);
2519 gcc_assert (integer_zerop (loop
->from
[0]));
2521 /* Split the constructor size into a static part and a dynamic part.
2522 Allocate the static size up-front and record whether the dynamic
2523 size might be nonzero. */
2525 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2526 mpz_sub_ui (size
, size
, 1);
2527 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2531 /* Special case constant array constructors. */
2534 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2537 tree size
= constant_array_constructor_loop_size (loop
);
2538 if (size
&& compare_tree_int (size
, nelem
) == 0)
2540 trans_constant_array_constructor (ss
, type
);
2546 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2547 NULL_TREE
, dynamic
, true, false, where
);
2549 desc
= ss_info
->data
.array
.descriptor
;
2550 offset
= gfc_index_zero_node
;
2551 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2552 TREE_NO_WARNING (offsetvar
) = 1;
2553 TREE_USED (offsetvar
) = 0;
2554 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2555 &offset
, &offsetvar
, dynamic
);
2557 /* If the array grows dynamically, the upper bound of the loop variable
2558 is determined by the array's final upper bound. */
2561 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2562 gfc_array_index_type
,
2563 offsetvar
, gfc_index_one_node
);
2564 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2565 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2566 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2567 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2569 *loop_ubound0
= tmp
;
2572 if (TREE_USED (offsetvar
))
2573 pushdecl (offsetvar
);
2575 gcc_assert (INTEGER_CST_P (offset
));
2578 /* Disable bound checking for now because it's probably broken. */
2579 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2586 /* Restore old values of globals. */
2587 first_len
= old_first_len
;
2588 first_len_val
= old_first_len_val
;
2589 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2593 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2594 called after evaluating all of INFO's vector dimensions. Go through
2595 each such vector dimension and see if we can now fill in any missing
2599 set_vector_loop_bounds (gfc_ss
* ss
)
2601 gfc_loopinfo
*loop
, *outer_loop
;
2602 gfc_array_info
*info
;
2610 outer_loop
= outermost_loop (ss
->loop
);
2612 info
= &ss
->info
->data
.array
;
2614 for (; ss
; ss
= ss
->parent
)
2618 for (n
= 0; n
< loop
->dimen
; n
++)
2621 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2622 || loop
->to
[n
] != NULL
)
2625 /* Loop variable N indexes vector dimension DIM, and we don't
2626 yet know the upper bound of loop variable N. Set it to the
2627 difference between the vector's upper and lower bounds. */
2628 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2629 gcc_assert (info
->subscript
[dim
]
2630 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2632 gfc_init_se (&se
, NULL
);
2633 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2634 zero
= gfc_rank_cst
[0];
2635 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2636 gfc_array_index_type
,
2637 gfc_conv_descriptor_ubound_get (desc
, zero
),
2638 gfc_conv_descriptor_lbound_get (desc
, zero
));
2639 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2646 /* Tells whether a scalar argument to an elemental procedure is saved out
2647 of a scalarization loop as a value or as a reference. */
2650 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2652 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2655 /* If the actual argument can be absent (in other words, it can
2656 be a NULL reference), don't try to evaluate it; pass instead
2657 the reference directly. */
2658 if (ss_info
->can_be_null_ref
)
2661 /* If the expression is of polymorphic type, it's actual size is not known,
2662 so we avoid copying it anywhere. */
2663 if (ss_info
->data
.scalar
.dummy_arg
2664 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2665 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2668 /* If the expression is a data reference of aggregate type,
2669 and the data reference is not used on the left hand side,
2670 avoid a copy by saving a reference to the content. */
2671 if (!ss_info
->data
.scalar
.needs_temporary
2672 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2673 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2674 && gfc_expr_is_variable (ss_info
->expr
))
2677 /* Otherwise the expression is evaluated to a temporary variable before the
2678 scalarization loop. */
2683 /* Add the pre and post chains for all the scalar expressions in a SS chain
2684 to loop. This is called after the loop parameters have been calculated,
2685 but before the actual scalarizing loops. */
2688 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2691 gfc_loopinfo
*nested_loop
, *outer_loop
;
2693 gfc_ss_info
*ss_info
;
2694 gfc_array_info
*info
;
2698 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2699 arguments could get evaluated multiple times. */
2700 if (ss
->is_alloc_lhs
)
2703 outer_loop
= outermost_loop (loop
);
2705 /* TODO: This can generate bad code if there are ordering dependencies,
2706 e.g., a callee allocated function and an unknown size constructor. */
2707 gcc_assert (ss
!= NULL
);
2709 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2713 /* Cross loop arrays are handled from within the most nested loop. */
2714 if (ss
->nested_ss
!= NULL
)
2718 expr
= ss_info
->expr
;
2719 info
= &ss_info
->data
.array
;
2721 switch (ss_info
->type
)
2724 /* Scalar expression. Evaluate this now. This includes elemental
2725 dimension indices, but not array section bounds. */
2726 gfc_init_se (&se
, NULL
);
2727 gfc_conv_expr (&se
, expr
);
2728 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2730 if (expr
->ts
.type
!= BT_CHARACTER
2731 && !gfc_is_alloc_class_scalar_function (expr
))
2733 /* Move the evaluation of scalar expressions outside the
2734 scalarization loop, except for WHERE assignments. */
2736 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2737 if (!ss_info
->where
)
2738 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2739 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2742 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2744 ss_info
->data
.scalar
.value
= se
.expr
;
2745 ss_info
->string_length
= se
.string_length
;
2748 case GFC_SS_REFERENCE
:
2749 /* Scalar argument to elemental procedure. */
2750 gfc_init_se (&se
, NULL
);
2751 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2752 gfc_conv_expr_reference (&se
, expr
);
2755 /* Evaluate the argument outside the loop and pass
2756 a reference to the value. */
2757 gfc_conv_expr (&se
, expr
);
2760 /* Ensure that a pointer to the string is stored. */
2761 if (expr
->ts
.type
== BT_CHARACTER
)
2762 gfc_conv_string_parameter (&se
);
2764 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2765 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2766 if (gfc_is_class_scalar_expr (expr
))
2767 /* This is necessary because the dynamic type will always be
2768 large than the declared type. In consequence, assigning
2769 the value to a temporary could segfault.
2770 OOP-TODO: see if this is generally correct or is the value
2771 has to be written to an allocated temporary, whose address
2772 is passed via ss_info. */
2773 ss_info
->data
.scalar
.value
= se
.expr
;
2775 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2778 ss_info
->string_length
= se
.string_length
;
2781 case GFC_SS_SECTION
:
2782 /* Add the expressions for scalar and vector subscripts. */
2783 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2784 if (info
->subscript
[n
])
2785 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2787 set_vector_loop_bounds (ss
);
2791 /* Get the vector's descriptor and store it in SS. */
2792 gfc_init_se (&se
, NULL
);
2793 gfc_conv_expr_descriptor (&se
, expr
);
2794 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2795 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2796 info
->descriptor
= se
.expr
;
2799 case GFC_SS_INTRINSIC
:
2800 gfc_add_intrinsic_ss_code (loop
, ss
);
2803 case GFC_SS_FUNCTION
:
2804 /* Array function return value. We call the function and save its
2805 result in a temporary for use inside the loop. */
2806 gfc_init_se (&se
, NULL
);
2809 if (gfc_is_class_array_function (expr
))
2810 expr
->must_finalize
= 1;
2811 gfc_conv_expr (&se
, expr
);
2812 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2813 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2814 ss_info
->string_length
= se
.string_length
;
2817 case GFC_SS_CONSTRUCTOR
:
2818 if (expr
->ts
.type
== BT_CHARACTER
2819 && ss_info
->string_length
== NULL
2821 && expr
->ts
.u
.cl
->length
2822 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2824 gfc_init_se (&se
, NULL
);
2825 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2826 gfc_charlen_type_node
);
2827 ss_info
->string_length
= se
.expr
;
2828 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2829 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2831 trans_array_constructor (ss
, where
);
2835 case GFC_SS_COMPONENT
:
2836 /* Do nothing. These are handled elsewhere. */
2845 for (nested_loop
= loop
->nested
; nested_loop
;
2846 nested_loop
= nested_loop
->next
)
2847 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2851 /* Translate expressions for the descriptor and data pointer of a SS. */
2855 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2858 gfc_ss_info
*ss_info
;
2859 gfc_array_info
*info
;
2863 info
= &ss_info
->data
.array
;
2865 /* Get the descriptor for the array to be scalarized. */
2866 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2867 gfc_init_se (&se
, NULL
);
2868 se
.descriptor_only
= 1;
2869 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2870 gfc_add_block_to_block (block
, &se
.pre
);
2871 info
->descriptor
= se
.expr
;
2872 ss_info
->string_length
= se
.string_length
;
2876 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2877 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2879 /* Emit a DECL_EXPR for the variable sized array type in
2880 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2881 sizes works correctly. */
2882 tree arraytype
= TREE_TYPE (
2883 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2884 if (! TYPE_NAME (arraytype
))
2885 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2886 NULL_TREE
, arraytype
);
2887 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2888 TYPE_NAME (arraytype
)));
2890 /* Also the data pointer. */
2891 tmp
= gfc_conv_array_data (se
.expr
);
2892 /* If this is a variable or address of a variable we use it directly.
2893 Otherwise we must evaluate it now to avoid breaking dependency
2894 analysis by pulling the expressions for elemental array indices
2897 || (TREE_CODE (tmp
) == ADDR_EXPR
2898 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2899 tmp
= gfc_evaluate_now (tmp
, block
);
2902 tmp
= gfc_conv_array_offset (se
.expr
);
2903 info
->offset
= gfc_evaluate_now (tmp
, block
);
2905 /* Make absolutely sure that the saved_offset is indeed saved
2906 so that the variable is still accessible after the loops
2908 info
->saved_offset
= info
->offset
;
2913 /* Initialize a gfc_loopinfo structure. */
2916 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2920 memset (loop
, 0, sizeof (gfc_loopinfo
));
2921 gfc_init_block (&loop
->pre
);
2922 gfc_init_block (&loop
->post
);
2924 /* Initially scalarize in order and default to no loop reversal. */
2925 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2928 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2931 loop
->ss
= gfc_ss_terminator
;
2935 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2939 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2945 /* Return an expression for the data pointer of an array. */
2948 gfc_conv_array_data (tree descriptor
)
2952 type
= TREE_TYPE (descriptor
);
2953 if (GFC_ARRAY_TYPE_P (type
))
2955 if (TREE_CODE (type
) == POINTER_TYPE
)
2959 /* Descriptorless arrays. */
2960 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2964 return gfc_conv_descriptor_data_get (descriptor
);
2968 /* Return an expression for the base offset of an array. */
2971 gfc_conv_array_offset (tree descriptor
)
2975 type
= TREE_TYPE (descriptor
);
2976 if (GFC_ARRAY_TYPE_P (type
))
2977 return GFC_TYPE_ARRAY_OFFSET (type
);
2979 return gfc_conv_descriptor_offset_get (descriptor
);
2983 /* Get an expression for the array stride. */
2986 gfc_conv_array_stride (tree descriptor
, int dim
)
2991 type
= TREE_TYPE (descriptor
);
2993 /* For descriptorless arrays use the array size. */
2994 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2995 if (tmp
!= NULL_TREE
)
2998 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3003 /* Like gfc_conv_array_stride, but for the lower bound. */
3006 gfc_conv_array_lbound (tree descriptor
, int dim
)
3011 type
= TREE_TYPE (descriptor
);
3013 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3014 if (tmp
!= NULL_TREE
)
3017 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3022 /* Like gfc_conv_array_stride, but for the upper bound. */
3025 gfc_conv_array_ubound (tree descriptor
, int dim
)
3030 type
= TREE_TYPE (descriptor
);
3032 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3033 if (tmp
!= NULL_TREE
)
3036 /* This should only ever happen when passing an assumed shape array
3037 as an actual parameter. The value will never be used. */
3038 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3039 return gfc_index_zero_node
;
3041 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3046 /* Generate code to perform an array index bound check. */
3049 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3050 locus
* where
, bool check_upper
)
3053 tree tmp_lo
, tmp_up
;
3056 const char * name
= NULL
;
3058 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3061 descriptor
= ss
->info
->data
.array
.descriptor
;
3063 index
= gfc_evaluate_now (index
, &se
->pre
);
3065 /* We find a name for the error message. */
3066 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3067 gcc_assert (name
!= NULL
);
3069 if (VAR_P (descriptor
))
3070 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3072 /* If upper bound is present, include both bounds in the error message. */
3075 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3076 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3079 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3080 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3082 msg
= xasprintf ("Index '%%ld' of dimension %d "
3083 "outside of expected range (%%ld:%%ld)", n
+1);
3085 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3087 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3088 fold_convert (long_integer_type_node
, index
),
3089 fold_convert (long_integer_type_node
, tmp_lo
),
3090 fold_convert (long_integer_type_node
, tmp_up
));
3091 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3093 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3094 fold_convert (long_integer_type_node
, index
),
3095 fold_convert (long_integer_type_node
, tmp_lo
),
3096 fold_convert (long_integer_type_node
, tmp_up
));
3101 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3104 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3105 "below lower bound of %%ld", n
+1, name
);
3107 msg
= xasprintf ("Index '%%ld' of dimension %d "
3108 "below lower bound of %%ld", n
+1);
3110 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3112 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3113 fold_convert (long_integer_type_node
, index
),
3114 fold_convert (long_integer_type_node
, tmp_lo
));
3122 /* Return the offset for an index. Performs bound checking for elemental
3123 dimensions. Single element references are processed separately.
3124 DIM is the array dimension, I is the loop dimension. */
3127 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3128 gfc_array_ref
* ar
, tree stride
)
3130 gfc_array_info
*info
;
3135 info
= &ss
->info
->data
.array
;
3137 /* Get the index into the array for this dimension. */
3140 gcc_assert (ar
->type
!= AR_ELEMENT
);
3141 switch (ar
->dimen_type
[dim
])
3143 case DIMEN_THIS_IMAGE
:
3147 /* Elemental dimension. */
3148 gcc_assert (info
->subscript
[dim
]
3149 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3150 /* We've already translated this value outside the loop. */
3151 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3153 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3154 ar
->as
->type
!= AS_ASSUMED_SIZE
3155 || dim
< ar
->dimen
- 1);
3159 gcc_assert (info
&& se
->loop
);
3160 gcc_assert (info
->subscript
[dim
]
3161 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3162 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3164 /* Get a zero-based index into the vector. */
3165 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3166 gfc_array_index_type
,
3167 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3169 /* Multiply the index by the stride. */
3170 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3171 gfc_array_index_type
,
3172 index
, gfc_conv_array_stride (desc
, 0));
3174 /* Read the vector to get an index into info->descriptor. */
3175 data
= build_fold_indirect_ref_loc (input_location
,
3176 gfc_conv_array_data (desc
));
3177 index
= gfc_build_array_ref (data
, index
, NULL
);
3178 index
= gfc_evaluate_now (index
, &se
->pre
);
3179 index
= fold_convert (gfc_array_index_type
, index
);
3181 /* Do any bounds checking on the final info->descriptor index. */
3182 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3183 ar
->as
->type
!= AS_ASSUMED_SIZE
3184 || dim
< ar
->dimen
- 1);
3188 /* Scalarized dimension. */
3189 gcc_assert (info
&& se
->loop
);
3191 /* Multiply the loop variable by the stride and delta. */
3192 index
= se
->loop
->loopvar
[i
];
3193 if (!integer_onep (info
->stride
[dim
]))
3194 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3195 gfc_array_index_type
, index
,
3197 if (!integer_zerop (info
->delta
[dim
]))
3198 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3199 gfc_array_index_type
, index
,
3209 /* Temporary array or derived type component. */
3210 gcc_assert (se
->loop
);
3211 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3213 /* Pointer functions can have stride[0] different from unity.
3214 Use the stride returned by the function call and stored in
3215 the descriptor for the temporary. */
3216 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3217 && se
->ss
->info
->expr
3218 && se
->ss
->info
->expr
->symtree
3219 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3220 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3221 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3224 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3225 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3226 gfc_array_index_type
, index
, info
->delta
[dim
]);
3229 /* Multiply by the stride. */
3230 if (stride
!= NULL
&& !integer_onep (stride
))
3231 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3238 /* Build a scalarized array reference using the vptr 'size'. */
3241 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3246 tree decl
= NULL_TREE
;
3248 gfc_expr
*expr
= se
->ss
->info
->expr
;
3250 gfc_ref
*class_ref
= NULL
;
3253 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3254 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3255 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3260 || (expr
->ts
.type
!= BT_CLASS
3261 && !gfc_is_class_array_function (expr
)
3262 && !gfc_is_class_array_ref (expr
, NULL
)))
3265 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3266 ts
= &expr
->symtree
->n
.sym
->ts
;
3270 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3272 if (ref
->type
== REF_COMPONENT
3273 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3274 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3275 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3277 && ref
->next
->next
->type
== REF_ARRAY
3278 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3280 ts
= &ref
->u
.c
.component
->ts
;
3290 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3291 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3292 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3294 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3296 else if (expr
&& gfc_is_class_array_function (expr
))
3300 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3303 type
= TREE_TYPE (tmp
);
3306 if (GFC_CLASS_TYPE_P (type
))
3308 if (type
!= TYPE_CANONICAL (type
))
3309 type
= TYPE_CANONICAL (type
);
3317 if (decl
== NULL_TREE
)
3320 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3322 else if (class_ref
== NULL
)
3324 if (decl
== NULL_TREE
)
3325 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3326 /* For class arrays the tree containing the class is stored in
3327 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3328 For all others it's sym's backend_decl directly. */
3329 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3330 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3334 /* Remove everything after the last class reference, convert the
3335 expression and then recover its tailend once more. */
3337 ref
= class_ref
->next
;
3338 class_ref
->next
= NULL
;
3339 gfc_init_se (&tmpse
, NULL
);
3340 gfc_conv_expr (&tmpse
, expr
);
3341 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3343 class_ref
->next
= ref
;
3346 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3347 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3349 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3352 size
= gfc_class_vtab_size_get (decl
);
3354 /* For unlimited polymorphic entities then _len component needs to be
3355 multiplied with the size. If no _len component is present, then
3356 gfc_class_len_or_zero_get () return a zero_node. */
3357 tmp
= gfc_class_len_or_zero_get (decl
);
3358 if (!integer_zerop (tmp
))
3359 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3360 fold_convert (TREE_TYPE (index
), size
),
3361 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3362 fold_convert (TREE_TYPE (index
), tmp
),
3363 fold_convert (TREE_TYPE (index
),
3364 integer_one_node
)));
3366 size
= fold_convert (TREE_TYPE (index
), size
);
3368 /* Build the address of the element. */
3369 type
= TREE_TYPE (TREE_TYPE (base
));
3370 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3371 gfc_array_index_type
,
3373 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3374 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3375 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3377 /* Return the element in the se expression. */
3378 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3383 /* Build a scalarized reference to an array. */
3386 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3388 gfc_array_info
*info
;
3389 tree decl
= NULL_TREE
;
3397 expr
= ss
->info
->expr
;
3398 info
= &ss
->info
->data
.array
;
3400 n
= se
->loop
->order
[0];
3404 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3405 /* Add the offset for this dimension to the stored offset for all other
3407 if (info
->offset
&& !integer_zerop (info
->offset
))
3408 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3409 index
, info
->offset
);
3411 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3413 /* Use the vptr 'size' field to access the element of a class array. */
3414 if (build_class_array_ref (se
, base
, index
))
3417 if (expr
&& ((is_subref_array (expr
)
3418 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
)))
3419 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3420 || expr
->expr_type
== EXPR_FUNCTION
))))
3421 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3423 /* A pointer array component can be detected from its field decl. Fix
3424 the descriptor, mark the resulting variable decl and pass it to
3425 gfc_build_array_ref. */
3426 if (is_pointer_array (info
->descriptor
)
3427 || (expr
&& expr
->ts
.deferred
&& info
->descriptor
3428 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
))))
3430 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3431 decl
= info
->descriptor
;
3432 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3433 decl
= TREE_OPERAND (info
->descriptor
, 0);
3435 if (decl
== NULL_TREE
)
3436 decl
= info
->descriptor
;
3439 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3443 /* Translate access of temporary array. */
3446 gfc_conv_tmp_array_ref (gfc_se
* se
)
3448 se
->string_length
= se
->ss
->info
->string_length
;
3449 gfc_conv_scalarized_array_ref (se
, NULL
);
3450 gfc_advance_se_ss_chain (se
);
3453 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3456 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3458 if (TREE_CODE (t
) == INTEGER_CST
)
3459 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3462 if (!integer_zerop (*offset
))
3463 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3464 gfc_array_index_type
, *offset
, t
);
3472 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3478 /* For class arrays the class declaration is stored in the saved
3480 if (INDIRECT_REF_P (desc
)
3481 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3482 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3483 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3484 TREE_OPERAND (desc
, 0)));
3488 /* Class container types do not always have the GFC_CLASS_TYPE_P
3489 but the canonical type does. */
3490 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3491 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3493 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3494 if (TYPE_CANONICAL (type
)
3495 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3496 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3499 tmp
= gfc_conv_array_data (desc
);
3500 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3501 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3506 /* Build an array reference. se->expr already holds the array descriptor.
3507 This should be either a variable, indirect variable reference or component
3508 reference. For arrays which do not have a descriptor, se->expr will be
3510 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3513 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3517 tree offset
, cst_offset
;
3520 tree decl
= NULL_TREE
;
3523 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3524 char *var_name
= NULL
;
3528 gcc_assert (ar
->codimen
);
3530 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3531 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3534 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3535 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3536 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3538 /* Use the actual tree type and not the wrapped coarray. */
3539 if (!se
->want_pointer
)
3540 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3547 /* Handle scalarized references separately. */
3548 if (ar
->type
!= AR_ELEMENT
)
3550 gfc_conv_scalarized_array_ref (se
, ar
);
3551 gfc_advance_se_ss_chain (se
);
3555 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3560 len
= strlen (sym
->name
) + 1;
3561 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3563 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3565 if (ref
->type
== REF_COMPONENT
)
3566 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3569 var_name
= XALLOCAVEC (char, len
);
3570 strcpy (var_name
, sym
->name
);
3572 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3574 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3576 if (ref
->type
== REF_COMPONENT
)
3578 strcat (var_name
, "%%");
3579 strcat (var_name
, ref
->u
.c
.component
->name
);
3584 cst_offset
= offset
= gfc_index_zero_node
;
3585 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3587 /* Calculate the offsets from all the dimensions. Make sure to associate
3588 the final offset so that we form a chain of loop invariant summands. */
3589 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3591 /* Calculate the index for this dimension. */
3592 gfc_init_se (&indexse
, se
);
3593 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3594 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3596 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3598 /* Check array bounds. */
3602 /* Evaluate the indexse.expr only once. */
3603 indexse
.expr
= save_expr (indexse
.expr
);
3606 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3607 if (sym
->attr
.temporary
)
3609 gfc_init_se (&tmpse
, se
);
3610 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3611 gfc_array_index_type
);
3612 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3616 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3618 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3619 "below lower bound of %%ld", n
+1, var_name
);
3620 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3621 fold_convert (long_integer_type_node
,
3623 fold_convert (long_integer_type_node
, tmp
));
3626 /* Upper bound, but not for the last dimension of assumed-size
3628 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3630 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3631 if (sym
->attr
.temporary
)
3633 gfc_init_se (&tmpse
, se
);
3634 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3635 gfc_array_index_type
);
3636 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3640 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3641 logical_type_node
, indexse
.expr
, tmp
);
3642 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3643 "above upper bound of %%ld", n
+1, var_name
);
3644 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3645 fold_convert (long_integer_type_node
,
3647 fold_convert (long_integer_type_node
, tmp
));
3652 /* Multiply the index by the stride. */
3653 stride
= gfc_conv_array_stride (se
->expr
, n
);
3654 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3655 indexse
.expr
, stride
);
3657 /* And add it to the total. */
3658 add_to_offset (&cst_offset
, &offset
, tmp
);
3661 if (!integer_zerop (cst_offset
))
3662 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3663 gfc_array_index_type
, offset
, cst_offset
);
3665 /* A pointer array component can be detected from its field decl. Fix
3666 the descriptor, mark the resulting variable decl and pass it to
3668 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3669 && is_pointer_array (se
->expr
))
3671 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3673 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3674 decl
= TREE_OPERAND (se
->expr
, 0);
3678 else if (expr
->ts
.deferred
3679 || (sym
->ts
.type
== BT_CHARACTER
3680 && sym
->attr
.select_type_temporary
))
3682 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3685 if (TREE_CODE (decl
) == INDIRECT_REF
)
3686 decl
= TREE_OPERAND (decl
, 0);
3689 decl
= sym
->backend_decl
;
3691 else if (sym
->ts
.type
== BT_CLASS
)
3694 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3698 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3699 LOOP_DIM dimension (if any) to array's offset. */
3702 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3703 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3706 gfc_array_info
*info
;
3709 info
= &ss
->info
->data
.array
;
3711 gfc_init_se (&se
, NULL
);
3713 se
.expr
= info
->descriptor
;
3714 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3715 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3716 gfc_add_block_to_block (pblock
, &se
.pre
);
3718 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3719 gfc_array_index_type
,
3720 info
->offset
, index
);
3721 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3725 /* Generate the code to be executed immediately before entering a
3726 scalarization loop. */
3729 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3730 stmtblock_t
* pblock
)
3733 gfc_ss_info
*ss_info
;
3734 gfc_array_info
*info
;
3735 gfc_ss_type ss_type
;
3737 gfc_loopinfo
*ploop
;
3741 /* This code will be executed before entering the scalarization loop
3742 for this dimension. */
3743 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3747 if ((ss_info
->useflags
& flag
) == 0)
3750 ss_type
= ss_info
->type
;
3751 if (ss_type
!= GFC_SS_SECTION
3752 && ss_type
!= GFC_SS_FUNCTION
3753 && ss_type
!= GFC_SS_CONSTRUCTOR
3754 && ss_type
!= GFC_SS_COMPONENT
)
3757 info
= &ss_info
->data
.array
;
3759 gcc_assert (dim
< ss
->dimen
);
3760 gcc_assert (ss
->dimen
== loop
->dimen
);
3763 ar
= &info
->ref
->u
.ar
;
3767 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3769 /* If we are in the outermost dimension of this loop, the previous
3770 dimension shall be in the parent loop. */
3771 gcc_assert (ss
->parent
!= NULL
);
3774 ploop
= loop
->parent
;
3776 /* ss and ss->parent are about the same array. */
3777 gcc_assert (ss_info
== pss
->info
);
3785 if (dim
== loop
->dimen
- 1)
3790 /* For the time being, there is no loop reordering. */
3791 gcc_assert (i
== ploop
->order
[i
]);
3792 i
= ploop
->order
[i
];
3794 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3796 stride
= gfc_conv_array_stride (info
->descriptor
,
3797 innermost_ss (ss
)->dim
[i
]);
3799 /* Calculate the stride of the innermost loop. Hopefully this will
3800 allow the backend optimizers to do their stuff more effectively.
3802 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3804 /* For the outermost loop calculate the offset due to any
3805 elemental dimensions. It will have been initialized with the
3806 base offset of the array. */
3809 for (i
= 0; i
< ar
->dimen
; i
++)
3811 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3814 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3819 /* Add the offset for the previous loop dimension. */
3820 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3822 /* Remember this offset for the second loop. */
3823 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3824 info
->saved_offset
= info
->offset
;
3829 /* Start a scalarized expression. Creates a scope and declares loop
3833 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3839 gcc_assert (!loop
->array_parameter
);
3841 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3843 n
= loop
->order
[dim
];
3845 gfc_start_block (&loop
->code
[n
]);
3847 /* Create the loop variable. */
3848 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3850 if (dim
< loop
->temp_dim
)
3854 /* Calculate values that will be constant within this loop. */
3855 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3857 gfc_start_block (pbody
);
3861 /* Generates the actual loop code for a scalarization loop. */
3864 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3865 stmtblock_t
* pbody
)
3876 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3877 | OMPWS_SCALARIZER_BODY
))
3878 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3879 && n
== loop
->dimen
- 1)
3881 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3882 init
= make_tree_vec (1);
3883 cond
= make_tree_vec (1);
3884 incr
= make_tree_vec (1);
3886 /* Cycle statement is implemented with a goto. Exit statement must not
3887 be present for this loop. */
3888 exit_label
= gfc_build_label_decl (NULL_TREE
);
3889 TREE_USED (exit_label
) = 1;
3891 /* Label for cycle statements (if needed). */
3892 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3893 gfc_add_expr_to_block (pbody
, tmp
);
3895 stmt
= make_node (OMP_FOR
);
3897 TREE_TYPE (stmt
) = void_type_node
;
3898 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3900 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3901 OMP_CLAUSE_SCHEDULE
);
3902 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3903 = OMP_CLAUSE_SCHEDULE_STATIC
;
3904 if (ompws_flags
& OMPWS_NOWAIT
)
3905 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3906 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3908 /* Initialize the loopvar. */
3909 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3911 OMP_FOR_INIT (stmt
) = init
;
3912 /* The exit condition. */
3913 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3915 loop
->loopvar
[n
], loop
->to
[n
]);
3916 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3917 OMP_FOR_COND (stmt
) = cond
;
3918 /* Increment the loopvar. */
3919 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3920 loop
->loopvar
[n
], gfc_index_one_node
);
3921 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3922 void_type_node
, loop
->loopvar
[n
], tmp
);
3923 OMP_FOR_INCR (stmt
) = incr
;
3925 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3926 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3930 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3931 && (loop
->temp_ss
== NULL
);
3933 loopbody
= gfc_finish_block (pbody
);
3936 std::swap (loop
->from
[n
], loop
->to
[n
]);
3938 /* Initialize the loopvar. */
3939 if (loop
->loopvar
[n
] != loop
->from
[n
])
3940 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3942 exit_label
= gfc_build_label_decl (NULL_TREE
);
3944 /* Generate the loop body. */
3945 gfc_init_block (&block
);
3947 /* The exit condition. */
3948 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3949 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3950 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3951 TREE_USED (exit_label
) = 1;
3952 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3953 gfc_add_expr_to_block (&block
, tmp
);
3955 /* The main body. */
3956 gfc_add_expr_to_block (&block
, loopbody
);
3958 /* Increment the loopvar. */
3959 tmp
= fold_build2_loc (input_location
,
3960 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3961 gfc_array_index_type
, loop
->loopvar
[n
],
3962 gfc_index_one_node
);
3964 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3966 /* Build the loop. */
3967 tmp
= gfc_finish_block (&block
);
3968 tmp
= build1_v (LOOP_EXPR
, tmp
);
3969 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3971 /* Add the exit label. */
3972 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3973 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3979 /* Finishes and generates the loops for a scalarized expression. */
3982 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3987 stmtblock_t
*pblock
;
3991 /* Generate the loops. */
3992 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3994 n
= loop
->order
[dim
];
3995 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3996 loop
->loopvar
[n
] = NULL_TREE
;
3997 pblock
= &loop
->code
[n
];
4000 tmp
= gfc_finish_block (pblock
);
4001 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4003 /* Clear all the used flags. */
4004 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4005 if (ss
->parent
== NULL
)
4006 ss
->info
->useflags
= 0;
4010 /* Finish the main body of a scalarized expression, and start the secondary
4014 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4018 stmtblock_t
*pblock
;
4022 /* We finish as many loops as are used by the temporary. */
4023 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4025 n
= loop
->order
[dim
];
4026 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4027 loop
->loopvar
[n
] = NULL_TREE
;
4028 pblock
= &loop
->code
[n
];
4031 /* We don't want to finish the outermost loop entirely. */
4032 n
= loop
->order
[loop
->temp_dim
- 1];
4033 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4035 /* Restore the initial offsets. */
4036 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4038 gfc_ss_type ss_type
;
4039 gfc_ss_info
*ss_info
;
4043 if ((ss_info
->useflags
& 2) == 0)
4046 ss_type
= ss_info
->type
;
4047 if (ss_type
!= GFC_SS_SECTION
4048 && ss_type
!= GFC_SS_FUNCTION
4049 && ss_type
!= GFC_SS_CONSTRUCTOR
4050 && ss_type
!= GFC_SS_COMPONENT
)
4053 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4056 /* Restart all the inner loops we just finished. */
4057 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4059 n
= loop
->order
[dim
];
4061 gfc_start_block (&loop
->code
[n
]);
4063 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4065 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4068 /* Start a block for the secondary copying code. */
4069 gfc_start_block (body
);
4073 /* Precalculate (either lower or upper) bound of an array section.
4074 BLOCK: Block in which the (pre)calculation code will go.
4075 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4076 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4077 DESC: Array descriptor from which the bound will be picked if unspecified
4078 (either lower or upper bound according to LBOUND). */
4081 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4082 tree desc
, int dim
, bool lbound
, bool deferred
)
4085 gfc_expr
* input_val
= values
[dim
];
4086 tree
*output
= &bounds
[dim
];
4091 /* Specified section bound. */
4092 gfc_init_se (&se
, NULL
);
4093 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4094 gfc_add_block_to_block (block
, &se
.pre
);
4097 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4099 /* The gfc_conv_array_lbound () routine returns a constant zero for
4100 deferred length arrays, which in the scalarizer wreaks havoc, when
4101 copying to a (newly allocated) one-based array.
4102 Keep returning the actual result in sync for both bounds. */
4103 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4105 gfc_conv_descriptor_ubound_get (desc
,
4110 /* No specific bound specified so use the bound of the array. */
4111 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4112 gfc_conv_array_ubound (desc
, dim
);
4114 *output
= gfc_evaluate_now (*output
, block
);
4118 /* Calculate the lower bound of an array section. */
4121 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4123 gfc_expr
*stride
= NULL
;
4126 gfc_array_info
*info
;
4129 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4131 info
= &ss
->info
->data
.array
;
4132 ar
= &info
->ref
->u
.ar
;
4134 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4136 /* We use a zero-based index to access the vector. */
4137 info
->start
[dim
] = gfc_index_zero_node
;
4138 info
->end
[dim
] = NULL
;
4139 info
->stride
[dim
] = gfc_index_one_node
;
4143 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4144 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4145 desc
= info
->descriptor
;
4146 stride
= ar
->stride
[dim
];
4149 /* Calculate the start of the range. For vector subscripts this will
4150 be the range of the vector. */
4151 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4152 ar
->as
->type
== AS_DEFERRED
);
4154 /* Similarly calculate the end. Although this is not used in the
4155 scalarizer, it is needed when checking bounds and where the end
4156 is an expression with side-effects. */
4157 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4158 ar
->as
->type
== AS_DEFERRED
);
4161 /* Calculate the stride. */
4163 info
->stride
[dim
] = gfc_index_one_node
;
4166 gfc_init_se (&se
, NULL
);
4167 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4168 gfc_add_block_to_block (block
, &se
.pre
);
4169 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4174 /* Calculates the range start and stride for a SS chain. Also gets the
4175 descriptor and data pointer. The range of vector subscripts is the size
4176 of the vector. Array bounds are also checked. */
4179 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4186 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4189 /* Determine the rank of the loop. */
4190 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4192 switch (ss
->info
->type
)
4194 case GFC_SS_SECTION
:
4195 case GFC_SS_CONSTRUCTOR
:
4196 case GFC_SS_FUNCTION
:
4197 case GFC_SS_COMPONENT
:
4198 loop
->dimen
= ss
->dimen
;
4201 /* As usual, lbound and ubound are exceptions!. */
4202 case GFC_SS_INTRINSIC
:
4203 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4205 case GFC_ISYM_LBOUND
:
4206 case GFC_ISYM_UBOUND
:
4207 case GFC_ISYM_LCOBOUND
:
4208 case GFC_ISYM_UCOBOUND
:
4209 case GFC_ISYM_THIS_IMAGE
:
4210 loop
->dimen
= ss
->dimen
;
4222 /* We should have determined the rank of the expression by now. If
4223 not, that's bad news. */
4227 /* Loop over all the SS in the chain. */
4228 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4230 gfc_ss_info
*ss_info
;
4231 gfc_array_info
*info
;
4235 expr
= ss_info
->expr
;
4236 info
= &ss_info
->data
.array
;
4238 if (expr
&& expr
->shape
&& !info
->shape
)
4239 info
->shape
= expr
->shape
;
4241 switch (ss_info
->type
)
4243 case GFC_SS_SECTION
:
4244 /* Get the descriptor for the array. If it is a cross loops array,
4245 we got the descriptor already in the outermost loop. */
4246 if (ss
->parent
== NULL
)
4247 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4248 !loop
->array_parameter
);
4250 for (n
= 0; n
< ss
->dimen
; n
++)
4251 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4254 case GFC_SS_INTRINSIC
:
4255 switch (expr
->value
.function
.isym
->id
)
4257 /* Fall through to supply start and stride. */
4258 case GFC_ISYM_LBOUND
:
4259 case GFC_ISYM_UBOUND
:
4263 /* This is the variant without DIM=... */
4264 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4266 arg
= expr
->value
.function
.actual
->expr
;
4267 if (arg
->rank
== -1)
4272 /* The rank (hence the return value's shape) is unknown,
4273 we have to retrieve it. */
4274 gfc_init_se (&se
, NULL
);
4275 se
.descriptor_only
= 1;
4276 gfc_conv_expr (&se
, arg
);
4277 /* This is a bare variable, so there is no preliminary
4279 gcc_assert (se
.pre
.head
== NULL_TREE
4280 && se
.post
.head
== NULL_TREE
);
4281 rank
= gfc_conv_descriptor_rank (se
.expr
);
4282 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4283 gfc_array_index_type
,
4284 fold_convert (gfc_array_index_type
,
4286 gfc_index_one_node
);
4287 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4288 info
->start
[0] = gfc_index_zero_node
;
4289 info
->stride
[0] = gfc_index_one_node
;
4292 /* Otherwise fall through GFC_SS_FUNCTION. */
4295 case GFC_ISYM_LCOBOUND
:
4296 case GFC_ISYM_UCOBOUND
:
4297 case GFC_ISYM_THIS_IMAGE
:
4305 case GFC_SS_CONSTRUCTOR
:
4306 case GFC_SS_FUNCTION
:
4307 for (n
= 0; n
< ss
->dimen
; n
++)
4309 int dim
= ss
->dim
[n
];
4311 info
->start
[dim
] = gfc_index_zero_node
;
4312 info
->end
[dim
] = gfc_index_zero_node
;
4313 info
->stride
[dim
] = gfc_index_one_node
;
4322 /* The rest is just runtime bounds checking. */
4323 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4326 tree lbound
, ubound
;
4328 tree size
[GFC_MAX_DIMENSIONS
];
4329 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4330 gfc_array_info
*info
;
4334 gfc_start_block (&block
);
4336 for (n
= 0; n
< loop
->dimen
; n
++)
4337 size
[n
] = NULL_TREE
;
4339 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4342 gfc_ss_info
*ss_info
;
4345 const char *expr_name
;
4348 if (ss_info
->type
!= GFC_SS_SECTION
)
4351 /* Catch allocatable lhs in f2003. */
4352 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4355 expr
= ss_info
->expr
;
4356 expr_loc
= &expr
->where
;
4357 expr_name
= expr
->symtree
->name
;
4359 gfc_start_block (&inner
);
4361 /* TODO: range checking for mapped dimensions. */
4362 info
= &ss_info
->data
.array
;
4364 /* This code only checks ranges. Elemental and vector
4365 dimensions are checked later. */
4366 for (n
= 0; n
< loop
->dimen
; n
++)
4371 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4374 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4375 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4376 check_upper
= false;
4380 /* Zero stride is not allowed. */
4381 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4382 info
->stride
[dim
], gfc_index_zero_node
);
4383 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4384 "of array '%s'", dim
+ 1, expr_name
);
4385 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4389 desc
= info
->descriptor
;
4391 /* This is the run-time equivalent of resolve.c's
4392 check_dimension(). The logical is more readable there
4393 than it is here, with all the trees. */
4394 lbound
= gfc_conv_array_lbound (desc
, dim
);
4395 end
= info
->end
[dim
];
4397 ubound
= gfc_conv_array_ubound (desc
, dim
);
4401 /* non_zerosized is true when the selected range is not
4403 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4404 logical_type_node
, info
->stride
[dim
],
4405 gfc_index_zero_node
);
4406 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4407 info
->start
[dim
], end
);
4408 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4409 logical_type_node
, stride_pos
, tmp
);
4411 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4413 info
->stride
[dim
], gfc_index_zero_node
);
4414 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4415 info
->start
[dim
], end
);
4416 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4419 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4421 stride_pos
, stride_neg
);
4423 /* Check the start of the range against the lower and upper
4424 bounds of the array, if the range is not empty.
4425 If upper bound is present, include both bounds in the
4429 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4431 info
->start
[dim
], lbound
);
4432 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4434 non_zerosized
, tmp
);
4435 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4437 info
->start
[dim
], ubound
);
4438 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4440 non_zerosized
, tmp2
);
4441 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4442 "outside of expected range (%%ld:%%ld)",
4443 dim
+ 1, expr_name
);
4444 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4446 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4447 fold_convert (long_integer_type_node
, lbound
),
4448 fold_convert (long_integer_type_node
, ubound
));
4449 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4451 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4452 fold_convert (long_integer_type_node
, lbound
),
4453 fold_convert (long_integer_type_node
, ubound
));
4458 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4460 info
->start
[dim
], lbound
);
4461 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4462 logical_type_node
, non_zerosized
, tmp
);
4463 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4464 "below lower bound of %%ld",
4465 dim
+ 1, expr_name
);
4466 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4468 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4469 fold_convert (long_integer_type_node
, lbound
));
4473 /* Compute the last element of the range, which is not
4474 necessarily "end" (think 0:5:3, which doesn't contain 5)
4475 and check it against both lower and upper bounds. */
4477 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4478 gfc_array_index_type
, end
,
4480 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4481 gfc_array_index_type
, tmp
,
4483 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4484 gfc_array_index_type
, end
, tmp
);
4485 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4486 logical_type_node
, tmp
, lbound
);
4487 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4488 logical_type_node
, non_zerosized
, tmp2
);
4491 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4492 logical_type_node
, tmp
, ubound
);
4493 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4494 logical_type_node
, non_zerosized
, tmp3
);
4495 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4496 "outside of expected range (%%ld:%%ld)",
4497 dim
+ 1, expr_name
);
4498 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4500 fold_convert (long_integer_type_node
, tmp
),
4501 fold_convert (long_integer_type_node
, ubound
),
4502 fold_convert (long_integer_type_node
, lbound
));
4503 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4505 fold_convert (long_integer_type_node
, tmp
),
4506 fold_convert (long_integer_type_node
, ubound
),
4507 fold_convert (long_integer_type_node
, lbound
));
4512 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4513 "below lower bound of %%ld",
4514 dim
+ 1, expr_name
);
4515 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4517 fold_convert (long_integer_type_node
, tmp
),
4518 fold_convert (long_integer_type_node
, lbound
));
4522 /* Check the section sizes match. */
4523 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4524 gfc_array_index_type
, end
,
4526 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4527 gfc_array_index_type
, tmp
,
4529 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4530 gfc_array_index_type
,
4531 gfc_index_one_node
, tmp
);
4532 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4533 gfc_array_index_type
, tmp
,
4534 build_int_cst (gfc_array_index_type
, 0));
4535 /* We remember the size of the first section, and check all the
4536 others against this. */
4539 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4540 logical_type_node
, tmp
, size
[n
]);
4541 msg
= xasprintf ("Array bound mismatch for dimension %d "
4542 "of array '%s' (%%ld/%%ld)",
4543 dim
+ 1, expr_name
);
4545 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4547 fold_convert (long_integer_type_node
, tmp
),
4548 fold_convert (long_integer_type_node
, size
[n
]));
4553 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4556 tmp
= gfc_finish_block (&inner
);
4558 /* For optional arguments, only check bounds if the argument is
4560 if (expr
->symtree
->n
.sym
->attr
.optional
4561 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4562 tmp
= build3_v (COND_EXPR
,
4563 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4564 tmp
, build_empty_stmt (input_location
));
4566 gfc_add_expr_to_block (&block
, tmp
);
4570 tmp
= gfc_finish_block (&block
);
4571 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4574 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4575 gfc_conv_ss_startstride (loop
);
4578 /* Return true if both symbols could refer to the same data object. Does
4579 not take account of aliasing due to equivalence statements. */
4582 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4583 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4585 /* Aliasing isn't possible if the symbols have different base types. */
4586 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4589 /* Pointers can point to other pointers and target objects. */
4591 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4592 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4595 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4596 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4598 if (lsym_target
&& rsym_target
4599 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4600 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4601 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4602 && (!rsym
->attr
.dimension
4603 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4610 /* Return true if the two SS could be aliased, i.e. both point to the same data
4612 /* TODO: resolve aliases based on frontend expressions. */
4615 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4619 gfc_expr
*lexpr
, *rexpr
;
4622 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4624 lexpr
= lss
->info
->expr
;
4625 rexpr
= rss
->info
->expr
;
4627 lsym
= lexpr
->symtree
->n
.sym
;
4628 rsym
= rexpr
->symtree
->n
.sym
;
4630 lsym_pointer
= lsym
->attr
.pointer
;
4631 lsym_target
= lsym
->attr
.target
;
4632 rsym_pointer
= rsym
->attr
.pointer
;
4633 rsym_target
= rsym
->attr
.target
;
4635 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4636 rsym_pointer
, rsym_target
))
4639 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4640 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4643 /* For derived types we must check all the component types. We can ignore
4644 array references as these will have the same base type as the previous
4646 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4648 if (lref
->type
!= REF_COMPONENT
)
4651 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4652 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4654 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4655 rsym_pointer
, rsym_target
))
4658 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4659 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4661 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4666 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4669 if (rref
->type
!= REF_COMPONENT
)
4672 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4673 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4675 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4676 lsym_pointer
, lsym_target
,
4677 rsym_pointer
, rsym_target
))
4680 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4681 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4683 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4684 &rref
->u
.c
.sym
->ts
))
4686 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4687 &rref
->u
.c
.component
->ts
))
4689 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4690 &rref
->u
.c
.component
->ts
))
4696 lsym_pointer
= lsym
->attr
.pointer
;
4697 lsym_target
= lsym
->attr
.target
;
4698 lsym_pointer
= lsym
->attr
.pointer
;
4699 lsym_target
= lsym
->attr
.target
;
4701 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4703 if (rref
->type
!= REF_COMPONENT
)
4706 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4707 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4709 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4710 lsym_pointer
, lsym_target
,
4711 rsym_pointer
, rsym_target
))
4714 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4715 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4717 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4726 /* Resolve array data dependencies. Creates a temporary if required. */
4727 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4731 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4737 gfc_ss_info
*ss_info
;
4738 gfc_expr
*dest_expr
;
4743 loop
->temp_ss
= NULL
;
4744 dest_expr
= dest
->info
->expr
;
4746 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4749 ss_expr
= ss_info
->expr
;
4751 if (ss_info
->array_outer_dependency
)
4757 if (ss_info
->type
!= GFC_SS_SECTION
)
4759 if (flag_realloc_lhs
4760 && dest_expr
!= ss_expr
4761 && gfc_is_reallocatable_lhs (dest_expr
)
4763 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4765 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4766 if (!nDepend
&& dest_expr
->rank
> 0
4767 && dest_expr
->ts
.type
== BT_CHARACTER
4768 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4770 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4772 if (ss_info
->type
== GFC_SS_REFERENCE
4773 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4774 ss_info
->data
.scalar
.needs_temporary
= 1;
4782 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4784 if (gfc_could_be_alias (dest
, ss
)
4785 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4793 lref
= dest_expr
->ref
;
4794 rref
= ss_expr
->ref
;
4796 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4801 for (i
= 0; i
< dest
->dimen
; i
++)
4802 for (j
= 0; j
< ss
->dimen
; j
++)
4804 && dest
->dim
[i
] == ss
->dim
[j
])
4806 /* If we don't access array elements in the same order,
4807 there is a dependency. */
4812 /* TODO : loop shifting. */
4815 /* Mark the dimensions for LOOP SHIFTING */
4816 for (n
= 0; n
< loop
->dimen
; n
++)
4818 int dim
= dest
->data
.info
.dim
[n
];
4820 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4822 else if (! gfc_is_same_range (&lref
->u
.ar
,
4823 &rref
->u
.ar
, dim
, 0))
4827 /* Put all the dimensions with dependencies in the
4830 for (n
= 0; n
< loop
->dimen
; n
++)
4832 gcc_assert (loop
->order
[n
] == n
);
4834 loop
->order
[dim
++] = n
;
4836 for (n
= 0; n
< loop
->dimen
; n
++)
4839 loop
->order
[dim
++] = n
;
4842 gcc_assert (dim
== loop
->dimen
);
4853 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4854 if (GFC_ARRAY_TYPE_P (base_type
)
4855 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4856 base_type
= gfc_get_element_type (base_type
);
4857 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4859 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4862 loop
->temp_ss
= NULL
;
4866 /* Browse through each array's information from the scalarizer and set the loop
4867 bounds according to the "best" one (per dimension), i.e. the one which
4868 provides the most information (constant bounds, shape, etc.). */
4871 set_loop_bounds (gfc_loopinfo
*loop
)
4873 int n
, dim
, spec_dim
;
4874 gfc_array_info
*info
;
4875 gfc_array_info
*specinfo
;
4879 bool dynamic
[GFC_MAX_DIMENSIONS
];
4882 bool nonoptional_arr
;
4884 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4886 loopspec
= loop
->specloop
;
4889 for (n
= 0; n
< loop
->dimen
; n
++)
4894 /* If there are both optional and nonoptional array arguments, scalarize
4895 over the nonoptional; otherwise, it does not matter as then all
4896 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4898 nonoptional_arr
= false;
4900 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4901 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4902 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4904 nonoptional_arr
= true;
4908 /* We use one SS term, and use that to determine the bounds of the
4909 loop for this dimension. We try to pick the simplest term. */
4910 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4912 gfc_ss_type ss_type
;
4914 ss_type
= ss
->info
->type
;
4915 if (ss_type
== GFC_SS_SCALAR
4916 || ss_type
== GFC_SS_TEMP
4917 || ss_type
== GFC_SS_REFERENCE
4918 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4921 info
= &ss
->info
->data
.array
;
4924 if (loopspec
[n
] != NULL
)
4926 specinfo
= &loopspec
[n
]->info
->data
.array
;
4927 spec_dim
= loopspec
[n
]->dim
[n
];
4931 /* Silence uninitialized warnings. */
4938 gcc_assert (info
->shape
[dim
]);
4939 /* The frontend has worked out the size for us. */
4942 || !integer_zerop (specinfo
->start
[spec_dim
]))
4943 /* Prefer zero-based descriptors if possible. */
4948 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4950 gfc_constructor_base base
;
4951 /* An unknown size constructor will always be rank one.
4952 Higher rank constructors will either have known shape,
4953 or still be wrapped in a call to reshape. */
4954 gcc_assert (loop
->dimen
== 1);
4956 /* Always prefer to use the constructor bounds if the size
4957 can be determined at compile time. Prefer not to otherwise,
4958 since the general case involves realloc, and it's better to
4959 avoid that overhead if possible. */
4960 base
= ss
->info
->expr
->value
.constructor
;
4961 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4962 if (!dynamic
[n
] || !loopspec
[n
])
4967 /* Avoid using an allocatable lhs in an assignment, since
4968 there might be a reallocation coming. */
4969 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4974 /* Criteria for choosing a loop specifier (most important first):
4975 doesn't need realloc
4981 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4983 else if (integer_onep (info
->stride
[dim
])
4984 && !integer_onep (specinfo
->stride
[spec_dim
]))
4986 else if (INTEGER_CST_P (info
->stride
[dim
])
4987 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4989 else if (INTEGER_CST_P (info
->start
[dim
])
4990 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4991 && integer_onep (info
->stride
[dim
])
4992 == integer_onep (specinfo
->stride
[spec_dim
])
4993 && INTEGER_CST_P (info
->stride
[dim
])
4994 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4996 /* We don't work out the upper bound.
4997 else if (INTEGER_CST_P (info->finish[n])
4998 && ! INTEGER_CST_P (specinfo->finish[n]))
4999 loopspec[n] = ss; */
5002 /* We should have found the scalarization loop specifier. If not,
5004 gcc_assert (loopspec
[n
]);
5006 info
= &loopspec
[n
]->info
->data
.array
;
5007 dim
= loopspec
[n
]->dim
[n
];
5009 /* Set the extents of this range. */
5010 cshape
= info
->shape
;
5011 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5012 && INTEGER_CST_P (info
->stride
[dim
]))
5014 loop
->from
[n
] = info
->start
[dim
];
5015 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5016 mpz_sub_ui (i
, i
, 1);
5017 /* To = from + (size - 1) * stride. */
5018 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5019 if (!integer_onep (info
->stride
[dim
]))
5020 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5021 gfc_array_index_type
, tmp
,
5023 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5024 gfc_array_index_type
,
5025 loop
->from
[n
], tmp
);
5029 loop
->from
[n
] = info
->start
[dim
];
5030 switch (loopspec
[n
]->info
->type
)
5032 case GFC_SS_CONSTRUCTOR
:
5033 /* The upper bound is calculated when we expand the
5035 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5038 case GFC_SS_SECTION
:
5039 /* Use the end expression if it exists and is not constant,
5040 so that it is only evaluated once. */
5041 loop
->to
[n
] = info
->end
[dim
];
5044 case GFC_SS_FUNCTION
:
5045 /* The loop bound will be set when we generate the call. */
5046 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5049 case GFC_SS_INTRINSIC
:
5051 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5053 /* The {l,u}bound of an assumed rank. */
5054 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5055 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5056 && expr
->value
.function
.actual
->next
->expr
== NULL
5057 && expr
->value
.function
.actual
->expr
->rank
== -1);
5059 loop
->to
[n
] = info
->end
[dim
];
5063 case GFC_SS_COMPONENT
:
5065 if (info
->end
[dim
] != NULL_TREE
)
5067 loop
->to
[n
] = info
->end
[dim
];
5079 /* Transform everything so we have a simple incrementing variable. */
5080 if (integer_onep (info
->stride
[dim
]))
5081 info
->delta
[dim
] = gfc_index_zero_node
;
5084 /* Set the delta for this section. */
5085 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5086 /* Number of iterations is (end - start + step) / step.
5087 with start = 0, this simplifies to
5089 for (i = 0; i<=last; i++){...}; */
5090 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5091 gfc_array_index_type
, loop
->to
[n
],
5093 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5094 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5095 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5096 tmp
, build_int_cst (gfc_array_index_type
, -1));
5097 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5098 /* Make the loop variable start at 0. */
5099 loop
->from
[n
] = gfc_index_zero_node
;
5104 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5105 set_loop_bounds (loop
);
5109 /* Initialize the scalarization loop. Creates the loop variables. Determines
5110 the range of the loop variables. Creates a temporary if required.
5111 Also generates code for scalar expressions which have been
5112 moved outside the loop. */
5115 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5120 set_loop_bounds (loop
);
5122 /* Add all the scalar code that can be taken out of the loops.
5123 This may include calculating the loop bounds, so do it before
5124 allocating the temporary. */
5125 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5127 tmp_ss
= loop
->temp_ss
;
5128 /* If we want a temporary then create it. */
5131 gfc_ss_info
*tmp_ss_info
;
5133 tmp_ss_info
= tmp_ss
->info
;
5134 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5135 gcc_assert (loop
->parent
== NULL
);
5137 /* Make absolutely sure that this is a complete type. */
5138 if (tmp_ss_info
->string_length
)
5139 tmp_ss_info
->data
.temp
.type
5140 = gfc_get_character_type_len_for_eltype
5141 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5142 tmp_ss_info
->string_length
);
5144 tmp
= tmp_ss_info
->data
.temp
.type
;
5145 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5146 tmp_ss_info
->type
= GFC_SS_SECTION
;
5148 gcc_assert (tmp_ss
->dimen
!= 0);
5150 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5151 NULL_TREE
, false, true, false, where
);
5154 /* For array parameters we don't have loop variables, so don't calculate the
5156 if (!loop
->array_parameter
)
5157 gfc_set_delta (loop
);
5161 /* Calculates how to transform from loop variables to array indices for each
5162 array: once loop bounds are chosen, sets the difference (DELTA field) between
5163 loop bounds and array reference bounds, for each array info. */
5166 gfc_set_delta (gfc_loopinfo
*loop
)
5168 gfc_ss
*ss
, **loopspec
;
5169 gfc_array_info
*info
;
5173 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5175 loopspec
= loop
->specloop
;
5177 /* Calculate the translation from loop variables to array indices. */
5178 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5180 gfc_ss_type ss_type
;
5182 ss_type
= ss
->info
->type
;
5183 if (ss_type
!= GFC_SS_SECTION
5184 && ss_type
!= GFC_SS_COMPONENT
5185 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5188 info
= &ss
->info
->data
.array
;
5190 for (n
= 0; n
< ss
->dimen
; n
++)
5192 /* If we are specifying the range the delta is already set. */
5193 if (loopspec
[n
] != ss
)
5197 /* Calculate the offset relative to the loop variable.
5198 First multiply by the stride. */
5199 tmp
= loop
->from
[n
];
5200 if (!integer_onep (info
->stride
[dim
]))
5201 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5202 gfc_array_index_type
,
5203 tmp
, info
->stride
[dim
]);
5205 /* Then subtract this from our starting value. */
5206 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5207 gfc_array_index_type
,
5208 info
->start
[dim
], tmp
);
5210 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5215 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5216 gfc_set_delta (loop
);
5220 /* Calculate the size of a given array dimension from the bounds. This
5221 is simply (ubound - lbound + 1) if this expression is positive
5222 or 0 if it is negative (pick either one if it is zero). Optionally
5223 (if or_expr is present) OR the (expression != 0) condition to it. */
5226 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5231 /* Calculate (ubound - lbound + 1). */
5232 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5234 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5235 gfc_index_one_node
);
5237 /* Check whether the size for this dimension is negative. */
5238 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5239 gfc_index_zero_node
);
5240 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5241 gfc_index_zero_node
, res
);
5243 /* Build OR expression. */
5245 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5246 logical_type_node
, *or_expr
, cond
);
5252 /* For an array descriptor, get the total number of elements. This is just
5253 the product of the extents along from_dim to to_dim. */
5256 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5261 res
= gfc_index_one_node
;
5263 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5269 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5270 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5272 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5273 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5281 /* Full size of an array. */
5284 gfc_conv_descriptor_size (tree desc
, int rank
)
5286 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5290 /* Size of a coarray for all dimensions but the last. */
5293 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5295 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5299 /* Fills in an array descriptor, and returns the size of the array.
5300 The size will be a simple_val, ie a variable or a constant. Also
5301 calculates the offset of the base. The pointer argument overflow,
5302 which should be of integer type, will increase in value if overflow
5303 occurs during the size calculation. Returns the size of the array.
5307 for (n = 0; n < rank; n++)
5309 a.lbound[n] = specified_lower_bound;
5310 offset = offset + a.lbond[n] * stride;
5312 a.ubound[n] = specified_upper_bound;
5313 a.stride[n] = stride;
5314 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5315 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5316 stride = stride * size;
5318 for (n = rank; n < rank+corank; n++)
5319 (Set lcobound/ucobound as above.)
5320 element_size = sizeof (array element);
5323 stride = (size_t) stride;
5324 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5325 stride = stride * element_size;
5331 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5332 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5333 stmtblock_t
* descriptor_block
, tree
* overflow
,
5334 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5335 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5348 stmtblock_t thenblock
;
5349 stmtblock_t elseblock
;
5354 type
= TREE_TYPE (descriptor
);
5356 stride
= gfc_index_one_node
;
5357 offset
= gfc_index_zero_node
;
5359 /* Set the dtype before the alloc, because registration of coarrays needs
5361 if (expr
->ts
.type
== BT_CHARACTER
5362 && expr
->ts
.deferred
5363 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5365 type
= gfc_typenode_for_spec (&expr
->ts
);
5366 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5367 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5371 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5372 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5375 or_expr
= logical_false_node
;
5377 for (n
= 0; n
< rank
; n
++)
5382 /* We have 3 possibilities for determining the size of the array:
5383 lower == NULL => lbound = 1, ubound = upper[n]
5384 upper[n] = NULL => lbound = 1, ubound = lower[n]
5385 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5388 /* Set lower bound. */
5389 gfc_init_se (&se
, NULL
);
5390 if (expr3_desc
!= NULL_TREE
)
5392 if (e3_is_array_constr
)
5393 /* The lbound of a constant array [] starts at zero, but when
5394 allocating it, the standard expects the array to start at
5396 se
.expr
= gfc_index_one_node
;
5398 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5401 else if (lower
== NULL
)
5402 se
.expr
= gfc_index_one_node
;
5405 gcc_assert (lower
[n
]);
5408 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5409 gfc_add_block_to_block (pblock
, &se
.pre
);
5413 se
.expr
= gfc_index_one_node
;
5417 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5418 gfc_rank_cst
[n
], se
.expr
);
5419 conv_lbound
= se
.expr
;
5421 /* Work out the offset for this component. */
5422 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5424 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5425 gfc_array_index_type
, offset
, tmp
);
5427 /* Set upper bound. */
5428 gfc_init_se (&se
, NULL
);
5429 if (expr3_desc
!= NULL_TREE
)
5431 if (e3_is_array_constr
)
5433 /* The lbound of a constant array [] starts at zero, but when
5434 allocating it, the standard expects the array to start at
5435 one. Therefore fix the upper bound to be
5436 (desc.ubound - desc.lbound)+ 1. */
5437 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5438 gfc_array_index_type
,
5439 gfc_conv_descriptor_ubound_get (
5440 expr3_desc
, gfc_rank_cst
[n
]),
5441 gfc_conv_descriptor_lbound_get (
5442 expr3_desc
, gfc_rank_cst
[n
]));
5443 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5444 gfc_array_index_type
, tmp
,
5445 gfc_index_one_node
);
5446 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5449 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5454 gcc_assert (ubound
);
5455 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5456 gfc_add_block_to_block (pblock
, &se
.pre
);
5457 if (ubound
->expr_type
== EXPR_FUNCTION
)
5458 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5460 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5461 gfc_rank_cst
[n
], se
.expr
);
5462 conv_ubound
= se
.expr
;
5464 /* Store the stride. */
5465 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5466 gfc_rank_cst
[n
], stride
);
5468 /* Calculate size and check whether extent is negative. */
5469 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5470 size
= gfc_evaluate_now (size
, pblock
);
5472 /* Check whether multiplying the stride by the number of
5473 elements in this dimension would overflow. We must also check
5474 whether the current dimension has zero size in order to avoid
5477 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5478 gfc_array_index_type
,
5479 fold_convert (gfc_array_index_type
,
5480 TYPE_MAX_VALUE (gfc_array_index_type
)),
5482 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5483 logical_type_node
, tmp
, stride
),
5484 PRED_FORTRAN_OVERFLOW
);
5485 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5486 integer_one_node
, integer_zero_node
);
5487 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5488 logical_type_node
, size
,
5489 gfc_index_zero_node
),
5490 PRED_FORTRAN_SIZE_ZERO
);
5491 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5492 integer_zero_node
, tmp
);
5493 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5495 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5497 /* Multiply the stride by the number of elements in this dimension. */
5498 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5499 gfc_array_index_type
, stride
, size
);
5500 stride
= gfc_evaluate_now (stride
, pblock
);
5503 for (n
= rank
; n
< rank
+ corank
; n
++)
5507 /* Set lower bound. */
5508 gfc_init_se (&se
, NULL
);
5509 if (lower
== NULL
|| lower
[n
] == NULL
)
5511 gcc_assert (n
== rank
+ corank
- 1);
5512 se
.expr
= gfc_index_one_node
;
5516 if (ubound
|| n
== rank
+ corank
- 1)
5518 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5519 gfc_add_block_to_block (pblock
, &se
.pre
);
5523 se
.expr
= gfc_index_one_node
;
5527 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5528 gfc_rank_cst
[n
], se
.expr
);
5530 if (n
< rank
+ corank
- 1)
5532 gfc_init_se (&se
, NULL
);
5533 gcc_assert (ubound
);
5534 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5535 gfc_add_block_to_block (pblock
, &se
.pre
);
5536 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5537 gfc_rank_cst
[n
], se
.expr
);
5541 /* The stride is the number of elements in the array, so multiply by the
5542 size of an element to get the total size. Obviously, if there is a
5543 SOURCE expression (expr3) we must use its element size. */
5544 if (expr3_elem_size
!= NULL_TREE
)
5545 tmp
= expr3_elem_size
;
5546 else if (expr3
!= NULL
)
5548 if (expr3
->ts
.type
== BT_CLASS
)
5551 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5552 gfc_add_vptr_component (sz
);
5553 gfc_add_size_component (sz
);
5554 gfc_init_se (&se_sz
, NULL
);
5555 gfc_conv_expr (&se_sz
, sz
);
5561 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5562 tmp
= TYPE_SIZE_UNIT (tmp
);
5566 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5568 /* Convert to size_t. */
5569 element_size
= fold_convert (size_type_node
, tmp
);
5572 return element_size
;
5574 *nelems
= gfc_evaluate_now (stride
, pblock
);
5575 stride
= fold_convert (size_type_node
, stride
);
5577 /* First check for overflow. Since an array of type character can
5578 have zero element_size, we must check for that before
5580 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5582 TYPE_MAX_VALUE (size_type_node
), element_size
);
5583 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5584 logical_type_node
, tmp
, stride
),
5585 PRED_FORTRAN_OVERFLOW
);
5586 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5587 integer_one_node
, integer_zero_node
);
5588 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5589 logical_type_node
, element_size
,
5590 build_int_cst (size_type_node
, 0)),
5591 PRED_FORTRAN_SIZE_ZERO
);
5592 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5593 integer_zero_node
, tmp
);
5594 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5596 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5598 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5599 stride
, element_size
);
5601 if (poffset
!= NULL
)
5603 offset
= gfc_evaluate_now (offset
, pblock
);
5607 if (integer_zerop (or_expr
))
5609 if (integer_onep (or_expr
))
5610 return build_int_cst (size_type_node
, 0);
5612 var
= gfc_create_var (TREE_TYPE (size
), "size");
5613 gfc_start_block (&thenblock
);
5614 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5615 thencase
= gfc_finish_block (&thenblock
);
5617 gfc_start_block (&elseblock
);
5618 gfc_add_modify (&elseblock
, var
, size
);
5619 elsecase
= gfc_finish_block (&elseblock
);
5621 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5622 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5623 gfc_add_expr_to_block (pblock
, tmp
);
5629 /* Retrieve the last ref from the chain. This routine is specific to
5630 gfc_array_allocate ()'s needs. */
5633 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5635 gfc_ref
*ref
, *prev_ref
;
5638 /* Prevent warnings for uninitialized variables. */
5639 prev_ref
= *prev_ref_in
;
5640 while (ref
&& ref
->next
!= NULL
)
5642 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5643 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5648 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5652 *prev_ref_in
= prev_ref
;
5656 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5657 the work for an ALLOCATE statement. */
5661 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5662 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5663 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5664 bool e3_is_array_constr
)
5668 tree offset
= NULL_TREE
;
5669 tree token
= NULL_TREE
;
5672 tree error
= NULL_TREE
;
5673 tree overflow
; /* Boolean storing whether size calculation overflows. */
5674 tree var_overflow
= NULL_TREE
;
5676 tree set_descriptor
;
5677 stmtblock_t set_descriptor_block
;
5678 stmtblock_t elseblock
;
5681 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5682 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5683 non_ulimate_coarray_ptr_comp
;
5687 /* Find the last reference in the chain. */
5688 if (!retrieve_last_ref (&ref
, &prev_ref
))
5691 /* Take the allocatable and coarray properties solely from the expr-ref's
5692 attributes and not from source=-expression. */
5695 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5696 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5697 non_ulimate_coarray_ptr_comp
= false;
5701 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5702 /* Pointer components in coarrayed derived types must be treated
5703 specially in that they are registered without a check if the are
5704 already associated. This does not hold for ultimate coarray
5706 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5707 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5708 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5711 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5712 a coarray. In this case it does not matter whether we are on this_image
5715 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5716 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5723 gcc_assert (coarray
);
5725 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5727 gfc_ref
*old_ref
= ref
;
5728 /* F08:C633: Array shape from expr3. */
5731 /* Find the last reference in the chain. */
5732 if (!retrieve_last_ref (&ref
, &prev_ref
))
5734 if (expr3
->expr_type
== EXPR_FUNCTION
5735 && gfc_expr_attr (expr3
).dimension
)
5740 alloc_w_e3_arr_spec
= true;
5743 /* Figure out the size of the array. */
5744 switch (ref
->u
.ar
.type
)
5750 upper
= ref
->u
.ar
.start
;
5756 lower
= ref
->u
.ar
.start
;
5757 upper
= ref
->u
.ar
.end
;
5761 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5762 || alloc_w_e3_arr_spec
);
5764 lower
= ref
->u
.ar
.as
->lower
;
5765 upper
= ref
->u
.ar
.as
->upper
;
5773 overflow
= integer_zero_node
;
5775 if (expr
->ts
.type
== BT_CHARACTER
5776 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5777 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
)
5779 if (VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5780 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5781 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5782 se
->string_length
));
5784 expr
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (se
->string_length
,
5788 gfc_init_block (&set_descriptor_block
);
5789 /* Take the corank only from the actual ref and not from the coref. The
5790 later will mislead the generation of the array dimensions for allocatable/
5791 pointer components in derived types. */
5792 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5793 : ref
->u
.ar
.as
->rank
,
5794 coarray
? ref
->u
.ar
.as
->corank
: 0,
5795 &offset
, lower
, upper
,
5796 &se
->pre
, &set_descriptor_block
, &overflow
,
5797 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5798 e3_is_array_constr
, expr
);
5802 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5803 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5805 if (status
== NULL_TREE
)
5807 /* Generate the block of code handling overflow. */
5808 msg
= gfc_build_addr_expr (pchar_type_node
,
5809 gfc_build_localized_cstring_const
5810 ("Integer overflow when calculating the amount of "
5811 "memory to allocate"));
5812 error
= build_call_expr_loc (input_location
,
5813 gfor_fndecl_runtime_error
, 1, msg
);
5817 tree status_type
= TREE_TYPE (status
);
5818 stmtblock_t set_status_block
;
5820 gfc_start_block (&set_status_block
);
5821 gfc_add_modify (&set_status_block
, status
,
5822 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5823 error
= gfc_finish_block (&set_status_block
);
5827 gfc_start_block (&elseblock
);
5829 /* Allocate memory to store the data. */
5830 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5831 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5833 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5835 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5836 : gfc_conv_descriptor_data_get (se
->expr
);
5837 token
= gfc_conv_descriptor_token (se
->expr
);
5838 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5841 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5842 STRIP_NOPS (pointer
);
5844 /* The allocatable variant takes the old pointer as first argument. */
5846 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5847 status
, errmsg
, errlen
, label_finish
, expr
,
5848 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5849 else if (non_ulimate_coarray_ptr_comp
&& token
)
5850 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5851 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5853 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5855 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5859 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5860 logical_type_node
, var_overflow
, integer_zero_node
),
5861 PRED_FORTRAN_OVERFLOW
);
5862 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5863 error
, gfc_finish_block (&elseblock
));
5866 tmp
= gfc_finish_block (&elseblock
);
5868 gfc_add_expr_to_block (&se
->pre
, tmp
);
5870 /* Update the array descriptors. */
5872 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5874 /* Pointer arrays need the span field to be set. */
5875 if (is_pointer_array (se
->expr
)
5876 || (expr
->ts
.type
== BT_CLASS
5877 && CLASS_DATA (expr
)->attr
.class_pointer
)
5878 || (expr
->ts
.type
== BT_CHARACTER
5879 && TREE_CODE (se
->string_length
) == COMPONENT_REF
))
5881 if (expr3
&& expr3_elem_size
!= NULL_TREE
)
5882 tmp
= expr3_elem_size
;
5883 else if (se
->string_length
5884 && TREE_CODE (se
->string_length
) == COMPONENT_REF
)
5886 if (expr
->ts
.kind
!= 1)
5888 tmp
= build_int_cst (gfc_array_index_type
, expr
->ts
.kind
);
5889 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5890 gfc_array_index_type
, tmp
,
5891 fold_convert (gfc_array_index_type
,
5892 se
->string_length
));
5895 tmp
= se
->string_length
;
5898 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se
->expr
)));
5899 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5900 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5903 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5904 if (status
!= NULL_TREE
)
5906 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5907 logical_type_node
, status
,
5908 build_int_cst (TREE_TYPE (status
), 0));
5909 gfc_add_expr_to_block (&se
->pre
,
5910 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5913 build_empty_stmt (input_location
)));
5916 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5922 /* Create an array constructor from an initialization expression.
5923 We assume the frontend already did any expansions and conversions. */
5926 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5933 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5935 if (expr
->expr_type
== EXPR_VARIABLE
5936 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5937 && expr
->symtree
->n
.sym
->value
)
5938 expr
= expr
->symtree
->n
.sym
->value
;
5940 switch (expr
->expr_type
)
5943 case EXPR_STRUCTURE
:
5944 /* A single scalar or derived type value. Create an array with all
5945 elements equal to that value. */
5946 gfc_init_se (&se
, NULL
);
5948 if (expr
->expr_type
== EXPR_CONSTANT
)
5949 gfc_conv_constant (&se
, expr
);
5951 gfc_conv_structure (&se
, expr
, 1);
5953 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5954 /* This will probably eat buckets of memory for large arrays. */
5957 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5963 /* Create a vector of all the elements. */
5964 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5965 c
; c
= gfc_constructor_next (c
))
5969 /* Problems occur when we get something like
5970 integer :: a(lots) = (/(i, i=1, lots)/) */
5971 gfc_fatal_error ("The number of elements in the array "
5972 "constructor at %L requires an increase of "
5973 "the allowed %d upper limit. See "
5974 "%<-fmax-array-constructor%> option",
5975 &expr
->where
, flag_max_array_constructor
);
5978 if (mpz_cmp_si (c
->offset
, 0) != 0)
5979 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5983 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5989 mpz_add (maxval
, c
->offset
, c
->repeat
);
5990 mpz_sub_ui (maxval
, maxval
, 1);
5991 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5992 if (mpz_cmp_si (c
->offset
, 0) != 0)
5994 mpz_add_ui (maxval
, c
->offset
, 1);
5995 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5998 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6000 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6006 gfc_init_se (&se
, NULL
);
6007 switch (c
->expr
->expr_type
)
6010 gfc_conv_constant (&se
, c
->expr
);
6012 /* See gfortran.dg/charlen_15.f90 for instance. */
6013 if (TREE_CODE (se
.expr
) == STRING_CST
6014 && TREE_CODE (type
) == ARRAY_TYPE
)
6017 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6018 atype
= TREE_TYPE (atype
);
6019 if (TREE_CODE (TREE_TYPE (atype
)) == INTEGER_TYPE
6020 && tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6021 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6023 unsigned HOST_WIDE_INT size
6024 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6025 const char *p
= TREE_STRING_POINTER (se
.expr
);
6027 se
.expr
= build_string (size
, p
);
6028 TREE_TYPE (se
.expr
) = atype
;
6033 case EXPR_STRUCTURE
:
6034 gfc_conv_structure (&se
, c
->expr
, 1);
6038 /* Catch those occasional beasts that do not simplify
6039 for one reason or another, assuming that if they are
6040 standard defying the frontend will catch them. */
6041 gfc_conv_expr (&se
, c
->expr
);
6045 if (range
== NULL_TREE
)
6046 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6049 if (index
!= NULL_TREE
)
6050 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6051 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6057 return gfc_build_null_descriptor (type
);
6063 /* Create a constructor from the list of elements. */
6064 tmp
= build_constructor (type
, v
);
6065 TREE_CONSTANT (tmp
) = 1;
6070 /* Generate code to evaluate non-constant coarray cobounds. */
6073 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6074 const gfc_symbol
*sym
)
6082 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6084 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6086 /* Evaluate non-constant array bound expressions. */
6087 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6088 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6090 gfc_init_se (&se
, NULL
);
6091 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6092 gfc_add_block_to_block (pblock
, &se
.pre
);
6093 gfc_add_modify (pblock
, lbound
, se
.expr
);
6095 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6096 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6098 gfc_init_se (&se
, NULL
);
6099 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6100 gfc_add_block_to_block (pblock
, &se
.pre
);
6101 gfc_add_modify (pblock
, ubound
, se
.expr
);
6107 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6108 returns the size (in elements) of the array. */
6111 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6112 stmtblock_t
* pblock
)
6125 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6127 size
= gfc_index_one_node
;
6128 offset
= gfc_index_zero_node
;
6129 for (dim
= 0; dim
< as
->rank
; dim
++)
6131 /* Evaluate non-constant array bound expressions. */
6132 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6133 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6135 gfc_init_se (&se
, NULL
);
6136 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6137 gfc_add_block_to_block (pblock
, &se
.pre
);
6138 gfc_add_modify (pblock
, lbound
, se
.expr
);
6140 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6141 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6143 gfc_init_se (&se
, NULL
);
6144 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6145 gfc_add_block_to_block (pblock
, &se
.pre
);
6146 gfc_add_modify (pblock
, ubound
, se
.expr
);
6148 /* The offset of this dimension. offset = offset - lbound * stride. */
6149 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6151 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6154 /* The size of this dimension, and the stride of the next. */
6155 if (dim
+ 1 < as
->rank
)
6156 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6158 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6160 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6162 /* Calculate stride = size * (ubound + 1 - lbound). */
6163 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6164 gfc_array_index_type
,
6165 gfc_index_one_node
, lbound
);
6166 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6167 gfc_array_index_type
, ubound
, tmp
);
6168 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6169 gfc_array_index_type
, size
, tmp
);
6171 gfc_add_modify (pblock
, stride
, tmp
);
6173 stride
= gfc_evaluate_now (tmp
, pblock
);
6175 /* Make sure that negative size arrays are translated
6176 to being zero size. */
6177 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6178 stride
, gfc_index_zero_node
);
6179 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6180 gfc_array_index_type
, tmp
,
6181 stride
, gfc_index_zero_node
);
6182 gfc_add_modify (pblock
, stride
, tmp
);
6188 gfc_trans_array_cobounds (type
, pblock
, sym
);
6189 gfc_trans_vla_type_sizes (sym
, pblock
);
6196 /* Generate code to initialize/allocate an array variable. */
6199 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6200 gfc_wrapped_block
* block
)
6204 tree tmp
= NULL_TREE
;
6211 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6213 /* Do nothing for USEd variables. */
6214 if (sym
->attr
.use_assoc
)
6217 type
= TREE_TYPE (decl
);
6218 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6219 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6221 gfc_init_block (&init
);
6223 /* Evaluate character string length. */
6224 if (sym
->ts
.type
== BT_CHARACTER
6225 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6227 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6229 gfc_trans_vla_type_sizes (sym
, &init
);
6231 /* Emit a DECL_EXPR for this variable, which will cause the
6232 gimplifier to allocate storage, and all that good stuff. */
6233 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6234 gfc_add_expr_to_block (&init
, tmp
);
6239 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6243 type
= TREE_TYPE (type
);
6245 gcc_assert (!sym
->attr
.use_assoc
);
6246 gcc_assert (!TREE_STATIC (decl
));
6247 gcc_assert (!sym
->module
);
6249 if (sym
->ts
.type
== BT_CHARACTER
6250 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6251 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6253 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6255 /* Don't actually allocate space for Cray Pointees. */
6256 if (sym
->attr
.cray_pointee
)
6258 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6259 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6261 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6265 if (flag_stack_arrays
)
6267 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6268 space
= build_decl (sym
->declared_at
.lb
->location
,
6269 VAR_DECL
, create_tmp_var_name ("A"),
6270 TREE_TYPE (TREE_TYPE (decl
)));
6271 gfc_trans_vla_type_sizes (sym
, &init
);
6275 /* The size is the number of elements in the array, so multiply by the
6276 size of an element to get the total size. */
6277 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6278 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6279 size
, fold_convert (gfc_array_index_type
, tmp
));
6281 /* Allocate memory to hold the data. */
6282 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6283 gfc_add_modify (&init
, decl
, tmp
);
6285 /* Free the temporary. */
6286 tmp
= gfc_call_free (decl
);
6290 /* Set offset of the array. */
6291 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6292 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6294 /* Automatic arrays should not have initializers. */
6295 gcc_assert (!sym
->value
);
6297 inittree
= gfc_finish_block (&init
);
6304 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6305 where also space is located. */
6306 gfc_init_block (&init
);
6307 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6308 TREE_TYPE (space
), space
);
6309 gfc_add_expr_to_block (&init
, tmp
);
6310 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6311 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6312 gfc_add_modify (&init
, decl
, addr
);
6313 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6316 gfc_add_init_cleanup (block
, inittree
, tmp
);
6320 /* Generate entry and exit code for g77 calling convention arrays. */
6323 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6333 gfc_save_backend_locus (&loc
);
6334 gfc_set_backend_locus (&sym
->declared_at
);
6336 /* Descriptor type. */
6337 parm
= sym
->backend_decl
;
6338 type
= TREE_TYPE (parm
);
6339 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6341 gfc_start_block (&init
);
6343 if (sym
->ts
.type
== BT_CHARACTER
6344 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6345 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6347 /* Evaluate the bounds of the array. */
6348 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6350 /* Set the offset. */
6351 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6352 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6354 /* Set the pointer itself if we aren't using the parameter directly. */
6355 if (TREE_CODE (parm
) != PARM_DECL
)
6357 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6358 gfc_add_modify (&init
, parm
, tmp
);
6360 stmt
= gfc_finish_block (&init
);
6362 gfc_restore_backend_locus (&loc
);
6364 /* Add the initialization code to the start of the function. */
6366 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6368 tmp
= gfc_conv_expr_present (sym
);
6369 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6372 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6376 /* Modify the descriptor of an array parameter so that it has the
6377 correct lower bound. Also move the upper bound accordingly.
6378 If the array is not packed, it will be copied into a temporary.
6379 For each dimension we set the new lower and upper bounds. Then we copy the
6380 stride and calculate the offset for this dimension. We also work out
6381 what the stride of a packed array would be, and see it the two match.
6382 If the array need repacking, we set the stride to the values we just
6383 calculated, recalculate the offset and copy the array data.
6384 Code is also added to copy the data back at the end of the function.
6388 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6389 gfc_wrapped_block
* block
)
6396 tree stmtInit
, stmtCleanup
;
6403 tree stride
, stride2
;
6413 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6415 /* Do nothing for pointer and allocatable arrays. */
6416 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6417 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6418 || sym
->attr
.allocatable
6419 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6422 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6424 gfc_trans_g77_array (sym
, block
);
6429 gfc_save_backend_locus (&loc
);
6430 /* loc.nextc is not set by save_backend_locus but the location routines
6432 if (loc
.nextc
== NULL
)
6433 loc
.nextc
= loc
.lb
->line
;
6434 gfc_set_backend_locus (&sym
->declared_at
);
6436 /* Descriptor type. */
6437 type
= TREE_TYPE (tmpdesc
);
6438 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6439 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6441 /* For a class array the dummy array descriptor is in the _class
6443 dumdesc
= gfc_class_data_get (dumdesc
);
6445 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6446 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6447 gfc_start_block (&init
);
6449 if (sym
->ts
.type
== BT_CHARACTER
6450 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6451 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6453 checkparm
= (as
->type
== AS_EXPLICIT
6454 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6456 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6457 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6459 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6461 /* For non-constant shape arrays we only check if the first dimension
6462 is contiguous. Repacking higher dimensions wouldn't gain us
6463 anything as we still don't know the array stride. */
6464 partial
= gfc_create_var (logical_type_node
, "partial");
6465 TREE_USED (partial
) = 1;
6466 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6467 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6468 gfc_index_one_node
);
6469 gfc_add_modify (&init
, partial
, tmp
);
6472 partial
= NULL_TREE
;
6474 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6475 here, however I think it does the right thing. */
6478 /* Set the first stride. */
6479 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6480 stride
= gfc_evaluate_now (stride
, &init
);
6482 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6483 stride
, gfc_index_zero_node
);
6484 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6485 tmp
, gfc_index_one_node
, stride
);
6486 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6487 gfc_add_modify (&init
, stride
, tmp
);
6489 /* Allow the user to disable array repacking. */
6490 stmt_unpacked
= NULL_TREE
;
6494 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6495 /* A library call to repack the array if necessary. */
6496 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6497 stmt_unpacked
= build_call_expr_loc (input_location
,
6498 gfor_fndecl_in_pack
, 1, tmp
);
6500 stride
= gfc_index_one_node
;
6502 if (warn_array_temporaries
)
6503 gfc_warning (OPT_Warray_temporaries
,
6504 "Creating array temporary at %L", &loc
);
6507 /* This is for the case where the array data is used directly without
6508 calling the repack function. */
6509 if (no_repack
|| partial
!= NULL_TREE
)
6510 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6512 stmt_packed
= NULL_TREE
;
6514 /* Assign the data pointer. */
6515 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6517 /* Don't repack unknown shape arrays when the first stride is 1. */
6518 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6519 partial
, stmt_packed
, stmt_unpacked
);
6522 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6523 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6525 offset
= gfc_index_zero_node
;
6526 size
= gfc_index_one_node
;
6528 /* Evaluate the bounds of the array. */
6529 for (n
= 0; n
< as
->rank
; n
++)
6531 if (checkparm
|| !as
->upper
[n
])
6533 /* Get the bounds of the actual parameter. */
6534 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6535 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6539 dubound
= NULL_TREE
;
6540 dlbound
= NULL_TREE
;
6543 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6544 if (!INTEGER_CST_P (lbound
))
6546 gfc_init_se (&se
, NULL
);
6547 gfc_conv_expr_type (&se
, as
->lower
[n
],
6548 gfc_array_index_type
);
6549 gfc_add_block_to_block (&init
, &se
.pre
);
6550 gfc_add_modify (&init
, lbound
, se
.expr
);
6553 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6554 /* Set the desired upper bound. */
6557 /* We know what we want the upper bound to be. */
6558 if (!INTEGER_CST_P (ubound
))
6560 gfc_init_se (&se
, NULL
);
6561 gfc_conv_expr_type (&se
, as
->upper
[n
],
6562 gfc_array_index_type
);
6563 gfc_add_block_to_block (&init
, &se
.pre
);
6564 gfc_add_modify (&init
, ubound
, se
.expr
);
6567 /* Check the sizes match. */
6570 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6574 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6575 gfc_array_index_type
, ubound
, lbound
);
6576 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6577 gfc_array_index_type
,
6578 gfc_index_one_node
, temp
);
6579 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6580 gfc_array_index_type
, dubound
,
6582 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6583 gfc_array_index_type
,
6584 gfc_index_one_node
, stride2
);
6585 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6586 gfc_array_index_type
, temp
, stride2
);
6587 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6588 "%%ld instead of %%ld", n
+1, sym
->name
);
6590 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6591 fold_convert (long_integer_type_node
, temp
),
6592 fold_convert (long_integer_type_node
, stride2
));
6599 /* For assumed shape arrays move the upper bound by the same amount
6600 as the lower bound. */
6601 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6602 gfc_array_index_type
, dubound
, dlbound
);
6603 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6604 gfc_array_index_type
, tmp
, lbound
);
6605 gfc_add_modify (&init
, ubound
, tmp
);
6607 /* The offset of this dimension. offset = offset - lbound * stride. */
6608 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6610 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6611 gfc_array_index_type
, offset
, tmp
);
6613 /* The size of this dimension, and the stride of the next. */
6614 if (n
+ 1 < as
->rank
)
6616 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6618 if (no_repack
|| partial
!= NULL_TREE
)
6620 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6622 /* Figure out the stride if not a known constant. */
6623 if (!INTEGER_CST_P (stride
))
6626 stmt_packed
= NULL_TREE
;
6629 /* Calculate stride = size * (ubound + 1 - lbound). */
6630 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6631 gfc_array_index_type
,
6632 gfc_index_one_node
, lbound
);
6633 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6634 gfc_array_index_type
, ubound
, tmp
);
6635 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6636 gfc_array_index_type
, size
, tmp
);
6640 /* Assign the stride. */
6641 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6642 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6643 gfc_array_index_type
, partial
,
6644 stmt_unpacked
, stmt_packed
);
6646 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6647 gfc_add_modify (&init
, stride
, tmp
);
6652 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6654 if (stride
&& !INTEGER_CST_P (stride
))
6656 /* Calculate size = stride * (ubound + 1 - lbound). */
6657 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6658 gfc_array_index_type
,
6659 gfc_index_one_node
, lbound
);
6660 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6661 gfc_array_index_type
,
6663 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6664 gfc_array_index_type
,
6665 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6666 gfc_add_modify (&init
, stride
, tmp
);
6671 gfc_trans_array_cobounds (type
, &init
, sym
);
6673 /* Set the offset. */
6674 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6675 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6677 gfc_trans_vla_type_sizes (sym
, &init
);
6679 stmtInit
= gfc_finish_block (&init
);
6681 /* Only do the entry/initialization code if the arg is present. */
6682 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6683 optional_arg
= (sym
->attr
.optional
6684 || (sym
->ns
->proc_name
->attr
.entry_master
6685 && sym
->attr
.dummy
));
6688 tmp
= gfc_conv_expr_present (sym
);
6689 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6690 build_empty_stmt (input_location
));
6695 stmtCleanup
= NULL_TREE
;
6698 stmtblock_t cleanup
;
6699 gfc_start_block (&cleanup
);
6701 if (sym
->attr
.intent
!= INTENT_IN
)
6703 /* Copy the data back. */
6704 tmp
= build_call_expr_loc (input_location
,
6705 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6706 gfc_add_expr_to_block (&cleanup
, tmp
);
6709 /* Free the temporary. */
6710 tmp
= gfc_call_free (tmpdesc
);
6711 gfc_add_expr_to_block (&cleanup
, tmp
);
6713 stmtCleanup
= gfc_finish_block (&cleanup
);
6715 /* Only do the cleanup if the array was repacked. */
6717 /* For a class array the dummy array descriptor is in the _class
6719 tmp
= gfc_class_data_get (dumdesc
);
6721 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6722 tmp
= gfc_conv_descriptor_data_get (tmp
);
6723 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6725 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6726 build_empty_stmt (input_location
));
6730 tmp
= gfc_conv_expr_present (sym
);
6731 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6732 build_empty_stmt (input_location
));
6736 /* We don't need to free any memory allocated by internal_pack as it will
6737 be freed at the end of the function by pop_context. */
6738 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6740 gfc_restore_backend_locus (&loc
);
6744 /* Calculate the overall offset, including subreferences. */
6746 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6747 bool subref
, gfc_expr
*expr
)
6757 /* If offset is NULL and this is not a subreferenced array, there is
6759 if (offset
== NULL_TREE
)
6762 offset
= gfc_index_zero_node
;
6767 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6769 /* Offset the data pointer for pointer assignments from arrays with
6770 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6773 /* Go past the array reference. */
6774 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6775 if (ref
->type
== REF_ARRAY
&&
6776 ref
->u
.ar
.type
!= AR_ELEMENT
)
6782 /* Calculate the offset for each subsequent subreference. */
6783 for (; ref
; ref
= ref
->next
)
6788 field
= ref
->u
.c
.component
->backend_decl
;
6789 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6790 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6792 tmp
, field
, NULL_TREE
);
6796 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6797 gfc_init_se (&start
, NULL
);
6798 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6799 gfc_add_block_to_block (block
, &start
.pre
);
6800 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6804 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6805 && ref
->u
.ar
.type
== AR_ELEMENT
);
6807 /* TODO - Add bounds checking. */
6808 stride
= gfc_index_one_node
;
6809 index
= gfc_index_zero_node
;
6810 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6815 /* Update the index. */
6816 gfc_init_se (&start
, NULL
);
6817 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6818 itmp
= gfc_evaluate_now (start
.expr
, block
);
6819 gfc_init_se (&start
, NULL
);
6820 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6821 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6822 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6823 gfc_array_index_type
, itmp
, jtmp
);
6824 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6825 gfc_array_index_type
, itmp
, stride
);
6826 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6827 gfc_array_index_type
, itmp
, index
);
6828 index
= gfc_evaluate_now (index
, block
);
6830 /* Update the stride. */
6831 gfc_init_se (&start
, NULL
);
6832 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6833 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6834 gfc_array_index_type
, start
.expr
,
6836 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6837 gfc_array_index_type
,
6838 gfc_index_one_node
, itmp
);
6839 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6840 gfc_array_index_type
, stride
, itmp
);
6841 stride
= gfc_evaluate_now (stride
, block
);
6844 /* Apply the index to obtain the array element. */
6845 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6855 /* Set the target data pointer. */
6856 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6857 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6861 /* gfc_conv_expr_descriptor needs the string length an expression
6862 so that the size of the temporary can be obtained. This is done
6863 by adding up the string lengths of all the elements in the
6864 expression. Function with non-constant expressions have their
6865 string lengths mapped onto the actual arguments using the
6866 interface mapping machinery in trans-expr.c. */
6868 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6870 gfc_interface_mapping mapping
;
6871 gfc_formal_arglist
*formal
;
6872 gfc_actual_arglist
*arg
;
6875 if (expr
->ts
.u
.cl
->length
6876 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6878 if (!expr
->ts
.u
.cl
->backend_decl
)
6879 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6883 switch (expr
->expr_type
)
6886 get_array_charlen (expr
->value
.op
.op1
, se
);
6888 /* For parentheses the expression ts.u.cl is identical. */
6889 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6892 expr
->ts
.u
.cl
->backend_decl
=
6893 gfc_create_var (gfc_charlen_type_node
, "sln");
6895 if (expr
->value
.op
.op2
)
6897 get_array_charlen (expr
->value
.op
.op2
, se
);
6899 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6901 /* Add the string lengths and assign them to the expression
6902 string length backend declaration. */
6903 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6904 fold_build2_loc (input_location
, PLUS_EXPR
,
6905 gfc_charlen_type_node
,
6906 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6907 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6910 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6911 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6915 if (expr
->value
.function
.esym
== NULL
6916 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6918 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6922 /* Map expressions involving the dummy arguments onto the actual
6923 argument expressions. */
6924 gfc_init_interface_mapping (&mapping
);
6925 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6926 arg
= expr
->value
.function
.actual
;
6928 /* Set se = NULL in the calls to the interface mapping, to suppress any
6930 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6935 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6938 gfc_init_se (&tse
, NULL
);
6940 /* Build the expression for the character length and convert it. */
6941 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6943 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6944 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6945 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6946 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6947 TREE_TYPE (tse
.expr
), tse
.expr
,
6948 build_zero_cst (TREE_TYPE (tse
.expr
)));
6949 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6950 gfc_free_interface_mapping (&mapping
);
6954 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6960 /* Helper function to check dimensions. */
6962 transposed_dims (gfc_ss
*ss
)
6966 for (n
= 0; n
< ss
->dimen
; n
++)
6967 if (ss
->dim
[n
] != n
)
6973 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6974 AR_FULL, suitable for the scalarizer. */
6977 walk_coarray (gfc_expr
*e
)
6981 gcc_assert (gfc_get_corank (e
) > 0);
6983 ss
= gfc_walk_expr (e
);
6985 /* Fix scalar coarray. */
6986 if (ss
== gfc_ss_terminator
)
6993 if (ref
->type
== REF_ARRAY
6994 && ref
->u
.ar
.codimen
> 0)
7000 gcc_assert (ref
!= NULL
);
7001 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7002 ref
->u
.ar
.type
= AR_SECTION
;
7003 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7010 /* Convert an array for passing as an actual argument. Expressions and
7011 vector subscripts are evaluated and stored in a temporary, which is then
7012 passed. For whole arrays the descriptor is passed. For array sections
7013 a modified copy of the descriptor is passed, but using the original data.
7015 This function is also used for array pointer assignments, and there
7018 - se->want_pointer && !se->direct_byref
7019 EXPR is an actual argument. On exit, se->expr contains a
7020 pointer to the array descriptor.
7022 - !se->want_pointer && !se->direct_byref
7023 EXPR is an actual argument to an intrinsic function or the
7024 left-hand side of a pointer assignment. On exit, se->expr
7025 contains the descriptor for EXPR.
7027 - !se->want_pointer && se->direct_byref
7028 EXPR is the right-hand side of a pointer assignment and
7029 se->expr is the descriptor for the previously-evaluated
7030 left-hand side. The function creates an assignment from
7034 The se->force_tmp flag disables the non-copying descriptor optimization
7035 that is used for transpose. It may be used in cases where there is an
7036 alias between the transpose argument and another argument in the same
7040 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7043 gfc_ss_type ss_type
;
7044 gfc_ss_info
*ss_info
;
7046 gfc_array_info
*info
;
7055 bool subref_array_target
= false;
7056 gfc_expr
*arg
, *ss_expr
;
7058 if (se
->want_coarray
)
7059 ss
= walk_coarray (expr
);
7061 ss
= gfc_walk_expr (expr
);
7063 gcc_assert (ss
!= NULL
);
7064 gcc_assert (ss
!= gfc_ss_terminator
);
7067 ss_type
= ss_info
->type
;
7068 ss_expr
= ss_info
->expr
;
7070 /* Special case: TRANSPOSE which needs no temporary. */
7071 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7072 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7074 /* This is a call to transpose which has already been handled by the
7075 scalarizer, so that we just need to get its argument's descriptor. */
7076 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7077 expr
= expr
->value
.function
.actual
->expr
;
7080 /* Special case things we know we can pass easily. */
7081 switch (expr
->expr_type
)
7084 /* If we have a linear array section, we can pass it directly.
7085 Otherwise we need to copy it into a temporary. */
7087 gcc_assert (ss_type
== GFC_SS_SECTION
);
7088 gcc_assert (ss_expr
== expr
);
7089 info
= &ss_info
->data
.array
;
7091 /* Get the descriptor for the array. */
7092 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7093 desc
= info
->descriptor
;
7095 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7096 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7097 && !subref_array_target
;
7104 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7106 /* Create a new descriptor if the array doesn't have one. */
7109 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7111 else if (se
->direct_byref
)
7114 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7116 if (full
&& !transposed_dims (ss
))
7118 if (se
->direct_byref
&& !se
->byref_noassign
)
7120 /* Copy the descriptor for pointer assignments. */
7121 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7123 /* Add any offsets from subreferences. */
7124 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7125 subref_array_target
, expr
);
7127 /* ....and set the span field. */
7128 tmp
= gfc_get_array_span (desc
, expr
);
7129 if (tmp
!= NULL_TREE
&& !integer_zerop (tmp
))
7130 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7132 else if (se
->want_pointer
)
7134 /* We pass full arrays directly. This means that pointers and
7135 allocatable arrays should also work. */
7136 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7143 if (expr
->ts
.type
== BT_CHARACTER
)
7144 se
->string_length
= gfc_get_expr_charlen (expr
);
7146 gfc_free_ss_chain (ss
);
7152 /* A transformational function return value will be a temporary
7153 array descriptor. We still need to go through the scalarizer
7154 to create the descriptor. Elemental functions are handled as
7155 arbitrary expressions, i.e. copy to a temporary. */
7157 if (se
->direct_byref
)
7159 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7161 /* For pointer assignments pass the descriptor directly. */
7165 gcc_assert (se
->ss
== ss
);
7167 if (!is_pointer_array (se
->expr
))
7169 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7170 tmp
= fold_convert (gfc_array_index_type
,
7171 size_in_bytes (tmp
));
7172 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7175 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7176 gfc_conv_expr (se
, expr
);
7178 gfc_free_ss_chain (ss
);
7182 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7184 if (ss_expr
!= expr
)
7185 /* Elemental function. */
7186 gcc_assert ((expr
->value
.function
.esym
!= NULL
7187 && expr
->value
.function
.esym
->attr
.elemental
)
7188 || (expr
->value
.function
.isym
!= NULL
7189 && expr
->value
.function
.isym
->elemental
)
7190 || gfc_inline_intrinsic_function_p (expr
));
7192 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7195 if (expr
->ts
.type
== BT_CHARACTER
7196 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7197 get_array_charlen (expr
, se
);
7203 /* Transformational function. */
7204 info
= &ss_info
->data
.array
;
7210 /* Constant array constructors don't need a temporary. */
7211 if (ss_type
== GFC_SS_CONSTRUCTOR
7212 && expr
->ts
.type
!= BT_CHARACTER
7213 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7216 info
= &ss_info
->data
.array
;
7226 /* Something complicated. Copy it into a temporary. */
7232 /* If we are creating a temporary, we don't need to bother about aliases
7237 gfc_init_loopinfo (&loop
);
7239 /* Associate the SS with the loop. */
7240 gfc_add_ss_to_loop (&loop
, ss
);
7242 /* Tell the scalarizer not to bother creating loop variables, etc. */
7244 loop
.array_parameter
= 1;
7246 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7247 gcc_assert (!se
->direct_byref
);
7249 /* Do we need bounds checking or not? */
7250 ss
->no_bounds_check
= expr
->no_bounds_check
;
7252 /* Setup the scalarizing loops and bounds. */
7253 gfc_conv_ss_startstride (&loop
);
7257 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
7258 get_array_charlen (expr
, se
);
7260 /* Tell the scalarizer to make a temporary. */
7261 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7262 ((expr
->ts
.type
== BT_CHARACTER
)
7263 ? expr
->ts
.u
.cl
->backend_decl
7267 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7268 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7269 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7272 gfc_conv_loop_setup (&loop
, & expr
->where
);
7276 /* Copy into a temporary and pass that. We don't need to copy the data
7277 back because expressions and vector subscripts must be INTENT_IN. */
7278 /* TODO: Optimize passing function return values. */
7283 /* Start the copying loops. */
7284 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7285 gfc_mark_ss_chain_used (ss
, 1);
7286 gfc_start_scalarized_body (&loop
, &block
);
7288 /* Copy each data element. */
7289 gfc_init_se (&lse
, NULL
);
7290 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7291 gfc_init_se (&rse
, NULL
);
7292 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7294 lse
.ss
= loop
.temp_ss
;
7297 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7298 if (expr
->ts
.type
== BT_CHARACTER
)
7300 gfc_conv_expr (&rse
, expr
);
7301 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7302 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7306 gfc_conv_expr_val (&rse
, expr
);
7308 gfc_add_block_to_block (&block
, &rse
.pre
);
7309 gfc_add_block_to_block (&block
, &lse
.pre
);
7311 lse
.string_length
= rse
.string_length
;
7313 deep_copy
= !se
->data_not_needed
7314 && (expr
->expr_type
== EXPR_VARIABLE
7315 || expr
->expr_type
== EXPR_ARRAY
);
7316 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7318 gfc_add_expr_to_block (&block
, tmp
);
7320 /* Finish the copying loops. */
7321 gfc_trans_scalarizing_loops (&loop
, &block
);
7323 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7325 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7327 desc
= info
->descriptor
;
7328 se
->string_length
= ss_info
->string_length
;
7332 /* We pass sections without copying to a temporary. Make a new
7333 descriptor and point it at the section we want. The loop variable
7334 limits will be the limits of the section.
7335 A function may decide to repack the array to speed up access, but
7336 we're not bothered about that here. */
7337 int dim
, ndim
, codim
;
7344 bool onebased
= false, rank_remap
;
7346 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7347 rank_remap
= ss
->dimen
< ndim
;
7349 if (se
->want_coarray
)
7351 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7353 codim
= gfc_get_corank (expr
);
7354 for (n
= 0; n
< codim
- 1; n
++)
7356 /* Make sure we are not lost somehow. */
7357 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7359 /* Make sure the call to gfc_conv_section_startstride won't
7360 generate unnecessary code to calculate stride. */
7361 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7363 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7364 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7365 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7368 gcc_assert (n
== codim
- 1);
7369 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7370 info
->descriptor
, n
+ ndim
, true,
7371 ar
->as
->type
== AS_DEFERRED
);
7372 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7377 /* Set the string_length for a character array. */
7378 if (expr
->ts
.type
== BT_CHARACTER
)
7379 se
->string_length
= gfc_get_expr_charlen (expr
);
7381 /* If we have an array section or are assigning make sure that
7382 the lower bound is 1. References to the full
7383 array should otherwise keep the original bounds. */
7384 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7385 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7386 if (!integer_onep (loop
.from
[dim
]))
7388 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7389 gfc_array_index_type
, gfc_index_one_node
,
7391 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7392 gfc_array_index_type
,
7394 loop
.from
[dim
] = gfc_index_one_node
;
7397 desc
= info
->descriptor
;
7398 if (se
->direct_byref
&& !se
->byref_noassign
)
7400 /* For pointer assignments we fill in the destination. */
7402 parmtype
= TREE_TYPE (parm
);
7406 /* Otherwise make a new one. */
7407 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7408 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7410 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7412 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7413 loop
.from
, loop
.to
, 0,
7414 GFC_ARRAY_UNKNOWN
, false);
7415 parm
= gfc_create_var (parmtype
, "parm");
7417 /* When expression is a class object, then add the class' handle to
7419 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7421 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7424 /* class_expr can be NULL, when no _class ref is in expr.
7425 We must not fix this here with a gfc_fix_class_ref (). */
7428 gfc_init_se (&classse
, NULL
);
7429 gfc_conv_expr (&classse
, class_expr
);
7430 gfc_free_expr (class_expr
);
7432 gcc_assert (classse
.pre
.head
== NULL_TREE
7433 && classse
.post
.head
== NULL_TREE
);
7434 gfc_allocate_lang_decl (parm
);
7435 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7440 /* Set the span field. */
7441 tmp
= gfc_get_array_span (desc
, expr
);
7442 if (tmp
!= NULL_TREE
)
7443 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7445 offset
= gfc_index_zero_node
;
7447 /* The following can be somewhat confusing. We have two
7448 descriptors, a new one and the original array.
7449 {parm, parmtype, dim} refer to the new one.
7450 {desc, type, n, loop} refer to the original, which maybe
7451 a descriptorless array.
7452 The bounds of the scalarization are the bounds of the section.
7453 We don't have to worry about numeric overflows when calculating
7454 the offsets because all elements are within the array data. */
7456 /* Set the dtype. */
7457 tmp
= gfc_conv_descriptor_dtype (parm
);
7458 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7460 /* Set offset for assignments to pointer only to zero if it is not
7462 if ((se
->direct_byref
|| se
->use_offset
)
7463 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7464 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7465 base
= gfc_index_zero_node
;
7466 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7467 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7471 for (n
= 0; n
< ndim
; n
++)
7473 stride
= gfc_conv_array_stride (desc
, n
);
7475 /* Work out the offset. */
7477 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7479 gcc_assert (info
->subscript
[n
]
7480 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7481 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7485 /* Evaluate and remember the start of the section. */
7486 start
= info
->start
[n
];
7487 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7490 tmp
= gfc_conv_array_lbound (desc
, n
);
7491 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7493 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7495 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7499 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7501 /* For elemental dimensions, we only need the offset. */
7505 /* Vector subscripts need copying and are handled elsewhere. */
7507 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7509 /* look for the corresponding scalarizer dimension: dim. */
7510 for (dim
= 0; dim
< ndim
; dim
++)
7511 if (ss
->dim
[dim
] == n
)
7514 /* loop exited early: the DIM being looked for has been found. */
7515 gcc_assert (dim
< ndim
);
7517 /* Set the new lower bound. */
7518 from
= loop
.from
[dim
];
7521 onebased
= integer_onep (from
);
7522 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7523 gfc_rank_cst
[dim
], from
);
7525 /* Set the new upper bound. */
7526 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7527 gfc_rank_cst
[dim
], to
);
7529 /* Multiply the stride by the section stride to get the
7531 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7532 gfc_array_index_type
,
7533 stride
, info
->stride
[n
]);
7535 if ((se
->direct_byref
|| se
->use_offset
)
7536 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7537 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7539 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7540 TREE_TYPE (base
), base
, stride
);
7542 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7545 tmp
= gfc_conv_array_lbound (desc
, n
);
7546 toonebased
= integer_onep (tmp
);
7547 // lb(arr) - from (- start + 1)
7548 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7549 TREE_TYPE (base
), tmp
, from
);
7550 if (onebased
&& toonebased
)
7552 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7553 TREE_TYPE (base
), tmp
, start
);
7554 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7555 TREE_TYPE (base
), tmp
,
7556 gfc_index_one_node
);
7558 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7559 TREE_TYPE (base
), tmp
,
7560 gfc_conv_array_stride (desc
, n
));
7561 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7562 TREE_TYPE (base
), tmp
, base
);
7565 /* Store the new stride. */
7566 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7567 gfc_rank_cst
[dim
], stride
);
7570 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7572 from
= loop
.from
[n
];
7574 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7575 gfc_rank_cst
[n
], from
);
7576 if (n
< loop
.dimen
+ codim
- 1)
7577 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7578 gfc_rank_cst
[n
], to
);
7581 if (se
->data_not_needed
)
7582 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7583 gfc_index_zero_node
);
7585 /* Point the data pointer at the 1st element in the section. */
7586 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7587 subref_array_target
, expr
);
7589 /* Force the offset to be -1, when the lower bound of the highest
7590 dimension is one and the symbol is present and is not a
7591 pointer/allocatable or associated. */
7592 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7593 && !se
->data_not_needed
)
7594 || (se
->use_offset
&& base
!= NULL_TREE
))
7596 /* Set the offset depending on base. */
7597 tmp
= rank_remap
&& !se
->direct_byref
?
7598 fold_build2_loc (input_location
, PLUS_EXPR
,
7599 gfc_array_index_type
, base
,
7602 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7604 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7605 && !se
->data_not_needed
7606 && (!rank_remap
|| se
->use_offset
))
7608 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7609 gfc_conv_descriptor_offset_get (desc
));
7611 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7613 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7614 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7615 && !expr
->symtree
->n
.sym
->attr
.allocatable
7616 && !expr
->symtree
->n
.sym
->attr
.pointer
7617 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7618 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7620 /* Set the offset to -1. */
7622 mpz_init_set_si (minus_one
, -1);
7623 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7624 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7628 /* Only the callee knows what the correct offset it, so just set
7630 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7635 /* For class arrays add the class tree into the saved descriptor to
7636 enable getting of _vptr and the like. */
7637 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7638 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7640 gfc_allocate_lang_decl (desc
);
7641 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7642 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7643 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7644 : expr
->symtree
->n
.sym
->backend_decl
;
7646 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7647 && IS_CLASS_ARRAY (expr
))
7650 gfc_allocate_lang_decl (desc
);
7651 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7652 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7653 vtype
= gfc_class_vptr_get (tmp
);
7654 gfc_add_modify (&se
->pre
, vtype
,
7655 gfc_build_addr_expr (TREE_TYPE (vtype
),
7656 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7658 if (!se
->direct_byref
|| se
->byref_noassign
)
7660 /* Get a pointer to the new descriptor. */
7661 if (se
->want_pointer
)
7662 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7667 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7668 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7670 /* Cleanup the scalarizer. */
7671 gfc_cleanup_loop (&loop
);
7674 /* Helper function for gfc_conv_array_parameter if array size needs to be
7678 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7681 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7682 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7683 else if (expr
->rank
> 1)
7684 *size
= build_call_expr_loc (input_location
,
7685 gfor_fndecl_size0
, 1,
7686 gfc_build_addr_expr (NULL
, desc
));
7689 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7690 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7692 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7693 gfc_array_index_type
, ubound
, lbound
);
7694 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7695 *size
, gfc_index_one_node
);
7696 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7697 *size
, gfc_index_zero_node
);
7699 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7700 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7701 *size
, fold_convert (gfc_array_index_type
, elem
));
7704 /* Convert an array for passing as an actual parameter. */
7705 /* TODO: Optimize passing g77 arrays. */
7708 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7709 const gfc_symbol
*fsym
, const char *proc_name
,
7714 tree tmp
= NULL_TREE
;
7716 tree parent
= DECL_CONTEXT (current_function_decl
);
7717 bool full_array_var
;
7718 bool this_array_result
;
7721 bool array_constructor
;
7722 bool good_allocatable
;
7723 bool ultimate_ptr_comp
;
7724 bool ultimate_alloc_comp
;
7729 ultimate_ptr_comp
= false;
7730 ultimate_alloc_comp
= false;
7732 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7734 if (ref
->next
== NULL
)
7737 if (ref
->type
== REF_COMPONENT
)
7739 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7740 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7744 full_array_var
= false;
7747 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7748 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7750 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7752 /* The symbol should have an array specification. */
7753 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7755 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7757 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7758 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7759 se
->string_length
= tmp
;
7762 /* Is this the result of the enclosing procedure? */
7763 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7764 if (this_array_result
7765 && (sym
->backend_decl
!= current_function_decl
)
7766 && (sym
->backend_decl
!= parent
))
7767 this_array_result
= false;
7769 /* Passing address of the array if it is not pointer or assumed-shape. */
7770 if (full_array_var
&& g77
&& !this_array_result
7771 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7773 tmp
= gfc_get_symbol_decl (sym
);
7775 if (sym
->ts
.type
== BT_CHARACTER
)
7776 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7778 if (!sym
->attr
.pointer
7780 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7781 && sym
->as
->type
!= AS_DEFERRED
7782 && sym
->as
->type
!= AS_ASSUMED_RANK
7783 && !sym
->attr
.allocatable
)
7785 /* Some variables are declared directly, others are declared as
7786 pointers and allocated on the heap. */
7787 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7790 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7792 array_parameter_size (tmp
, expr
, size
);
7796 if (sym
->attr
.allocatable
)
7798 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7800 gfc_conv_expr_descriptor (se
, expr
);
7804 array_parameter_size (tmp
, expr
, size
);
7805 se
->expr
= gfc_conv_array_data (tmp
);
7810 /* A convenient reduction in scope. */
7811 contiguous
= g77
&& !this_array_result
&& contiguous
;
7813 /* There is no need to pack and unpack the array, if it is contiguous
7814 and not a deferred- or assumed-shape array, or if it is simply
7816 no_pack
= ((sym
&& sym
->as
7817 && !sym
->attr
.pointer
7818 && sym
->as
->type
!= AS_DEFERRED
7819 && sym
->as
->type
!= AS_ASSUMED_RANK
7820 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7822 (ref
&& ref
->u
.ar
.as
7823 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7824 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7825 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7827 gfc_is_simply_contiguous (expr
, false, true));
7829 no_pack
= contiguous
&& no_pack
;
7831 /* Array constructors are always contiguous and do not need packing. */
7832 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7834 /* Same is true of contiguous sections from allocatable variables. */
7835 good_allocatable
= contiguous
7837 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7839 /* Or ultimate allocatable components. */
7840 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7842 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7844 gfc_conv_expr_descriptor (se
, expr
);
7845 /* Deallocate the allocatable components of structures that are
7847 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7848 && expr
->ts
.u
.derived
->attr
.alloc_comp
7849 && expr
->expr_type
!= EXPR_VARIABLE
)
7851 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7853 /* The components shall be deallocated before their containing entity. */
7854 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7856 if (expr
->ts
.type
== BT_CHARACTER
)
7857 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7859 array_parameter_size (se
->expr
, expr
, size
);
7860 se
->expr
= gfc_conv_array_data (se
->expr
);
7864 if (this_array_result
)
7866 /* Result of the enclosing function. */
7867 gfc_conv_expr_descriptor (se
, expr
);
7869 array_parameter_size (se
->expr
, expr
, size
);
7870 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7872 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7873 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7874 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7881 /* Every other type of array. */
7882 se
->want_pointer
= 1;
7883 gfc_conv_expr_descriptor (se
, expr
);
7886 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7891 /* Deallocate the allocatable components of structures that are
7892 not variable, for descriptorless arguments.
7893 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7894 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7895 && expr
->ts
.u
.derived
->attr
.alloc_comp
7896 && expr
->expr_type
!= EXPR_VARIABLE
)
7898 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7899 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7901 /* The components shall be deallocated before their containing entity. */
7902 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7905 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7906 && !gfc_is_simply_contiguous (expr
, false, true)))
7908 tree origptr
= NULL_TREE
;
7912 /* For contiguous arrays, save the original value of the descriptor. */
7915 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7916 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7917 tmp
= gfc_conv_array_data (tmp
);
7918 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7919 TREE_TYPE (origptr
), origptr
,
7920 fold_convert (TREE_TYPE (origptr
), tmp
));
7921 gfc_add_expr_to_block (&se
->pre
, tmp
);
7924 /* Repack the array. */
7925 if (warn_array_temporaries
)
7928 gfc_warning (OPT_Warray_temporaries
,
7929 "Creating array temporary at %L for argument %qs",
7930 &expr
->where
, fsym
->name
);
7932 gfc_warning (OPT_Warray_temporaries
,
7933 "Creating array temporary at %L", &expr
->where
);
7936 ptr
= build_call_expr_loc (input_location
,
7937 gfor_fndecl_in_pack
, 1, desc
);
7939 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7941 tmp
= gfc_conv_expr_present (sym
);
7942 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7943 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7944 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7947 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7949 /* Use the packed data for the actual argument, except for contiguous arrays,
7950 where the descriptor's data component is set. */
7955 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7957 gfc_ss
* ss
= gfc_walk_expr (expr
);
7958 if (!transposed_dims (ss
))
7959 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7962 tree old_field
, new_field
;
7964 /* The original descriptor has transposed dims so we can't reuse
7965 it directly; we have to create a new one. */
7966 tree old_desc
= tmp
;
7967 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7969 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7970 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7971 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7973 old_field
= gfc_conv_descriptor_offset (old_desc
);
7974 new_field
= gfc_conv_descriptor_offset (new_desc
);
7975 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7977 for (int i
= 0; i
< expr
->rank
; i
++)
7979 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7980 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7981 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7983 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7986 if (flag_coarray
== GFC_FCOARRAY_LIB
7987 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7988 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7989 == GFC_ARRAY_ALLOCATABLE
)
7991 old_field
= gfc_conv_descriptor_token (old_desc
);
7992 new_field
= gfc_conv_descriptor_token (new_desc
);
7993 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7996 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7997 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8002 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8006 if (fsym
&& proc_name
)
8007 msg
= xasprintf ("An array temporary was created for argument "
8008 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8010 msg
= xasprintf ("An array temporary was created");
8012 tmp
= build_fold_indirect_ref_loc (input_location
,
8014 tmp
= gfc_conv_array_data (tmp
);
8015 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8016 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8018 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8019 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8021 gfc_conv_expr_present (sym
), tmp
);
8023 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8028 gfc_start_block (&block
);
8030 /* Copy the data back. */
8031 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8033 tmp
= build_call_expr_loc (input_location
,
8034 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8035 gfc_add_expr_to_block (&block
, tmp
);
8038 /* Free the temporary. */
8039 tmp
= gfc_call_free (ptr
);
8040 gfc_add_expr_to_block (&block
, tmp
);
8042 stmt
= gfc_finish_block (&block
);
8044 gfc_init_block (&block
);
8045 /* Only if it was repacked. This code needs to be executed before the
8046 loop cleanup code. */
8047 tmp
= build_fold_indirect_ref_loc (input_location
,
8049 tmp
= gfc_conv_array_data (tmp
);
8050 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8051 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8053 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8054 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8056 gfc_conv_expr_present (sym
), tmp
);
8058 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8060 gfc_add_expr_to_block (&block
, tmp
);
8061 gfc_add_block_to_block (&block
, &se
->post
);
8063 gfc_init_block (&se
->post
);
8065 /* Reset the descriptor pointer. */
8068 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8069 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8072 gfc_add_block_to_block (&se
->post
, &block
);
8077 /* This helper function calculates the size in words of a full array. */
8080 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8085 idx
= gfc_rank_cst
[rank
- 1];
8086 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8087 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8088 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8090 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8091 tmp
, gfc_index_one_node
);
8092 tmp
= gfc_evaluate_now (tmp
, block
);
8094 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8095 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8097 return gfc_evaluate_now (tmp
, block
);
8101 /* Allocate dest to the same size as src, and copy src -> dest.
8102 If no_malloc is set, only the copy is done. */
8105 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8106 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8107 tree add_when_allocated
)
8116 /* If the source is null, set the destination to null. Then,
8117 allocate memory to the destination. */
8118 gfc_init_block (&block
);
8120 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8122 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8123 null_data
= gfc_finish_block (&block
);
8125 gfc_init_block (&block
);
8126 if (str_sz
!= NULL_TREE
)
8129 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8133 tmp
= gfc_call_malloc (&block
, type
, size
);
8134 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8139 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8140 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8141 fold_convert (size_type_node
, size
));
8142 gfc_add_expr_to_block (&block
, tmp
);
8147 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8148 null_data
= gfc_finish_block (&block
);
8150 gfc_init_block (&block
);
8152 nelems
= gfc_full_array_size (&block
, src
, rank
);
8154 nelems
= gfc_index_one_node
;
8156 if (str_sz
!= NULL_TREE
)
8157 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8159 tmp
= fold_convert (gfc_array_index_type
,
8160 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8161 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8165 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8166 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8167 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8170 /* We know the temporary and the value will be the same length,
8171 so can use memcpy. */
8174 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8175 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8176 gfc_conv_descriptor_data_get (dest
),
8177 gfc_conv_descriptor_data_get (src
),
8178 fold_convert (size_type_node
, size
));
8179 gfc_add_expr_to_block (&block
, tmp
);
8183 gfc_add_expr_to_block (&block
, add_when_allocated
);
8184 tmp
= gfc_finish_block (&block
);
8186 /* Null the destination if the source is null; otherwise do
8187 the allocate and copy. */
8188 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8191 null_cond
= gfc_conv_descriptor_data_get (src
);
8193 null_cond
= convert (pvoid_type_node
, null_cond
);
8194 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8195 null_cond
, null_pointer_node
);
8196 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8200 /* Allocate dest to the same size as src, and copy data src -> dest. */
8203 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8204 tree add_when_allocated
)
8206 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8207 NULL_TREE
, add_when_allocated
);
8211 /* Copy data src -> dest. */
8214 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8216 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8217 NULL_TREE
, NULL_TREE
);
8220 /* Allocate dest to the same size as src, but don't copy anything. */
8223 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8225 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8226 NULL_TREE
, NULL_TREE
);
8231 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8232 tree type
, int rank
)
8239 stmtblock_t block
, globalblock
;
8241 /* If the source is null, set the destination to null. Then,
8242 allocate memory to the destination. */
8243 gfc_init_block (&block
);
8244 gfc_init_block (&globalblock
);
8246 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8249 symbol_attribute attr
;
8252 gfc_init_se (&se
, NULL
);
8253 gfc_clear_attr (&attr
);
8254 attr
.allocatable
= 1;
8255 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8256 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8257 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8259 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8260 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8261 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8262 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8263 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8264 null_data
= gfc_finish_block (&block
);
8266 gfc_init_block (&block
);
8268 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8269 fold_convert (size_type_node
, size
),
8270 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8271 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8272 GFC_CAF_COARRAY_ALLOC
);
8274 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8275 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8276 fold_convert (size_type_node
, size
));
8277 gfc_add_expr_to_block (&block
, tmp
);
8281 /* Set the rank or unitialized memory access may be reported. */
8282 tmp
= gfc_conv_descriptor_rank (dest
);
8283 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8286 nelems
= gfc_full_array_size (&block
, src
, rank
);
8288 nelems
= integer_one_node
;
8290 tmp
= fold_convert (size_type_node
,
8291 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8292 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8293 fold_convert (size_type_node
, nelems
), tmp
);
8295 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8296 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8298 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8299 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8300 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8301 null_data
= gfc_finish_block (&block
);
8303 gfc_init_block (&block
);
8304 gfc_allocate_using_caf_lib (&block
, dest
,
8305 fold_convert (size_type_node
, size
),
8306 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8307 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8308 GFC_CAF_COARRAY_ALLOC
);
8310 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8311 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8312 gfc_conv_descriptor_data_get (dest
),
8313 gfc_conv_descriptor_data_get (src
),
8314 fold_convert (size_type_node
, size
));
8315 gfc_add_expr_to_block (&block
, tmp
);
8318 tmp
= gfc_finish_block (&block
);
8320 /* Null the destination if the source is null; otherwise do
8321 the register and copy. */
8322 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8325 null_cond
= gfc_conv_descriptor_data_get (src
);
8327 null_cond
= convert (pvoid_type_node
, null_cond
);
8328 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8329 null_cond
, null_pointer_node
);
8330 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8332 return gfc_finish_block (&globalblock
);
8336 /* Helper function to abstract whether coarray processing is enabled. */
8339 caf_enabled (int caf_mode
)
8341 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8342 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8346 /* Helper function to abstract whether coarray processing is enabled
8347 and we are in a derived type coarray. */
8350 caf_in_coarray (int caf_mode
)
8352 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8353 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8354 return (caf_mode
& pat
) == pat
;
8358 /* Helper function to abstract whether coarray is to deallocate only. */
8361 gfc_caf_is_dealloc_only (int caf_mode
)
8363 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8364 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8368 /* Recursively traverse an object of derived type, generating code to
8369 deallocate, nullify or copy allocatable components. This is the work horse
8370 function for the functions named in this enum. */
8372 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8373 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8374 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8376 static gfc_actual_arglist
*pdt_param_list
;
8379 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8380 tree dest
, int rank
, int purpose
, int caf_mode
)
8384 stmtblock_t fnblock
;
8385 stmtblock_t loopbody
;
8386 stmtblock_t tmpblock
;
8397 tree null_cond
= NULL_TREE
;
8398 tree add_when_allocated
;
8399 tree dealloc_fndecl
;
8403 symbol_attribute
*attr
;
8404 bool deallocate_called
;
8406 gfc_init_block (&fnblock
);
8408 decl_type
= TREE_TYPE (decl
);
8410 if ((POINTER_TYPE_P (decl_type
))
8411 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8413 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8414 /* Deref dest in sync with decl, but only when it is not NULL. */
8416 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8418 /* Update the decl_type because it got dereferenced. */
8419 decl_type
= TREE_TYPE (decl
);
8422 /* If this is an array of derived types with allocatable components
8423 build a loop and recursively call this function. */
8424 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8425 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8427 tmp
= gfc_conv_array_data (decl
);
8428 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8430 /* Get the number of elements - 1 and set the counter. */
8431 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8433 /* Use the descriptor for an allocatable array. Since this
8434 is a full array reference, we only need the descriptor
8435 information from dimension = rank. */
8436 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8437 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8438 gfc_array_index_type
, tmp
,
8439 gfc_index_one_node
);
8441 null_cond
= gfc_conv_descriptor_data_get (decl
);
8442 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8443 logical_type_node
, null_cond
,
8444 build_int_cst (TREE_TYPE (null_cond
), 0));
8448 /* Otherwise use the TYPE_DOMAIN information. */
8449 tmp
= array_type_nelts (decl_type
);
8450 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8453 /* Remember that this is, in fact, the no. of elements - 1. */
8454 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8455 index
= gfc_create_var (gfc_array_index_type
, "S");
8457 /* Build the body of the loop. */
8458 gfc_init_block (&loopbody
);
8460 vref
= gfc_build_array_ref (var
, index
, NULL
);
8462 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8463 && !caf_enabled (caf_mode
))
8465 tmp
= build_fold_indirect_ref_loc (input_location
,
8466 gfc_conv_array_data (dest
));
8467 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8468 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8469 COPY_ALLOC_COMP
, 0);
8472 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8475 gfc_add_expr_to_block (&loopbody
, tmp
);
8477 /* Build the loop and return. */
8478 gfc_init_loopinfo (&loop
);
8480 loop
.from
[0] = gfc_index_zero_node
;
8481 loop
.loopvar
[0] = index
;
8482 loop
.to
[0] = nelems
;
8483 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8484 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8486 tmp
= gfc_finish_block (&fnblock
);
8487 /* When copying allocateable components, the above implements the
8488 deep copy. Nevertheless is a deep copy only allowed, when the current
8489 component is allocated, for which code will be generated in
8490 gfc_duplicate_allocatable (), where the deep copy code is just added
8491 into the if's body, by adding tmp (the deep copy code) as last
8492 argument to gfc_duplicate_allocatable (). */
8493 if (purpose
== COPY_ALLOC_COMP
8494 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8495 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8497 else if (null_cond
!= NULL_TREE
)
8498 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8499 build_empty_stmt (input_location
));
8504 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8506 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8507 DEALLOCATE_PDT_COMP
, 0);
8508 gfc_add_expr_to_block (&fnblock
, tmp
);
8510 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8512 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8513 NULLIFY_ALLOC_COMP
, 0);
8514 gfc_add_expr_to_block (&fnblock
, tmp
);
8517 /* Otherwise, act on the components or recursively call self to
8518 act on a chain of components. */
8519 for (c
= der_type
->components
; c
; c
= c
->next
)
8521 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8522 || c
->ts
.type
== BT_CLASS
)
8523 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8524 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8525 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8527 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8528 && c
->ts
.u
.derived
->attr
.pdt_type
;
8530 cdecl = c
->backend_decl
;
8531 ctype
= TREE_TYPE (cdecl);
8535 case DEALLOCATE_ALLOC_COMP
:
8537 gfc_init_block (&tmpblock
);
8539 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8540 decl
, cdecl, NULL_TREE
);
8542 /* Shortcut to get the attributes of the component. */
8543 if (c
->ts
.type
== BT_CLASS
)
8545 attr
= &CLASS_DATA (c
)->attr
;
8546 if (attr
->class_pointer
)
8556 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8557 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8558 /* Call the finalizer, which will free the memory and nullify the
8559 pointer of an array. */
8560 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8561 caf_enabled (caf_mode
))
8564 deallocate_called
= false;
8566 /* Add the _class ref for classes. */
8567 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8568 comp
= gfc_class_data_get (comp
);
8570 add_when_allocated
= NULL_TREE
;
8571 if (cmp_has_alloc_comps
8572 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8574 && !deallocate_called
)
8576 /* Add checked deallocation of the components. This code is
8577 obviously added because the finalizer is not trusted to free
8579 if (c
->ts
.type
== BT_CLASS
)
8581 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8583 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8584 comp
, NULL_TREE
, rank
, purpose
,
8589 rank
= c
->as
? c
->as
->rank
: 0;
8590 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8597 if (attr
->allocatable
&& !same_type
8598 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8600 /* Handle all types of components besides components of the
8601 same_type as the current one, because those would create an
8604 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8605 ? (gfc_caf_is_dealloc_only (caf_mode
)
8606 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8607 : GFC_CAF_COARRAY_DEREGISTER
)
8608 : GFC_CAF_COARRAY_NOCOARRAY
;
8610 caf_token
= NULL_TREE
;
8611 /* Coarray components are handled directly by
8612 deallocate_with_status. */
8613 if (!attr
->codimension
8614 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8617 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8618 TREE_TYPE (c
->caf_token
),
8619 decl
, c
->caf_token
, NULL_TREE
);
8620 else if (attr
->dimension
&& !attr
->proc_pointer
)
8621 caf_token
= gfc_conv_descriptor_token (comp
);
8623 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8624 /* When this is an array but not in conjunction with a coarray
8625 then add the data-ref. For coarray'ed arrays the data-ref
8626 is added by deallocate_with_status. */
8627 comp
= gfc_conv_descriptor_data_get (comp
);
8629 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8630 NULL_TREE
, NULL_TREE
, true,
8631 NULL
, caf_dereg_mode
,
8632 add_when_allocated
, caf_token
);
8634 gfc_add_expr_to_block (&tmpblock
, tmp
);
8636 else if (attr
->allocatable
&& !attr
->codimension
8637 && !deallocate_called
)
8639 /* Case of recursive allocatable derived types. */
8643 stmtblock_t dealloc_block
;
8645 gfc_init_block (&dealloc_block
);
8646 if (add_when_allocated
)
8647 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8649 /* Convert the component into a rank 1 descriptor type. */
8650 if (attr
->dimension
)
8652 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8653 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8654 c
->ts
.type
== BT_CLASS
8655 ? CLASS_DATA (c
)->as
->rank
8660 tmp
= TREE_TYPE (comp
);
8661 ubound
= build_int_cst (gfc_array_index_type
, 1);
8664 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8666 GFC_ARRAY_ALLOCATABLE
, false);
8668 cdesc
= gfc_create_var (cdesc
, "cdesc");
8669 DECL_ARTIFICIAL (cdesc
) = 1;
8671 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8672 gfc_get_dtype_rank_type (1, tmp
));
8673 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8674 gfc_index_zero_node
,
8675 gfc_index_one_node
);
8676 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8677 gfc_index_zero_node
,
8678 gfc_index_one_node
);
8679 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8680 gfc_index_zero_node
, ubound
);
8682 if (attr
->dimension
)
8683 comp
= gfc_conv_descriptor_data_get (comp
);
8685 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8687 /* Now call the deallocator. */
8688 vtab
= gfc_find_vtab (&c
->ts
);
8689 if (vtab
->backend_decl
== NULL
)
8690 gfc_get_symbol_decl (vtab
);
8691 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8692 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8693 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8695 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8696 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8697 logical_type_node
, tmp
,
8699 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8701 tmp
= build_call_expr_loc (input_location
,
8704 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8706 tmp
= gfc_finish_block (&dealloc_block
);
8708 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8709 void_type_node
, is_allocated
, tmp
,
8710 build_empty_stmt (input_location
));
8712 gfc_add_expr_to_block (&tmpblock
, tmp
);
8714 else if (add_when_allocated
)
8715 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8717 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8718 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8720 /* Finally, reset the vptr to the declared type vtable and, if
8721 necessary reset the _len field.
8723 First recover the reference to the component and obtain
8725 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8726 decl
, cdecl, NULL_TREE
);
8727 tmp
= gfc_class_vptr_get (comp
);
8729 if (UNLIMITED_POLY (c
))
8731 /* Both vptr and _len field should be nulled. */
8732 gfc_add_modify (&tmpblock
, tmp
,
8733 build_int_cst (TREE_TYPE (tmp
), 0));
8734 tmp
= gfc_class_len_get (comp
);
8735 gfc_add_modify (&tmpblock
, tmp
,
8736 build_int_cst (TREE_TYPE (tmp
), 0));
8740 /* Build the vtable address and set the vptr with it. */
8743 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8744 vtab
= vtable
->backend_decl
;
8745 if (vtab
== NULL_TREE
)
8746 vtab
= gfc_get_symbol_decl (vtable
);
8747 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8748 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8749 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8753 /* Now add the deallocation of this component. */
8754 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8757 case NULLIFY_ALLOC_COMP
:
8759 - allocatable components (regular or in class)
8760 - components that have allocatable components
8761 - pointer components when in a coarray.
8762 Skip everything else especially proc_pointers, which may come
8763 coupled with the regular pointer attribute. */
8764 if (c
->attr
.proc_pointer
8765 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8766 && CLASS_DATA (c
)->attr
.allocatable
)
8767 || (cmp_has_alloc_comps
8768 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8769 || (c
->ts
.type
== BT_CLASS
8770 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8771 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8774 /* Process class components first, because they always have the
8775 pointer-attribute set which would be caught wrong else. */
8776 if (c
->ts
.type
== BT_CLASS
8777 && (CLASS_DATA (c
)->attr
.allocatable
8778 || CLASS_DATA (c
)->attr
.class_pointer
))
8780 /* Allocatable CLASS components. */
8781 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8782 decl
, cdecl, NULL_TREE
);
8784 comp
= gfc_class_data_get (comp
);
8785 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8786 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8790 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8791 void_type_node
, comp
,
8792 build_int_cst (TREE_TYPE (comp
), 0));
8793 gfc_add_expr_to_block (&fnblock
, tmp
);
8795 cmp_has_alloc_comps
= false;
8797 /* Coarrays need the component to be nulled before the api-call
8799 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8801 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8802 decl
, cdecl, NULL_TREE
);
8803 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8804 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8807 gfc_add_modify (&fnblock
, comp
,
8808 build_int_cst (TREE_TYPE (comp
), 0));
8809 if (gfc_deferred_strlen (c
, &comp
))
8811 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8813 decl
, comp
, NULL_TREE
);
8814 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8815 TREE_TYPE (comp
), comp
,
8816 build_int_cst (TREE_TYPE (comp
), 0));
8817 gfc_add_expr_to_block (&fnblock
, tmp
);
8819 cmp_has_alloc_comps
= false;
8822 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
8824 /* Register a component of a derived type coarray with the
8825 coarray library. Do not register ultimate component
8826 coarrays here. They are treated like regular coarrays and
8827 are either allocated on all images or on none. */
8830 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8831 decl
, cdecl, NULL_TREE
);
8832 if (c
->attr
.dimension
)
8834 /* Set the dtype, because caf_register needs it. */
8835 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8836 gfc_get_dtype (TREE_TYPE (comp
)));
8837 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8838 decl
, cdecl, NULL_TREE
);
8839 token
= gfc_conv_descriptor_token (tmp
);
8845 gfc_init_se (&se
, NULL
);
8846 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8847 pvoid_type_node
, decl
, c
->caf_token
,
8849 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8850 c
->ts
.type
== BT_CLASS
8851 ? CLASS_DATA (c
)->attr
8853 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8856 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8857 gfc_build_addr_expr (NULL_TREE
,
8859 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8860 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8863 if (cmp_has_alloc_comps
)
8865 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8866 decl
, cdecl, NULL_TREE
);
8867 rank
= c
->as
? c
->as
->rank
: 0;
8868 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8869 rank
, purpose
, caf_mode
);
8870 gfc_add_expr_to_block (&fnblock
, tmp
);
8874 case REASSIGN_CAF_COMP
:
8875 if (caf_enabled (caf_mode
)
8876 && (c
->attr
.codimension
8877 || (c
->ts
.type
== BT_CLASS
8878 && (CLASS_DATA (c
)->attr
.coarray_comp
8879 || caf_in_coarray (caf_mode
)))
8880 || (c
->ts
.type
== BT_DERIVED
8881 && (c
->ts
.u
.derived
->attr
.coarray_comp
8882 || caf_in_coarray (caf_mode
))))
8885 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8886 decl
, cdecl, NULL_TREE
);
8887 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8888 dest
, cdecl, NULL_TREE
);
8890 if (c
->attr
.codimension
)
8892 if (c
->ts
.type
== BT_CLASS
)
8894 comp
= gfc_class_data_get (comp
);
8895 dcmp
= gfc_class_data_get (dcmp
);
8897 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8898 gfc_conv_descriptor_data_get (comp
));
8902 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8903 rank
, purpose
, caf_mode
8904 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8905 gfc_add_expr_to_block (&fnblock
, tmp
);
8910 case COPY_ALLOC_COMP
:
8911 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
8914 /* We need source and destination components. */
8915 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8917 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8919 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8921 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8929 dst_data
= gfc_class_data_get (dcmp
);
8930 src_data
= gfc_class_data_get (comp
);
8931 size
= fold_convert (size_type_node
,
8932 gfc_class_vtab_size_get (comp
));
8934 if (CLASS_DATA (c
)->attr
.dimension
)
8936 nelems
= gfc_conv_descriptor_size (src_data
,
8937 CLASS_DATA (c
)->as
->rank
);
8938 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8939 size_type_node
, size
,
8940 fold_convert (size_type_node
,
8944 nelems
= build_int_cst (size_type_node
, 1);
8946 if (CLASS_DATA (c
)->attr
.dimension
8947 || CLASS_DATA (c
)->attr
.codimension
)
8949 src_data
= gfc_conv_descriptor_data_get (src_data
);
8950 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8953 gfc_init_block (&tmpblock
);
8955 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
8956 gfc_class_vptr_get (comp
));
8958 /* Copy the unlimited '_len' field. If it is greater than zero
8959 (ie. a character(_len)), multiply it by size and use this
8960 for the malloc call. */
8961 if (UNLIMITED_POLY (c
))
8964 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
8965 gfc_class_len_get (comp
));
8967 size
= gfc_evaluate_now (size
, &tmpblock
);
8968 tmp
= gfc_class_len_get (comp
);
8969 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8970 size_type_node
, size
,
8971 fold_convert (size_type_node
, tmp
));
8972 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
8973 logical_type_node
, tmp
,
8974 build_zero_cst (TREE_TYPE (tmp
)));
8975 size
= fold_build3_loc (input_location
, COND_EXPR
,
8976 size_type_node
, tmp
, ctmp
, size
);
8977 size
= gfc_evaluate_now (size
, &tmpblock
);
8980 /* Coarray component have to have the same allocation status and
8981 shape/type-parameter/effective-type on the LHS and RHS of an
8982 intrinsic assignment. Hence, we did not deallocated them - and
8983 do not allocate them here. */
8984 if (!CLASS_DATA (c
)->attr
.codimension
)
8986 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8987 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8988 gfc_add_modify (&tmpblock
, dst_data
,
8989 fold_convert (TREE_TYPE (dst_data
), tmp
));
8992 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8993 UNLIMITED_POLY (c
));
8994 gfc_add_expr_to_block (&tmpblock
, tmp
);
8995 tmp
= gfc_finish_block (&tmpblock
);
8997 gfc_init_block (&tmpblock
);
8998 gfc_add_modify (&tmpblock
, dst_data
,
8999 fold_convert (TREE_TYPE (dst_data
),
9000 null_pointer_node
));
9001 null_data
= gfc_finish_block (&tmpblock
);
9003 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9004 logical_type_node
, src_data
,
9007 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9012 /* To implement guarded deep copy, i.e., deep copy only allocatable
9013 components that are really allocated, the deep copy code has to
9014 be generated first and then added to the if-block in
9015 gfc_duplicate_allocatable (). */
9016 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9018 rank
= c
->as
? c
->as
->rank
: 0;
9019 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9020 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9021 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9027 add_when_allocated
= NULL_TREE
;
9029 if (gfc_deferred_strlen (c
, &tmp
))
9033 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9035 decl
, len
, NULL_TREE
);
9036 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9038 dest
, len
, NULL_TREE
);
9039 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9040 TREE_TYPE (len
), len
, tmp
);
9041 gfc_add_expr_to_block (&fnblock
, tmp
);
9042 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9043 /* This component can not have allocatable components,
9044 therefore add_when_allocated of duplicate_allocatable ()
9046 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9047 false, false, size
, NULL_TREE
);
9048 gfc_add_expr_to_block (&fnblock
, tmp
);
9050 else if (c
->attr
.pdt_array
)
9052 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9053 c
->as
? c
->as
->rank
: 0,
9054 false, false, NULL_TREE
, NULL_TREE
);
9055 gfc_add_expr_to_block (&fnblock
, tmp
);
9057 else if ((c
->attr
.allocatable
)
9058 && !c
->attr
.proc_pointer
&& !same_type
9059 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9060 || caf_in_coarray (caf_mode
)))
9062 rank
= c
->as
? c
->as
->rank
: 0;
9063 if (c
->attr
.codimension
)
9064 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9065 else if (flag_coarray
== GFC_FCOARRAY_LIB
9066 && caf_in_coarray (caf_mode
))
9068 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
9069 : fold_build3_loc (input_location
,
9071 pvoid_type_node
, dest
,
9074 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9078 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9079 add_when_allocated
);
9080 gfc_add_expr_to_block (&fnblock
, tmp
);
9083 if (cmp_has_alloc_comps
|| is_pdt_type
)
9084 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9088 case ALLOCATE_PDT_COMP
:
9090 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9091 decl
, cdecl, NULL_TREE
);
9093 /* Set the PDT KIND and LEN fields. */
9094 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9097 gfc_expr
*c_expr
= NULL
;
9098 gfc_actual_arglist
*param
= pdt_param_list
;
9099 gfc_init_se (&tse
, NULL
);
9100 for (; param
; param
= param
->next
)
9101 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9102 c_expr
= param
->expr
;
9105 c_expr
= c
->initializer
;
9109 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9110 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9114 if (c
->attr
.pdt_string
)
9117 gfc_init_se (&tse
, NULL
);
9118 tree strlen
= NULL_TREE
;
9119 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9120 /* Convert the parameterized string length to its value. The
9121 string length is stored in a hidden field in the same way as
9122 deferred string lengths. */
9123 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9124 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9126 gfc_conv_expr_type (&tse
, e
,
9127 TREE_TYPE (strlen
));
9128 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9130 decl
, strlen
, NULL_TREE
);
9131 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9132 c
->ts
.u
.cl
->backend_decl
= strlen
;
9136 /* Scalar parameterized strings can be allocated now. */
9139 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9140 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9141 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9142 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9143 gfc_add_modify (&fnblock
, comp
, tmp
);
9147 /* Allocate parameterized arrays of parameterized derived types. */
9148 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9149 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9150 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9153 if (c
->ts
.type
== BT_CLASS
)
9154 comp
= gfc_class_data_get (comp
);
9156 if (c
->attr
.pdt_array
)
9160 tree size
= gfc_index_one_node
;
9161 tree offset
= gfc_index_zero_node
;
9165 /* This chunk takes the expressions for 'lower' and 'upper'
9166 in the arrayspec and substitutes in the expressions for
9167 the parameters from 'pdt_param_list'. The descriptor
9168 fields can then be filled from the values so obtained. */
9169 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9170 for (i
= 0; i
< c
->as
->rank
; i
++)
9172 gfc_init_se (&tse
, NULL
);
9173 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9174 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9175 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9178 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9181 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9182 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9183 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9186 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9189 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9192 size
= gfc_evaluate_now (size
, &fnblock
);
9193 offset
= fold_build2_loc (input_location
,
9195 gfc_array_index_type
,
9197 offset
= gfc_evaluate_now (offset
, &fnblock
);
9198 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9199 gfc_array_index_type
,
9201 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9202 gfc_array_index_type
,
9203 tmp
, gfc_index_one_node
);
9204 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9205 gfc_array_index_type
, size
, tmp
);
9207 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9208 if (c
->ts
.type
== BT_CLASS
)
9210 tmp
= gfc_get_vptr_from_expr (comp
);
9211 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9212 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9213 tmp
= gfc_vptr_size_get (tmp
);
9216 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9217 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9218 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9219 gfc_array_index_type
, size
, tmp
);
9220 size
= gfc_evaluate_now (size
, &fnblock
);
9221 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9222 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9223 tmp
= gfc_conv_descriptor_dtype (comp
);
9224 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9226 if (c
->initializer
&& c
->initializer
->rank
)
9228 gfc_init_se (&tse
, NULL
);
9229 e
= gfc_copy_expr (c
->initializer
);
9230 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9231 gfc_conv_expr_descriptor (&tse
, e
);
9232 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9234 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9235 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9236 gfc_conv_descriptor_data_get (comp
),
9237 gfc_conv_descriptor_data_get (tse
.expr
),
9238 fold_convert (size_type_node
, size
));
9239 gfc_add_expr_to_block (&fnblock
, tmp
);
9240 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9244 /* Recurse in to PDT components. */
9245 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9246 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9247 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9249 bool is_deferred
= false;
9250 gfc_actual_arglist
*tail
= c
->param_list
;
9252 for (; tail
; tail
= tail
->next
)
9256 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9257 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9258 c
->as
? c
->as
->rank
: 0,
9260 gfc_add_expr_to_block (&fnblock
, tmp
);
9265 case DEALLOCATE_PDT_COMP
:
9266 /* Deallocate array or parameterized string length components
9267 of parameterized derived types. */
9268 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9269 && !c
->attr
.pdt_string
9270 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9271 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9274 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9275 decl
, cdecl, NULL_TREE
);
9276 if (c
->ts
.type
== BT_CLASS
)
9277 comp
= gfc_class_data_get (comp
);
9279 /* Recurse in to PDT components. */
9280 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9281 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9282 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9284 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9285 c
->as
? c
->as
->rank
: 0);
9286 gfc_add_expr_to_block (&fnblock
, tmp
);
9289 if (c
->attr
.pdt_array
)
9291 tmp
= gfc_conv_descriptor_data_get (comp
);
9292 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9293 logical_type_node
, tmp
,
9294 build_int_cst (TREE_TYPE (tmp
), 0));
9295 tmp
= gfc_call_free (tmp
);
9296 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9297 build_empty_stmt (input_location
));
9298 gfc_add_expr_to_block (&fnblock
, tmp
);
9299 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9301 else if (c
->attr
.pdt_string
)
9303 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9304 logical_type_node
, comp
,
9305 build_int_cst (TREE_TYPE (comp
), 0));
9306 tmp
= gfc_call_free (comp
);
9307 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9308 build_empty_stmt (input_location
));
9309 gfc_add_expr_to_block (&fnblock
, tmp
);
9310 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9311 gfc_add_modify (&fnblock
, comp
, tmp
);
9316 case CHECK_PDT_DUMMY
:
9318 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9319 decl
, cdecl, NULL_TREE
);
9320 if (c
->ts
.type
== BT_CLASS
)
9321 comp
= gfc_class_data_get (comp
);
9323 /* Recurse in to PDT components. */
9324 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9325 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9327 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9328 c
->as
? c
->as
->rank
: 0,
9330 gfc_add_expr_to_block (&fnblock
, tmp
);
9333 if (!c
->attr
.pdt_len
)
9338 gfc_expr
*c_expr
= NULL
;
9339 gfc_actual_arglist
*param
= pdt_param_list
;
9341 gfc_init_se (&tse
, NULL
);
9342 for (; param
; param
= param
->next
)
9343 if (!strcmp (c
->name
, param
->name
)
9344 && param
->spec_type
== SPEC_EXPLICIT
)
9345 c_expr
= param
->expr
;
9349 tree error
, cond
, cname
;
9350 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9351 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9354 cname
= gfc_build_cstring_const (c
->name
);
9355 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9356 error
= gfc_trans_runtime_error (true, NULL
,
9357 "The value of the PDT LEN "
9358 "parameter '%s' does not "
9359 "agree with that in the "
9360 "dummy declaration",
9362 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9363 void_type_node
, cond
, error
,
9364 build_empty_stmt (input_location
));
9365 gfc_add_expr_to_block (&fnblock
, tmp
);
9376 return gfc_finish_block (&fnblock
);
9379 /* Recursively traverse an object of derived type, generating code to
9380 nullify allocatable components. */
9383 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9386 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9388 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9392 /* Recursively traverse an object of derived type, generating code to
9393 deallocate allocatable components. */
9396 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9399 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9400 DEALLOCATE_ALLOC_COMP
,
9401 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9405 /* Recursively traverse an object of derived type, generating code to
9406 deallocate allocatable components. But do not deallocate coarrays.
9407 To be used for intrinsic assignment, which may not change the allocation
9408 status of coarrays. */
9411 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9413 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9414 DEALLOCATE_ALLOC_COMP
, 0);
9419 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9421 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9422 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9426 /* Recursively traverse an object of derived type, generating code to
9427 copy it and its allocatable components. */
9430 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9433 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9438 /* Recursively traverse an object of derived type, generating code to
9439 copy only its allocatable components. */
9442 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9444 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9445 COPY_ONLY_ALLOC_COMP
, 0);
9449 /* Recursively traverse an object of paramterized derived type, generating
9450 code to allocate parameterized components. */
9453 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9454 gfc_actual_arglist
*param_list
)
9457 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9458 pdt_param_list
= param_list
;
9459 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9460 ALLOCATE_PDT_COMP
, 0);
9461 pdt_param_list
= old_param_list
;
9465 /* Recursively traverse an object of paramterized derived type, generating
9466 code to deallocate parameterized components. */
9469 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9471 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9472 DEALLOCATE_PDT_COMP
, 0);
9476 /* Recursively traverse a dummy of paramterized derived type to check the
9477 values of LEN parameters. */
9480 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9481 gfc_actual_arglist
*param_list
)
9484 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9485 pdt_param_list
= param_list
;
9486 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9487 CHECK_PDT_DUMMY
, 0);
9488 pdt_param_list
= old_param_list
;
9493 /* Returns the value of LBOUND for an expression. This could be broken out
9494 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9495 called by gfc_alloc_allocatable_for_assignment. */
9497 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9502 tree cond
, cond1
, cond3
, cond4
;
9506 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9508 tmp
= gfc_rank_cst
[dim
];
9509 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9510 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9511 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9512 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9514 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9515 stride
, gfc_index_zero_node
);
9516 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9517 logical_type_node
, cond3
, cond1
);
9518 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9519 stride
, gfc_index_zero_node
);
9521 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9522 tmp
, build_int_cst (gfc_array_index_type
,
9525 cond
= logical_false_node
;
9527 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9528 logical_type_node
, cond3
, cond4
);
9529 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9530 logical_type_node
, cond
, cond1
);
9532 return fold_build3_loc (input_location
, COND_EXPR
,
9533 gfc_array_index_type
, cond
,
9534 lbound
, gfc_index_one_node
);
9537 if (expr
->expr_type
== EXPR_FUNCTION
)
9539 /* A conversion function, so use the argument. */
9540 gcc_assert (expr
->value
.function
.isym
9541 && expr
->value
.function
.isym
->conversion
);
9542 expr
= expr
->value
.function
.actual
->expr
;
9545 if (expr
->expr_type
== EXPR_VARIABLE
)
9547 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9548 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9550 if (ref
->type
== REF_COMPONENT
9551 && ref
->u
.c
.component
->as
9553 && ref
->next
->u
.ar
.type
== AR_FULL
)
9554 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9556 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9559 return gfc_index_one_node
;
9563 /* Returns true if an expression represents an lhs that can be reallocated
9567 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9575 sym
= expr
->symtree
->n
.sym
;
9577 if (sym
->attr
.associate_var
)
9580 /* An allocatable class variable with no reference. */
9581 if (sym
->ts
.type
== BT_CLASS
9582 && CLASS_DATA (sym
)->attr
.allocatable
9583 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
9584 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9585 && expr
->ref
->next
== NULL
)
9588 /* An allocatable variable. */
9589 if (sym
->attr
.allocatable
9591 && expr
->ref
->type
== REF_ARRAY
9592 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9595 /* All that can be left are allocatable components. */
9596 if ((sym
->ts
.type
!= BT_DERIVED
9597 && sym
->ts
.type
!= BT_CLASS
)
9598 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9601 /* Find a component ref followed by an array reference. */
9602 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9604 && ref
->type
== REF_COMPONENT
9605 && ref
->next
->type
== REF_ARRAY
9606 && !ref
->next
->next
)
9612 /* Return true if valid reallocatable lhs. */
9613 if (ref
->u
.c
.component
->attr
.allocatable
9614 && ref
->next
->u
.ar
.type
== AR_FULL
)
9622 concat_str_length (gfc_expr
* expr
)
9629 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9630 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9631 if (len1
== NULL_TREE
)
9633 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9634 len1
= concat_str_length (expr
->value
.op
.op1
);
9635 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9636 len1
= build_int_cst (gfc_charlen_type_node
,
9637 expr
->value
.op
.op1
->value
.character
.length
);
9638 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9640 gfc_init_se (&se
, NULL
);
9641 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9647 gfc_init_se (&se
, NULL
);
9648 se
.want_pointer
= 1;
9649 se
.descriptor_only
= 1;
9650 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9651 len1
= se
.string_length
;
9655 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9656 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9657 if (len2
== NULL_TREE
)
9659 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9660 len2
= concat_str_length (expr
->value
.op
.op2
);
9661 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9662 len2
= build_int_cst (gfc_charlen_type_node
,
9663 expr
->value
.op
.op2
->value
.character
.length
);
9664 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9666 gfc_init_se (&se
, NULL
);
9667 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9673 gfc_init_se (&se
, NULL
);
9674 se
.want_pointer
= 1;
9675 se
.descriptor_only
= 1;
9676 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9677 len2
= se
.string_length
;
9681 gcc_assert(len1
&& len2
);
9682 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9683 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9685 return fold_build2_loc (input_location
, PLUS_EXPR
,
9686 gfc_charlen_type_node
, len1
, len2
);
9690 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9694 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9698 stmtblock_t realloc_block
;
9699 stmtblock_t alloc_block
;
9703 gfc_array_info
*linfo
;
9725 gfc_array_spec
* as
;
9726 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9727 && gfc_caf_attr (expr1
, true).codimension
);
9731 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9732 Find the lhs expression in the loop chain and set expr1 and
9733 expr2 accordingly. */
9734 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9737 /* Find the ss for the lhs. */
9739 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9740 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9742 if (lss
== gfc_ss_terminator
)
9744 expr1
= lss
->info
->expr
;
9747 /* Bail out if this is not a valid allocate on assignment. */
9748 if (!gfc_is_reallocatable_lhs (expr1
)
9749 || (expr2
&& !expr2
->rank
))
9752 /* Find the ss for the lhs. */
9754 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9755 if (lss
->info
->expr
== expr1
)
9758 if (lss
== gfc_ss_terminator
)
9761 linfo
= &lss
->info
->data
.array
;
9763 /* Find an ss for the rhs. For operator expressions, we see the
9764 ss's for the operands. Any one of these will do. */
9766 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9767 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9770 if (expr2
&& rss
== gfc_ss_terminator
)
9773 /* Ensure that the string length from the current scope is used. */
9774 if (expr2
->ts
.type
== BT_CHARACTER
9775 && expr2
->expr_type
== EXPR_FUNCTION
9776 && !expr2
->value
.function
.isym
)
9777 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
9779 gfc_start_block (&fblock
);
9781 /* Since the lhs is allocatable, this must be a descriptor type.
9782 Get the data and array size. */
9783 desc
= linfo
->descriptor
;
9784 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9785 array1
= gfc_conv_descriptor_data_get (desc
);
9787 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9788 deallocated if expr is an array of different shape or any of the
9789 corresponding length type parameter values of variable and expr
9790 differ." This assures F95 compatibility. */
9791 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9792 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9794 /* Allocate if data is NULL. */
9795 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9796 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9798 if (expr1
->ts
.deferred
)
9799 cond_null
= gfc_evaluate_now (logical_true_node
, &fblock
);
9801 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9803 tmp
= build3_v (COND_EXPR
, cond_null
,
9804 build1_v (GOTO_EXPR
, jump_label1
),
9805 build_empty_stmt (input_location
));
9806 gfc_add_expr_to_block (&fblock
, tmp
);
9808 /* Get arrayspec if expr is a full array. */
9809 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9810 && expr2
->value
.function
.isym
9811 && expr2
->value
.function
.isym
->conversion
)
9813 /* For conversion functions, take the arg. */
9814 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9815 as
= gfc_get_full_arrayspec_from_expr (arg
);
9818 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9822 /* If the lhs shape is not the same as the rhs jump to setting the
9823 bounds and doing the reallocation....... */
9824 for (n
= 0; n
< expr1
->rank
; n
++)
9826 /* Check the shape. */
9827 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9828 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9829 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9830 gfc_array_index_type
,
9831 loop
->to
[n
], loop
->from
[n
]);
9832 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9833 gfc_array_index_type
,
9835 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9836 gfc_array_index_type
,
9838 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9840 tmp
, gfc_index_zero_node
);
9841 tmp
= build3_v (COND_EXPR
, cond
,
9842 build1_v (GOTO_EXPR
, jump_label1
),
9843 build_empty_stmt (input_location
));
9844 gfc_add_expr_to_block (&fblock
, tmp
);
9847 /* ....else jump past the (re)alloc code. */
9848 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9849 gfc_add_expr_to_block (&fblock
, tmp
);
9851 /* Add the label to start automatic (re)allocation. */
9852 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9853 gfc_add_expr_to_block (&fblock
, tmp
);
9855 /* If the lhs has not been allocated, its bounds will not have been
9856 initialized and so its size is set to zero. */
9857 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9858 gfc_init_block (&alloc_block
);
9859 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9860 gfc_init_block (&realloc_block
);
9861 gfc_add_modify (&realloc_block
, size1
,
9862 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9863 tmp
= build3_v (COND_EXPR
, cond_null
,
9864 gfc_finish_block (&alloc_block
),
9865 gfc_finish_block (&realloc_block
));
9866 gfc_add_expr_to_block (&fblock
, tmp
);
9868 /* Get the rhs size and fix it. */
9870 desc2
= rss
->info
->data
.array
.descriptor
;
9874 size2
= gfc_index_one_node
;
9875 for (n
= 0; n
< expr2
->rank
; n
++)
9877 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9878 gfc_array_index_type
,
9879 loop
->to
[n
], loop
->from
[n
]);
9880 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9881 gfc_array_index_type
,
9882 tmp
, gfc_index_one_node
);
9883 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9884 gfc_array_index_type
,
9887 size2
= gfc_evaluate_now (size2
, &fblock
);
9889 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9892 /* If the lhs is deferred length, assume that the element size
9893 changes and force a reallocation. */
9894 if (expr1
->ts
.deferred
)
9895 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
9897 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9899 /* Deallocation of allocatable components will have to occur on
9900 reallocation. Fix the old descriptor now. */
9901 if ((expr1
->ts
.type
== BT_DERIVED
)
9902 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9903 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9905 old_desc
= NULL_TREE
;
9907 /* Now modify the lhs descriptor and the associated scalarizer
9908 variables. F2003 7.4.1.3: "If variable is or becomes an
9909 unallocated allocatable variable, then it is allocated with each
9910 deferred type parameter equal to the corresponding type parameters
9911 of expr , with the shape of expr , and with each lower bound equal
9912 to the corresponding element of LBOUND(expr)."
9913 Reuse size1 to keep a dimension-by-dimension track of the
9914 stride of the new array. */
9915 size1
= gfc_index_one_node
;
9916 offset
= gfc_index_zero_node
;
9918 for (n
= 0; n
< expr2
->rank
; n
++)
9920 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9921 gfc_array_index_type
,
9922 loop
->to
[n
], loop
->from
[n
]);
9923 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9924 gfc_array_index_type
,
9925 tmp
, gfc_index_one_node
);
9927 lbound
= gfc_index_one_node
;
9932 lbd
= get_std_lbound (expr2
, desc2
, n
,
9933 as
->type
== AS_ASSUMED_SIZE
);
9934 ubound
= fold_build2_loc (input_location
,
9936 gfc_array_index_type
,
9938 ubound
= fold_build2_loc (input_location
,
9940 gfc_array_index_type
,
9945 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9948 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9951 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9954 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9956 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9957 gfc_array_index_type
,
9959 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9960 gfc_array_index_type
,
9962 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9963 gfc_array_index_type
,
9967 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9968 the array offset is saved and the info.offset is used for a
9969 running offset. Use the saved_offset instead. */
9970 tmp
= gfc_conv_descriptor_offset (desc
);
9971 gfc_add_modify (&fblock
, tmp
, offset
);
9972 if (linfo
->saved_offset
9973 && VAR_P (linfo
->saved_offset
))
9974 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9976 /* Now set the deltas for the lhs. */
9977 for (n
= 0; n
< expr1
->rank
; n
++)
9979 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9981 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9982 gfc_array_index_type
, tmp
,
9984 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9985 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9988 /* Get the new lhs size in bytes. */
9989 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9991 if (expr2
->ts
.deferred
)
9993 if (expr2
->ts
.u
.cl
->backend_decl
9994 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9995 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9997 tmp
= rss
->info
->string_length
;
10001 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10002 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10003 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10005 tmp
= concat_str_length (expr2
);
10006 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10008 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10011 gfc_init_se (&tmpse
, NULL
);
10012 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10013 gfc_charlen_type_node
);
10015 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10017 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10020 if (expr1
->ts
.u
.cl
->backend_decl
10021 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10022 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10024 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10026 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10028 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10029 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10030 gfc_array_index_type
, tmp
,
10031 expr1
->ts
.u
.cl
->backend_decl
);
10033 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10034 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10036 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10037 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10038 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10039 gfc_array_index_type
,
10041 size2
= fold_convert (size_type_node
, size2
);
10042 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10043 size2
, size_one_node
);
10044 size2
= gfc_evaluate_now (size2
, &fblock
);
10046 /* For deferred character length, the 'size' field of the dtype might
10047 have changed so set the dtype. */
10048 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10049 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10052 tmp
= gfc_conv_descriptor_dtype (desc
);
10053 if (expr2
->ts
.u
.cl
->backend_decl
)
10054 type
= gfc_typenode_for_spec (&expr2
->ts
);
10056 type
= gfc_typenode_for_spec (&expr1
->ts
);
10058 gfc_add_modify (&fblock
, tmp
,
10059 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10061 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10064 tmp
= gfc_conv_descriptor_dtype (desc
);
10065 type
= gfc_typenode_for_spec (&expr2
->ts
);
10066 gfc_add_modify (&fblock
, tmp
,
10067 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10068 /* Set the _len field as well... */
10069 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10070 if (expr2
->ts
.type
== BT_CHARACTER
)
10071 gfc_add_modify (&fblock
, tmp
,
10072 fold_convert (TREE_TYPE (tmp
),
10073 TYPE_SIZE_UNIT (type
)));
10075 gfc_add_modify (&fblock
, tmp
,
10076 build_int_cst (TREE_TYPE (tmp
), 0));
10077 /* ...and the vptr. */
10078 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10079 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10080 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10081 gfc_add_modify (&fblock
, tmp
, tmp2
);
10083 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10085 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10086 gfc_get_dtype (TREE_TYPE (desc
)));
10089 /* Realloc expression. Note that the scalarizer uses desc.data
10090 in the array reference - (*desc.data)[<element>]. */
10091 gfc_init_block (&realloc_block
);
10092 gfc_init_se (&caf_se
, NULL
);
10096 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10097 if (token
== NULL_TREE
)
10099 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10100 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10101 tmp
= build_fold_indirect_ref (tmp
);
10102 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10104 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10107 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10109 if ((expr1
->ts
.type
== BT_DERIVED
)
10110 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10112 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10114 gfc_add_expr_to_block (&realloc_block
, tmp
);
10119 tmp
= build_call_expr_loc (input_location
,
10120 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10121 fold_convert (pvoid_type_node
, array1
),
10123 gfc_conv_descriptor_data_set (&realloc_block
,
10128 tmp
= build_call_expr_loc (input_location
,
10129 gfor_fndecl_caf_deregister
, 5, token
,
10130 build_int_cst (integer_type_node
,
10131 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10132 null_pointer_node
, null_pointer_node
,
10133 integer_zero_node
);
10134 gfc_add_expr_to_block (&realloc_block
, tmp
);
10135 tmp
= build_call_expr_loc (input_location
,
10136 gfor_fndecl_caf_register
,
10138 build_int_cst (integer_type_node
,
10139 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10140 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10141 null_pointer_node
, null_pointer_node
,
10142 integer_zero_node
);
10143 gfc_add_expr_to_block (&realloc_block
, tmp
);
10146 if ((expr1
->ts
.type
== BT_DERIVED
)
10147 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10149 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10151 gfc_add_expr_to_block (&realloc_block
, tmp
);
10154 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10155 realloc_expr
= gfc_finish_block (&realloc_block
);
10157 /* Only reallocate if sizes are different. */
10158 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10159 build_empty_stmt (input_location
));
10160 realloc_expr
= tmp
;
10163 /* Malloc expression. */
10164 gfc_init_block (&alloc_block
);
10167 tmp
= build_call_expr_loc (input_location
,
10168 builtin_decl_explicit (BUILT_IN_MALLOC
),
10170 gfc_conv_descriptor_data_set (&alloc_block
,
10175 tmp
= build_call_expr_loc (input_location
,
10176 gfor_fndecl_caf_register
,
10178 build_int_cst (integer_type_node
,
10179 GFC_CAF_COARRAY_ALLOC
),
10180 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10181 null_pointer_node
, null_pointer_node
,
10182 integer_zero_node
);
10183 gfc_add_expr_to_block (&alloc_block
, tmp
);
10187 /* We already set the dtype in the case of deferred character
10188 length arrays and unlimited polymorphic arrays. */
10189 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10190 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10192 && !UNLIMITED_POLY (expr1
))
10194 tmp
= gfc_conv_descriptor_dtype (desc
);
10195 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10198 if ((expr1
->ts
.type
== BT_DERIVED
)
10199 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10201 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10203 gfc_add_expr_to_block (&alloc_block
, tmp
);
10205 alloc_expr
= gfc_finish_block (&alloc_block
);
10207 /* Malloc if not allocated; realloc otherwise. */
10208 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10209 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10212 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10213 gfc_add_expr_to_block (&fblock
, tmp
);
10215 /* Make sure that the scalarizer data pointer is updated. */
10216 if (linfo
->data
&& VAR_P (linfo
->data
))
10218 tmp
= gfc_conv_descriptor_data_get (desc
);
10219 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10222 /* Add the exit label. */
10223 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10224 gfc_add_expr_to_block (&fblock
, tmp
);
10226 return gfc_finish_block (&fblock
);
10230 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10231 Do likewise, recursively if necessary, with the allocatable components of
10235 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10241 stmtblock_t cleanup
;
10244 bool sym_has_alloc_comp
, has_finalizer
;
10246 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10247 || sym
->ts
.type
== BT_CLASS
)
10248 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10249 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10250 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10252 /* Make sure the frontend gets these right. */
10253 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10256 gfc_save_backend_locus (&loc
);
10257 gfc_set_backend_locus (&sym
->declared_at
);
10258 gfc_init_block (&init
);
10260 gcc_assert (VAR_P (sym
->backend_decl
)
10261 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10263 if (sym
->ts
.type
== BT_CHARACTER
10264 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10266 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10267 gfc_trans_vla_type_sizes (sym
, &init
);
10270 /* Dummy, use associated and result variables don't need anything special. */
10271 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10273 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10274 gfc_restore_backend_locus (&loc
);
10278 descriptor
= sym
->backend_decl
;
10280 /* Although static, derived types with default initializers and
10281 allocatable components must not be nulled wholesale; instead they
10282 are treated component by component. */
10283 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10285 /* SAVEd variables are not freed on exit. */
10286 gfc_trans_static_array_pointer (sym
);
10288 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10289 gfc_restore_backend_locus (&loc
);
10293 /* Get the descriptor type. */
10294 type
= TREE_TYPE (sym
->backend_decl
);
10296 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10297 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10299 if (!sym
->attr
.save
10300 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10302 if (sym
->value
== NULL
10303 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10305 rank
= sym
->as
? sym
->as
->rank
: 0;
10306 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10308 gfc_add_expr_to_block (&init
, tmp
);
10311 gfc_init_default_dt (sym
, &init
, false);
10314 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10316 /* If the backend_decl is not a descriptor, we must have a pointer
10318 descriptor
= build_fold_indirect_ref_loc (input_location
,
10319 sym
->backend_decl
);
10320 type
= TREE_TYPE (descriptor
);
10323 /* NULLIFY the data pointer, for non-saved allocatables. */
10324 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10326 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10327 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10329 /* Declare the variable static so its array descriptor stays present
10330 after leaving the scope. It may still be accessed through another
10331 image. This may happen, for example, with the caf_mpi
10333 TREE_STATIC (descriptor
) = 1;
10334 tmp
= gfc_conv_descriptor_token (descriptor
);
10335 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10336 null_pointer_node
));
10340 gfc_restore_backend_locus (&loc
);
10341 gfc_init_block (&cleanup
);
10343 /* Allocatable arrays need to be freed when they go out of scope.
10344 The allocatable components of pointers must not be touched. */
10345 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10346 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10347 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10350 sym
->attr
.referenced
= 1;
10351 e
= gfc_lval_expr_from_sym (sym
);
10352 gfc_add_finalizer_call (&cleanup
, e
);
10355 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10356 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10357 && !sym
->attr
.pointer
&& !sym
->attr
.save
10358 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10361 rank
= sym
->as
? sym
->as
->rank
: 0;
10362 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10363 gfc_add_expr_to_block (&cleanup
, tmp
);
10366 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10367 && !sym
->attr
.save
&& !sym
->attr
.result
10368 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10371 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10372 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10373 NULL_TREE
, NULL_TREE
, true, e
,
10374 sym
->attr
.codimension
10375 ? GFC_CAF_COARRAY_DEREGISTER
10376 : GFC_CAF_COARRAY_NOCOARRAY
);
10379 gfc_add_expr_to_block (&cleanup
, tmp
);
10382 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10383 gfc_finish_block (&cleanup
));
10386 /************ Expression Walking Functions ******************/
10388 /* Walk a variable reference.
10390 Possible extension - multiple component subscripts.
10391 x(:,:) = foo%a(:)%b(:)
10393 forall (i=..., j=...)
10394 x(i,j) = foo%a(j)%b(i)
10396 This adds a fair amount of complexity because you need to deal with more
10397 than one ref. Maybe handle in a similar manner to vector subscripts.
10398 Maybe not worth the effort. */
10402 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10406 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10407 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10410 return gfc_walk_array_ref (ss
, expr
, ref
);
10415 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10421 for (; ref
; ref
= ref
->next
)
10423 if (ref
->type
== REF_SUBSTRING
)
10425 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10426 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10429 /* We're only interested in array sections from now on. */
10430 if (ref
->type
!= REF_ARRAY
)
10438 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10439 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10443 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10444 newss
->info
->data
.array
.ref
= ref
;
10446 /* Make sure array is the same as array(:,:), this way
10447 we don't need to special case all the time. */
10448 ar
->dimen
= ar
->as
->rank
;
10449 for (n
= 0; n
< ar
->dimen
; n
++)
10451 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10453 gcc_assert (ar
->start
[n
] == NULL
);
10454 gcc_assert (ar
->end
[n
] == NULL
);
10455 gcc_assert (ar
->stride
[n
] == NULL
);
10461 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10462 newss
->info
->data
.array
.ref
= ref
;
10464 /* We add SS chains for all the subscripts in the section. */
10465 for (n
= 0; n
< ar
->dimen
; n
++)
10469 switch (ar
->dimen_type
[n
])
10471 case DIMEN_ELEMENT
:
10472 /* Add SS for elemental (scalar) subscripts. */
10473 gcc_assert (ar
->start
[n
]);
10474 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10475 indexss
->loop_chain
= gfc_ss_terminator
;
10476 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10480 /* We don't add anything for sections, just remember this
10481 dimension for later. */
10482 newss
->dim
[newss
->dimen
] = n
;
10487 /* Create a GFC_SS_VECTOR index in which we can store
10488 the vector's descriptor. */
10489 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10491 indexss
->loop_chain
= gfc_ss_terminator
;
10492 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10493 newss
->dim
[newss
->dimen
] = n
;
10498 /* We should know what sort of section it is by now. */
10499 gcc_unreachable ();
10502 /* We should have at least one non-elemental dimension,
10503 unless we are creating a descriptor for a (scalar) coarray. */
10504 gcc_assert (newss
->dimen
> 0
10505 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10510 /* We should know what sort of section it is by now. */
10511 gcc_unreachable ();
10519 /* Walk an expression operator. If only one operand of a binary expression is
10520 scalar, we must also add the scalar term to the SS chain. */
10523 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10528 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10529 if (expr
->value
.op
.op2
== NULL
)
10532 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10534 /* All operands are scalar. Pass back and let the caller deal with it. */
10538 /* All operands require scalarization. */
10539 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10542 /* One of the operands needs scalarization, the other is scalar.
10543 Create a gfc_ss for the scalar expression. */
10546 /* First operand is scalar. We build the chain in reverse order, so
10547 add the scalar SS after the second operand. */
10549 while (head
&& head
->next
!= ss
)
10551 /* Check we haven't somehow broken the chain. */
10553 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10555 else /* head2 == head */
10557 gcc_assert (head2
== head
);
10558 /* Second operand is scalar. */
10559 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10566 /* Reverse a SS chain. */
10569 gfc_reverse_ss (gfc_ss
* ss
)
10574 gcc_assert (ss
!= NULL
);
10576 head
= gfc_ss_terminator
;
10577 while (ss
!= gfc_ss_terminator
)
10580 /* Check we didn't somehow break the chain. */
10581 gcc_assert (next
!= NULL
);
10591 /* Given an expression referring to a procedure, return the symbol of its
10592 interface. We can't get the procedure symbol directly as we have to handle
10593 the case of (deferred) type-bound procedures. */
10596 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10601 if (procedure_ref
== NULL
)
10604 /* Normal procedure case. */
10605 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10606 && procedure_ref
->value
.function
.esym
)
10607 sym
= procedure_ref
->value
.function
.esym
;
10609 sym
= procedure_ref
->symtree
->n
.sym
;
10611 /* Typebound procedure case. */
10612 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10614 if (ref
->type
== REF_COMPONENT
10615 && ref
->u
.c
.component
->attr
.proc_pointer
)
10616 sym
= ref
->u
.c
.component
->ts
.interface
;
10625 /* Walk the arguments of an elemental function.
10626 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10627 it is NULL, we don't do the check and the argument is assumed to be present.
10631 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10632 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10634 gfc_formal_arglist
*dummy_arg
;
10640 head
= gfc_ss_terminator
;
10644 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10649 for (; arg
; arg
= arg
->next
)
10651 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10652 goto loop_continue
;
10654 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10657 /* Scalar argument. */
10658 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10659 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10660 newss
->info
->type
= type
;
10662 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10667 if (dummy_arg
!= NULL
10668 && dummy_arg
->sym
->attr
.optional
10669 && arg
->expr
->expr_type
== EXPR_VARIABLE
10670 && (gfc_expr_attr (arg
->expr
).optional
10671 || gfc_expr_attr (arg
->expr
).allocatable
10672 || gfc_expr_attr (arg
->expr
).pointer
))
10673 newss
->info
->can_be_null_ref
= true;
10679 while (tail
->next
!= gfc_ss_terminator
)
10684 if (dummy_arg
!= NULL
)
10685 dummy_arg
= dummy_arg
->next
;
10690 /* If all the arguments are scalar we don't need the argument SS. */
10691 gfc_free_ss_chain (head
);
10692 /* Pass it back. */
10696 /* Add it onto the existing chain. */
10702 /* Walk a function call. Scalar functions are passed back, and taken out of
10703 scalarization loops. For elemental functions we walk their arguments.
10704 The result of functions returning arrays is stored in a temporary outside
10705 the loop, so that the function is only called once. Hence we do not need
10706 to walk their arguments. */
10709 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10711 gfc_intrinsic_sym
*isym
;
10713 gfc_component
*comp
= NULL
;
10715 isym
= expr
->value
.function
.isym
;
10717 /* Handle intrinsic functions separately. */
10719 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10721 sym
= expr
->value
.function
.esym
;
10723 sym
= expr
->symtree
->n
.sym
;
10725 if (gfc_is_class_array_function (expr
))
10726 return gfc_get_array_ss (ss
, expr
,
10727 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10730 /* A function that returns arrays. */
10731 comp
= gfc_get_proc_ptr_comp (expr
);
10732 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10733 || (comp
&& comp
->attr
.dimension
))
10734 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10736 /* Walk the parameters of an elemental function. For now we always pass
10738 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10740 gfc_ss
*old_ss
= ss
;
10742 ss
= gfc_walk_elemental_function_args (old_ss
,
10743 expr
->value
.function
.actual
,
10744 gfc_get_proc_ifc_for_expr (expr
),
10748 || sym
->attr
.proc_pointer
10749 || sym
->attr
.if_source
!= IFSRC_DECL
10750 || sym
->attr
.array_outer_dependency
))
10751 ss
->info
->array_outer_dependency
= 1;
10754 /* Scalar functions are OK as these are evaluated outside the scalarization
10755 loop. Pass back and let the caller deal with it. */
10760 /* An array temporary is constructed for array constructors. */
10763 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10765 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10769 /* Walk an expression. Add walked expressions to the head of the SS chain.
10770 A wholly scalar expression will not be added. */
10773 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10777 switch (expr
->expr_type
)
10779 case EXPR_VARIABLE
:
10780 head
= gfc_walk_variable_expr (ss
, expr
);
10784 head
= gfc_walk_op_expr (ss
, expr
);
10787 case EXPR_FUNCTION
:
10788 head
= gfc_walk_function_expr (ss
, expr
);
10791 case EXPR_CONSTANT
:
10793 case EXPR_STRUCTURE
:
10794 /* Pass back and let the caller deal with it. */
10798 head
= gfc_walk_array_constructor (ss
, expr
);
10801 case EXPR_SUBSTRING
:
10802 /* Pass back and let the caller deal with it. */
10806 gfc_internal_error ("bad expression type during walk (%d)",
10813 /* Entry point for expression walking.
10814 A return value equal to the passed chain means this is
10815 a scalar expression. It is up to the caller to take whatever action is
10816 necessary to translate these. */
10819 gfc_walk_expr (gfc_expr
* expr
)
10823 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10824 return gfc_reverse_ss (res
);