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. */
853 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
854 tmp
= fold_convert (gfc_array_index_type
,
855 size_in_bytes (tmp
));
861 /* Generate an initializer for a static pointer or allocatable array. */
864 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
868 gcc_assert (TREE_STATIC (sym
->backend_decl
));
869 /* Just zero the data member. */
870 type
= TREE_TYPE (sym
->backend_decl
);
871 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
875 /* If the bounds of SE's loop have not yet been set, see if they can be
876 determined from array spec AS, which is the array spec of a called
877 function. MAPPING maps the callee's dummy arguments to the values
878 that the caller is passing. Add any initialization and finalization
882 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
883 gfc_se
* se
, gfc_array_spec
* as
)
885 int n
, dim
, total_dim
;
894 if (!as
|| as
->type
!= AS_EXPLICIT
)
897 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
899 total_dim
+= ss
->loop
->dimen
;
900 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
902 /* The bound is known, nothing to do. */
903 if (ss
->loop
->to
[n
] != NULL_TREE
)
907 gcc_assert (dim
< as
->rank
);
908 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
910 /* Evaluate the lower bound. */
911 gfc_init_se (&tmpse
, NULL
);
912 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
913 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
914 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
915 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
917 /* ...and the upper bound. */
918 gfc_init_se (&tmpse
, NULL
);
919 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
920 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
921 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
922 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
924 /* Set the upper bound of the loop to UPPER - LOWER. */
925 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
926 gfc_array_index_type
, upper
, lower
);
927 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
928 ss
->loop
->to
[n
] = tmp
;
932 gcc_assert (total_dim
== as
->rank
);
936 /* Generate code to allocate an array temporary, or create a variable to
937 hold the data. If size is NULL, zero the descriptor so that the
938 callee will allocate the array. If DEALLOC is true, also generate code to
939 free the array afterwards.
941 If INITIAL is not NULL, it is packed using internal_pack and the result used
942 as data instead of allocating a fresh, unitialized area of memory.
944 Initialization code is added to PRE and finalization code to POST.
945 DYNAMIC is true if the caller may want to extend the array later
946 using realloc. This prevents us from putting the array on the stack. */
949 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
950 gfc_array_info
* info
, tree size
, tree nelem
,
951 tree initial
, bool dynamic
, bool dealloc
)
957 desc
= info
->descriptor
;
958 info
->offset
= gfc_index_zero_node
;
959 if (size
== NULL_TREE
|| integer_zerop (size
))
961 /* A callee allocated array. */
962 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
967 /* Allocate the temporary. */
968 onstack
= !dynamic
&& initial
== NULL_TREE
969 && (flag_stack_arrays
970 || gfc_can_put_var_on_stack (size
));
974 /* Make a temporary variable to hold the data. */
975 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
976 nelem
, gfc_index_one_node
);
977 tmp
= gfc_evaluate_now (tmp
, pre
);
978 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
980 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
982 tmp
= gfc_create_var (tmp
, "A");
983 /* If we're here only because of -fstack-arrays we have to
984 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
985 if (!gfc_can_put_var_on_stack (size
))
986 gfc_add_expr_to_block (pre
,
987 fold_build1_loc (input_location
,
988 DECL_EXPR
, TREE_TYPE (tmp
),
990 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
991 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
995 /* Allocate memory to hold the data or call internal_pack. */
996 if (initial
== NULL_TREE
)
998 tmp
= gfc_call_malloc (pre
, NULL
, size
);
999 tmp
= gfc_evaluate_now (tmp
, pre
);
1006 stmtblock_t do_copying
;
1008 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1009 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1010 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1011 tmp
= gfc_get_element_type (tmp
);
1012 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1013 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1015 tmp
= build_call_expr_loc (input_location
,
1016 gfor_fndecl_in_pack
, 1, initial
);
1017 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1018 gfc_add_modify (pre
, packed
, tmp
);
1020 tmp
= build_fold_indirect_ref_loc (input_location
,
1022 source_data
= gfc_conv_descriptor_data_get (tmp
);
1024 /* internal_pack may return source->data without any allocation
1025 or copying if it is already packed. If that's the case, we
1026 need to allocate and copy manually. */
1028 gfc_start_block (&do_copying
);
1029 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1030 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1031 gfc_add_modify (&do_copying
, packed
, tmp
);
1032 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1033 gfc_add_expr_to_block (&do_copying
, tmp
);
1035 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1036 logical_type_node
, packed
,
1038 tmp
= gfc_finish_block (&do_copying
);
1039 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1040 build_empty_stmt (input_location
));
1041 gfc_add_expr_to_block (pre
, tmp
);
1043 tmp
= fold_convert (pvoid_type_node
, packed
);
1046 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1049 info
->data
= gfc_conv_descriptor_data_get (desc
);
1051 /* The offset is zero because we create temporaries with a zero
1053 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1055 if (dealloc
&& !onstack
)
1057 /* Free the temporary. */
1058 tmp
= gfc_conv_descriptor_data_get (desc
);
1059 tmp
= gfc_call_free (tmp
);
1060 gfc_add_expr_to_block (post
, tmp
);
1065 /* Get the scalarizer array dimension corresponding to actual array dimension
1068 For example, if SS represents the array ref a(1,:,:,1), it is a
1069 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1070 and 1 for ARRAY_DIM=2.
1071 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1072 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1074 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1075 array. If called on the inner ss, the result would be respectively 0,1,2 for
1076 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1077 for ARRAY_DIM=1,2. */
1080 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1087 for (; ss
; ss
= ss
->parent
)
1088 for (n
= 0; n
< ss
->dimen
; n
++)
1089 if (ss
->dim
[n
] < array_dim
)
1092 return array_ref_dim
;
1097 innermost_ss (gfc_ss
*ss
)
1099 while (ss
->nested_ss
!= NULL
)
1107 /* Get the array reference dimension corresponding to the given loop dimension.
1108 It is different from the true array dimension given by the dim array in
1109 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1110 It is different from the loop dimension in the case of a transposed array.
1114 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1116 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1121 /* Generate code to create and initialize the descriptor for a temporary
1122 array. This is used for both temporaries needed by the scalarizer, and
1123 functions returning arrays. Adjusts the loop variables to be
1124 zero-based, and calculates the loop bounds for callee allocated arrays.
1125 Allocate the array unless it's callee allocated (we have a callee
1126 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1127 NULL_TREE for any n). Also fills in the descriptor, data and offset
1128 fields of info if known. Returns the size of the array, or NULL for a
1129 callee allocated array.
1131 'eltype' == NULL signals that the temporary should be a class object.
1132 The 'initial' expression is used to obtain the size of the dynamic
1133 type; otherwise the allocation and initialization proceeds as for any
1136 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1137 gfc_trans_allocate_array_storage. */
1140 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1141 tree eltype
, tree initial
, bool dynamic
,
1142 bool dealloc
, bool callee_alloc
, locus
* where
)
1146 gfc_array_info
*info
;
1147 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1155 tree class_expr
= NULL_TREE
;
1156 int n
, dim
, tmp_dim
;
1159 /* This signals a class array for which we need the size of the
1160 dynamic type. Generate an eltype and then the class expression. */
1161 if (eltype
== NULL_TREE
&& initial
)
1163 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1164 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1165 eltype
= TREE_TYPE (class_expr
);
1166 eltype
= gfc_get_element_type (eltype
);
1167 /* Obtain the structure (class) expression. */
1168 class_expr
= TREE_OPERAND (class_expr
, 0);
1169 gcc_assert (class_expr
);
1172 memset (from
, 0, sizeof (from
));
1173 memset (to
, 0, sizeof (to
));
1175 info
= &ss
->info
->data
.array
;
1177 gcc_assert (ss
->dimen
> 0);
1178 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1180 if (warn_array_temporaries
&& where
)
1181 gfc_warning (OPT_Warray_temporaries
,
1182 "Creating array temporary at %L", where
);
1184 /* Set the lower bound to zero. */
1185 for (s
= ss
; s
; s
= s
->parent
)
1189 total_dim
+= loop
->dimen
;
1190 for (n
= 0; n
< loop
->dimen
; n
++)
1194 /* Callee allocated arrays may not have a known bound yet. */
1196 loop
->to
[n
] = gfc_evaluate_now (
1197 fold_build2_loc (input_location
, MINUS_EXPR
,
1198 gfc_array_index_type
,
1199 loop
->to
[n
], loop
->from
[n
]),
1201 loop
->from
[n
] = gfc_index_zero_node
;
1203 /* We have just changed the loop bounds, we must clear the
1204 corresponding specloop, so that delta calculation is not skipped
1205 later in gfc_set_delta. */
1206 loop
->specloop
[n
] = NULL
;
1208 /* We are constructing the temporary's descriptor based on the loop
1209 dimensions. As the dimensions may be accessed in arbitrary order
1210 (think of transpose) the size taken from the n'th loop may not map
1211 to the n'th dimension of the array. We need to reconstruct loop
1212 infos in the right order before using it to set the descriptor
1214 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1215 from
[tmp_dim
] = loop
->from
[n
];
1216 to
[tmp_dim
] = loop
->to
[n
];
1218 info
->delta
[dim
] = gfc_index_zero_node
;
1219 info
->start
[dim
] = gfc_index_zero_node
;
1220 info
->end
[dim
] = gfc_index_zero_node
;
1221 info
->stride
[dim
] = gfc_index_one_node
;
1225 /* Initialize the descriptor. */
1227 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1228 GFC_ARRAY_UNKNOWN
, true);
1229 desc
= gfc_create_var (type
, "atmp");
1230 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1232 info
->descriptor
= desc
;
1233 size
= gfc_index_one_node
;
1235 /* Emit a DECL_EXPR for the variable sized array type in
1236 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1237 sizes works correctly. */
1238 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1239 if (! TYPE_NAME (arraytype
))
1240 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1241 NULL_TREE
, arraytype
);
1242 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1243 arraytype
, TYPE_NAME (arraytype
)));
1245 /* Fill in the array dtype. */
1246 tmp
= gfc_conv_descriptor_dtype (desc
);
1247 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1250 Fill in the bounds and stride. This is a packed array, so:
1253 for (n = 0; n < rank; n++)
1256 delta = ubound[n] + 1 - lbound[n];
1257 size = size * delta;
1259 size = size * sizeof(element);
1262 or_expr
= NULL_TREE
;
1264 /* If there is at least one null loop->to[n], it is a callee allocated
1266 for (n
= 0; n
< total_dim
; n
++)
1267 if (to
[n
] == NULL_TREE
)
1273 if (size
== NULL_TREE
)
1274 for (s
= ss
; s
; s
= s
->parent
)
1275 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1277 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1279 /* For a callee allocated array express the loop bounds in terms
1280 of the descriptor fields. */
1281 tmp
= fold_build2_loc (input_location
,
1282 MINUS_EXPR
, gfc_array_index_type
,
1283 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1284 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1285 s
->loop
->to
[n
] = tmp
;
1289 for (n
= 0; n
< total_dim
; n
++)
1291 /* Store the stride and bound components in the descriptor. */
1292 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1294 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1295 gfc_index_zero_node
);
1297 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1299 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1300 gfc_array_index_type
,
1301 to
[n
], gfc_index_one_node
);
1303 /* Check whether the size for this dimension is negative. */
1304 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1305 tmp
, gfc_index_zero_node
);
1306 cond
= gfc_evaluate_now (cond
, pre
);
1311 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1312 logical_type_node
, or_expr
, cond
);
1314 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1315 gfc_array_index_type
, size
, tmp
);
1316 size
= gfc_evaluate_now (size
, pre
);
1320 /* Get the size of the array. */
1321 if (size
&& !callee_alloc
)
1324 /* If or_expr is true, then the extent in at least one
1325 dimension is zero and the size is set to zero. */
1326 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1327 or_expr
, gfc_index_zero_node
, size
);
1330 if (class_expr
== NULL_TREE
)
1331 elemsize
= fold_convert (gfc_array_index_type
,
1332 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1334 elemsize
= gfc_class_vtab_size_get (class_expr
);
1336 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1345 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1351 if (ss
->dimen
> ss
->loop
->temp_dim
)
1352 ss
->loop
->temp_dim
= ss
->dimen
;
1358 /* Return the number of iterations in a loop that starts at START,
1359 ends at END, and has step STEP. */
1362 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1367 type
= TREE_TYPE (step
);
1368 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1369 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1370 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1371 build_int_cst (type
, 1));
1372 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1373 build_int_cst (type
, 0));
1374 return fold_convert (gfc_array_index_type
, tmp
);
1378 /* Extend the data in array DESC by EXTRA elements. */
1381 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1388 if (integer_zerop (extra
))
1391 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1393 /* Add EXTRA to the upper bound. */
1394 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1396 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1398 /* Get the value of the current data pointer. */
1399 arg0
= gfc_conv_descriptor_data_get (desc
);
1401 /* Calculate the new array size. */
1402 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1403 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1404 ubound
, gfc_index_one_node
);
1405 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1406 fold_convert (size_type_node
, tmp
),
1407 fold_convert (size_type_node
, size
));
1409 /* Call the realloc() function. */
1410 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1411 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1415 /* Return true if the bounds of iterator I can only be determined
1419 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1421 return (i
->start
->expr_type
!= EXPR_CONSTANT
1422 || i
->end
->expr_type
!= EXPR_CONSTANT
1423 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1427 /* Split the size of constructor element EXPR into the sum of two terms,
1428 one of which can be determined at compile time and one of which must
1429 be calculated at run time. Set *SIZE to the former and return true
1430 if the latter might be nonzero. */
1433 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1435 if (expr
->expr_type
== EXPR_ARRAY
)
1436 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1437 else if (expr
->rank
> 0)
1439 /* Calculate everything at run time. */
1440 mpz_set_ui (*size
, 0);
1445 /* A single element. */
1446 mpz_set_ui (*size
, 1);
1452 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1453 of array constructor C. */
1456 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1464 mpz_set_ui (*size
, 0);
1469 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1472 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1476 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1479 /* Multiply the static part of the element size by the
1480 number of iterations. */
1481 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1482 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1483 mpz_add_ui (val
, val
, 1);
1484 if (mpz_sgn (val
) > 0)
1485 mpz_mul (len
, len
, val
);
1487 mpz_set_ui (len
, 0);
1489 mpz_add (*size
, *size
, len
);
1498 /* Make sure offset is a variable. */
1501 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1504 /* We should have already created the offset variable. We cannot
1505 create it here because we may be in an inner scope. */
1506 gcc_assert (*offsetvar
!= NULL_TREE
);
1507 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1508 *poffset
= *offsetvar
;
1509 TREE_USED (*offsetvar
) = 1;
1513 /* Variables needed for bounds-checking. */
1514 static bool first_len
;
1515 static tree first_len_val
;
1516 static bool typespec_chararray_ctor
;
1519 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1520 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1524 gfc_conv_expr (se
, expr
);
1526 /* Store the value. */
1527 tmp
= build_fold_indirect_ref_loc (input_location
,
1528 gfc_conv_descriptor_data_get (desc
));
1529 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1531 if (expr
->ts
.type
== BT_CHARACTER
)
1533 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1536 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1537 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1538 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1539 TREE_TYPE (esize
), esize
,
1540 build_int_cst (TREE_TYPE (esize
),
1541 gfc_character_kinds
[i
].bit_size
/ 8));
1543 gfc_conv_string_parameter (se
);
1544 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1546 /* The temporary is an array of pointers. */
1547 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1548 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1552 /* The temporary is an array of string values. */
1553 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1554 /* We know the temporary and the value will be the same length,
1555 so can use memcpy. */
1556 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1557 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1559 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1563 gfc_add_modify (&se
->pre
, first_len_val
,
1564 fold_convert (TREE_TYPE (first_len_val
),
1565 se
->string_length
));
1570 /* Verify that all constructor elements are of the same
1572 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1574 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1575 logical_type_node
, first_len_val
,
1577 gfc_trans_runtime_check
1578 (true, false, cond
, &se
->pre
, &expr
->where
,
1579 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1580 fold_convert (long_integer_type_node
, first_len_val
),
1581 fold_convert (long_integer_type_node
, se
->string_length
));
1585 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1586 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1588 /* Assignment of a CLASS array constructor to a derived type array. */
1589 if (expr
->expr_type
== EXPR_FUNCTION
)
1590 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1591 se
->expr
= gfc_class_data_get (se
->expr
);
1592 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1593 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1594 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1598 /* TODO: Should the frontend already have done this conversion? */
1599 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1600 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1603 gfc_add_block_to_block (pblock
, &se
->pre
);
1604 gfc_add_block_to_block (pblock
, &se
->post
);
1608 /* Add the contents of an array to the constructor. DYNAMIC is as for
1609 gfc_trans_array_constructor_value. */
1612 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1613 tree type ATTRIBUTE_UNUSED
,
1614 tree desc
, gfc_expr
* expr
,
1615 tree
* poffset
, tree
* offsetvar
,
1626 /* We need this to be a variable so we can increment it. */
1627 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1629 gfc_init_se (&se
, NULL
);
1631 /* Walk the array expression. */
1632 ss
= gfc_walk_expr (expr
);
1633 gcc_assert (ss
!= gfc_ss_terminator
);
1635 /* Initialize the scalarizer. */
1636 gfc_init_loopinfo (&loop
);
1637 gfc_add_ss_to_loop (&loop
, ss
);
1639 /* Initialize the loop. */
1640 gfc_conv_ss_startstride (&loop
);
1641 gfc_conv_loop_setup (&loop
, &expr
->where
);
1643 /* Make sure the constructed array has room for the new data. */
1646 /* Set SIZE to the total number of elements in the subarray. */
1647 size
= gfc_index_one_node
;
1648 for (n
= 0; n
< loop
.dimen
; n
++)
1650 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1651 gfc_index_one_node
);
1652 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1653 gfc_array_index_type
, size
, tmp
);
1656 /* Grow the constructed array by SIZE elements. */
1657 gfc_grow_array (&loop
.pre
, desc
, size
);
1660 /* Make the loop body. */
1661 gfc_mark_ss_chain_used (ss
, 1);
1662 gfc_start_scalarized_body (&loop
, &body
);
1663 gfc_copy_loopinfo_to_se (&se
, &loop
);
1666 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1667 gcc_assert (se
.ss
== gfc_ss_terminator
);
1669 /* Increment the offset. */
1670 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1671 *poffset
, gfc_index_one_node
);
1672 gfc_add_modify (&body
, *poffset
, tmp
);
1674 /* Finish the loop. */
1675 gfc_trans_scalarizing_loops (&loop
, &body
);
1676 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1677 tmp
= gfc_finish_block (&loop
.pre
);
1678 gfc_add_expr_to_block (pblock
, tmp
);
1680 gfc_cleanup_loop (&loop
);
1684 /* Assign the values to the elements of an array constructor. DYNAMIC
1685 is true if descriptor DESC only contains enough data for the static
1686 size calculated by gfc_get_array_constructor_size. When true, memory
1687 for the dynamic parts must be allocated using realloc. */
1690 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1691 tree desc
, gfc_constructor_base base
,
1692 tree
* poffset
, tree
* offsetvar
,
1696 tree start
= NULL_TREE
;
1697 tree end
= NULL_TREE
;
1698 tree step
= NULL_TREE
;
1704 tree shadow_loopvar
= NULL_TREE
;
1705 gfc_saved_var saved_loopvar
;
1708 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1710 /* If this is an iterator or an array, the offset must be a variable. */
1711 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1712 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1714 /* Shadowing the iterator avoids changing its value and saves us from
1715 keeping track of it. Further, it makes sure that there's always a
1716 backend-decl for the symbol, even if there wasn't one before,
1717 e.g. in the case of an iterator that appears in a specification
1718 expression in an interface mapping. */
1724 /* Evaluate loop bounds before substituting the loop variable
1725 in case they depend on it. Such a case is invalid, but it is
1726 not more expensive to do the right thing here.
1728 gfc_init_se (&se
, NULL
);
1729 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1730 gfc_add_block_to_block (pblock
, &se
.pre
);
1731 start
= gfc_evaluate_now (se
.expr
, pblock
);
1733 gfc_init_se (&se
, NULL
);
1734 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1735 gfc_add_block_to_block (pblock
, &se
.pre
);
1736 end
= gfc_evaluate_now (se
.expr
, pblock
);
1738 gfc_init_se (&se
, NULL
);
1739 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1740 gfc_add_block_to_block (pblock
, &se
.pre
);
1741 step
= gfc_evaluate_now (se
.expr
, pblock
);
1743 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1744 type
= gfc_typenode_for_spec (&sym
->ts
);
1746 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1747 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1750 gfc_start_block (&body
);
1752 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1754 /* Array constructors can be nested. */
1755 gfc_trans_array_constructor_value (&body
, type
, desc
,
1756 c
->expr
->value
.constructor
,
1757 poffset
, offsetvar
, dynamic
);
1759 else if (c
->expr
->rank
> 0)
1761 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1762 poffset
, offsetvar
, dynamic
);
1766 /* This code really upsets the gimplifier so don't bother for now. */
1773 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1775 p
= gfc_constructor_next (p
);
1780 /* Scalar values. */
1781 gfc_init_se (&se
, NULL
);
1782 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1785 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1786 gfc_array_index_type
,
1787 *poffset
, gfc_index_one_node
);
1791 /* Collect multiple scalar constants into a constructor. */
1792 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1796 HOST_WIDE_INT idx
= 0;
1799 /* Count the number of consecutive scalar constants. */
1800 while (p
&& !(p
->iterator
1801 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1803 gfc_init_se (&se
, NULL
);
1804 gfc_conv_constant (&se
, p
->expr
);
1806 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1807 se
.expr
= fold_convert (type
, se
.expr
);
1808 /* For constant character array constructors we build
1809 an array of pointers. */
1810 else if (POINTER_TYPE_P (type
))
1811 se
.expr
= gfc_build_addr_expr
1812 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1815 CONSTRUCTOR_APPEND_ELT (v
,
1816 build_int_cst (gfc_array_index_type
,
1820 p
= gfc_constructor_next (p
);
1823 bound
= size_int (n
- 1);
1824 /* Create an array type to hold them. */
1825 tmptype
= build_range_type (gfc_array_index_type
,
1826 gfc_index_zero_node
, bound
);
1827 tmptype
= build_array_type (type
, tmptype
);
1829 init
= build_constructor (tmptype
, v
);
1830 TREE_CONSTANT (init
) = 1;
1831 TREE_STATIC (init
) = 1;
1832 /* Create a static variable to hold the data. */
1833 tmp
= gfc_create_var (tmptype
, "data");
1834 TREE_STATIC (tmp
) = 1;
1835 TREE_CONSTANT (tmp
) = 1;
1836 TREE_READONLY (tmp
) = 1;
1837 DECL_INITIAL (tmp
) = init
;
1840 /* Use BUILTIN_MEMCPY to assign the values. */
1841 tmp
= gfc_conv_descriptor_data_get (desc
);
1842 tmp
= build_fold_indirect_ref_loc (input_location
,
1844 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1845 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1846 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1848 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1849 bound
= build_int_cst (size_type_node
, n
* size
);
1850 tmp
= build_call_expr_loc (input_location
,
1851 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1852 3, tmp
, init
, bound
);
1853 gfc_add_expr_to_block (&body
, tmp
);
1855 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1856 gfc_array_index_type
, *poffset
,
1857 build_int_cst (gfc_array_index_type
, n
));
1859 if (!INTEGER_CST_P (*poffset
))
1861 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1862 *poffset
= *offsetvar
;
1866 /* The frontend should already have done any expansions
1870 /* Pass the code as is. */
1871 tmp
= gfc_finish_block (&body
);
1872 gfc_add_expr_to_block (pblock
, tmp
);
1876 /* Build the implied do-loop. */
1877 stmtblock_t implied_do_block
;
1883 loopbody
= gfc_finish_block (&body
);
1885 /* Create a new block that holds the implied-do loop. A temporary
1886 loop-variable is used. */
1887 gfc_start_block(&implied_do_block
);
1889 /* Initialize the loop. */
1890 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1892 /* If this array expands dynamically, and the number of iterations
1893 is not constant, we won't have allocated space for the static
1894 part of C->EXPR's size. Do that now. */
1895 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1897 /* Get the number of iterations. */
1898 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1900 /* Get the static part of C->EXPR's size. */
1901 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1902 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1904 /* Grow the array by TMP * TMP2 elements. */
1905 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1906 gfc_array_index_type
, tmp
, tmp2
);
1907 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1910 /* Generate the loop body. */
1911 exit_label
= gfc_build_label_decl (NULL_TREE
);
1912 gfc_start_block (&body
);
1914 /* Generate the exit condition. Depending on the sign of
1915 the step variable we have to generate the correct
1917 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1918 step
, build_int_cst (TREE_TYPE (step
), 0));
1919 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1920 logical_type_node
, tmp
,
1921 fold_build2_loc (input_location
, GT_EXPR
,
1922 logical_type_node
, shadow_loopvar
, end
),
1923 fold_build2_loc (input_location
, LT_EXPR
,
1924 logical_type_node
, shadow_loopvar
, end
));
1925 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1926 TREE_USED (exit_label
) = 1;
1927 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1928 build_empty_stmt (input_location
));
1929 gfc_add_expr_to_block (&body
, tmp
);
1931 /* The main loop body. */
1932 gfc_add_expr_to_block (&body
, loopbody
);
1934 /* Increase loop variable by step. */
1935 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1936 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1938 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1940 /* Finish the loop. */
1941 tmp
= gfc_finish_block (&body
);
1942 tmp
= build1_v (LOOP_EXPR
, tmp
);
1943 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1945 /* Add the exit label. */
1946 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1947 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1949 /* Finish the implied-do loop. */
1950 tmp
= gfc_finish_block(&implied_do_block
);
1951 gfc_add_expr_to_block(pblock
, tmp
);
1953 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1960 /* The array constructor code can create a string length with an operand
1961 in the form of a temporary variable. This variable will retain its
1962 context (current_function_decl). If we store this length tree in a
1963 gfc_charlen structure which is shared by a variable in another
1964 context, the resulting gfc_charlen structure with a variable in a
1965 different context, we could trip the assertion in expand_expr_real_1
1966 when it sees that a variable has been created in one context and
1967 referenced in another.
1969 If this might be the case, we create a new gfc_charlen structure and
1970 link it into the current namespace. */
1973 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1977 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1980 (*clp
)->backend_decl
= len
;
1983 /* A catch-all to obtain the string length for anything that is not
1984 a substring of non-constant length, a constant, array or variable. */
1987 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1991 /* Don't bother if we already know the length is a constant. */
1992 if (*len
&& INTEGER_CST_P (*len
))
1995 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1996 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1999 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2000 *len
= e
->ts
.u
.cl
->backend_decl
;
2004 /* Otherwise, be brutal even if inefficient. */
2005 gfc_init_se (&se
, NULL
);
2007 /* No function call, in case of side effects. */
2008 se
.no_function_call
= 1;
2010 gfc_conv_expr (&se
, e
);
2012 gfc_conv_expr_descriptor (&se
, e
);
2014 /* Fix the value. */
2015 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2017 gfc_add_block_to_block (block
, &se
.pre
);
2018 gfc_add_block_to_block (block
, &se
.post
);
2020 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2025 /* Figure out the string length of a variable reference expression.
2026 Used by get_array_ctor_strlen. */
2029 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2035 /* Don't bother if we already know the length is a constant. */
2036 if (*len
&& INTEGER_CST_P (*len
))
2039 ts
= &expr
->symtree
->n
.sym
->ts
;
2040 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2045 /* Array references don't change the string length. */
2049 /* Use the length of the component. */
2050 ts
= &ref
->u
.c
.component
->ts
;
2054 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2055 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2057 /* Note that this might evaluate expr. */
2058 get_array_ctor_all_strlen (block
, expr
, len
);
2061 mpz_init_set_ui (char_len
, 1);
2062 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2063 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2064 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2065 mpz_clear (char_len
);
2073 *len
= ts
->u
.cl
->backend_decl
;
2077 /* Figure out the string length of a character array constructor.
2078 If len is NULL, don't calculate the length; this happens for recursive calls
2079 when a sub-array-constructor is an element but not at the first position,
2080 so when we're not interested in the length.
2081 Returns TRUE if all elements are character constants. */
2084 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2091 if (gfc_constructor_first (base
) == NULL
)
2094 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2098 /* Loop over all constructor elements to find out is_const, but in len we
2099 want to store the length of the first, not the last, element. We can
2100 of course exit the loop as soon as is_const is found to be false. */
2101 for (c
= gfc_constructor_first (base
);
2102 c
&& is_const
; c
= gfc_constructor_next (c
))
2104 switch (c
->expr
->expr_type
)
2107 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2108 *len
= build_int_cstu (gfc_charlen_type_node
,
2109 c
->expr
->value
.character
.length
);
2113 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2120 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2126 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2130 /* After the first iteration, we don't want the length modified. */
2137 /* Check whether the array constructor C consists entirely of constant
2138 elements, and if so returns the number of those elements, otherwise
2139 return zero. Note, an empty or NULL array constructor returns zero. */
2141 unsigned HOST_WIDE_INT
2142 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2144 unsigned HOST_WIDE_INT nelem
= 0;
2146 gfc_constructor
*c
= gfc_constructor_first (base
);
2150 || c
->expr
->rank
> 0
2151 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2153 c
= gfc_constructor_next (c
);
2160 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2161 and the tree type of it's elements, TYPE, return a static constant
2162 variable that is compile-time initialized. */
2165 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2167 tree tmptype
, init
, tmp
;
2168 HOST_WIDE_INT nelem
;
2173 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2175 /* First traverse the constructor list, converting the constants
2176 to tree to build an initializer. */
2178 c
= gfc_constructor_first (expr
->value
.constructor
);
2181 gfc_init_se (&se
, NULL
);
2182 gfc_conv_constant (&se
, c
->expr
);
2183 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2184 se
.expr
= fold_convert (type
, se
.expr
);
2185 else if (POINTER_TYPE_P (type
))
2186 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2188 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2190 c
= gfc_constructor_next (c
);
2194 /* Next determine the tree type for the array. We use the gfortran
2195 front-end's gfc_get_nodesc_array_type in order to create a suitable
2196 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2198 memset (&as
, 0, sizeof (gfc_array_spec
));
2200 as
.rank
= expr
->rank
;
2201 as
.type
= AS_EXPLICIT
;
2204 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2205 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2209 for (i
= 0; i
< expr
->rank
; i
++)
2211 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2212 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2213 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2217 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2219 /* as is not needed anymore. */
2220 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2222 gfc_free_expr (as
.lower
[i
]);
2223 gfc_free_expr (as
.upper
[i
]);
2226 init
= build_constructor (tmptype
, v
);
2228 TREE_CONSTANT (init
) = 1;
2229 TREE_STATIC (init
) = 1;
2231 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2233 DECL_ARTIFICIAL (tmp
) = 1;
2234 DECL_IGNORED_P (tmp
) = 1;
2235 TREE_STATIC (tmp
) = 1;
2236 TREE_CONSTANT (tmp
) = 1;
2237 TREE_READONLY (tmp
) = 1;
2238 DECL_INITIAL (tmp
) = init
;
2245 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2246 This mostly initializes the scalarizer state info structure with the
2247 appropriate values to directly use the array created by the function
2248 gfc_build_constant_array_constructor. */
2251 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2253 gfc_array_info
*info
;
2257 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2259 info
= &ss
->info
->data
.array
;
2261 info
->descriptor
= tmp
;
2262 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2263 info
->offset
= gfc_index_zero_node
;
2265 for (i
= 0; i
< ss
->dimen
; i
++)
2267 info
->delta
[i
] = gfc_index_zero_node
;
2268 info
->start
[i
] = gfc_index_zero_node
;
2269 info
->end
[i
] = gfc_index_zero_node
;
2270 info
->stride
[i
] = gfc_index_one_node
;
2276 get_rank (gfc_loopinfo
*loop
)
2281 for (; loop
; loop
= loop
->parent
)
2282 rank
+= loop
->dimen
;
2288 /* Helper routine of gfc_trans_array_constructor to determine if the
2289 bounds of the loop specified by LOOP are constant and simple enough
2290 to use with trans_constant_array_constructor. Returns the
2291 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2294 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2297 tree size
= gfc_index_one_node
;
2301 total_dim
= get_rank (l
);
2303 for (loop
= l
; loop
; loop
= loop
->parent
)
2305 for (i
= 0; i
< loop
->dimen
; i
++)
2307 /* If the bounds aren't constant, return NULL_TREE. */
2308 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2310 if (!integer_zerop (loop
->from
[i
]))
2312 /* Only allow nonzero "from" in one-dimensional arrays. */
2315 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2316 gfc_array_index_type
,
2317 loop
->to
[i
], loop
->from
[i
]);
2321 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2322 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2323 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2324 gfc_array_index_type
, size
, tmp
);
2333 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2338 gcc_assert (array
->nested_ss
== NULL
);
2340 for (ss
= array
; ss
; ss
= ss
->parent
)
2341 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2342 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2343 return &(ss
->loop
->to
[n
]);
2349 static gfc_loopinfo
*
2350 outermost_loop (gfc_loopinfo
* loop
)
2352 while (loop
->parent
!= NULL
)
2353 loop
= loop
->parent
;
2359 /* Array constructors are handled by constructing a temporary, then using that
2360 within the scalarization loop. This is not optimal, but seems by far the
2364 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2366 gfc_constructor_base c
;
2374 bool old_first_len
, old_typespec_chararray_ctor
;
2375 tree old_first_len_val
;
2376 gfc_loopinfo
*loop
, *outer_loop
;
2377 gfc_ss_info
*ss_info
;
2383 /* Save the old values for nested checking. */
2384 old_first_len
= first_len
;
2385 old_first_len_val
= first_len_val
;
2386 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2389 outer_loop
= outermost_loop (loop
);
2391 expr
= ss_info
->expr
;
2393 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2394 typespec was given for the array constructor. */
2395 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2397 && expr
->ts
.u
.cl
->length_from_typespec
);
2399 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2400 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2402 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2406 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2408 c
= expr
->value
.constructor
;
2409 if (expr
->ts
.type
== BT_CHARACTER
)
2412 bool force_new_cl
= false;
2414 /* get_array_ctor_strlen walks the elements of the constructor, if a
2415 typespec was given, we already know the string length and want the one
2417 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2418 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2422 const_string
= false;
2423 gfc_init_se (&length_se
, NULL
);
2424 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2425 gfc_charlen_type_node
);
2426 ss_info
->string_length
= length_se
.expr
;
2428 /* Check if the character length is negative. If it is, then
2430 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2431 logical_type_node
, ss_info
->string_length
,
2432 build_zero_cst (TREE_TYPE
2433 (ss_info
->string_length
)));
2434 /* Print a warning if bounds checking is enabled. */
2435 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2437 msg
= xasprintf ("Negative character length treated as LEN = 0");
2438 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2443 ss_info
->string_length
2444 = fold_build3_loc (input_location
, COND_EXPR
,
2445 gfc_charlen_type_node
, neg_len
,
2447 (TREE_TYPE (ss_info
->string_length
)),
2448 ss_info
->string_length
);
2449 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2452 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2453 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2457 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2458 &ss_info
->string_length
);
2459 force_new_cl
= true;
2462 /* Complex character array constructors should have been taken care of
2463 and not end up here. */
2464 gcc_assert (ss_info
->string_length
);
2466 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2468 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2470 type
= build_pointer_type (type
);
2473 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2474 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2476 /* See if the constructor determines the loop bounds. */
2479 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2481 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2483 /* We have a multidimensional parameter. */
2484 for (s
= ss
; s
; s
= s
->parent
)
2487 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2489 s
->loop
->from
[n
] = gfc_index_zero_node
;
2490 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2491 gfc_index_integer_kind
);
2492 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2493 gfc_array_index_type
,
2495 gfc_index_one_node
);
2500 if (*loop_ubound0
== NULL_TREE
)
2504 /* We should have a 1-dimensional, zero-based loop. */
2505 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2506 gcc_assert (loop
->dimen
== 1);
2507 gcc_assert (integer_zerop (loop
->from
[0]));
2509 /* Split the constructor size into a static part and a dynamic part.
2510 Allocate the static size up-front and record whether the dynamic
2511 size might be nonzero. */
2513 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2514 mpz_sub_ui (size
, size
, 1);
2515 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2519 /* Special case constant array constructors. */
2522 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2525 tree size
= constant_array_constructor_loop_size (loop
);
2526 if (size
&& compare_tree_int (size
, nelem
) == 0)
2528 trans_constant_array_constructor (ss
, type
);
2534 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2535 NULL_TREE
, dynamic
, true, false, where
);
2537 desc
= ss_info
->data
.array
.descriptor
;
2538 offset
= gfc_index_zero_node
;
2539 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2540 TREE_NO_WARNING (offsetvar
) = 1;
2541 TREE_USED (offsetvar
) = 0;
2542 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2543 &offset
, &offsetvar
, dynamic
);
2545 /* If the array grows dynamically, the upper bound of the loop variable
2546 is determined by the array's final upper bound. */
2549 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2550 gfc_array_index_type
,
2551 offsetvar
, gfc_index_one_node
);
2552 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2553 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2554 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2555 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2557 *loop_ubound0
= tmp
;
2560 if (TREE_USED (offsetvar
))
2561 pushdecl (offsetvar
);
2563 gcc_assert (INTEGER_CST_P (offset
));
2566 /* Disable bound checking for now because it's probably broken. */
2567 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2574 /* Restore old values of globals. */
2575 first_len
= old_first_len
;
2576 first_len_val
= old_first_len_val
;
2577 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2581 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2582 called after evaluating all of INFO's vector dimensions. Go through
2583 each such vector dimension and see if we can now fill in any missing
2587 set_vector_loop_bounds (gfc_ss
* ss
)
2589 gfc_loopinfo
*loop
, *outer_loop
;
2590 gfc_array_info
*info
;
2598 outer_loop
= outermost_loop (ss
->loop
);
2600 info
= &ss
->info
->data
.array
;
2602 for (; ss
; ss
= ss
->parent
)
2606 for (n
= 0; n
< loop
->dimen
; n
++)
2609 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2610 || loop
->to
[n
] != NULL
)
2613 /* Loop variable N indexes vector dimension DIM, and we don't
2614 yet know the upper bound of loop variable N. Set it to the
2615 difference between the vector's upper and lower bounds. */
2616 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2617 gcc_assert (info
->subscript
[dim
]
2618 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2620 gfc_init_se (&se
, NULL
);
2621 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2622 zero
= gfc_rank_cst
[0];
2623 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2624 gfc_array_index_type
,
2625 gfc_conv_descriptor_ubound_get (desc
, zero
),
2626 gfc_conv_descriptor_lbound_get (desc
, zero
));
2627 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2634 /* Tells whether a scalar argument to an elemental procedure is saved out
2635 of a scalarization loop as a value or as a reference. */
2638 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2640 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2643 /* If the actual argument can be absent (in other words, it can
2644 be a NULL reference), don't try to evaluate it; pass instead
2645 the reference directly. */
2646 if (ss_info
->can_be_null_ref
)
2649 /* If the expression is of polymorphic type, it's actual size is not known,
2650 so we avoid copying it anywhere. */
2651 if (ss_info
->data
.scalar
.dummy_arg
2652 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2653 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2656 /* If the expression is a data reference of aggregate type,
2657 and the data reference is not used on the left hand side,
2658 avoid a copy by saving a reference to the content. */
2659 if (!ss_info
->data
.scalar
.needs_temporary
2660 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2661 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2662 && gfc_expr_is_variable (ss_info
->expr
))
2665 /* Otherwise the expression is evaluated to a temporary variable before the
2666 scalarization loop. */
2671 /* Add the pre and post chains for all the scalar expressions in a SS chain
2672 to loop. This is called after the loop parameters have been calculated,
2673 but before the actual scalarizing loops. */
2676 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2679 gfc_loopinfo
*nested_loop
, *outer_loop
;
2681 gfc_ss_info
*ss_info
;
2682 gfc_array_info
*info
;
2686 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2687 arguments could get evaluated multiple times. */
2688 if (ss
->is_alloc_lhs
)
2691 outer_loop
= outermost_loop (loop
);
2693 /* TODO: This can generate bad code if there are ordering dependencies,
2694 e.g., a callee allocated function and an unknown size constructor. */
2695 gcc_assert (ss
!= NULL
);
2697 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2701 /* Cross loop arrays are handled from within the most nested loop. */
2702 if (ss
->nested_ss
!= NULL
)
2706 expr
= ss_info
->expr
;
2707 info
= &ss_info
->data
.array
;
2709 switch (ss_info
->type
)
2712 /* Scalar expression. Evaluate this now. This includes elemental
2713 dimension indices, but not array section bounds. */
2714 gfc_init_se (&se
, NULL
);
2715 gfc_conv_expr (&se
, expr
);
2716 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2718 if (expr
->ts
.type
!= BT_CHARACTER
2719 && !gfc_is_alloc_class_scalar_function (expr
))
2721 /* Move the evaluation of scalar expressions outside the
2722 scalarization loop, except for WHERE assignments. */
2724 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2725 if (!ss_info
->where
)
2726 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2727 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2730 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2732 ss_info
->data
.scalar
.value
= se
.expr
;
2733 ss_info
->string_length
= se
.string_length
;
2736 case GFC_SS_REFERENCE
:
2737 /* Scalar argument to elemental procedure. */
2738 gfc_init_se (&se
, NULL
);
2739 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2740 gfc_conv_expr_reference (&se
, expr
);
2743 /* Evaluate the argument outside the loop and pass
2744 a reference to the value. */
2745 gfc_conv_expr (&se
, expr
);
2748 /* Ensure that a pointer to the string is stored. */
2749 if (expr
->ts
.type
== BT_CHARACTER
)
2750 gfc_conv_string_parameter (&se
);
2752 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2753 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2754 if (gfc_is_class_scalar_expr (expr
))
2755 /* This is necessary because the dynamic type will always be
2756 large than the declared type. In consequence, assigning
2757 the value to a temporary could segfault.
2758 OOP-TODO: see if this is generally correct or is the value
2759 has to be written to an allocated temporary, whose address
2760 is passed via ss_info. */
2761 ss_info
->data
.scalar
.value
= se
.expr
;
2763 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2766 ss_info
->string_length
= se
.string_length
;
2769 case GFC_SS_SECTION
:
2770 /* Add the expressions for scalar and vector subscripts. */
2771 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2772 if (info
->subscript
[n
])
2773 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2775 set_vector_loop_bounds (ss
);
2779 /* Get the vector's descriptor and store it in SS. */
2780 gfc_init_se (&se
, NULL
);
2781 gfc_conv_expr_descriptor (&se
, expr
);
2782 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2783 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2784 info
->descriptor
= se
.expr
;
2787 case GFC_SS_INTRINSIC
:
2788 gfc_add_intrinsic_ss_code (loop
, ss
);
2791 case GFC_SS_FUNCTION
:
2792 /* Array function return value. We call the function and save its
2793 result in a temporary for use inside the loop. */
2794 gfc_init_se (&se
, NULL
);
2797 if (gfc_is_class_array_function (expr
))
2798 expr
->must_finalize
= 1;
2799 gfc_conv_expr (&se
, expr
);
2800 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2801 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2802 ss_info
->string_length
= se
.string_length
;
2805 case GFC_SS_CONSTRUCTOR
:
2806 if (expr
->ts
.type
== BT_CHARACTER
2807 && ss_info
->string_length
== NULL
2809 && expr
->ts
.u
.cl
->length
2810 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2812 gfc_init_se (&se
, NULL
);
2813 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2814 gfc_charlen_type_node
);
2815 ss_info
->string_length
= se
.expr
;
2816 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2817 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2819 trans_array_constructor (ss
, where
);
2823 case GFC_SS_COMPONENT
:
2824 /* Do nothing. These are handled elsewhere. */
2833 for (nested_loop
= loop
->nested
; nested_loop
;
2834 nested_loop
= nested_loop
->next
)
2835 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2839 /* Translate expressions for the descriptor and data pointer of a SS. */
2843 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2846 gfc_ss_info
*ss_info
;
2847 gfc_array_info
*info
;
2851 info
= &ss_info
->data
.array
;
2853 /* Get the descriptor for the array to be scalarized. */
2854 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2855 gfc_init_se (&se
, NULL
);
2856 se
.descriptor_only
= 1;
2857 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2858 gfc_add_block_to_block (block
, &se
.pre
);
2859 info
->descriptor
= se
.expr
;
2860 ss_info
->string_length
= se
.string_length
;
2864 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2865 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2867 /* Emit a DECL_EXPR for the variable sized array type in
2868 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2869 sizes works correctly. */
2870 tree arraytype
= TREE_TYPE (
2871 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2872 if (! TYPE_NAME (arraytype
))
2873 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2874 NULL_TREE
, arraytype
);
2875 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2876 TYPE_NAME (arraytype
)));
2878 /* Also the data pointer. */
2879 tmp
= gfc_conv_array_data (se
.expr
);
2880 /* If this is a variable or address of a variable we use it directly.
2881 Otherwise we must evaluate it now to avoid breaking dependency
2882 analysis by pulling the expressions for elemental array indices
2885 || (TREE_CODE (tmp
) == ADDR_EXPR
2886 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2887 tmp
= gfc_evaluate_now (tmp
, block
);
2890 tmp
= gfc_conv_array_offset (se
.expr
);
2891 info
->offset
= gfc_evaluate_now (tmp
, block
);
2893 /* Make absolutely sure that the saved_offset is indeed saved
2894 so that the variable is still accessible after the loops
2896 info
->saved_offset
= info
->offset
;
2901 /* Initialize a gfc_loopinfo structure. */
2904 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2908 memset (loop
, 0, sizeof (gfc_loopinfo
));
2909 gfc_init_block (&loop
->pre
);
2910 gfc_init_block (&loop
->post
);
2912 /* Initially scalarize in order and default to no loop reversal. */
2913 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2916 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2919 loop
->ss
= gfc_ss_terminator
;
2923 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2927 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2933 /* Return an expression for the data pointer of an array. */
2936 gfc_conv_array_data (tree descriptor
)
2940 type
= TREE_TYPE (descriptor
);
2941 if (GFC_ARRAY_TYPE_P (type
))
2943 if (TREE_CODE (type
) == POINTER_TYPE
)
2947 /* Descriptorless arrays. */
2948 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2952 return gfc_conv_descriptor_data_get (descriptor
);
2956 /* Return an expression for the base offset of an array. */
2959 gfc_conv_array_offset (tree descriptor
)
2963 type
= TREE_TYPE (descriptor
);
2964 if (GFC_ARRAY_TYPE_P (type
))
2965 return GFC_TYPE_ARRAY_OFFSET (type
);
2967 return gfc_conv_descriptor_offset_get (descriptor
);
2971 /* Get an expression for the array stride. */
2974 gfc_conv_array_stride (tree descriptor
, int dim
)
2979 type
= TREE_TYPE (descriptor
);
2981 /* For descriptorless arrays use the array size. */
2982 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2983 if (tmp
!= NULL_TREE
)
2986 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2991 /* Like gfc_conv_array_stride, but for the lower bound. */
2994 gfc_conv_array_lbound (tree descriptor
, int dim
)
2999 type
= TREE_TYPE (descriptor
);
3001 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3002 if (tmp
!= NULL_TREE
)
3005 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3010 /* Like gfc_conv_array_stride, but for the upper bound. */
3013 gfc_conv_array_ubound (tree descriptor
, int dim
)
3018 type
= TREE_TYPE (descriptor
);
3020 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3021 if (tmp
!= NULL_TREE
)
3024 /* This should only ever happen when passing an assumed shape array
3025 as an actual parameter. The value will never be used. */
3026 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3027 return gfc_index_zero_node
;
3029 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3034 /* Generate code to perform an array index bound check. */
3037 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3038 locus
* where
, bool check_upper
)
3041 tree tmp_lo
, tmp_up
;
3044 const char * name
= NULL
;
3046 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3049 descriptor
= ss
->info
->data
.array
.descriptor
;
3051 index
= gfc_evaluate_now (index
, &se
->pre
);
3053 /* We find a name for the error message. */
3054 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3055 gcc_assert (name
!= NULL
);
3057 if (VAR_P (descriptor
))
3058 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3060 /* If upper bound is present, include both bounds in the error message. */
3063 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3064 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3067 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3068 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3070 msg
= xasprintf ("Index '%%ld' of dimension %d "
3071 "outside of expected range (%%ld:%%ld)", n
+1);
3073 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3075 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3076 fold_convert (long_integer_type_node
, index
),
3077 fold_convert (long_integer_type_node
, tmp_lo
),
3078 fold_convert (long_integer_type_node
, tmp_up
));
3079 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3081 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3082 fold_convert (long_integer_type_node
, index
),
3083 fold_convert (long_integer_type_node
, tmp_lo
),
3084 fold_convert (long_integer_type_node
, tmp_up
));
3089 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3092 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3093 "below lower bound of %%ld", n
+1, name
);
3095 msg
= xasprintf ("Index '%%ld' of dimension %d "
3096 "below lower bound of %%ld", n
+1);
3098 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3100 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3101 fold_convert (long_integer_type_node
, index
),
3102 fold_convert (long_integer_type_node
, tmp_lo
));
3110 /* Return the offset for an index. Performs bound checking for elemental
3111 dimensions. Single element references are processed separately.
3112 DIM is the array dimension, I is the loop dimension. */
3115 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3116 gfc_array_ref
* ar
, tree stride
)
3118 gfc_array_info
*info
;
3123 info
= &ss
->info
->data
.array
;
3125 /* Get the index into the array for this dimension. */
3128 gcc_assert (ar
->type
!= AR_ELEMENT
);
3129 switch (ar
->dimen_type
[dim
])
3131 case DIMEN_THIS_IMAGE
:
3135 /* Elemental dimension. */
3136 gcc_assert (info
->subscript
[dim
]
3137 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3138 /* We've already translated this value outside the loop. */
3139 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3141 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3142 ar
->as
->type
!= AS_ASSUMED_SIZE
3143 || dim
< ar
->dimen
- 1);
3147 gcc_assert (info
&& se
->loop
);
3148 gcc_assert (info
->subscript
[dim
]
3149 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3150 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3152 /* Get a zero-based index into the vector. */
3153 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3154 gfc_array_index_type
,
3155 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3157 /* Multiply the index by the stride. */
3158 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3159 gfc_array_index_type
,
3160 index
, gfc_conv_array_stride (desc
, 0));
3162 /* Read the vector to get an index into info->descriptor. */
3163 data
= build_fold_indirect_ref_loc (input_location
,
3164 gfc_conv_array_data (desc
));
3165 index
= gfc_build_array_ref (data
, index
, NULL
);
3166 index
= gfc_evaluate_now (index
, &se
->pre
);
3167 index
= fold_convert (gfc_array_index_type
, index
);
3169 /* Do any bounds checking on the final info->descriptor index. */
3170 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3171 ar
->as
->type
!= AS_ASSUMED_SIZE
3172 || dim
< ar
->dimen
- 1);
3176 /* Scalarized dimension. */
3177 gcc_assert (info
&& se
->loop
);
3179 /* Multiply the loop variable by the stride and delta. */
3180 index
= se
->loop
->loopvar
[i
];
3181 if (!integer_onep (info
->stride
[dim
]))
3182 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3183 gfc_array_index_type
, index
,
3185 if (!integer_zerop (info
->delta
[dim
]))
3186 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3187 gfc_array_index_type
, index
,
3197 /* Temporary array or derived type component. */
3198 gcc_assert (se
->loop
);
3199 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3201 /* Pointer functions can have stride[0] different from unity.
3202 Use the stride returned by the function call and stored in
3203 the descriptor for the temporary. */
3204 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3205 && se
->ss
->info
->expr
3206 && se
->ss
->info
->expr
->symtree
3207 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3208 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3209 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3212 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3213 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3214 gfc_array_index_type
, index
, info
->delta
[dim
]);
3217 /* Multiply by the stride. */
3218 if (stride
!= NULL
&& !integer_onep (stride
))
3219 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3226 /* Build a scalarized array reference using the vptr 'size'. */
3229 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3234 tree decl
= NULL_TREE
;
3236 gfc_expr
*expr
= se
->ss
->info
->expr
;
3238 gfc_ref
*class_ref
= NULL
;
3241 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3242 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3243 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3248 || (expr
->ts
.type
!= BT_CLASS
3249 && !gfc_is_class_array_function (expr
)
3250 && !gfc_is_class_array_ref (expr
, NULL
)))
3253 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3254 ts
= &expr
->symtree
->n
.sym
->ts
;
3258 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3260 if (ref
->type
== REF_COMPONENT
3261 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3262 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3263 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3265 && ref
->next
->next
->type
== REF_ARRAY
3266 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3268 ts
= &ref
->u
.c
.component
->ts
;
3278 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3279 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3280 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3282 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3284 else if (expr
&& gfc_is_class_array_function (expr
))
3288 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3291 type
= TREE_TYPE (tmp
);
3294 if (GFC_CLASS_TYPE_P (type
))
3296 if (type
!= TYPE_CANONICAL (type
))
3297 type
= TYPE_CANONICAL (type
);
3305 if (decl
== NULL_TREE
)
3308 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3310 else if (class_ref
== NULL
)
3312 if (decl
== NULL_TREE
)
3313 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3314 /* For class arrays the tree containing the class is stored in
3315 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3316 For all others it's sym's backend_decl directly. */
3317 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3318 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3322 /* Remove everything after the last class reference, convert the
3323 expression and then recover its tailend once more. */
3325 ref
= class_ref
->next
;
3326 class_ref
->next
= NULL
;
3327 gfc_init_se (&tmpse
, NULL
);
3328 gfc_conv_expr (&tmpse
, expr
);
3329 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3331 class_ref
->next
= ref
;
3334 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3335 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3337 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3340 size
= gfc_class_vtab_size_get (decl
);
3342 /* For unlimited polymorphic entities then _len component needs to be
3343 multiplied with the size. If no _len component is present, then
3344 gfc_class_len_or_zero_get () return a zero_node. */
3345 tmp
= gfc_class_len_or_zero_get (decl
);
3346 if (!integer_zerop (tmp
))
3347 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3348 fold_convert (TREE_TYPE (index
), size
),
3349 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3350 fold_convert (TREE_TYPE (index
), tmp
),
3351 fold_convert (TREE_TYPE (index
),
3352 integer_one_node
)));
3354 size
= fold_convert (TREE_TYPE (index
), size
);
3356 /* Build the address of the element. */
3357 type
= TREE_TYPE (TREE_TYPE (base
));
3358 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3359 gfc_array_index_type
,
3361 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3362 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3363 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3365 /* Return the element in the se expression. */
3366 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3371 /* Build a scalarized reference to an array. */
3374 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3376 gfc_array_info
*info
;
3377 tree decl
= NULL_TREE
;
3385 expr
= ss
->info
->expr
;
3386 info
= &ss
->info
->data
.array
;
3388 n
= se
->loop
->order
[0];
3392 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3393 /* Add the offset for this dimension to the stored offset for all other
3395 if (info
->offset
&& !integer_zerop (info
->offset
))
3396 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3397 index
, info
->offset
);
3399 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3401 /* Use the vptr 'size' field to access the element of a class array. */
3402 if (build_class_array_ref (se
, base
, index
))
3405 if (expr
&& ((is_subref_array (expr
)
3406 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
)))
3407 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3408 || expr
->expr_type
== EXPR_FUNCTION
))))
3409 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3411 /* A pointer array component can be detected from its field decl. Fix
3412 the descriptor, mark the resulting variable decl and pass it to
3413 gfc_build_array_ref. */
3414 if (is_pointer_array (info
->descriptor
))
3416 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3417 decl
= info
->descriptor
;
3418 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3419 decl
= TREE_OPERAND (info
->descriptor
, 0);
3421 if (decl
== NULL_TREE
)
3422 decl
= info
->descriptor
;
3425 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3429 /* Translate access of temporary array. */
3432 gfc_conv_tmp_array_ref (gfc_se
* se
)
3434 se
->string_length
= se
->ss
->info
->string_length
;
3435 gfc_conv_scalarized_array_ref (se
, NULL
);
3436 gfc_advance_se_ss_chain (se
);
3439 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3442 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3444 if (TREE_CODE (t
) == INTEGER_CST
)
3445 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3448 if (!integer_zerop (*offset
))
3449 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3450 gfc_array_index_type
, *offset
, t
);
3458 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3464 /* For class arrays the class declaration is stored in the saved
3466 if (INDIRECT_REF_P (desc
)
3467 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3468 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3469 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3470 TREE_OPERAND (desc
, 0)));
3474 /* Class container types do not always have the GFC_CLASS_TYPE_P
3475 but the canonical type does. */
3476 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3477 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3479 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3480 if (TYPE_CANONICAL (type
)
3481 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3482 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3485 tmp
= gfc_conv_array_data (desc
);
3486 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3487 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3492 /* Build an array reference. se->expr already holds the array descriptor.
3493 This should be either a variable, indirect variable reference or component
3494 reference. For arrays which do not have a descriptor, se->expr will be
3496 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3499 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3503 tree offset
, cst_offset
;
3506 tree decl
= NULL_TREE
;
3509 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3510 char *var_name
= NULL
;
3514 gcc_assert (ar
->codimen
);
3516 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3517 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3520 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3521 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3522 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3524 /* Use the actual tree type and not the wrapped coarray. */
3525 if (!se
->want_pointer
)
3526 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3533 /* Handle scalarized references separately. */
3534 if (ar
->type
!= AR_ELEMENT
)
3536 gfc_conv_scalarized_array_ref (se
, ar
);
3537 gfc_advance_se_ss_chain (se
);
3541 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3546 len
= strlen (sym
->name
) + 1;
3547 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3549 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3551 if (ref
->type
== REF_COMPONENT
)
3552 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3555 var_name
= XALLOCAVEC (char, len
);
3556 strcpy (var_name
, sym
->name
);
3558 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3560 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3562 if (ref
->type
== REF_COMPONENT
)
3564 strcat (var_name
, "%%");
3565 strcat (var_name
, ref
->u
.c
.component
->name
);
3570 cst_offset
= offset
= gfc_index_zero_node
;
3571 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3573 /* Calculate the offsets from all the dimensions. Make sure to associate
3574 the final offset so that we form a chain of loop invariant summands. */
3575 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3577 /* Calculate the index for this dimension. */
3578 gfc_init_se (&indexse
, se
);
3579 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3580 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3582 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3584 /* Check array bounds. */
3588 /* Evaluate the indexse.expr only once. */
3589 indexse
.expr
= save_expr (indexse
.expr
);
3592 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3593 if (sym
->attr
.temporary
)
3595 gfc_init_se (&tmpse
, se
);
3596 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3597 gfc_array_index_type
);
3598 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3602 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3604 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3605 "below lower bound of %%ld", n
+1, var_name
);
3606 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3607 fold_convert (long_integer_type_node
,
3609 fold_convert (long_integer_type_node
, tmp
));
3612 /* Upper bound, but not for the last dimension of assumed-size
3614 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3616 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3617 if (sym
->attr
.temporary
)
3619 gfc_init_se (&tmpse
, se
);
3620 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3621 gfc_array_index_type
);
3622 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3626 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3627 logical_type_node
, indexse
.expr
, tmp
);
3628 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3629 "above upper bound of %%ld", n
+1, var_name
);
3630 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3631 fold_convert (long_integer_type_node
,
3633 fold_convert (long_integer_type_node
, tmp
));
3638 /* Multiply the index by the stride. */
3639 stride
= gfc_conv_array_stride (se
->expr
, n
);
3640 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3641 indexse
.expr
, stride
);
3643 /* And add it to the total. */
3644 add_to_offset (&cst_offset
, &offset
, tmp
);
3647 if (!integer_zerop (cst_offset
))
3648 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3649 gfc_array_index_type
, offset
, cst_offset
);
3651 /* A pointer array component can be detected from its field decl. Fix
3652 the descriptor, mark the resulting variable decl and pass it to
3654 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3655 && is_pointer_array (se
->expr
))
3657 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3659 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3660 decl
= TREE_OPERAND (se
->expr
, 0);
3664 else if (expr
->ts
.deferred
3665 || (sym
->ts
.type
== BT_CHARACTER
3666 && sym
->attr
.select_type_temporary
))
3667 decl
= sym
->backend_decl
;
3668 else if (sym
->ts
.type
== BT_CLASS
)
3671 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3675 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3676 LOOP_DIM dimension (if any) to array's offset. */
3679 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3680 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3683 gfc_array_info
*info
;
3686 info
= &ss
->info
->data
.array
;
3688 gfc_init_se (&se
, NULL
);
3690 se
.expr
= info
->descriptor
;
3691 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3692 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3693 gfc_add_block_to_block (pblock
, &se
.pre
);
3695 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3696 gfc_array_index_type
,
3697 info
->offset
, index
);
3698 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3702 /* Generate the code to be executed immediately before entering a
3703 scalarization loop. */
3706 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3707 stmtblock_t
* pblock
)
3710 gfc_ss_info
*ss_info
;
3711 gfc_array_info
*info
;
3712 gfc_ss_type ss_type
;
3714 gfc_loopinfo
*ploop
;
3718 /* This code will be executed before entering the scalarization loop
3719 for this dimension. */
3720 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3724 if ((ss_info
->useflags
& flag
) == 0)
3727 ss_type
= ss_info
->type
;
3728 if (ss_type
!= GFC_SS_SECTION
3729 && ss_type
!= GFC_SS_FUNCTION
3730 && ss_type
!= GFC_SS_CONSTRUCTOR
3731 && ss_type
!= GFC_SS_COMPONENT
)
3734 info
= &ss_info
->data
.array
;
3736 gcc_assert (dim
< ss
->dimen
);
3737 gcc_assert (ss
->dimen
== loop
->dimen
);
3740 ar
= &info
->ref
->u
.ar
;
3744 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3746 /* If we are in the outermost dimension of this loop, the previous
3747 dimension shall be in the parent loop. */
3748 gcc_assert (ss
->parent
!= NULL
);
3751 ploop
= loop
->parent
;
3753 /* ss and ss->parent are about the same array. */
3754 gcc_assert (ss_info
== pss
->info
);
3762 if (dim
== loop
->dimen
- 1)
3767 /* For the time being, there is no loop reordering. */
3768 gcc_assert (i
== ploop
->order
[i
]);
3769 i
= ploop
->order
[i
];
3771 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3773 stride
= gfc_conv_array_stride (info
->descriptor
,
3774 innermost_ss (ss
)->dim
[i
]);
3776 /* Calculate the stride of the innermost loop. Hopefully this will
3777 allow the backend optimizers to do their stuff more effectively.
3779 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3781 /* For the outermost loop calculate the offset due to any
3782 elemental dimensions. It will have been initialized with the
3783 base offset of the array. */
3786 for (i
= 0; i
< ar
->dimen
; i
++)
3788 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3791 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3796 /* Add the offset for the previous loop dimension. */
3797 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3799 /* Remember this offset for the second loop. */
3800 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3801 info
->saved_offset
= info
->offset
;
3806 /* Start a scalarized expression. Creates a scope and declares loop
3810 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3816 gcc_assert (!loop
->array_parameter
);
3818 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3820 n
= loop
->order
[dim
];
3822 gfc_start_block (&loop
->code
[n
]);
3824 /* Create the loop variable. */
3825 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3827 if (dim
< loop
->temp_dim
)
3831 /* Calculate values that will be constant within this loop. */
3832 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3834 gfc_start_block (pbody
);
3838 /* Generates the actual loop code for a scalarization loop. */
3841 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3842 stmtblock_t
* pbody
)
3853 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3854 | OMPWS_SCALARIZER_BODY
))
3855 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3856 && n
== loop
->dimen
- 1)
3858 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3859 init
= make_tree_vec (1);
3860 cond
= make_tree_vec (1);
3861 incr
= make_tree_vec (1);
3863 /* Cycle statement is implemented with a goto. Exit statement must not
3864 be present for this loop. */
3865 exit_label
= gfc_build_label_decl (NULL_TREE
);
3866 TREE_USED (exit_label
) = 1;
3868 /* Label for cycle statements (if needed). */
3869 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3870 gfc_add_expr_to_block (pbody
, tmp
);
3872 stmt
= make_node (OMP_FOR
);
3874 TREE_TYPE (stmt
) = void_type_node
;
3875 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3877 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3878 OMP_CLAUSE_SCHEDULE
);
3879 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3880 = OMP_CLAUSE_SCHEDULE_STATIC
;
3881 if (ompws_flags
& OMPWS_NOWAIT
)
3882 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3883 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3885 /* Initialize the loopvar. */
3886 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3888 OMP_FOR_INIT (stmt
) = init
;
3889 /* The exit condition. */
3890 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3892 loop
->loopvar
[n
], loop
->to
[n
]);
3893 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3894 OMP_FOR_COND (stmt
) = cond
;
3895 /* Increment the loopvar. */
3896 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3897 loop
->loopvar
[n
], gfc_index_one_node
);
3898 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3899 void_type_node
, loop
->loopvar
[n
], tmp
);
3900 OMP_FOR_INCR (stmt
) = incr
;
3902 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3903 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3907 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3908 && (loop
->temp_ss
== NULL
);
3910 loopbody
= gfc_finish_block (pbody
);
3913 std::swap (loop
->from
[n
], loop
->to
[n
]);
3915 /* Initialize the loopvar. */
3916 if (loop
->loopvar
[n
] != loop
->from
[n
])
3917 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3919 exit_label
= gfc_build_label_decl (NULL_TREE
);
3921 /* Generate the loop body. */
3922 gfc_init_block (&block
);
3924 /* The exit condition. */
3925 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3926 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3927 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3928 TREE_USED (exit_label
) = 1;
3929 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3930 gfc_add_expr_to_block (&block
, tmp
);
3932 /* The main body. */
3933 gfc_add_expr_to_block (&block
, loopbody
);
3935 /* Increment the loopvar. */
3936 tmp
= fold_build2_loc (input_location
,
3937 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3938 gfc_array_index_type
, loop
->loopvar
[n
],
3939 gfc_index_one_node
);
3941 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3943 /* Build the loop. */
3944 tmp
= gfc_finish_block (&block
);
3945 tmp
= build1_v (LOOP_EXPR
, tmp
);
3946 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3948 /* Add the exit label. */
3949 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3950 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3956 /* Finishes and generates the loops for a scalarized expression. */
3959 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3964 stmtblock_t
*pblock
;
3968 /* Generate the loops. */
3969 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3971 n
= loop
->order
[dim
];
3972 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3973 loop
->loopvar
[n
] = NULL_TREE
;
3974 pblock
= &loop
->code
[n
];
3977 tmp
= gfc_finish_block (pblock
);
3978 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3980 /* Clear all the used flags. */
3981 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3982 if (ss
->parent
== NULL
)
3983 ss
->info
->useflags
= 0;
3987 /* Finish the main body of a scalarized expression, and start the secondary
3991 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3995 stmtblock_t
*pblock
;
3999 /* We finish as many loops as are used by the temporary. */
4000 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4002 n
= loop
->order
[dim
];
4003 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4004 loop
->loopvar
[n
] = NULL_TREE
;
4005 pblock
= &loop
->code
[n
];
4008 /* We don't want to finish the outermost loop entirely. */
4009 n
= loop
->order
[loop
->temp_dim
- 1];
4010 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4012 /* Restore the initial offsets. */
4013 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4015 gfc_ss_type ss_type
;
4016 gfc_ss_info
*ss_info
;
4020 if ((ss_info
->useflags
& 2) == 0)
4023 ss_type
= ss_info
->type
;
4024 if (ss_type
!= GFC_SS_SECTION
4025 && ss_type
!= GFC_SS_FUNCTION
4026 && ss_type
!= GFC_SS_CONSTRUCTOR
4027 && ss_type
!= GFC_SS_COMPONENT
)
4030 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4033 /* Restart all the inner loops we just finished. */
4034 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4036 n
= loop
->order
[dim
];
4038 gfc_start_block (&loop
->code
[n
]);
4040 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4042 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4045 /* Start a block for the secondary copying code. */
4046 gfc_start_block (body
);
4050 /* Precalculate (either lower or upper) bound of an array section.
4051 BLOCK: Block in which the (pre)calculation code will go.
4052 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4053 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4054 DESC: Array descriptor from which the bound will be picked if unspecified
4055 (either lower or upper bound according to LBOUND). */
4058 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4059 tree desc
, int dim
, bool lbound
, bool deferred
)
4062 gfc_expr
* input_val
= values
[dim
];
4063 tree
*output
= &bounds
[dim
];
4068 /* Specified section bound. */
4069 gfc_init_se (&se
, NULL
);
4070 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4071 gfc_add_block_to_block (block
, &se
.pre
);
4074 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4076 /* The gfc_conv_array_lbound () routine returns a constant zero for
4077 deferred length arrays, which in the scalarizer wreaks havoc, when
4078 copying to a (newly allocated) one-based array.
4079 Keep returning the actual result in sync for both bounds. */
4080 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4082 gfc_conv_descriptor_ubound_get (desc
,
4087 /* No specific bound specified so use the bound of the array. */
4088 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4089 gfc_conv_array_ubound (desc
, dim
);
4091 *output
= gfc_evaluate_now (*output
, block
);
4095 /* Calculate the lower bound of an array section. */
4098 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4100 gfc_expr
*stride
= NULL
;
4103 gfc_array_info
*info
;
4106 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4108 info
= &ss
->info
->data
.array
;
4109 ar
= &info
->ref
->u
.ar
;
4111 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4113 /* We use a zero-based index to access the vector. */
4114 info
->start
[dim
] = gfc_index_zero_node
;
4115 info
->end
[dim
] = NULL
;
4116 info
->stride
[dim
] = gfc_index_one_node
;
4120 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4121 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4122 desc
= info
->descriptor
;
4123 stride
= ar
->stride
[dim
];
4126 /* Calculate the start of the range. For vector subscripts this will
4127 be the range of the vector. */
4128 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4129 ar
->as
->type
== AS_DEFERRED
);
4131 /* Similarly calculate the end. Although this is not used in the
4132 scalarizer, it is needed when checking bounds and where the end
4133 is an expression with side-effects. */
4134 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4135 ar
->as
->type
== AS_DEFERRED
);
4138 /* Calculate the stride. */
4140 info
->stride
[dim
] = gfc_index_one_node
;
4143 gfc_init_se (&se
, NULL
);
4144 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4145 gfc_add_block_to_block (block
, &se
.pre
);
4146 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4151 /* Calculates the range start and stride for a SS chain. Also gets the
4152 descriptor and data pointer. The range of vector subscripts is the size
4153 of the vector. Array bounds are also checked. */
4156 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4163 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4166 /* Determine the rank of the loop. */
4167 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4169 switch (ss
->info
->type
)
4171 case GFC_SS_SECTION
:
4172 case GFC_SS_CONSTRUCTOR
:
4173 case GFC_SS_FUNCTION
:
4174 case GFC_SS_COMPONENT
:
4175 loop
->dimen
= ss
->dimen
;
4178 /* As usual, lbound and ubound are exceptions!. */
4179 case GFC_SS_INTRINSIC
:
4180 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4182 case GFC_ISYM_LBOUND
:
4183 case GFC_ISYM_UBOUND
:
4184 case GFC_ISYM_LCOBOUND
:
4185 case GFC_ISYM_UCOBOUND
:
4186 case GFC_ISYM_THIS_IMAGE
:
4187 loop
->dimen
= ss
->dimen
;
4199 /* We should have determined the rank of the expression by now. If
4200 not, that's bad news. */
4204 /* Loop over all the SS in the chain. */
4205 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4207 gfc_ss_info
*ss_info
;
4208 gfc_array_info
*info
;
4212 expr
= ss_info
->expr
;
4213 info
= &ss_info
->data
.array
;
4215 if (expr
&& expr
->shape
&& !info
->shape
)
4216 info
->shape
= expr
->shape
;
4218 switch (ss_info
->type
)
4220 case GFC_SS_SECTION
:
4221 /* Get the descriptor for the array. If it is a cross loops array,
4222 we got the descriptor already in the outermost loop. */
4223 if (ss
->parent
== NULL
)
4224 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4225 !loop
->array_parameter
);
4227 for (n
= 0; n
< ss
->dimen
; n
++)
4228 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4231 case GFC_SS_INTRINSIC
:
4232 switch (expr
->value
.function
.isym
->id
)
4234 /* Fall through to supply start and stride. */
4235 case GFC_ISYM_LBOUND
:
4236 case GFC_ISYM_UBOUND
:
4240 /* This is the variant without DIM=... */
4241 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4243 arg
= expr
->value
.function
.actual
->expr
;
4244 if (arg
->rank
== -1)
4249 /* The rank (hence the return value's shape) is unknown,
4250 we have to retrieve it. */
4251 gfc_init_se (&se
, NULL
);
4252 se
.descriptor_only
= 1;
4253 gfc_conv_expr (&se
, arg
);
4254 /* This is a bare variable, so there is no preliminary
4256 gcc_assert (se
.pre
.head
== NULL_TREE
4257 && se
.post
.head
== NULL_TREE
);
4258 rank
= gfc_conv_descriptor_rank (se
.expr
);
4259 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4260 gfc_array_index_type
,
4261 fold_convert (gfc_array_index_type
,
4263 gfc_index_one_node
);
4264 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4265 info
->start
[0] = gfc_index_zero_node
;
4266 info
->stride
[0] = gfc_index_one_node
;
4269 /* Otherwise fall through GFC_SS_FUNCTION. */
4272 case GFC_ISYM_LCOBOUND
:
4273 case GFC_ISYM_UCOBOUND
:
4274 case GFC_ISYM_THIS_IMAGE
:
4282 case GFC_SS_CONSTRUCTOR
:
4283 case GFC_SS_FUNCTION
:
4284 for (n
= 0; n
< ss
->dimen
; n
++)
4286 int dim
= ss
->dim
[n
];
4288 info
->start
[dim
] = gfc_index_zero_node
;
4289 info
->end
[dim
] = gfc_index_zero_node
;
4290 info
->stride
[dim
] = gfc_index_one_node
;
4299 /* The rest is just runtime bounds checking. */
4300 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4303 tree lbound
, ubound
;
4305 tree size
[GFC_MAX_DIMENSIONS
];
4306 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4307 gfc_array_info
*info
;
4311 gfc_start_block (&block
);
4313 for (n
= 0; n
< loop
->dimen
; n
++)
4314 size
[n
] = NULL_TREE
;
4316 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4319 gfc_ss_info
*ss_info
;
4322 const char *expr_name
;
4325 if (ss_info
->type
!= GFC_SS_SECTION
)
4328 /* Catch allocatable lhs in f2003. */
4329 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4332 expr
= ss_info
->expr
;
4333 expr_loc
= &expr
->where
;
4334 expr_name
= expr
->symtree
->name
;
4336 gfc_start_block (&inner
);
4338 /* TODO: range checking for mapped dimensions. */
4339 info
= &ss_info
->data
.array
;
4341 /* This code only checks ranges. Elemental and vector
4342 dimensions are checked later. */
4343 for (n
= 0; n
< loop
->dimen
; n
++)
4348 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4351 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4352 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4353 check_upper
= false;
4357 /* Zero stride is not allowed. */
4358 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4359 info
->stride
[dim
], gfc_index_zero_node
);
4360 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4361 "of array '%s'", dim
+ 1, expr_name
);
4362 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4366 desc
= info
->descriptor
;
4368 /* This is the run-time equivalent of resolve.c's
4369 check_dimension(). The logical is more readable there
4370 than it is here, with all the trees. */
4371 lbound
= gfc_conv_array_lbound (desc
, dim
);
4372 end
= info
->end
[dim
];
4374 ubound
= gfc_conv_array_ubound (desc
, dim
);
4378 /* non_zerosized is true when the selected range is not
4380 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4381 logical_type_node
, info
->stride
[dim
],
4382 gfc_index_zero_node
);
4383 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4384 info
->start
[dim
], end
);
4385 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4386 logical_type_node
, stride_pos
, tmp
);
4388 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4390 info
->stride
[dim
], gfc_index_zero_node
);
4391 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4392 info
->start
[dim
], end
);
4393 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4396 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4398 stride_pos
, stride_neg
);
4400 /* Check the start of the range against the lower and upper
4401 bounds of the array, if the range is not empty.
4402 If upper bound is present, include both bounds in the
4406 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4408 info
->start
[dim
], lbound
);
4409 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4411 non_zerosized
, tmp
);
4412 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4414 info
->start
[dim
], ubound
);
4415 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4417 non_zerosized
, tmp2
);
4418 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4419 "outside of expected range (%%ld:%%ld)",
4420 dim
+ 1, expr_name
);
4421 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4423 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4424 fold_convert (long_integer_type_node
, lbound
),
4425 fold_convert (long_integer_type_node
, ubound
));
4426 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4428 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4429 fold_convert (long_integer_type_node
, lbound
),
4430 fold_convert (long_integer_type_node
, ubound
));
4435 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4437 info
->start
[dim
], lbound
);
4438 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4439 logical_type_node
, non_zerosized
, tmp
);
4440 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4441 "below lower bound of %%ld",
4442 dim
+ 1, expr_name
);
4443 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4445 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4446 fold_convert (long_integer_type_node
, lbound
));
4450 /* Compute the last element of the range, which is not
4451 necessarily "end" (think 0:5:3, which doesn't contain 5)
4452 and check it against both lower and upper bounds. */
4454 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4455 gfc_array_index_type
, end
,
4457 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4458 gfc_array_index_type
, tmp
,
4460 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4461 gfc_array_index_type
, end
, tmp
);
4462 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4463 logical_type_node
, tmp
, lbound
);
4464 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4465 logical_type_node
, non_zerosized
, tmp2
);
4468 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4469 logical_type_node
, tmp
, ubound
);
4470 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4471 logical_type_node
, non_zerosized
, tmp3
);
4472 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4473 "outside of expected range (%%ld:%%ld)",
4474 dim
+ 1, expr_name
);
4475 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4477 fold_convert (long_integer_type_node
, tmp
),
4478 fold_convert (long_integer_type_node
, ubound
),
4479 fold_convert (long_integer_type_node
, lbound
));
4480 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4482 fold_convert (long_integer_type_node
, tmp
),
4483 fold_convert (long_integer_type_node
, ubound
),
4484 fold_convert (long_integer_type_node
, lbound
));
4489 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4490 "below lower bound of %%ld",
4491 dim
+ 1, expr_name
);
4492 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4494 fold_convert (long_integer_type_node
, tmp
),
4495 fold_convert (long_integer_type_node
, lbound
));
4499 /* Check the section sizes match. */
4500 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4501 gfc_array_index_type
, end
,
4503 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4504 gfc_array_index_type
, tmp
,
4506 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4507 gfc_array_index_type
,
4508 gfc_index_one_node
, tmp
);
4509 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4510 gfc_array_index_type
, tmp
,
4511 build_int_cst (gfc_array_index_type
, 0));
4512 /* We remember the size of the first section, and check all the
4513 others against this. */
4516 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4517 logical_type_node
, tmp
, size
[n
]);
4518 msg
= xasprintf ("Array bound mismatch for dimension %d "
4519 "of array '%s' (%%ld/%%ld)",
4520 dim
+ 1, expr_name
);
4522 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4524 fold_convert (long_integer_type_node
, tmp
),
4525 fold_convert (long_integer_type_node
, size
[n
]));
4530 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4533 tmp
= gfc_finish_block (&inner
);
4535 /* For optional arguments, only check bounds if the argument is
4537 if (expr
->symtree
->n
.sym
->attr
.optional
4538 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4539 tmp
= build3_v (COND_EXPR
,
4540 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4541 tmp
, build_empty_stmt (input_location
));
4543 gfc_add_expr_to_block (&block
, tmp
);
4547 tmp
= gfc_finish_block (&block
);
4548 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4551 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4552 gfc_conv_ss_startstride (loop
);
4555 /* Return true if both symbols could refer to the same data object. Does
4556 not take account of aliasing due to equivalence statements. */
4559 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4560 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4562 /* Aliasing isn't possible if the symbols have different base types. */
4563 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4566 /* Pointers can point to other pointers and target objects. */
4568 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4569 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4572 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4573 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4575 if (lsym_target
&& rsym_target
4576 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4577 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4578 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4579 && (!rsym
->attr
.dimension
4580 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4587 /* Return true if the two SS could be aliased, i.e. both point to the same data
4589 /* TODO: resolve aliases based on frontend expressions. */
4592 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4596 gfc_expr
*lexpr
, *rexpr
;
4599 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4601 lexpr
= lss
->info
->expr
;
4602 rexpr
= rss
->info
->expr
;
4604 lsym
= lexpr
->symtree
->n
.sym
;
4605 rsym
= rexpr
->symtree
->n
.sym
;
4607 lsym_pointer
= lsym
->attr
.pointer
;
4608 lsym_target
= lsym
->attr
.target
;
4609 rsym_pointer
= rsym
->attr
.pointer
;
4610 rsym_target
= rsym
->attr
.target
;
4612 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4613 rsym_pointer
, rsym_target
))
4616 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4617 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4620 /* For derived types we must check all the component types. We can ignore
4621 array references as these will have the same base type as the previous
4623 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4625 if (lref
->type
!= REF_COMPONENT
)
4628 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4629 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4631 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4632 rsym_pointer
, rsym_target
))
4635 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4636 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4638 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4643 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4646 if (rref
->type
!= REF_COMPONENT
)
4649 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4650 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4652 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4653 lsym_pointer
, lsym_target
,
4654 rsym_pointer
, rsym_target
))
4657 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4658 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4660 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4661 &rref
->u
.c
.sym
->ts
))
4663 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4664 &rref
->u
.c
.component
->ts
))
4666 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4667 &rref
->u
.c
.component
->ts
))
4673 lsym_pointer
= lsym
->attr
.pointer
;
4674 lsym_target
= lsym
->attr
.target
;
4675 lsym_pointer
= lsym
->attr
.pointer
;
4676 lsym_target
= lsym
->attr
.target
;
4678 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4680 if (rref
->type
!= REF_COMPONENT
)
4683 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4684 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4686 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4687 lsym_pointer
, lsym_target
,
4688 rsym_pointer
, rsym_target
))
4691 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4692 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4694 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4703 /* Resolve array data dependencies. Creates a temporary if required. */
4704 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4708 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4714 gfc_ss_info
*ss_info
;
4715 gfc_expr
*dest_expr
;
4720 loop
->temp_ss
= NULL
;
4721 dest_expr
= dest
->info
->expr
;
4723 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4726 ss_expr
= ss_info
->expr
;
4728 if (ss_info
->array_outer_dependency
)
4734 if (ss_info
->type
!= GFC_SS_SECTION
)
4736 if (flag_realloc_lhs
4737 && dest_expr
!= ss_expr
4738 && gfc_is_reallocatable_lhs (dest_expr
)
4740 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4742 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4743 if (!nDepend
&& dest_expr
->rank
> 0
4744 && dest_expr
->ts
.type
== BT_CHARACTER
4745 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4747 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4749 if (ss_info
->type
== GFC_SS_REFERENCE
4750 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4751 ss_info
->data
.scalar
.needs_temporary
= 1;
4759 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4761 if (gfc_could_be_alias (dest
, ss
)
4762 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4770 lref
= dest_expr
->ref
;
4771 rref
= ss_expr
->ref
;
4773 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4778 for (i
= 0; i
< dest
->dimen
; i
++)
4779 for (j
= 0; j
< ss
->dimen
; j
++)
4781 && dest
->dim
[i
] == ss
->dim
[j
])
4783 /* If we don't access array elements in the same order,
4784 there is a dependency. */
4789 /* TODO : loop shifting. */
4792 /* Mark the dimensions for LOOP SHIFTING */
4793 for (n
= 0; n
< loop
->dimen
; n
++)
4795 int dim
= dest
->data
.info
.dim
[n
];
4797 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4799 else if (! gfc_is_same_range (&lref
->u
.ar
,
4800 &rref
->u
.ar
, dim
, 0))
4804 /* Put all the dimensions with dependencies in the
4807 for (n
= 0; n
< loop
->dimen
; n
++)
4809 gcc_assert (loop
->order
[n
] == n
);
4811 loop
->order
[dim
++] = n
;
4813 for (n
= 0; n
< loop
->dimen
; n
++)
4816 loop
->order
[dim
++] = n
;
4819 gcc_assert (dim
== loop
->dimen
);
4830 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4831 if (GFC_ARRAY_TYPE_P (base_type
)
4832 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4833 base_type
= gfc_get_element_type (base_type
);
4834 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4836 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4839 loop
->temp_ss
= NULL
;
4843 /* Browse through each array's information from the scalarizer and set the loop
4844 bounds according to the "best" one (per dimension), i.e. the one which
4845 provides the most information (constant bounds, shape, etc.). */
4848 set_loop_bounds (gfc_loopinfo
*loop
)
4850 int n
, dim
, spec_dim
;
4851 gfc_array_info
*info
;
4852 gfc_array_info
*specinfo
;
4856 bool dynamic
[GFC_MAX_DIMENSIONS
];
4859 bool nonoptional_arr
;
4861 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4863 loopspec
= loop
->specloop
;
4866 for (n
= 0; n
< loop
->dimen
; n
++)
4871 /* If there are both optional and nonoptional array arguments, scalarize
4872 over the nonoptional; otherwise, it does not matter as then all
4873 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4875 nonoptional_arr
= false;
4877 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4878 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4879 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4881 nonoptional_arr
= true;
4885 /* We use one SS term, and use that to determine the bounds of the
4886 loop for this dimension. We try to pick the simplest term. */
4887 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4889 gfc_ss_type ss_type
;
4891 ss_type
= ss
->info
->type
;
4892 if (ss_type
== GFC_SS_SCALAR
4893 || ss_type
== GFC_SS_TEMP
4894 || ss_type
== GFC_SS_REFERENCE
4895 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4898 info
= &ss
->info
->data
.array
;
4901 if (loopspec
[n
] != NULL
)
4903 specinfo
= &loopspec
[n
]->info
->data
.array
;
4904 spec_dim
= loopspec
[n
]->dim
[n
];
4908 /* Silence uninitialized warnings. */
4915 gcc_assert (info
->shape
[dim
]);
4916 /* The frontend has worked out the size for us. */
4919 || !integer_zerop (specinfo
->start
[spec_dim
]))
4920 /* Prefer zero-based descriptors if possible. */
4925 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4927 gfc_constructor_base base
;
4928 /* An unknown size constructor will always be rank one.
4929 Higher rank constructors will either have known shape,
4930 or still be wrapped in a call to reshape. */
4931 gcc_assert (loop
->dimen
== 1);
4933 /* Always prefer to use the constructor bounds if the size
4934 can be determined at compile time. Prefer not to otherwise,
4935 since the general case involves realloc, and it's better to
4936 avoid that overhead if possible. */
4937 base
= ss
->info
->expr
->value
.constructor
;
4938 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4939 if (!dynamic
[n
] || !loopspec
[n
])
4944 /* Avoid using an allocatable lhs in an assignment, since
4945 there might be a reallocation coming. */
4946 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4951 /* Criteria for choosing a loop specifier (most important first):
4952 doesn't need realloc
4958 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4960 else if (integer_onep (info
->stride
[dim
])
4961 && !integer_onep (specinfo
->stride
[spec_dim
]))
4963 else if (INTEGER_CST_P (info
->stride
[dim
])
4964 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4966 else if (INTEGER_CST_P (info
->start
[dim
])
4967 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4968 && integer_onep (info
->stride
[dim
])
4969 == integer_onep (specinfo
->stride
[spec_dim
])
4970 && INTEGER_CST_P (info
->stride
[dim
])
4971 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4973 /* We don't work out the upper bound.
4974 else if (INTEGER_CST_P (info->finish[n])
4975 && ! INTEGER_CST_P (specinfo->finish[n]))
4976 loopspec[n] = ss; */
4979 /* We should have found the scalarization loop specifier. If not,
4981 gcc_assert (loopspec
[n
]);
4983 info
= &loopspec
[n
]->info
->data
.array
;
4984 dim
= loopspec
[n
]->dim
[n
];
4986 /* Set the extents of this range. */
4987 cshape
= info
->shape
;
4988 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4989 && INTEGER_CST_P (info
->stride
[dim
]))
4991 loop
->from
[n
] = info
->start
[dim
];
4992 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4993 mpz_sub_ui (i
, i
, 1);
4994 /* To = from + (size - 1) * stride. */
4995 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4996 if (!integer_onep (info
->stride
[dim
]))
4997 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4998 gfc_array_index_type
, tmp
,
5000 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5001 gfc_array_index_type
,
5002 loop
->from
[n
], tmp
);
5006 loop
->from
[n
] = info
->start
[dim
];
5007 switch (loopspec
[n
]->info
->type
)
5009 case GFC_SS_CONSTRUCTOR
:
5010 /* The upper bound is calculated when we expand the
5012 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5015 case GFC_SS_SECTION
:
5016 /* Use the end expression if it exists and is not constant,
5017 so that it is only evaluated once. */
5018 loop
->to
[n
] = info
->end
[dim
];
5021 case GFC_SS_FUNCTION
:
5022 /* The loop bound will be set when we generate the call. */
5023 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5026 case GFC_SS_INTRINSIC
:
5028 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5030 /* The {l,u}bound of an assumed rank. */
5031 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5032 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5033 && expr
->value
.function
.actual
->next
->expr
== NULL
5034 && expr
->value
.function
.actual
->expr
->rank
== -1);
5036 loop
->to
[n
] = info
->end
[dim
];
5040 case GFC_SS_COMPONENT
:
5042 if (info
->end
[dim
] != NULL_TREE
)
5044 loop
->to
[n
] = info
->end
[dim
];
5056 /* Transform everything so we have a simple incrementing variable. */
5057 if (integer_onep (info
->stride
[dim
]))
5058 info
->delta
[dim
] = gfc_index_zero_node
;
5061 /* Set the delta for this section. */
5062 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5063 /* Number of iterations is (end - start + step) / step.
5064 with start = 0, this simplifies to
5066 for (i = 0; i<=last; i++){...}; */
5067 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5068 gfc_array_index_type
, loop
->to
[n
],
5070 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5071 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5072 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5073 tmp
, build_int_cst (gfc_array_index_type
, -1));
5074 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5075 /* Make the loop variable start at 0. */
5076 loop
->from
[n
] = gfc_index_zero_node
;
5081 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5082 set_loop_bounds (loop
);
5086 /* Initialize the scalarization loop. Creates the loop variables. Determines
5087 the range of the loop variables. Creates a temporary if required.
5088 Also generates code for scalar expressions which have been
5089 moved outside the loop. */
5092 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5097 set_loop_bounds (loop
);
5099 /* Add all the scalar code that can be taken out of the loops.
5100 This may include calculating the loop bounds, so do it before
5101 allocating the temporary. */
5102 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5104 tmp_ss
= loop
->temp_ss
;
5105 /* If we want a temporary then create it. */
5108 gfc_ss_info
*tmp_ss_info
;
5110 tmp_ss_info
= tmp_ss
->info
;
5111 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5112 gcc_assert (loop
->parent
== NULL
);
5114 /* Make absolutely sure that this is a complete type. */
5115 if (tmp_ss_info
->string_length
)
5116 tmp_ss_info
->data
.temp
.type
5117 = gfc_get_character_type_len_for_eltype
5118 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5119 tmp_ss_info
->string_length
);
5121 tmp
= tmp_ss_info
->data
.temp
.type
;
5122 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5123 tmp_ss_info
->type
= GFC_SS_SECTION
;
5125 gcc_assert (tmp_ss
->dimen
!= 0);
5127 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5128 NULL_TREE
, false, true, false, where
);
5131 /* For array parameters we don't have loop variables, so don't calculate the
5133 if (!loop
->array_parameter
)
5134 gfc_set_delta (loop
);
5138 /* Calculates how to transform from loop variables to array indices for each
5139 array: once loop bounds are chosen, sets the difference (DELTA field) between
5140 loop bounds and array reference bounds, for each array info. */
5143 gfc_set_delta (gfc_loopinfo
*loop
)
5145 gfc_ss
*ss
, **loopspec
;
5146 gfc_array_info
*info
;
5150 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5152 loopspec
= loop
->specloop
;
5154 /* Calculate the translation from loop variables to array indices. */
5155 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5157 gfc_ss_type ss_type
;
5159 ss_type
= ss
->info
->type
;
5160 if (ss_type
!= GFC_SS_SECTION
5161 && ss_type
!= GFC_SS_COMPONENT
5162 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5165 info
= &ss
->info
->data
.array
;
5167 for (n
= 0; n
< ss
->dimen
; n
++)
5169 /* If we are specifying the range the delta is already set. */
5170 if (loopspec
[n
] != ss
)
5174 /* Calculate the offset relative to the loop variable.
5175 First multiply by the stride. */
5176 tmp
= loop
->from
[n
];
5177 if (!integer_onep (info
->stride
[dim
]))
5178 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5179 gfc_array_index_type
,
5180 tmp
, info
->stride
[dim
]);
5182 /* Then subtract this from our starting value. */
5183 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5184 gfc_array_index_type
,
5185 info
->start
[dim
], tmp
);
5187 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5192 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5193 gfc_set_delta (loop
);
5197 /* Calculate the size of a given array dimension from the bounds. This
5198 is simply (ubound - lbound + 1) if this expression is positive
5199 or 0 if it is negative (pick either one if it is zero). Optionally
5200 (if or_expr is present) OR the (expression != 0) condition to it. */
5203 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5208 /* Calculate (ubound - lbound + 1). */
5209 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5211 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5212 gfc_index_one_node
);
5214 /* Check whether the size for this dimension is negative. */
5215 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5216 gfc_index_zero_node
);
5217 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5218 gfc_index_zero_node
, res
);
5220 /* Build OR expression. */
5222 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5223 logical_type_node
, *or_expr
, cond
);
5229 /* For an array descriptor, get the total number of elements. This is just
5230 the product of the extents along from_dim to to_dim. */
5233 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5238 res
= gfc_index_one_node
;
5240 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5246 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5247 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5249 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5250 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5258 /* Full size of an array. */
5261 gfc_conv_descriptor_size (tree desc
, int rank
)
5263 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5267 /* Size of a coarray for all dimensions but the last. */
5270 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5272 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5276 /* Fills in an array descriptor, and returns the size of the array.
5277 The size will be a simple_val, ie a variable or a constant. Also
5278 calculates the offset of the base. The pointer argument overflow,
5279 which should be of integer type, will increase in value if overflow
5280 occurs during the size calculation. Returns the size of the array.
5284 for (n = 0; n < rank; n++)
5286 a.lbound[n] = specified_lower_bound;
5287 offset = offset + a.lbond[n] * stride;
5289 a.ubound[n] = specified_upper_bound;
5290 a.stride[n] = stride;
5291 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5292 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5293 stride = stride * size;
5295 for (n = rank; n < rank+corank; n++)
5296 (Set lcobound/ucobound as above.)
5297 element_size = sizeof (array element);
5300 stride = (size_t) stride;
5301 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5302 stride = stride * element_size;
5308 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5309 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5310 stmtblock_t
* descriptor_block
, tree
* overflow
,
5311 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5312 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5325 stmtblock_t thenblock
;
5326 stmtblock_t elseblock
;
5331 type
= TREE_TYPE (descriptor
);
5333 stride
= gfc_index_one_node
;
5334 offset
= gfc_index_zero_node
;
5336 /* Set the dtype before the alloc, because registration of coarrays needs
5338 if (expr
->ts
.type
== BT_CHARACTER
5339 && expr
->ts
.deferred
5340 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5342 type
= gfc_typenode_for_spec (&expr
->ts
);
5343 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5344 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5348 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5349 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5352 or_expr
= logical_false_node
;
5354 for (n
= 0; n
< rank
; n
++)
5359 /* We have 3 possibilities for determining the size of the array:
5360 lower == NULL => lbound = 1, ubound = upper[n]
5361 upper[n] = NULL => lbound = 1, ubound = lower[n]
5362 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5365 /* Set lower bound. */
5366 gfc_init_se (&se
, NULL
);
5367 if (expr3_desc
!= NULL_TREE
)
5369 if (e3_is_array_constr
)
5370 /* The lbound of a constant array [] starts at zero, but when
5371 allocating it, the standard expects the array to start at
5373 se
.expr
= gfc_index_one_node
;
5375 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5378 else if (lower
== NULL
)
5379 se
.expr
= gfc_index_one_node
;
5382 gcc_assert (lower
[n
]);
5385 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5386 gfc_add_block_to_block (pblock
, &se
.pre
);
5390 se
.expr
= gfc_index_one_node
;
5394 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5395 gfc_rank_cst
[n
], se
.expr
);
5396 conv_lbound
= se
.expr
;
5398 /* Work out the offset for this component. */
5399 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5401 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5402 gfc_array_index_type
, offset
, tmp
);
5404 /* Set upper bound. */
5405 gfc_init_se (&se
, NULL
);
5406 if (expr3_desc
!= NULL_TREE
)
5408 if (e3_is_array_constr
)
5410 /* The lbound of a constant array [] starts at zero, but when
5411 allocating it, the standard expects the array to start at
5412 one. Therefore fix the upper bound to be
5413 (desc.ubound - desc.lbound)+ 1. */
5414 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5415 gfc_array_index_type
,
5416 gfc_conv_descriptor_ubound_get (
5417 expr3_desc
, gfc_rank_cst
[n
]),
5418 gfc_conv_descriptor_lbound_get (
5419 expr3_desc
, gfc_rank_cst
[n
]));
5420 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5421 gfc_array_index_type
, tmp
,
5422 gfc_index_one_node
);
5423 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5426 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5431 gcc_assert (ubound
);
5432 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5433 gfc_add_block_to_block (pblock
, &se
.pre
);
5434 if (ubound
->expr_type
== EXPR_FUNCTION
)
5435 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5437 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5438 gfc_rank_cst
[n
], se
.expr
);
5439 conv_ubound
= se
.expr
;
5441 /* Store the stride. */
5442 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5443 gfc_rank_cst
[n
], stride
);
5445 /* Calculate size and check whether extent is negative. */
5446 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5447 size
= gfc_evaluate_now (size
, pblock
);
5449 /* Check whether multiplying the stride by the number of
5450 elements in this dimension would overflow. We must also check
5451 whether the current dimension has zero size in order to avoid
5454 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5455 gfc_array_index_type
,
5456 fold_convert (gfc_array_index_type
,
5457 TYPE_MAX_VALUE (gfc_array_index_type
)),
5459 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5460 logical_type_node
, tmp
, stride
),
5461 PRED_FORTRAN_OVERFLOW
);
5462 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5463 integer_one_node
, integer_zero_node
);
5464 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5465 logical_type_node
, size
,
5466 gfc_index_zero_node
),
5467 PRED_FORTRAN_SIZE_ZERO
);
5468 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5469 integer_zero_node
, tmp
);
5470 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5472 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5474 /* Multiply the stride by the number of elements in this dimension. */
5475 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5476 gfc_array_index_type
, stride
, size
);
5477 stride
= gfc_evaluate_now (stride
, pblock
);
5480 for (n
= rank
; n
< rank
+ corank
; n
++)
5484 /* Set lower bound. */
5485 gfc_init_se (&se
, NULL
);
5486 if (lower
== NULL
|| lower
[n
] == NULL
)
5488 gcc_assert (n
== rank
+ corank
- 1);
5489 se
.expr
= gfc_index_one_node
;
5493 if (ubound
|| n
== rank
+ corank
- 1)
5495 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5496 gfc_add_block_to_block (pblock
, &se
.pre
);
5500 se
.expr
= gfc_index_one_node
;
5504 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5505 gfc_rank_cst
[n
], se
.expr
);
5507 if (n
< rank
+ corank
- 1)
5509 gfc_init_se (&se
, NULL
);
5510 gcc_assert (ubound
);
5511 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5512 gfc_add_block_to_block (pblock
, &se
.pre
);
5513 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5514 gfc_rank_cst
[n
], se
.expr
);
5518 /* The stride is the number of elements in the array, so multiply by the
5519 size of an element to get the total size. Obviously, if there is a
5520 SOURCE expression (expr3) we must use its element size. */
5521 if (expr3_elem_size
!= NULL_TREE
)
5522 tmp
= expr3_elem_size
;
5523 else if (expr3
!= NULL
)
5525 if (expr3
->ts
.type
== BT_CLASS
)
5528 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5529 gfc_add_vptr_component (sz
);
5530 gfc_add_size_component (sz
);
5531 gfc_init_se (&se_sz
, NULL
);
5532 gfc_conv_expr (&se_sz
, sz
);
5538 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5539 tmp
= TYPE_SIZE_UNIT (tmp
);
5543 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5545 /* Convert to size_t. */
5546 element_size
= fold_convert (size_type_node
, tmp
);
5549 return element_size
;
5551 *nelems
= gfc_evaluate_now (stride
, pblock
);
5552 stride
= fold_convert (size_type_node
, stride
);
5554 /* First check for overflow. Since an array of type character can
5555 have zero element_size, we must check for that before
5557 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5559 TYPE_MAX_VALUE (size_type_node
), element_size
);
5560 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5561 logical_type_node
, tmp
, stride
),
5562 PRED_FORTRAN_OVERFLOW
);
5563 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5564 integer_one_node
, integer_zero_node
);
5565 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5566 logical_type_node
, element_size
,
5567 build_int_cst (size_type_node
, 0)),
5568 PRED_FORTRAN_SIZE_ZERO
);
5569 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5570 integer_zero_node
, tmp
);
5571 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5573 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5575 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5576 stride
, element_size
);
5578 if (poffset
!= NULL
)
5580 offset
= gfc_evaluate_now (offset
, pblock
);
5584 if (integer_zerop (or_expr
))
5586 if (integer_onep (or_expr
))
5587 return build_int_cst (size_type_node
, 0);
5589 var
= gfc_create_var (TREE_TYPE (size
), "size");
5590 gfc_start_block (&thenblock
);
5591 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5592 thencase
= gfc_finish_block (&thenblock
);
5594 gfc_start_block (&elseblock
);
5595 gfc_add_modify (&elseblock
, var
, size
);
5596 elsecase
= gfc_finish_block (&elseblock
);
5598 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5599 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5600 gfc_add_expr_to_block (pblock
, tmp
);
5606 /* Retrieve the last ref from the chain. This routine is specific to
5607 gfc_array_allocate ()'s needs. */
5610 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5612 gfc_ref
*ref
, *prev_ref
;
5615 /* Prevent warnings for uninitialized variables. */
5616 prev_ref
= *prev_ref_in
;
5617 while (ref
&& ref
->next
!= NULL
)
5619 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5620 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5625 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5629 *prev_ref_in
= prev_ref
;
5633 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5634 the work for an ALLOCATE statement. */
5638 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5639 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5640 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5641 bool e3_is_array_constr
)
5645 tree offset
= NULL_TREE
;
5646 tree token
= NULL_TREE
;
5649 tree error
= NULL_TREE
;
5650 tree overflow
; /* Boolean storing whether size calculation overflows. */
5651 tree var_overflow
= NULL_TREE
;
5653 tree set_descriptor
;
5654 stmtblock_t set_descriptor_block
;
5655 stmtblock_t elseblock
;
5658 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5659 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5660 non_ulimate_coarray_ptr_comp
;
5664 /* Find the last reference in the chain. */
5665 if (!retrieve_last_ref (&ref
, &prev_ref
))
5668 /* Take the allocatable and coarray properties solely from the expr-ref's
5669 attributes and not from source=-expression. */
5672 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5673 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5674 non_ulimate_coarray_ptr_comp
= false;
5678 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5679 /* Pointer components in coarrayed derived types must be treated
5680 specially in that they are registered without a check if the are
5681 already associated. This does not hold for ultimate coarray
5683 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5684 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5685 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5688 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5689 a coarray. In this case it does not matter whether we are on this_image
5692 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5693 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5700 gcc_assert (coarray
);
5702 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5704 gfc_ref
*old_ref
= ref
;
5705 /* F08:C633: Array shape from expr3. */
5708 /* Find the last reference in the chain. */
5709 if (!retrieve_last_ref (&ref
, &prev_ref
))
5711 if (expr3
->expr_type
== EXPR_FUNCTION
5712 && gfc_expr_attr (expr3
).dimension
)
5717 alloc_w_e3_arr_spec
= true;
5720 /* Figure out the size of the array. */
5721 switch (ref
->u
.ar
.type
)
5727 upper
= ref
->u
.ar
.start
;
5733 lower
= ref
->u
.ar
.start
;
5734 upper
= ref
->u
.ar
.end
;
5738 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5739 || alloc_w_e3_arr_spec
);
5741 lower
= ref
->u
.ar
.as
->lower
;
5742 upper
= ref
->u
.ar
.as
->upper
;
5750 overflow
= integer_zero_node
;
5752 gfc_init_block (&set_descriptor_block
);
5753 /* Take the corank only from the actual ref and not from the coref. The
5754 later will mislead the generation of the array dimensions for allocatable/
5755 pointer components in derived types. */
5756 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5757 : ref
->u
.ar
.as
->rank
,
5758 coarray
? ref
->u
.ar
.as
->corank
: 0,
5759 &offset
, lower
, upper
,
5760 &se
->pre
, &set_descriptor_block
, &overflow
,
5761 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5762 e3_is_array_constr
, expr
);
5766 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5767 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5769 if (status
== NULL_TREE
)
5771 /* Generate the block of code handling overflow. */
5772 msg
= gfc_build_addr_expr (pchar_type_node
,
5773 gfc_build_localized_cstring_const
5774 ("Integer overflow when calculating the amount of "
5775 "memory to allocate"));
5776 error
= build_call_expr_loc (input_location
,
5777 gfor_fndecl_runtime_error
, 1, msg
);
5781 tree status_type
= TREE_TYPE (status
);
5782 stmtblock_t set_status_block
;
5784 gfc_start_block (&set_status_block
);
5785 gfc_add_modify (&set_status_block
, status
,
5786 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5787 error
= gfc_finish_block (&set_status_block
);
5791 gfc_start_block (&elseblock
);
5793 /* Allocate memory to store the data. */
5794 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5795 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5797 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5799 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5800 : gfc_conv_descriptor_data_get (se
->expr
);
5801 token
= gfc_conv_descriptor_token (se
->expr
);
5802 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5805 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5806 STRIP_NOPS (pointer
);
5808 /* The allocatable variant takes the old pointer as first argument. */
5810 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5811 status
, errmsg
, errlen
, label_finish
, expr
,
5812 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5813 else if (non_ulimate_coarray_ptr_comp
&& token
)
5814 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5815 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5817 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5819 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5823 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5824 logical_type_node
, var_overflow
, integer_zero_node
),
5825 PRED_FORTRAN_OVERFLOW
);
5826 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5827 error
, gfc_finish_block (&elseblock
));
5830 tmp
= gfc_finish_block (&elseblock
);
5832 gfc_add_expr_to_block (&se
->pre
, tmp
);
5834 /* Update the array descriptors. */
5836 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5838 /* Pointer arrays need the span field to be set. */
5839 if (is_pointer_array (se
->expr
)
5840 || (expr
->ts
.type
== BT_CLASS
5841 && CLASS_DATA (expr
)->attr
.class_pointer
))
5843 if (expr3
&& expr3_elem_size
!= NULL_TREE
)
5844 tmp
= expr3_elem_size
;
5846 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se
->expr
)));
5847 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5848 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5851 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5852 if (status
!= NULL_TREE
)
5854 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5855 logical_type_node
, status
,
5856 build_int_cst (TREE_TYPE (status
), 0));
5857 gfc_add_expr_to_block (&se
->pre
,
5858 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5861 build_empty_stmt (input_location
)));
5864 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5870 /* Create an array constructor from an initialization expression.
5871 We assume the frontend already did any expansions and conversions. */
5874 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5881 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5883 if (expr
->expr_type
== EXPR_VARIABLE
5884 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5885 && expr
->symtree
->n
.sym
->value
)
5886 expr
= expr
->symtree
->n
.sym
->value
;
5888 switch (expr
->expr_type
)
5891 case EXPR_STRUCTURE
:
5892 /* A single scalar or derived type value. Create an array with all
5893 elements equal to that value. */
5894 gfc_init_se (&se
, NULL
);
5896 if (expr
->expr_type
== EXPR_CONSTANT
)
5897 gfc_conv_constant (&se
, expr
);
5899 gfc_conv_structure (&se
, expr
, 1);
5901 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5902 /* This will probably eat buckets of memory for large arrays. */
5905 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5911 /* Create a vector of all the elements. */
5912 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5913 c
; c
= gfc_constructor_next (c
))
5917 /* Problems occur when we get something like
5918 integer :: a(lots) = (/(i, i=1, lots)/) */
5919 gfc_fatal_error ("The number of elements in the array "
5920 "constructor at %L requires an increase of "
5921 "the allowed %d upper limit. See "
5922 "%<-fmax-array-constructor%> option",
5923 &expr
->where
, flag_max_array_constructor
);
5926 if (mpz_cmp_si (c
->offset
, 0) != 0)
5927 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5931 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5937 mpz_add (maxval
, c
->offset
, c
->repeat
);
5938 mpz_sub_ui (maxval
, maxval
, 1);
5939 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5940 if (mpz_cmp_si (c
->offset
, 0) != 0)
5942 mpz_add_ui (maxval
, c
->offset
, 1);
5943 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5946 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5948 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5954 gfc_init_se (&se
, NULL
);
5955 switch (c
->expr
->expr_type
)
5958 gfc_conv_constant (&se
, c
->expr
);
5960 /* See gfortran.dg/charlen_15.f90 for instance. */
5961 if (TREE_CODE (se
.expr
) == STRING_CST
5962 && TREE_CODE (type
) == ARRAY_TYPE
)
5965 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
5966 atype
= TREE_TYPE (atype
);
5967 if (TREE_CODE (TREE_TYPE (atype
)) == INTEGER_TYPE
5968 && tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
5969 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
5971 unsigned HOST_WIDE_INT size
5972 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
5973 const char *p
= TREE_STRING_POINTER (se
.expr
);
5975 se
.expr
= build_string (size
, p
);
5976 TREE_TYPE (se
.expr
) = atype
;
5981 case EXPR_STRUCTURE
:
5982 gfc_conv_structure (&se
, c
->expr
, 1);
5986 /* Catch those occasional beasts that do not simplify
5987 for one reason or another, assuming that if they are
5988 standard defying the frontend will catch them. */
5989 gfc_conv_expr (&se
, c
->expr
);
5993 if (range
== NULL_TREE
)
5994 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5997 if (index
!= NULL_TREE
)
5998 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5999 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6005 return gfc_build_null_descriptor (type
);
6011 /* Create a constructor from the list of elements. */
6012 tmp
= build_constructor (type
, v
);
6013 TREE_CONSTANT (tmp
) = 1;
6018 /* Generate code to evaluate non-constant coarray cobounds. */
6021 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6022 const gfc_symbol
*sym
)
6030 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6032 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6034 /* Evaluate non-constant array bound expressions. */
6035 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6036 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6038 gfc_init_se (&se
, NULL
);
6039 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6040 gfc_add_block_to_block (pblock
, &se
.pre
);
6041 gfc_add_modify (pblock
, lbound
, se
.expr
);
6043 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6044 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6046 gfc_init_se (&se
, NULL
);
6047 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6048 gfc_add_block_to_block (pblock
, &se
.pre
);
6049 gfc_add_modify (pblock
, ubound
, se
.expr
);
6055 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6056 returns the size (in elements) of the array. */
6059 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6060 stmtblock_t
* pblock
)
6073 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6075 size
= gfc_index_one_node
;
6076 offset
= gfc_index_zero_node
;
6077 for (dim
= 0; dim
< as
->rank
; dim
++)
6079 /* Evaluate non-constant array bound expressions. */
6080 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6081 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6083 gfc_init_se (&se
, NULL
);
6084 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6085 gfc_add_block_to_block (pblock
, &se
.pre
);
6086 gfc_add_modify (pblock
, lbound
, se
.expr
);
6088 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6089 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6091 gfc_init_se (&se
, NULL
);
6092 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6093 gfc_add_block_to_block (pblock
, &se
.pre
);
6094 gfc_add_modify (pblock
, ubound
, se
.expr
);
6096 /* The offset of this dimension. offset = offset - lbound * stride. */
6097 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6099 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6102 /* The size of this dimension, and the stride of the next. */
6103 if (dim
+ 1 < as
->rank
)
6104 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6106 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6108 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6110 /* Calculate stride = size * (ubound + 1 - lbound). */
6111 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6112 gfc_array_index_type
,
6113 gfc_index_one_node
, lbound
);
6114 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6115 gfc_array_index_type
, ubound
, tmp
);
6116 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6117 gfc_array_index_type
, size
, tmp
);
6119 gfc_add_modify (pblock
, stride
, tmp
);
6121 stride
= gfc_evaluate_now (tmp
, pblock
);
6123 /* Make sure that negative size arrays are translated
6124 to being zero size. */
6125 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6126 stride
, gfc_index_zero_node
);
6127 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6128 gfc_array_index_type
, tmp
,
6129 stride
, gfc_index_zero_node
);
6130 gfc_add_modify (pblock
, stride
, tmp
);
6136 gfc_trans_array_cobounds (type
, pblock
, sym
);
6137 gfc_trans_vla_type_sizes (sym
, pblock
);
6144 /* Generate code to initialize/allocate an array variable. */
6147 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6148 gfc_wrapped_block
* block
)
6152 tree tmp
= NULL_TREE
;
6159 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6161 /* Do nothing for USEd variables. */
6162 if (sym
->attr
.use_assoc
)
6165 type
= TREE_TYPE (decl
);
6166 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6167 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6169 gfc_init_block (&init
);
6171 /* Evaluate character string length. */
6172 if (sym
->ts
.type
== BT_CHARACTER
6173 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6175 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6177 gfc_trans_vla_type_sizes (sym
, &init
);
6179 /* Emit a DECL_EXPR for this variable, which will cause the
6180 gimplifier to allocate storage, and all that good stuff. */
6181 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6182 gfc_add_expr_to_block (&init
, tmp
);
6187 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6191 type
= TREE_TYPE (type
);
6193 gcc_assert (!sym
->attr
.use_assoc
);
6194 gcc_assert (!TREE_STATIC (decl
));
6195 gcc_assert (!sym
->module
);
6197 if (sym
->ts
.type
== BT_CHARACTER
6198 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6199 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6201 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6203 /* Don't actually allocate space for Cray Pointees. */
6204 if (sym
->attr
.cray_pointee
)
6206 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6207 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6209 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6213 if (flag_stack_arrays
)
6215 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6216 space
= build_decl (sym
->declared_at
.lb
->location
,
6217 VAR_DECL
, create_tmp_var_name ("A"),
6218 TREE_TYPE (TREE_TYPE (decl
)));
6219 gfc_trans_vla_type_sizes (sym
, &init
);
6223 /* The size is the number of elements in the array, so multiply by the
6224 size of an element to get the total size. */
6225 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6226 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6227 size
, fold_convert (gfc_array_index_type
, tmp
));
6229 /* Allocate memory to hold the data. */
6230 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6231 gfc_add_modify (&init
, decl
, tmp
);
6233 /* Free the temporary. */
6234 tmp
= gfc_call_free (decl
);
6238 /* Set offset of the array. */
6239 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6240 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6242 /* Automatic arrays should not have initializers. */
6243 gcc_assert (!sym
->value
);
6245 inittree
= gfc_finish_block (&init
);
6252 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6253 where also space is located. */
6254 gfc_init_block (&init
);
6255 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6256 TREE_TYPE (space
), space
);
6257 gfc_add_expr_to_block (&init
, tmp
);
6258 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6259 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6260 gfc_add_modify (&init
, decl
, addr
);
6261 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6264 gfc_add_init_cleanup (block
, inittree
, tmp
);
6268 /* Generate entry and exit code for g77 calling convention arrays. */
6271 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6281 gfc_save_backend_locus (&loc
);
6282 gfc_set_backend_locus (&sym
->declared_at
);
6284 /* Descriptor type. */
6285 parm
= sym
->backend_decl
;
6286 type
= TREE_TYPE (parm
);
6287 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6289 gfc_start_block (&init
);
6291 if (sym
->ts
.type
== BT_CHARACTER
6292 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6293 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6295 /* Evaluate the bounds of the array. */
6296 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6298 /* Set the offset. */
6299 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6300 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6302 /* Set the pointer itself if we aren't using the parameter directly. */
6303 if (TREE_CODE (parm
) != PARM_DECL
)
6305 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6306 gfc_add_modify (&init
, parm
, tmp
);
6308 stmt
= gfc_finish_block (&init
);
6310 gfc_restore_backend_locus (&loc
);
6312 /* Add the initialization code to the start of the function. */
6314 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6316 tmp
= gfc_conv_expr_present (sym
);
6317 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6320 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6324 /* Modify the descriptor of an array parameter so that it has the
6325 correct lower bound. Also move the upper bound accordingly.
6326 If the array is not packed, it will be copied into a temporary.
6327 For each dimension we set the new lower and upper bounds. Then we copy the
6328 stride and calculate the offset for this dimension. We also work out
6329 what the stride of a packed array would be, and see it the two match.
6330 If the array need repacking, we set the stride to the values we just
6331 calculated, recalculate the offset and copy the array data.
6332 Code is also added to copy the data back at the end of the function.
6336 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6337 gfc_wrapped_block
* block
)
6344 tree stmtInit
, stmtCleanup
;
6351 tree stride
, stride2
;
6361 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6363 /* Do nothing for pointer and allocatable arrays. */
6364 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6365 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6366 || sym
->attr
.allocatable
6367 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6370 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6372 gfc_trans_g77_array (sym
, block
);
6377 gfc_save_backend_locus (&loc
);
6378 /* loc.nextc is not set by save_backend_locus but the location routines
6380 if (loc
.nextc
== NULL
)
6381 loc
.nextc
= loc
.lb
->line
;
6382 gfc_set_backend_locus (&sym
->declared_at
);
6384 /* Descriptor type. */
6385 type
= TREE_TYPE (tmpdesc
);
6386 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6387 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6389 /* For a class array the dummy array descriptor is in the _class
6391 dumdesc
= gfc_class_data_get (dumdesc
);
6393 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6394 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6395 gfc_start_block (&init
);
6397 if (sym
->ts
.type
== BT_CHARACTER
6398 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6399 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6401 checkparm
= (as
->type
== AS_EXPLICIT
6402 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6404 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6405 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6407 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6409 /* For non-constant shape arrays we only check if the first dimension
6410 is contiguous. Repacking higher dimensions wouldn't gain us
6411 anything as we still don't know the array stride. */
6412 partial
= gfc_create_var (logical_type_node
, "partial");
6413 TREE_USED (partial
) = 1;
6414 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6415 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6416 gfc_index_one_node
);
6417 gfc_add_modify (&init
, partial
, tmp
);
6420 partial
= NULL_TREE
;
6422 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6423 here, however I think it does the right thing. */
6426 /* Set the first stride. */
6427 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6428 stride
= gfc_evaluate_now (stride
, &init
);
6430 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6431 stride
, gfc_index_zero_node
);
6432 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6433 tmp
, gfc_index_one_node
, stride
);
6434 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6435 gfc_add_modify (&init
, stride
, tmp
);
6437 /* Allow the user to disable array repacking. */
6438 stmt_unpacked
= NULL_TREE
;
6442 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6443 /* A library call to repack the array if necessary. */
6444 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6445 stmt_unpacked
= build_call_expr_loc (input_location
,
6446 gfor_fndecl_in_pack
, 1, tmp
);
6448 stride
= gfc_index_one_node
;
6450 if (warn_array_temporaries
)
6451 gfc_warning (OPT_Warray_temporaries
,
6452 "Creating array temporary at %L", &loc
);
6455 /* This is for the case where the array data is used directly without
6456 calling the repack function. */
6457 if (no_repack
|| partial
!= NULL_TREE
)
6458 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6460 stmt_packed
= NULL_TREE
;
6462 /* Assign the data pointer. */
6463 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6465 /* Don't repack unknown shape arrays when the first stride is 1. */
6466 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6467 partial
, stmt_packed
, stmt_unpacked
);
6470 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6471 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6473 offset
= gfc_index_zero_node
;
6474 size
= gfc_index_one_node
;
6476 /* Evaluate the bounds of the array. */
6477 for (n
= 0; n
< as
->rank
; n
++)
6479 if (checkparm
|| !as
->upper
[n
])
6481 /* Get the bounds of the actual parameter. */
6482 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6483 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6487 dubound
= NULL_TREE
;
6488 dlbound
= NULL_TREE
;
6491 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6492 if (!INTEGER_CST_P (lbound
))
6494 gfc_init_se (&se
, NULL
);
6495 gfc_conv_expr_type (&se
, as
->lower
[n
],
6496 gfc_array_index_type
);
6497 gfc_add_block_to_block (&init
, &se
.pre
);
6498 gfc_add_modify (&init
, lbound
, se
.expr
);
6501 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6502 /* Set the desired upper bound. */
6505 /* We know what we want the upper bound to be. */
6506 if (!INTEGER_CST_P (ubound
))
6508 gfc_init_se (&se
, NULL
);
6509 gfc_conv_expr_type (&se
, as
->upper
[n
],
6510 gfc_array_index_type
);
6511 gfc_add_block_to_block (&init
, &se
.pre
);
6512 gfc_add_modify (&init
, ubound
, se
.expr
);
6515 /* Check the sizes match. */
6518 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6522 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6523 gfc_array_index_type
, ubound
, lbound
);
6524 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6525 gfc_array_index_type
,
6526 gfc_index_one_node
, temp
);
6527 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6528 gfc_array_index_type
, dubound
,
6530 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6531 gfc_array_index_type
,
6532 gfc_index_one_node
, stride2
);
6533 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6534 gfc_array_index_type
, temp
, stride2
);
6535 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6536 "%%ld instead of %%ld", n
+1, sym
->name
);
6538 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6539 fold_convert (long_integer_type_node
, temp
),
6540 fold_convert (long_integer_type_node
, stride2
));
6547 /* For assumed shape arrays move the upper bound by the same amount
6548 as the lower bound. */
6549 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6550 gfc_array_index_type
, dubound
, dlbound
);
6551 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6552 gfc_array_index_type
, tmp
, lbound
);
6553 gfc_add_modify (&init
, ubound
, tmp
);
6555 /* The offset of this dimension. offset = offset - lbound * stride. */
6556 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6558 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6559 gfc_array_index_type
, offset
, tmp
);
6561 /* The size of this dimension, and the stride of the next. */
6562 if (n
+ 1 < as
->rank
)
6564 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6566 if (no_repack
|| partial
!= NULL_TREE
)
6568 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6570 /* Figure out the stride if not a known constant. */
6571 if (!INTEGER_CST_P (stride
))
6574 stmt_packed
= NULL_TREE
;
6577 /* Calculate stride = size * (ubound + 1 - lbound). */
6578 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6579 gfc_array_index_type
,
6580 gfc_index_one_node
, lbound
);
6581 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6582 gfc_array_index_type
, ubound
, tmp
);
6583 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6584 gfc_array_index_type
, size
, tmp
);
6588 /* Assign the stride. */
6589 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6590 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6591 gfc_array_index_type
, partial
,
6592 stmt_unpacked
, stmt_packed
);
6594 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6595 gfc_add_modify (&init
, stride
, tmp
);
6600 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6602 if (stride
&& !INTEGER_CST_P (stride
))
6604 /* Calculate size = stride * (ubound + 1 - lbound). */
6605 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6606 gfc_array_index_type
,
6607 gfc_index_one_node
, lbound
);
6608 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6609 gfc_array_index_type
,
6611 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6612 gfc_array_index_type
,
6613 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6614 gfc_add_modify (&init
, stride
, tmp
);
6619 gfc_trans_array_cobounds (type
, &init
, sym
);
6621 /* Set the offset. */
6622 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6623 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6625 gfc_trans_vla_type_sizes (sym
, &init
);
6627 stmtInit
= gfc_finish_block (&init
);
6629 /* Only do the entry/initialization code if the arg is present. */
6630 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6631 optional_arg
= (sym
->attr
.optional
6632 || (sym
->ns
->proc_name
->attr
.entry_master
6633 && sym
->attr
.dummy
));
6636 tmp
= gfc_conv_expr_present (sym
);
6637 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6638 build_empty_stmt (input_location
));
6643 stmtCleanup
= NULL_TREE
;
6646 stmtblock_t cleanup
;
6647 gfc_start_block (&cleanup
);
6649 if (sym
->attr
.intent
!= INTENT_IN
)
6651 /* Copy the data back. */
6652 tmp
= build_call_expr_loc (input_location
,
6653 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6654 gfc_add_expr_to_block (&cleanup
, tmp
);
6657 /* Free the temporary. */
6658 tmp
= gfc_call_free (tmpdesc
);
6659 gfc_add_expr_to_block (&cleanup
, tmp
);
6661 stmtCleanup
= gfc_finish_block (&cleanup
);
6663 /* Only do the cleanup if the array was repacked. */
6665 /* For a class array the dummy array descriptor is in the _class
6667 tmp
= gfc_class_data_get (dumdesc
);
6669 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6670 tmp
= gfc_conv_descriptor_data_get (tmp
);
6671 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6673 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6674 build_empty_stmt (input_location
));
6678 tmp
= gfc_conv_expr_present (sym
);
6679 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6680 build_empty_stmt (input_location
));
6684 /* We don't need to free any memory allocated by internal_pack as it will
6685 be freed at the end of the function by pop_context. */
6686 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6688 gfc_restore_backend_locus (&loc
);
6692 /* Calculate the overall offset, including subreferences. */
6694 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6695 bool subref
, gfc_expr
*expr
)
6705 /* If offset is NULL and this is not a subreferenced array, there is
6707 if (offset
== NULL_TREE
)
6710 offset
= gfc_index_zero_node
;
6715 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6717 /* Offset the data pointer for pointer assignments from arrays with
6718 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6721 /* Go past the array reference. */
6722 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6723 if (ref
->type
== REF_ARRAY
&&
6724 ref
->u
.ar
.type
!= AR_ELEMENT
)
6730 /* Calculate the offset for each subsequent subreference. */
6731 for (; ref
; ref
= ref
->next
)
6736 field
= ref
->u
.c
.component
->backend_decl
;
6737 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6738 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6740 tmp
, field
, NULL_TREE
);
6744 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6745 gfc_init_se (&start
, NULL
);
6746 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6747 gfc_add_block_to_block (block
, &start
.pre
);
6748 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6752 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6753 && ref
->u
.ar
.type
== AR_ELEMENT
);
6755 /* TODO - Add bounds checking. */
6756 stride
= gfc_index_one_node
;
6757 index
= gfc_index_zero_node
;
6758 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6763 /* Update the index. */
6764 gfc_init_se (&start
, NULL
);
6765 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6766 itmp
= gfc_evaluate_now (start
.expr
, block
);
6767 gfc_init_se (&start
, NULL
);
6768 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6769 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6770 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6771 gfc_array_index_type
, itmp
, jtmp
);
6772 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6773 gfc_array_index_type
, itmp
, stride
);
6774 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6775 gfc_array_index_type
, itmp
, index
);
6776 index
= gfc_evaluate_now (index
, block
);
6778 /* Update the stride. */
6779 gfc_init_se (&start
, NULL
);
6780 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6781 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6782 gfc_array_index_type
, start
.expr
,
6784 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6785 gfc_array_index_type
,
6786 gfc_index_one_node
, itmp
);
6787 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6788 gfc_array_index_type
, stride
, itmp
);
6789 stride
= gfc_evaluate_now (stride
, block
);
6792 /* Apply the index to obtain the array element. */
6793 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6803 /* Set the target data pointer. */
6804 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6805 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6809 /* gfc_conv_expr_descriptor needs the string length an expression
6810 so that the size of the temporary can be obtained. This is done
6811 by adding up the string lengths of all the elements in the
6812 expression. Function with non-constant expressions have their
6813 string lengths mapped onto the actual arguments using the
6814 interface mapping machinery in trans-expr.c. */
6816 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6818 gfc_interface_mapping mapping
;
6819 gfc_formal_arglist
*formal
;
6820 gfc_actual_arglist
*arg
;
6823 if (expr
->ts
.u
.cl
->length
6824 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6826 if (!expr
->ts
.u
.cl
->backend_decl
)
6827 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6831 switch (expr
->expr_type
)
6834 get_array_charlen (expr
->value
.op
.op1
, se
);
6836 /* For parentheses the expression ts.u.cl is identical. */
6837 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6840 expr
->ts
.u
.cl
->backend_decl
=
6841 gfc_create_var (gfc_charlen_type_node
, "sln");
6843 if (expr
->value
.op
.op2
)
6845 get_array_charlen (expr
->value
.op
.op2
, se
);
6847 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6849 /* Add the string lengths and assign them to the expression
6850 string length backend declaration. */
6851 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6852 fold_build2_loc (input_location
, PLUS_EXPR
,
6853 gfc_charlen_type_node
,
6854 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6855 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6858 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6859 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6863 if (expr
->value
.function
.esym
== NULL
6864 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6866 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6870 /* Map expressions involving the dummy arguments onto the actual
6871 argument expressions. */
6872 gfc_init_interface_mapping (&mapping
);
6873 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6874 arg
= expr
->value
.function
.actual
;
6876 /* Set se = NULL in the calls to the interface mapping, to suppress any
6878 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6883 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6886 gfc_init_se (&tse
, NULL
);
6888 /* Build the expression for the character length and convert it. */
6889 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6891 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6892 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6893 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6894 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6895 TREE_TYPE (tse
.expr
), tse
.expr
,
6896 build_zero_cst (TREE_TYPE (tse
.expr
)));
6897 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6898 gfc_free_interface_mapping (&mapping
);
6902 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6908 /* Helper function to check dimensions. */
6910 transposed_dims (gfc_ss
*ss
)
6914 for (n
= 0; n
< ss
->dimen
; n
++)
6915 if (ss
->dim
[n
] != n
)
6921 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6922 AR_FULL, suitable for the scalarizer. */
6925 walk_coarray (gfc_expr
*e
)
6929 gcc_assert (gfc_get_corank (e
) > 0);
6931 ss
= gfc_walk_expr (e
);
6933 /* Fix scalar coarray. */
6934 if (ss
== gfc_ss_terminator
)
6941 if (ref
->type
== REF_ARRAY
6942 && ref
->u
.ar
.codimen
> 0)
6948 gcc_assert (ref
!= NULL
);
6949 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6950 ref
->u
.ar
.type
= AR_SECTION
;
6951 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6958 /* Convert an array for passing as an actual argument. Expressions and
6959 vector subscripts are evaluated and stored in a temporary, which is then
6960 passed. For whole arrays the descriptor is passed. For array sections
6961 a modified copy of the descriptor is passed, but using the original data.
6963 This function is also used for array pointer assignments, and there
6966 - se->want_pointer && !se->direct_byref
6967 EXPR is an actual argument. On exit, se->expr contains a
6968 pointer to the array descriptor.
6970 - !se->want_pointer && !se->direct_byref
6971 EXPR is an actual argument to an intrinsic function or the
6972 left-hand side of a pointer assignment. On exit, se->expr
6973 contains the descriptor for EXPR.
6975 - !se->want_pointer && se->direct_byref
6976 EXPR is the right-hand side of a pointer assignment and
6977 se->expr is the descriptor for the previously-evaluated
6978 left-hand side. The function creates an assignment from
6982 The se->force_tmp flag disables the non-copying descriptor optimization
6983 that is used for transpose. It may be used in cases where there is an
6984 alias between the transpose argument and another argument in the same
6988 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6991 gfc_ss_type ss_type
;
6992 gfc_ss_info
*ss_info
;
6994 gfc_array_info
*info
;
7003 bool subref_array_target
= false;
7004 gfc_expr
*arg
, *ss_expr
;
7006 if (se
->want_coarray
)
7007 ss
= walk_coarray (expr
);
7009 ss
= gfc_walk_expr (expr
);
7011 gcc_assert (ss
!= NULL
);
7012 gcc_assert (ss
!= gfc_ss_terminator
);
7015 ss_type
= ss_info
->type
;
7016 ss_expr
= ss_info
->expr
;
7018 /* Special case: TRANSPOSE which needs no temporary. */
7019 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7020 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7022 /* This is a call to transpose which has already been handled by the
7023 scalarizer, so that we just need to get its argument's descriptor. */
7024 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7025 expr
= expr
->value
.function
.actual
->expr
;
7028 /* Special case things we know we can pass easily. */
7029 switch (expr
->expr_type
)
7032 /* If we have a linear array section, we can pass it directly.
7033 Otherwise we need to copy it into a temporary. */
7035 gcc_assert (ss_type
== GFC_SS_SECTION
);
7036 gcc_assert (ss_expr
== expr
);
7037 info
= &ss_info
->data
.array
;
7039 /* Get the descriptor for the array. */
7040 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7041 desc
= info
->descriptor
;
7043 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7044 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7045 && !subref_array_target
;
7052 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7054 /* Create a new descriptor if the array doesn't have one. */
7057 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7059 else if (se
->direct_byref
)
7062 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7064 if (full
&& !transposed_dims (ss
))
7066 if (se
->direct_byref
&& !se
->byref_noassign
)
7068 /* Copy the descriptor for pointer assignments. */
7069 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7071 /* Add any offsets from subreferences. */
7072 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7073 subref_array_target
, expr
);
7075 /* ....and set the span field. */
7076 tmp
= gfc_get_array_span (desc
, expr
);
7077 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7079 else if (se
->want_pointer
)
7081 /* We pass full arrays directly. This means that pointers and
7082 allocatable arrays should also work. */
7083 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7090 if (expr
->ts
.type
== BT_CHARACTER
)
7091 se
->string_length
= gfc_get_expr_charlen (expr
);
7093 gfc_free_ss_chain (ss
);
7099 /* A transformational function return value will be a temporary
7100 array descriptor. We still need to go through the scalarizer
7101 to create the descriptor. Elemental functions are handled as
7102 arbitrary expressions, i.e. copy to a temporary. */
7104 if (se
->direct_byref
)
7106 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7108 /* For pointer assignments pass the descriptor directly. */
7112 gcc_assert (se
->ss
== ss
);
7114 if (!is_pointer_array (se
->expr
))
7116 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7117 tmp
= fold_convert (gfc_array_index_type
,
7118 size_in_bytes (tmp
));
7119 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7122 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7123 gfc_conv_expr (se
, expr
);
7125 gfc_free_ss_chain (ss
);
7129 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7131 if (ss_expr
!= expr
)
7132 /* Elemental function. */
7133 gcc_assert ((expr
->value
.function
.esym
!= NULL
7134 && expr
->value
.function
.esym
->attr
.elemental
)
7135 || (expr
->value
.function
.isym
!= NULL
7136 && expr
->value
.function
.isym
->elemental
)
7137 || gfc_inline_intrinsic_function_p (expr
));
7139 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7142 if (expr
->ts
.type
== BT_CHARACTER
7143 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7144 get_array_charlen (expr
, se
);
7150 /* Transformational function. */
7151 info
= &ss_info
->data
.array
;
7157 /* Constant array constructors don't need a temporary. */
7158 if (ss_type
== GFC_SS_CONSTRUCTOR
7159 && expr
->ts
.type
!= BT_CHARACTER
7160 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7163 info
= &ss_info
->data
.array
;
7173 /* Something complicated. Copy it into a temporary. */
7179 /* If we are creating a temporary, we don't need to bother about aliases
7184 gfc_init_loopinfo (&loop
);
7186 /* Associate the SS with the loop. */
7187 gfc_add_ss_to_loop (&loop
, ss
);
7189 /* Tell the scalarizer not to bother creating loop variables, etc. */
7191 loop
.array_parameter
= 1;
7193 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7194 gcc_assert (!se
->direct_byref
);
7196 /* Do we need bounds checking or not? */
7197 ss
->no_bounds_check
= expr
->no_bounds_check
;
7199 /* Setup the scalarizing loops and bounds. */
7200 gfc_conv_ss_startstride (&loop
);
7204 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
7205 get_array_charlen (expr
, se
);
7207 /* Tell the scalarizer to make a temporary. */
7208 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7209 ((expr
->ts
.type
== BT_CHARACTER
)
7210 ? expr
->ts
.u
.cl
->backend_decl
7214 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7215 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7216 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7219 gfc_conv_loop_setup (&loop
, & expr
->where
);
7223 /* Copy into a temporary and pass that. We don't need to copy the data
7224 back because expressions and vector subscripts must be INTENT_IN. */
7225 /* TODO: Optimize passing function return values. */
7230 /* Start the copying loops. */
7231 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7232 gfc_mark_ss_chain_used (ss
, 1);
7233 gfc_start_scalarized_body (&loop
, &block
);
7235 /* Copy each data element. */
7236 gfc_init_se (&lse
, NULL
);
7237 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7238 gfc_init_se (&rse
, NULL
);
7239 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7241 lse
.ss
= loop
.temp_ss
;
7244 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7245 if (expr
->ts
.type
== BT_CHARACTER
)
7247 gfc_conv_expr (&rse
, expr
);
7248 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7249 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7253 gfc_conv_expr_val (&rse
, expr
);
7255 gfc_add_block_to_block (&block
, &rse
.pre
);
7256 gfc_add_block_to_block (&block
, &lse
.pre
);
7258 lse
.string_length
= rse
.string_length
;
7260 deep_copy
= !se
->data_not_needed
7261 && (expr
->expr_type
== EXPR_VARIABLE
7262 || expr
->expr_type
== EXPR_ARRAY
);
7263 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7265 gfc_add_expr_to_block (&block
, tmp
);
7267 /* Finish the copying loops. */
7268 gfc_trans_scalarizing_loops (&loop
, &block
);
7270 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7272 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7274 desc
= info
->descriptor
;
7275 se
->string_length
= ss_info
->string_length
;
7279 /* We pass sections without copying to a temporary. Make a new
7280 descriptor and point it at the section we want. The loop variable
7281 limits will be the limits of the section.
7282 A function may decide to repack the array to speed up access, but
7283 we're not bothered about that here. */
7284 int dim
, ndim
, codim
;
7291 bool onebased
= false, rank_remap
;
7293 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7294 rank_remap
= ss
->dimen
< ndim
;
7296 if (se
->want_coarray
)
7298 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7300 codim
= gfc_get_corank (expr
);
7301 for (n
= 0; n
< codim
- 1; n
++)
7303 /* Make sure we are not lost somehow. */
7304 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7306 /* Make sure the call to gfc_conv_section_startstride won't
7307 generate unnecessary code to calculate stride. */
7308 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7310 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7311 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7312 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7315 gcc_assert (n
== codim
- 1);
7316 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7317 info
->descriptor
, n
+ ndim
, true,
7318 ar
->as
->type
== AS_DEFERRED
);
7319 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7324 /* Set the string_length for a character array. */
7325 if (expr
->ts
.type
== BT_CHARACTER
)
7326 se
->string_length
= gfc_get_expr_charlen (expr
);
7328 /* If we have an array section or are assigning make sure that
7329 the lower bound is 1. References to the full
7330 array should otherwise keep the original bounds. */
7331 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7332 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7333 if (!integer_onep (loop
.from
[dim
]))
7335 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7336 gfc_array_index_type
, gfc_index_one_node
,
7338 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7339 gfc_array_index_type
,
7341 loop
.from
[dim
] = gfc_index_one_node
;
7344 desc
= info
->descriptor
;
7345 if (se
->direct_byref
&& !se
->byref_noassign
)
7347 /* For pointer assignments we fill in the destination.... */
7349 parmtype
= TREE_TYPE (parm
);
7351 /* ....and set the span field. */
7352 tmp
= gfc_get_array_span (desc
, expr
);
7353 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7357 /* Otherwise make a new one. */
7358 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7359 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7361 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7363 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7364 loop
.from
, loop
.to
, 0,
7365 GFC_ARRAY_UNKNOWN
, false);
7366 parm
= gfc_create_var (parmtype
, "parm");
7368 /* When expression is a class object, then add the class' handle to
7370 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7372 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7375 /* class_expr can be NULL, when no _class ref is in expr.
7376 We must not fix this here with a gfc_fix_class_ref (). */
7379 gfc_init_se (&classse
, NULL
);
7380 gfc_conv_expr (&classse
, class_expr
);
7381 gfc_free_expr (class_expr
);
7383 gcc_assert (classse
.pre
.head
== NULL_TREE
7384 && classse
.post
.head
== NULL_TREE
);
7385 gfc_allocate_lang_decl (parm
);
7386 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7391 offset
= gfc_index_zero_node
;
7393 /* The following can be somewhat confusing. We have two
7394 descriptors, a new one and the original array.
7395 {parm, parmtype, dim} refer to the new one.
7396 {desc, type, n, loop} refer to the original, which maybe
7397 a descriptorless array.
7398 The bounds of the scalarization are the bounds of the section.
7399 We don't have to worry about numeric overflows when calculating
7400 the offsets because all elements are within the array data. */
7402 /* Set the dtype. */
7403 tmp
= gfc_conv_descriptor_dtype (parm
);
7404 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7406 /* Set offset for assignments to pointer only to zero if it is not
7408 if ((se
->direct_byref
|| se
->use_offset
)
7409 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7410 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7411 base
= gfc_index_zero_node
;
7412 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7413 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7417 for (n
= 0; n
< ndim
; n
++)
7419 stride
= gfc_conv_array_stride (desc
, n
);
7421 /* Work out the offset. */
7423 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7425 gcc_assert (info
->subscript
[n
]
7426 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7427 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7431 /* Evaluate and remember the start of the section. */
7432 start
= info
->start
[n
];
7433 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7436 tmp
= gfc_conv_array_lbound (desc
, n
);
7437 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7439 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7441 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7445 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7447 /* For elemental dimensions, we only need the offset. */
7451 /* Vector subscripts need copying and are handled elsewhere. */
7453 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7455 /* look for the corresponding scalarizer dimension: dim. */
7456 for (dim
= 0; dim
< ndim
; dim
++)
7457 if (ss
->dim
[dim
] == n
)
7460 /* loop exited early: the DIM being looked for has been found. */
7461 gcc_assert (dim
< ndim
);
7463 /* Set the new lower bound. */
7464 from
= loop
.from
[dim
];
7467 onebased
= integer_onep (from
);
7468 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7469 gfc_rank_cst
[dim
], from
);
7471 /* Set the new upper bound. */
7472 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7473 gfc_rank_cst
[dim
], to
);
7475 /* Multiply the stride by the section stride to get the
7477 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7478 gfc_array_index_type
,
7479 stride
, info
->stride
[n
]);
7481 if ((se
->direct_byref
|| se
->use_offset
)
7482 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7483 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7485 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7486 TREE_TYPE (base
), base
, stride
);
7488 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7491 tmp
= gfc_conv_array_lbound (desc
, n
);
7492 toonebased
= integer_onep (tmp
);
7493 // lb(arr) - from (- start + 1)
7494 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7495 TREE_TYPE (base
), tmp
, from
);
7496 if (onebased
&& toonebased
)
7498 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7499 TREE_TYPE (base
), tmp
, start
);
7500 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7501 TREE_TYPE (base
), tmp
,
7502 gfc_index_one_node
);
7504 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7505 TREE_TYPE (base
), tmp
,
7506 gfc_conv_array_stride (desc
, n
));
7507 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7508 TREE_TYPE (base
), tmp
, base
);
7511 /* Store the new stride. */
7512 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7513 gfc_rank_cst
[dim
], stride
);
7516 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7518 from
= loop
.from
[n
];
7520 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7521 gfc_rank_cst
[n
], from
);
7522 if (n
< loop
.dimen
+ codim
- 1)
7523 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7524 gfc_rank_cst
[n
], to
);
7527 if (se
->data_not_needed
)
7528 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7529 gfc_index_zero_node
);
7531 /* Point the data pointer at the 1st element in the section. */
7532 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7533 subref_array_target
, expr
);
7535 /* Force the offset to be -1, when the lower bound of the highest
7536 dimension is one and the symbol is present and is not a
7537 pointer/allocatable or associated. */
7538 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7539 && !se
->data_not_needed
)
7540 || (se
->use_offset
&& base
!= NULL_TREE
))
7542 /* Set the offset depending on base. */
7543 tmp
= rank_remap
&& !se
->direct_byref
?
7544 fold_build2_loc (input_location
, PLUS_EXPR
,
7545 gfc_array_index_type
, base
,
7548 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7550 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7551 && !se
->data_not_needed
7552 && (!rank_remap
|| se
->use_offset
))
7554 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7555 gfc_conv_descriptor_offset_get (desc
));
7557 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7559 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7560 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7561 && !expr
->symtree
->n
.sym
->attr
.allocatable
7562 && !expr
->symtree
->n
.sym
->attr
.pointer
7563 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7564 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7566 /* Set the offset to -1. */
7568 mpz_init_set_si (minus_one
, -1);
7569 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7570 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7574 /* Only the callee knows what the correct offset it, so just set
7576 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7581 /* For class arrays add the class tree into the saved descriptor to
7582 enable getting of _vptr and the like. */
7583 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7584 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7586 gfc_allocate_lang_decl (desc
);
7587 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7588 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7589 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7590 : expr
->symtree
->n
.sym
->backend_decl
;
7592 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7593 && IS_CLASS_ARRAY (expr
))
7596 gfc_allocate_lang_decl (desc
);
7597 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7598 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7599 vtype
= gfc_class_vptr_get (tmp
);
7600 gfc_add_modify (&se
->pre
, vtype
,
7601 gfc_build_addr_expr (TREE_TYPE (vtype
),
7602 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7604 if (!se
->direct_byref
|| se
->byref_noassign
)
7606 /* Get a pointer to the new descriptor. */
7607 if (se
->want_pointer
)
7608 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7613 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7614 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7616 /* Cleanup the scalarizer. */
7617 gfc_cleanup_loop (&loop
);
7620 /* Helper function for gfc_conv_array_parameter if array size needs to be
7624 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7627 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7628 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7629 else if (expr
->rank
> 1)
7630 *size
= build_call_expr_loc (input_location
,
7631 gfor_fndecl_size0
, 1,
7632 gfc_build_addr_expr (NULL
, desc
));
7635 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7636 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7638 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7639 gfc_array_index_type
, ubound
, lbound
);
7640 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7641 *size
, gfc_index_one_node
);
7642 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7643 *size
, gfc_index_zero_node
);
7645 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7646 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7647 *size
, fold_convert (gfc_array_index_type
, elem
));
7650 /* Convert an array for passing as an actual parameter. */
7651 /* TODO: Optimize passing g77 arrays. */
7654 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7655 const gfc_symbol
*fsym
, const char *proc_name
,
7660 tree tmp
= NULL_TREE
;
7662 tree parent
= DECL_CONTEXT (current_function_decl
);
7663 bool full_array_var
;
7664 bool this_array_result
;
7667 bool array_constructor
;
7668 bool good_allocatable
;
7669 bool ultimate_ptr_comp
;
7670 bool ultimate_alloc_comp
;
7675 ultimate_ptr_comp
= false;
7676 ultimate_alloc_comp
= false;
7678 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7680 if (ref
->next
== NULL
)
7683 if (ref
->type
== REF_COMPONENT
)
7685 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7686 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7690 full_array_var
= false;
7693 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7694 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7696 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7698 /* The symbol should have an array specification. */
7699 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7701 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7703 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7704 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7705 se
->string_length
= tmp
;
7708 /* Is this the result of the enclosing procedure? */
7709 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7710 if (this_array_result
7711 && (sym
->backend_decl
!= current_function_decl
)
7712 && (sym
->backend_decl
!= parent
))
7713 this_array_result
= false;
7715 /* Passing address of the array if it is not pointer or assumed-shape. */
7716 if (full_array_var
&& g77
&& !this_array_result
7717 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7719 tmp
= gfc_get_symbol_decl (sym
);
7721 if (sym
->ts
.type
== BT_CHARACTER
)
7722 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7724 if (!sym
->attr
.pointer
7726 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7727 && sym
->as
->type
!= AS_DEFERRED
7728 && sym
->as
->type
!= AS_ASSUMED_RANK
7729 && !sym
->attr
.allocatable
)
7731 /* Some variables are declared directly, others are declared as
7732 pointers and allocated on the heap. */
7733 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7736 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7738 array_parameter_size (tmp
, expr
, size
);
7742 if (sym
->attr
.allocatable
)
7744 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7746 gfc_conv_expr_descriptor (se
, expr
);
7750 array_parameter_size (tmp
, expr
, size
);
7751 se
->expr
= gfc_conv_array_data (tmp
);
7756 /* A convenient reduction in scope. */
7757 contiguous
= g77
&& !this_array_result
&& contiguous
;
7759 /* There is no need to pack and unpack the array, if it is contiguous
7760 and not a deferred- or assumed-shape array, or if it is simply
7762 no_pack
= ((sym
&& sym
->as
7763 && !sym
->attr
.pointer
7764 && sym
->as
->type
!= AS_DEFERRED
7765 && sym
->as
->type
!= AS_ASSUMED_RANK
7766 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7768 (ref
&& ref
->u
.ar
.as
7769 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7770 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7771 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7773 gfc_is_simply_contiguous (expr
, false, true));
7775 no_pack
= contiguous
&& no_pack
;
7777 /* Array constructors are always contiguous and do not need packing. */
7778 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7780 /* Same is true of contiguous sections from allocatable variables. */
7781 good_allocatable
= contiguous
7783 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7785 /* Or ultimate allocatable components. */
7786 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7788 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7790 gfc_conv_expr_descriptor (se
, expr
);
7791 /* Deallocate the allocatable components of structures that are
7793 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7794 && expr
->ts
.u
.derived
->attr
.alloc_comp
7795 && expr
->expr_type
!= EXPR_VARIABLE
)
7797 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7799 /* The components shall be deallocated before their containing entity. */
7800 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7802 if (expr
->ts
.type
== BT_CHARACTER
)
7803 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7805 array_parameter_size (se
->expr
, expr
, size
);
7806 se
->expr
= gfc_conv_array_data (se
->expr
);
7810 if (this_array_result
)
7812 /* Result of the enclosing function. */
7813 gfc_conv_expr_descriptor (se
, expr
);
7815 array_parameter_size (se
->expr
, expr
, size
);
7816 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7818 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7819 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7820 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7827 /* Every other type of array. */
7828 se
->want_pointer
= 1;
7829 gfc_conv_expr_descriptor (se
, expr
);
7832 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7837 /* Deallocate the allocatable components of structures that are
7838 not variable, for descriptorless arguments.
7839 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7840 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7841 && expr
->ts
.u
.derived
->attr
.alloc_comp
7842 && expr
->expr_type
!= EXPR_VARIABLE
)
7844 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7845 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7847 /* The components shall be deallocated before their containing entity. */
7848 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7851 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7852 && !gfc_is_simply_contiguous (expr
, false, true)))
7854 tree origptr
= NULL_TREE
;
7858 /* For contiguous arrays, save the original value of the descriptor. */
7861 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7862 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7863 tmp
= gfc_conv_array_data (tmp
);
7864 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7865 TREE_TYPE (origptr
), origptr
,
7866 fold_convert (TREE_TYPE (origptr
), tmp
));
7867 gfc_add_expr_to_block (&se
->pre
, tmp
);
7870 /* Repack the array. */
7871 if (warn_array_temporaries
)
7874 gfc_warning (OPT_Warray_temporaries
,
7875 "Creating array temporary at %L for argument %qs",
7876 &expr
->where
, fsym
->name
);
7878 gfc_warning (OPT_Warray_temporaries
,
7879 "Creating array temporary at %L", &expr
->where
);
7882 ptr
= build_call_expr_loc (input_location
,
7883 gfor_fndecl_in_pack
, 1, desc
);
7885 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7887 tmp
= gfc_conv_expr_present (sym
);
7888 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7889 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7890 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7893 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7895 /* Use the packed data for the actual argument, except for contiguous arrays,
7896 where the descriptor's data component is set. */
7901 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7903 gfc_ss
* ss
= gfc_walk_expr (expr
);
7904 if (!transposed_dims (ss
))
7905 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7908 tree old_field
, new_field
;
7910 /* The original descriptor has transposed dims so we can't reuse
7911 it directly; we have to create a new one. */
7912 tree old_desc
= tmp
;
7913 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7915 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7916 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7917 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7919 old_field
= gfc_conv_descriptor_offset (old_desc
);
7920 new_field
= gfc_conv_descriptor_offset (new_desc
);
7921 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7923 for (int i
= 0; i
< expr
->rank
; i
++)
7925 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7926 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7927 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7929 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7932 if (flag_coarray
== GFC_FCOARRAY_LIB
7933 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7934 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7935 == GFC_ARRAY_ALLOCATABLE
)
7937 old_field
= gfc_conv_descriptor_token (old_desc
);
7938 new_field
= gfc_conv_descriptor_token (new_desc
);
7939 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7942 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7943 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7948 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7952 if (fsym
&& proc_name
)
7953 msg
= xasprintf ("An array temporary was created for argument "
7954 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7956 msg
= xasprintf ("An array temporary was created");
7958 tmp
= build_fold_indirect_ref_loc (input_location
,
7960 tmp
= gfc_conv_array_data (tmp
);
7961 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7962 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7964 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7965 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7967 gfc_conv_expr_present (sym
), tmp
);
7969 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7974 gfc_start_block (&block
);
7976 /* Copy the data back. */
7977 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7979 tmp
= build_call_expr_loc (input_location
,
7980 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7981 gfc_add_expr_to_block (&block
, tmp
);
7984 /* Free the temporary. */
7985 tmp
= gfc_call_free (ptr
);
7986 gfc_add_expr_to_block (&block
, tmp
);
7988 stmt
= gfc_finish_block (&block
);
7990 gfc_init_block (&block
);
7991 /* Only if it was repacked. This code needs to be executed before the
7992 loop cleanup code. */
7993 tmp
= build_fold_indirect_ref_loc (input_location
,
7995 tmp
= gfc_conv_array_data (tmp
);
7996 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7997 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7999 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8000 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8002 gfc_conv_expr_present (sym
), tmp
);
8004 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8006 gfc_add_expr_to_block (&block
, tmp
);
8007 gfc_add_block_to_block (&block
, &se
->post
);
8009 gfc_init_block (&se
->post
);
8011 /* Reset the descriptor pointer. */
8014 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8015 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8018 gfc_add_block_to_block (&se
->post
, &block
);
8023 /* This helper function calculates the size in words of a full array. */
8026 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8031 idx
= gfc_rank_cst
[rank
- 1];
8032 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8033 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8034 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8036 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8037 tmp
, gfc_index_one_node
);
8038 tmp
= gfc_evaluate_now (tmp
, block
);
8040 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8041 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8043 return gfc_evaluate_now (tmp
, block
);
8047 /* Allocate dest to the same size as src, and copy src -> dest.
8048 If no_malloc is set, only the copy is done. */
8051 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8052 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8053 tree add_when_allocated
)
8062 /* If the source is null, set the destination to null. Then,
8063 allocate memory to the destination. */
8064 gfc_init_block (&block
);
8066 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8068 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8069 null_data
= gfc_finish_block (&block
);
8071 gfc_init_block (&block
);
8072 if (str_sz
!= NULL_TREE
)
8075 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8079 tmp
= gfc_call_malloc (&block
, type
, size
);
8080 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8085 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8086 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8087 fold_convert (size_type_node
, size
));
8088 gfc_add_expr_to_block (&block
, tmp
);
8093 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8094 null_data
= gfc_finish_block (&block
);
8096 gfc_init_block (&block
);
8098 nelems
= gfc_full_array_size (&block
, src
, rank
);
8100 nelems
= gfc_index_one_node
;
8102 if (str_sz
!= NULL_TREE
)
8103 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8105 tmp
= fold_convert (gfc_array_index_type
,
8106 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8107 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8111 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8112 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8113 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8116 /* We know the temporary and the value will be the same length,
8117 so can use memcpy. */
8120 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8121 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8122 gfc_conv_descriptor_data_get (dest
),
8123 gfc_conv_descriptor_data_get (src
),
8124 fold_convert (size_type_node
, size
));
8125 gfc_add_expr_to_block (&block
, tmp
);
8129 gfc_add_expr_to_block (&block
, add_when_allocated
);
8130 tmp
= gfc_finish_block (&block
);
8132 /* Null the destination if the source is null; otherwise do
8133 the allocate and copy. */
8134 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8137 null_cond
= gfc_conv_descriptor_data_get (src
);
8139 null_cond
= convert (pvoid_type_node
, null_cond
);
8140 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8141 null_cond
, null_pointer_node
);
8142 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8146 /* Allocate dest to the same size as src, and copy data src -> dest. */
8149 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8150 tree add_when_allocated
)
8152 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8153 NULL_TREE
, add_when_allocated
);
8157 /* Copy data src -> dest. */
8160 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8162 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8163 NULL_TREE
, NULL_TREE
);
8166 /* Allocate dest to the same size as src, but don't copy anything. */
8169 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8171 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8172 NULL_TREE
, NULL_TREE
);
8177 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8178 tree type
, int rank
)
8185 stmtblock_t block
, globalblock
;
8187 /* If the source is null, set the destination to null. Then,
8188 allocate memory to the destination. */
8189 gfc_init_block (&block
);
8190 gfc_init_block (&globalblock
);
8192 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8195 symbol_attribute attr
;
8198 gfc_init_se (&se
, NULL
);
8199 gfc_clear_attr (&attr
);
8200 attr
.allocatable
= 1;
8201 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8202 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8203 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8205 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8206 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8207 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8208 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8209 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8210 null_data
= gfc_finish_block (&block
);
8212 gfc_init_block (&block
);
8214 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8215 fold_convert (size_type_node
, size
),
8216 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8217 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8218 GFC_CAF_COARRAY_ALLOC
);
8220 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8221 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8222 fold_convert (size_type_node
, size
));
8223 gfc_add_expr_to_block (&block
, tmp
);
8227 /* Set the rank or unitialized memory access may be reported. */
8228 tmp
= gfc_conv_descriptor_rank (dest
);
8229 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8232 nelems
= gfc_full_array_size (&block
, src
, rank
);
8234 nelems
= integer_one_node
;
8236 tmp
= fold_convert (size_type_node
,
8237 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8238 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8239 fold_convert (size_type_node
, nelems
), tmp
);
8241 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8242 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8244 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8245 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8246 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8247 null_data
= gfc_finish_block (&block
);
8249 gfc_init_block (&block
);
8250 gfc_allocate_using_caf_lib (&block
, dest
,
8251 fold_convert (size_type_node
, size
),
8252 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8253 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8254 GFC_CAF_COARRAY_ALLOC
);
8256 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8257 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8258 gfc_conv_descriptor_data_get (dest
),
8259 gfc_conv_descriptor_data_get (src
),
8260 fold_convert (size_type_node
, size
));
8261 gfc_add_expr_to_block (&block
, tmp
);
8264 tmp
= gfc_finish_block (&block
);
8266 /* Null the destination if the source is null; otherwise do
8267 the register and copy. */
8268 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8271 null_cond
= gfc_conv_descriptor_data_get (src
);
8273 null_cond
= convert (pvoid_type_node
, null_cond
);
8274 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8275 null_cond
, null_pointer_node
);
8276 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8278 return gfc_finish_block (&globalblock
);
8282 /* Helper function to abstract whether coarray processing is enabled. */
8285 caf_enabled (int caf_mode
)
8287 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8288 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8292 /* Helper function to abstract whether coarray processing is enabled
8293 and we are in a derived type coarray. */
8296 caf_in_coarray (int caf_mode
)
8298 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8299 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8300 return (caf_mode
& pat
) == pat
;
8304 /* Helper function to abstract whether coarray is to deallocate only. */
8307 gfc_caf_is_dealloc_only (int caf_mode
)
8309 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8310 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8314 /* Recursively traverse an object of derived type, generating code to
8315 deallocate, nullify or copy allocatable components. This is the work horse
8316 function for the functions named in this enum. */
8318 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8319 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8320 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8322 static gfc_actual_arglist
*pdt_param_list
;
8325 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8326 tree dest
, int rank
, int purpose
, int caf_mode
)
8330 stmtblock_t fnblock
;
8331 stmtblock_t loopbody
;
8332 stmtblock_t tmpblock
;
8343 tree null_cond
= NULL_TREE
;
8344 tree add_when_allocated
;
8345 tree dealloc_fndecl
;
8349 symbol_attribute
*attr
;
8350 bool deallocate_called
;
8352 gfc_init_block (&fnblock
);
8354 decl_type
= TREE_TYPE (decl
);
8356 if ((POINTER_TYPE_P (decl_type
))
8357 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8359 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8360 /* Deref dest in sync with decl, but only when it is not NULL. */
8362 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8364 /* Update the decl_type because it got dereferenced. */
8365 decl_type
= TREE_TYPE (decl
);
8368 /* If this is an array of derived types with allocatable components
8369 build a loop and recursively call this function. */
8370 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8371 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8373 tmp
= gfc_conv_array_data (decl
);
8374 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8376 /* Get the number of elements - 1 and set the counter. */
8377 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8379 /* Use the descriptor for an allocatable array. Since this
8380 is a full array reference, we only need the descriptor
8381 information from dimension = rank. */
8382 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8383 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8384 gfc_array_index_type
, tmp
,
8385 gfc_index_one_node
);
8387 null_cond
= gfc_conv_descriptor_data_get (decl
);
8388 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8389 logical_type_node
, null_cond
,
8390 build_int_cst (TREE_TYPE (null_cond
), 0));
8394 /* Otherwise use the TYPE_DOMAIN information. */
8395 tmp
= array_type_nelts (decl_type
);
8396 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8399 /* Remember that this is, in fact, the no. of elements - 1. */
8400 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8401 index
= gfc_create_var (gfc_array_index_type
, "S");
8403 /* Build the body of the loop. */
8404 gfc_init_block (&loopbody
);
8406 vref
= gfc_build_array_ref (var
, index
, NULL
);
8408 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8409 && !caf_enabled (caf_mode
))
8411 tmp
= build_fold_indirect_ref_loc (input_location
,
8412 gfc_conv_array_data (dest
));
8413 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8414 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8415 COPY_ALLOC_COMP
, 0);
8418 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8421 gfc_add_expr_to_block (&loopbody
, tmp
);
8423 /* Build the loop and return. */
8424 gfc_init_loopinfo (&loop
);
8426 loop
.from
[0] = gfc_index_zero_node
;
8427 loop
.loopvar
[0] = index
;
8428 loop
.to
[0] = nelems
;
8429 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8430 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8432 tmp
= gfc_finish_block (&fnblock
);
8433 /* When copying allocateable components, the above implements the
8434 deep copy. Nevertheless is a deep copy only allowed, when the current
8435 component is allocated, for which code will be generated in
8436 gfc_duplicate_allocatable (), where the deep copy code is just added
8437 into the if's body, by adding tmp (the deep copy code) as last
8438 argument to gfc_duplicate_allocatable (). */
8439 if (purpose
== COPY_ALLOC_COMP
8440 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8441 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8443 else if (null_cond
!= NULL_TREE
)
8444 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8445 build_empty_stmt (input_location
));
8450 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8452 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8453 DEALLOCATE_PDT_COMP
, 0);
8454 gfc_add_expr_to_block (&fnblock
, tmp
);
8456 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8458 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8459 NULLIFY_ALLOC_COMP
, 0);
8460 gfc_add_expr_to_block (&fnblock
, tmp
);
8463 /* Otherwise, act on the components or recursively call self to
8464 act on a chain of components. */
8465 for (c
= der_type
->components
; c
; c
= c
->next
)
8467 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8468 || c
->ts
.type
== BT_CLASS
)
8469 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8470 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8471 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8473 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8474 && c
->ts
.u
.derived
->attr
.pdt_type
;
8476 cdecl = c
->backend_decl
;
8477 ctype
= TREE_TYPE (cdecl);
8481 case DEALLOCATE_ALLOC_COMP
:
8483 gfc_init_block (&tmpblock
);
8485 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8486 decl
, cdecl, NULL_TREE
);
8488 /* Shortcut to get the attributes of the component. */
8489 if (c
->ts
.type
== BT_CLASS
)
8491 attr
= &CLASS_DATA (c
)->attr
;
8492 if (attr
->class_pointer
)
8502 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8503 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8504 /* Call the finalizer, which will free the memory and nullify the
8505 pointer of an array. */
8506 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8507 caf_enabled (caf_mode
))
8510 deallocate_called
= false;
8512 /* Add the _class ref for classes. */
8513 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8514 comp
= gfc_class_data_get (comp
);
8516 add_when_allocated
= NULL_TREE
;
8517 if (cmp_has_alloc_comps
8518 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8520 && !deallocate_called
)
8522 /* Add checked deallocation of the components. This code is
8523 obviously added because the finalizer is not trusted to free
8525 if (c
->ts
.type
== BT_CLASS
)
8527 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8529 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8530 comp
, NULL_TREE
, rank
, purpose
,
8535 rank
= c
->as
? c
->as
->rank
: 0;
8536 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8543 if (attr
->allocatable
&& !same_type
8544 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8546 /* Handle all types of components besides components of the
8547 same_type as the current one, because those would create an
8550 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8551 ? (gfc_caf_is_dealloc_only (caf_mode
)
8552 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8553 : GFC_CAF_COARRAY_DEREGISTER
)
8554 : GFC_CAF_COARRAY_NOCOARRAY
;
8556 caf_token
= NULL_TREE
;
8557 /* Coarray components are handled directly by
8558 deallocate_with_status. */
8559 if (!attr
->codimension
8560 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8563 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8564 TREE_TYPE (c
->caf_token
),
8565 decl
, c
->caf_token
, NULL_TREE
);
8566 else if (attr
->dimension
&& !attr
->proc_pointer
)
8567 caf_token
= gfc_conv_descriptor_token (comp
);
8569 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8570 /* When this is an array but not in conjunction with a coarray
8571 then add the data-ref. For coarray'ed arrays the data-ref
8572 is added by deallocate_with_status. */
8573 comp
= gfc_conv_descriptor_data_get (comp
);
8575 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8576 NULL_TREE
, NULL_TREE
, true,
8577 NULL
, caf_dereg_mode
,
8578 add_when_allocated
, caf_token
);
8580 gfc_add_expr_to_block (&tmpblock
, tmp
);
8582 else if (attr
->allocatable
&& !attr
->codimension
8583 && !deallocate_called
)
8585 /* Case of recursive allocatable derived types. */
8589 stmtblock_t dealloc_block
;
8591 gfc_init_block (&dealloc_block
);
8592 if (add_when_allocated
)
8593 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8595 /* Convert the component into a rank 1 descriptor type. */
8596 if (attr
->dimension
)
8598 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8599 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8600 c
->ts
.type
== BT_CLASS
8601 ? CLASS_DATA (c
)->as
->rank
8606 tmp
= TREE_TYPE (comp
);
8607 ubound
= build_int_cst (gfc_array_index_type
, 1);
8610 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8612 GFC_ARRAY_ALLOCATABLE
, false);
8614 cdesc
= gfc_create_var (cdesc
, "cdesc");
8615 DECL_ARTIFICIAL (cdesc
) = 1;
8617 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8618 gfc_get_dtype_rank_type (1, tmp
));
8619 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8620 gfc_index_zero_node
,
8621 gfc_index_one_node
);
8622 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8623 gfc_index_zero_node
,
8624 gfc_index_one_node
);
8625 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8626 gfc_index_zero_node
, ubound
);
8628 if (attr
->dimension
)
8629 comp
= gfc_conv_descriptor_data_get (comp
);
8631 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8633 /* Now call the deallocator. */
8634 vtab
= gfc_find_vtab (&c
->ts
);
8635 if (vtab
->backend_decl
== NULL
)
8636 gfc_get_symbol_decl (vtab
);
8637 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8638 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8639 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8641 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8642 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8643 logical_type_node
, tmp
,
8645 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8647 tmp
= build_call_expr_loc (input_location
,
8650 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8652 tmp
= gfc_finish_block (&dealloc_block
);
8654 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8655 void_type_node
, is_allocated
, tmp
,
8656 build_empty_stmt (input_location
));
8658 gfc_add_expr_to_block (&tmpblock
, tmp
);
8660 else if (add_when_allocated
)
8661 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8663 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8664 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8666 /* Finally, reset the vptr to the declared type vtable and, if
8667 necessary reset the _len field.
8669 First recover the reference to the component and obtain
8671 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8672 decl
, cdecl, NULL_TREE
);
8673 tmp
= gfc_class_vptr_get (comp
);
8675 if (UNLIMITED_POLY (c
))
8677 /* Both vptr and _len field should be nulled. */
8678 gfc_add_modify (&tmpblock
, tmp
,
8679 build_int_cst (TREE_TYPE (tmp
), 0));
8680 tmp
= gfc_class_len_get (comp
);
8681 gfc_add_modify (&tmpblock
, tmp
,
8682 build_int_cst (TREE_TYPE (tmp
), 0));
8686 /* Build the vtable address and set the vptr with it. */
8689 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8690 vtab
= vtable
->backend_decl
;
8691 if (vtab
== NULL_TREE
)
8692 vtab
= gfc_get_symbol_decl (vtable
);
8693 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8694 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8695 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8699 /* Now add the deallocation of this component. */
8700 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8703 case NULLIFY_ALLOC_COMP
:
8705 - allocatable components (regular or in class)
8706 - components that have allocatable components
8707 - pointer components when in a coarray.
8708 Skip everything else especially proc_pointers, which may come
8709 coupled with the regular pointer attribute. */
8710 if (c
->attr
.proc_pointer
8711 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8712 && CLASS_DATA (c
)->attr
.allocatable
)
8713 || (cmp_has_alloc_comps
8714 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8715 || (c
->ts
.type
== BT_CLASS
8716 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8717 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8720 /* Process class components first, because they always have the
8721 pointer-attribute set which would be caught wrong else. */
8722 if (c
->ts
.type
== BT_CLASS
8723 && (CLASS_DATA (c
)->attr
.allocatable
8724 || CLASS_DATA (c
)->attr
.class_pointer
))
8726 /* Allocatable CLASS components. */
8727 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8728 decl
, cdecl, NULL_TREE
);
8730 comp
= gfc_class_data_get (comp
);
8731 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8732 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8736 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8737 void_type_node
, comp
,
8738 build_int_cst (TREE_TYPE (comp
), 0));
8739 gfc_add_expr_to_block (&fnblock
, tmp
);
8741 cmp_has_alloc_comps
= false;
8743 /* Coarrays need the component to be nulled before the api-call
8745 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8747 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8748 decl
, cdecl, NULL_TREE
);
8749 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8750 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8753 gfc_add_modify (&fnblock
, comp
,
8754 build_int_cst (TREE_TYPE (comp
), 0));
8755 if (gfc_deferred_strlen (c
, &comp
))
8757 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8759 decl
, comp
, NULL_TREE
);
8760 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8761 TREE_TYPE (comp
), comp
,
8762 build_int_cst (TREE_TYPE (comp
), 0));
8763 gfc_add_expr_to_block (&fnblock
, tmp
);
8765 cmp_has_alloc_comps
= false;
8768 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
8770 /* Register a component of a derived type coarray with the
8771 coarray library. Do not register ultimate component
8772 coarrays here. They are treated like regular coarrays and
8773 are either allocated on all images or on none. */
8776 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8777 decl
, cdecl, NULL_TREE
);
8778 if (c
->attr
.dimension
)
8780 /* Set the dtype, because caf_register needs it. */
8781 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8782 gfc_get_dtype (TREE_TYPE (comp
)));
8783 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8784 decl
, cdecl, NULL_TREE
);
8785 token
= gfc_conv_descriptor_token (tmp
);
8791 gfc_init_se (&se
, NULL
);
8792 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8793 pvoid_type_node
, decl
, c
->caf_token
,
8795 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8796 c
->ts
.type
== BT_CLASS
8797 ? CLASS_DATA (c
)->attr
8799 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8802 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8803 gfc_build_addr_expr (NULL_TREE
,
8805 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8806 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8809 if (cmp_has_alloc_comps
)
8811 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8812 decl
, cdecl, NULL_TREE
);
8813 rank
= c
->as
? c
->as
->rank
: 0;
8814 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8815 rank
, purpose
, caf_mode
);
8816 gfc_add_expr_to_block (&fnblock
, tmp
);
8820 case REASSIGN_CAF_COMP
:
8821 if (caf_enabled (caf_mode
)
8822 && (c
->attr
.codimension
8823 || (c
->ts
.type
== BT_CLASS
8824 && (CLASS_DATA (c
)->attr
.coarray_comp
8825 || caf_in_coarray (caf_mode
)))
8826 || (c
->ts
.type
== BT_DERIVED
8827 && (c
->ts
.u
.derived
->attr
.coarray_comp
8828 || caf_in_coarray (caf_mode
))))
8831 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8832 decl
, cdecl, NULL_TREE
);
8833 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8834 dest
, cdecl, NULL_TREE
);
8836 if (c
->attr
.codimension
)
8838 if (c
->ts
.type
== BT_CLASS
)
8840 comp
= gfc_class_data_get (comp
);
8841 dcmp
= gfc_class_data_get (dcmp
);
8843 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8844 gfc_conv_descriptor_data_get (comp
));
8848 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8849 rank
, purpose
, caf_mode
8850 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8851 gfc_add_expr_to_block (&fnblock
, tmp
);
8856 case COPY_ALLOC_COMP
:
8857 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
8860 /* We need source and destination components. */
8861 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8863 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8865 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8867 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8875 dst_data
= gfc_class_data_get (dcmp
);
8876 src_data
= gfc_class_data_get (comp
);
8877 size
= fold_convert (size_type_node
,
8878 gfc_class_vtab_size_get (comp
));
8880 if (CLASS_DATA (c
)->attr
.dimension
)
8882 nelems
= gfc_conv_descriptor_size (src_data
,
8883 CLASS_DATA (c
)->as
->rank
);
8884 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8885 size_type_node
, size
,
8886 fold_convert (size_type_node
,
8890 nelems
= build_int_cst (size_type_node
, 1);
8892 if (CLASS_DATA (c
)->attr
.dimension
8893 || CLASS_DATA (c
)->attr
.codimension
)
8895 src_data
= gfc_conv_descriptor_data_get (src_data
);
8896 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8899 gfc_init_block (&tmpblock
);
8901 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
8902 gfc_class_vptr_get (comp
));
8904 /* Copy the unlimited '_len' field. If it is greater than zero
8905 (ie. a character(_len)), multiply it by size and use this
8906 for the malloc call. */
8907 if (UNLIMITED_POLY (c
))
8910 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
8911 gfc_class_len_get (comp
));
8913 size
= gfc_evaluate_now (size
, &tmpblock
);
8914 tmp
= gfc_class_len_get (comp
);
8915 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8916 size_type_node
, size
,
8917 fold_convert (size_type_node
, tmp
));
8918 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
8919 logical_type_node
, tmp
,
8920 build_zero_cst (TREE_TYPE (tmp
)));
8921 size
= fold_build3_loc (input_location
, COND_EXPR
,
8922 size_type_node
, tmp
, ctmp
, size
);
8923 size
= gfc_evaluate_now (size
, &tmpblock
);
8926 /* Coarray component have to have the same allocation status and
8927 shape/type-parameter/effective-type on the LHS and RHS of an
8928 intrinsic assignment. Hence, we did not deallocated them - and
8929 do not allocate them here. */
8930 if (!CLASS_DATA (c
)->attr
.codimension
)
8932 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8933 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8934 gfc_add_modify (&tmpblock
, dst_data
,
8935 fold_convert (TREE_TYPE (dst_data
), tmp
));
8938 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8939 UNLIMITED_POLY (c
));
8940 gfc_add_expr_to_block (&tmpblock
, tmp
);
8941 tmp
= gfc_finish_block (&tmpblock
);
8943 gfc_init_block (&tmpblock
);
8944 gfc_add_modify (&tmpblock
, dst_data
,
8945 fold_convert (TREE_TYPE (dst_data
),
8946 null_pointer_node
));
8947 null_data
= gfc_finish_block (&tmpblock
);
8949 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8950 logical_type_node
, src_data
,
8953 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8958 /* To implement guarded deep copy, i.e., deep copy only allocatable
8959 components that are really allocated, the deep copy code has to
8960 be generated first and then added to the if-block in
8961 gfc_duplicate_allocatable (). */
8962 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
8964 rank
= c
->as
? c
->as
->rank
: 0;
8965 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8966 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8967 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8973 add_when_allocated
= NULL_TREE
;
8975 if (gfc_deferred_strlen (c
, &tmp
))
8979 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8981 decl
, len
, NULL_TREE
);
8982 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8984 dest
, len
, NULL_TREE
);
8985 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8986 TREE_TYPE (len
), len
, tmp
);
8987 gfc_add_expr_to_block (&fnblock
, tmp
);
8988 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8989 /* This component can not have allocatable components,
8990 therefore add_when_allocated of duplicate_allocatable ()
8992 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8993 false, false, size
, NULL_TREE
);
8994 gfc_add_expr_to_block (&fnblock
, tmp
);
8996 else if (c
->attr
.pdt_array
)
8998 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
8999 c
->as
? c
->as
->rank
: 0,
9000 false, false, NULL_TREE
, NULL_TREE
);
9001 gfc_add_expr_to_block (&fnblock
, tmp
);
9003 else if ((c
->attr
.allocatable
)
9004 && !c
->attr
.proc_pointer
&& !same_type
9005 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9006 || caf_in_coarray (caf_mode
)))
9008 rank
= c
->as
? c
->as
->rank
: 0;
9009 if (c
->attr
.codimension
)
9010 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9011 else if (flag_coarray
== GFC_FCOARRAY_LIB
9012 && caf_in_coarray (caf_mode
))
9014 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
9015 : fold_build3_loc (input_location
,
9017 pvoid_type_node
, dest
,
9020 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9024 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9025 add_when_allocated
);
9026 gfc_add_expr_to_block (&fnblock
, tmp
);
9029 if (cmp_has_alloc_comps
|| is_pdt_type
)
9030 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9034 case ALLOCATE_PDT_COMP
:
9036 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9037 decl
, cdecl, NULL_TREE
);
9039 /* Set the PDT KIND and LEN fields. */
9040 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9043 gfc_expr
*c_expr
= NULL
;
9044 gfc_actual_arglist
*param
= pdt_param_list
;
9045 gfc_init_se (&tse
, NULL
);
9046 for (; param
; param
= param
->next
)
9047 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9048 c_expr
= param
->expr
;
9051 c_expr
= c
->initializer
;
9055 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9056 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9060 if (c
->attr
.pdt_string
)
9063 gfc_init_se (&tse
, NULL
);
9064 tree strlen
= NULL_TREE
;
9065 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9066 /* Convert the parameterized string length to its value. The
9067 string length is stored in a hidden field in the same way as
9068 deferred string lengths. */
9069 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9070 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9072 gfc_conv_expr_type (&tse
, e
,
9073 TREE_TYPE (strlen
));
9074 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9076 decl
, strlen
, NULL_TREE
);
9077 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9078 c
->ts
.u
.cl
->backend_decl
= strlen
;
9082 /* Scalar parameterized strings can be allocated now. */
9085 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9086 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9087 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9088 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9089 gfc_add_modify (&fnblock
, comp
, tmp
);
9093 /* Allocate parameterized arrays of parameterized derived types. */
9094 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9095 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9096 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9099 if (c
->ts
.type
== BT_CLASS
)
9100 comp
= gfc_class_data_get (comp
);
9102 if (c
->attr
.pdt_array
)
9106 tree size
= gfc_index_one_node
;
9107 tree offset
= gfc_index_zero_node
;
9111 /* This chunk takes the expressions for 'lower' and 'upper'
9112 in the arrayspec and substitutes in the expressions for
9113 the parameters from 'pdt_param_list'. The descriptor
9114 fields can then be filled from the values so obtained. */
9115 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9116 for (i
= 0; i
< c
->as
->rank
; i
++)
9118 gfc_init_se (&tse
, NULL
);
9119 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9120 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9121 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9124 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9127 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9128 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9129 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9132 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9135 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9138 size
= gfc_evaluate_now (size
, &fnblock
);
9139 offset
= fold_build2_loc (input_location
,
9141 gfc_array_index_type
,
9143 offset
= gfc_evaluate_now (offset
, &fnblock
);
9144 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9145 gfc_array_index_type
,
9147 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9148 gfc_array_index_type
,
9149 tmp
, gfc_index_one_node
);
9150 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9151 gfc_array_index_type
, size
, tmp
);
9153 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9154 if (c
->ts
.type
== BT_CLASS
)
9156 tmp
= gfc_get_vptr_from_expr (comp
);
9157 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9158 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9159 tmp
= gfc_vptr_size_get (tmp
);
9162 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9163 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9164 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9165 gfc_array_index_type
, size
, tmp
);
9166 size
= gfc_evaluate_now (size
, &fnblock
);
9167 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9168 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9169 tmp
= gfc_conv_descriptor_dtype (comp
);
9170 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9172 if (c
->initializer
&& c
->initializer
->rank
)
9174 gfc_init_se (&tse
, NULL
);
9175 e
= gfc_copy_expr (c
->initializer
);
9176 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9177 gfc_conv_expr_descriptor (&tse
, e
);
9178 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9180 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9181 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9182 gfc_conv_descriptor_data_get (comp
),
9183 gfc_conv_descriptor_data_get (tse
.expr
),
9184 fold_convert (size_type_node
, size
));
9185 gfc_add_expr_to_block (&fnblock
, tmp
);
9186 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9190 /* Recurse in to PDT components. */
9191 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9192 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9193 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9195 bool is_deferred
= false;
9196 gfc_actual_arglist
*tail
= c
->param_list
;
9198 for (; tail
; tail
= tail
->next
)
9202 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9203 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9204 c
->as
? c
->as
->rank
: 0,
9206 gfc_add_expr_to_block (&fnblock
, tmp
);
9211 case DEALLOCATE_PDT_COMP
:
9212 /* Deallocate array or parameterized string length components
9213 of parameterized derived types. */
9214 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9215 && !c
->attr
.pdt_string
9216 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9217 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9220 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9221 decl
, cdecl, NULL_TREE
);
9222 if (c
->ts
.type
== BT_CLASS
)
9223 comp
= gfc_class_data_get (comp
);
9225 /* Recurse in to PDT components. */
9226 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9227 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9228 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9230 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9231 c
->as
? c
->as
->rank
: 0);
9232 gfc_add_expr_to_block (&fnblock
, tmp
);
9235 if (c
->attr
.pdt_array
)
9237 tmp
= gfc_conv_descriptor_data_get (comp
);
9238 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9239 logical_type_node
, tmp
,
9240 build_int_cst (TREE_TYPE (tmp
), 0));
9241 tmp
= gfc_call_free (tmp
);
9242 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9243 build_empty_stmt (input_location
));
9244 gfc_add_expr_to_block (&fnblock
, tmp
);
9245 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9247 else if (c
->attr
.pdt_string
)
9249 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9250 logical_type_node
, comp
,
9251 build_int_cst (TREE_TYPE (comp
), 0));
9252 tmp
= gfc_call_free (comp
);
9253 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9254 build_empty_stmt (input_location
));
9255 gfc_add_expr_to_block (&fnblock
, tmp
);
9256 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9257 gfc_add_modify (&fnblock
, comp
, tmp
);
9262 case CHECK_PDT_DUMMY
:
9264 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9265 decl
, cdecl, NULL_TREE
);
9266 if (c
->ts
.type
== BT_CLASS
)
9267 comp
= gfc_class_data_get (comp
);
9269 /* Recurse in to PDT components. */
9270 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9271 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9273 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9274 c
->as
? c
->as
->rank
: 0,
9276 gfc_add_expr_to_block (&fnblock
, tmp
);
9279 if (!c
->attr
.pdt_len
)
9284 gfc_expr
*c_expr
= NULL
;
9285 gfc_actual_arglist
*param
= pdt_param_list
;
9287 gfc_init_se (&tse
, NULL
);
9288 for (; param
; param
= param
->next
)
9289 if (!strcmp (c
->name
, param
->name
)
9290 && param
->spec_type
== SPEC_EXPLICIT
)
9291 c_expr
= param
->expr
;
9295 tree error
, cond
, cname
;
9296 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9297 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9300 cname
= gfc_build_cstring_const (c
->name
);
9301 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9302 error
= gfc_trans_runtime_error (true, NULL
,
9303 "The value of the PDT LEN "
9304 "parameter '%s' does not "
9305 "agree with that in the "
9306 "dummy declaration",
9308 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9309 void_type_node
, cond
, error
,
9310 build_empty_stmt (input_location
));
9311 gfc_add_expr_to_block (&fnblock
, tmp
);
9322 return gfc_finish_block (&fnblock
);
9325 /* Recursively traverse an object of derived type, generating code to
9326 nullify allocatable components. */
9329 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9332 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9334 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9338 /* Recursively traverse an object of derived type, generating code to
9339 deallocate allocatable components. */
9342 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9345 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9346 DEALLOCATE_ALLOC_COMP
,
9347 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9351 /* Recursively traverse an object of derived type, generating code to
9352 deallocate allocatable components. But do not deallocate coarrays.
9353 To be used for intrinsic assignment, which may not change the allocation
9354 status of coarrays. */
9357 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9359 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9360 DEALLOCATE_ALLOC_COMP
, 0);
9365 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9367 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9368 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9372 /* Recursively traverse an object of derived type, generating code to
9373 copy it and its allocatable components. */
9376 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9379 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9384 /* Recursively traverse an object of derived type, generating code to
9385 copy only its allocatable components. */
9388 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9390 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9391 COPY_ONLY_ALLOC_COMP
, 0);
9395 /* Recursively traverse an object of paramterized derived type, generating
9396 code to allocate parameterized components. */
9399 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9400 gfc_actual_arglist
*param_list
)
9403 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9404 pdt_param_list
= param_list
;
9405 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9406 ALLOCATE_PDT_COMP
, 0);
9407 pdt_param_list
= old_param_list
;
9411 /* Recursively traverse an object of paramterized derived type, generating
9412 code to deallocate parameterized components. */
9415 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9417 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9418 DEALLOCATE_PDT_COMP
, 0);
9422 /* Recursively traverse a dummy of paramterized derived type to check the
9423 values of LEN parameters. */
9426 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9427 gfc_actual_arglist
*param_list
)
9430 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9431 pdt_param_list
= param_list
;
9432 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9433 CHECK_PDT_DUMMY
, 0);
9434 pdt_param_list
= old_param_list
;
9439 /* Returns the value of LBOUND for an expression. This could be broken out
9440 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9441 called by gfc_alloc_allocatable_for_assignment. */
9443 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9448 tree cond
, cond1
, cond3
, cond4
;
9452 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9454 tmp
= gfc_rank_cst
[dim
];
9455 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9456 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9457 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9458 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9460 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9461 stride
, gfc_index_zero_node
);
9462 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9463 logical_type_node
, cond3
, cond1
);
9464 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9465 stride
, gfc_index_zero_node
);
9467 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9468 tmp
, build_int_cst (gfc_array_index_type
,
9471 cond
= logical_false_node
;
9473 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9474 logical_type_node
, cond3
, cond4
);
9475 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9476 logical_type_node
, cond
, cond1
);
9478 return fold_build3_loc (input_location
, COND_EXPR
,
9479 gfc_array_index_type
, cond
,
9480 lbound
, gfc_index_one_node
);
9483 if (expr
->expr_type
== EXPR_FUNCTION
)
9485 /* A conversion function, so use the argument. */
9486 gcc_assert (expr
->value
.function
.isym
9487 && expr
->value
.function
.isym
->conversion
);
9488 expr
= expr
->value
.function
.actual
->expr
;
9491 if (expr
->expr_type
== EXPR_VARIABLE
)
9493 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9494 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9496 if (ref
->type
== REF_COMPONENT
9497 && ref
->u
.c
.component
->as
9499 && ref
->next
->u
.ar
.type
== AR_FULL
)
9500 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9502 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9505 return gfc_index_one_node
;
9509 /* Returns true if an expression represents an lhs that can be reallocated
9513 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9521 sym
= expr
->symtree
->n
.sym
;
9523 if (sym
->attr
.associate_var
)
9526 /* An allocatable class variable with no reference. */
9527 if (sym
->ts
.type
== BT_CLASS
9528 && CLASS_DATA (sym
)->attr
.allocatable
9529 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
9530 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9531 && expr
->ref
->next
== NULL
)
9534 /* An allocatable variable. */
9535 if (sym
->attr
.allocatable
9537 && expr
->ref
->type
== REF_ARRAY
9538 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9541 /* All that can be left are allocatable components. */
9542 if ((sym
->ts
.type
!= BT_DERIVED
9543 && sym
->ts
.type
!= BT_CLASS
)
9544 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9547 /* Find a component ref followed by an array reference. */
9548 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9550 && ref
->type
== REF_COMPONENT
9551 && ref
->next
->type
== REF_ARRAY
9552 && !ref
->next
->next
)
9558 /* Return true if valid reallocatable lhs. */
9559 if (ref
->u
.c
.component
->attr
.allocatable
9560 && ref
->next
->u
.ar
.type
== AR_FULL
)
9568 concat_str_length (gfc_expr
* expr
)
9575 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9576 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9577 if (len1
== NULL_TREE
)
9579 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9580 len1
= concat_str_length (expr
->value
.op
.op1
);
9581 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9582 len1
= build_int_cst (gfc_charlen_type_node
,
9583 expr
->value
.op
.op1
->value
.character
.length
);
9584 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9586 gfc_init_se (&se
, NULL
);
9587 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9593 gfc_init_se (&se
, NULL
);
9594 se
.want_pointer
= 1;
9595 se
.descriptor_only
= 1;
9596 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9597 len1
= se
.string_length
;
9601 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9602 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9603 if (len2
== NULL_TREE
)
9605 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9606 len2
= concat_str_length (expr
->value
.op
.op2
);
9607 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9608 len2
= build_int_cst (gfc_charlen_type_node
,
9609 expr
->value
.op
.op2
->value
.character
.length
);
9610 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9612 gfc_init_se (&se
, NULL
);
9613 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9619 gfc_init_se (&se
, NULL
);
9620 se
.want_pointer
= 1;
9621 se
.descriptor_only
= 1;
9622 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9623 len2
= se
.string_length
;
9627 gcc_assert(len1
&& len2
);
9628 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9629 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9631 return fold_build2_loc (input_location
, PLUS_EXPR
,
9632 gfc_charlen_type_node
, len1
, len2
);
9636 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9640 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9644 stmtblock_t realloc_block
;
9645 stmtblock_t alloc_block
;
9649 gfc_array_info
*linfo
;
9671 gfc_array_spec
* as
;
9672 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9673 && gfc_caf_attr (expr1
, true).codimension
);
9677 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9678 Find the lhs expression in the loop chain and set expr1 and
9679 expr2 accordingly. */
9680 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9683 /* Find the ss for the lhs. */
9685 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9686 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9688 if (lss
== gfc_ss_terminator
)
9690 expr1
= lss
->info
->expr
;
9693 /* Bail out if this is not a valid allocate on assignment. */
9694 if (!gfc_is_reallocatable_lhs (expr1
)
9695 || (expr2
&& !expr2
->rank
))
9698 /* Find the ss for the lhs. */
9700 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9701 if (lss
->info
->expr
== expr1
)
9704 if (lss
== gfc_ss_terminator
)
9707 linfo
= &lss
->info
->data
.array
;
9709 /* Find an ss for the rhs. For operator expressions, we see the
9710 ss's for the operands. Any one of these will do. */
9712 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9713 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9716 if (expr2
&& rss
== gfc_ss_terminator
)
9719 /* Ensure that the string length from the current scope is used. */
9720 if (expr2
->ts
.type
== BT_CHARACTER
9721 && expr2
->expr_type
== EXPR_FUNCTION
9722 && !expr2
->value
.function
.isym
)
9723 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
9725 gfc_start_block (&fblock
);
9727 /* Since the lhs is allocatable, this must be a descriptor type.
9728 Get the data and array size. */
9729 desc
= linfo
->descriptor
;
9730 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9731 array1
= gfc_conv_descriptor_data_get (desc
);
9733 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9734 deallocated if expr is an array of different shape or any of the
9735 corresponding length type parameter values of variable and expr
9736 differ." This assures F95 compatibility. */
9737 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9738 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9740 /* Allocate if data is NULL. */
9741 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9742 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9744 if (expr1
->ts
.deferred
)
9745 cond_null
= gfc_evaluate_now (logical_true_node
, &fblock
);
9747 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9749 tmp
= build3_v (COND_EXPR
, cond_null
,
9750 build1_v (GOTO_EXPR
, jump_label1
),
9751 build_empty_stmt (input_location
));
9752 gfc_add_expr_to_block (&fblock
, tmp
);
9754 /* Get arrayspec if expr is a full array. */
9755 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9756 && expr2
->value
.function
.isym
9757 && expr2
->value
.function
.isym
->conversion
)
9759 /* For conversion functions, take the arg. */
9760 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9761 as
= gfc_get_full_arrayspec_from_expr (arg
);
9764 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9768 /* If the lhs shape is not the same as the rhs jump to setting the
9769 bounds and doing the reallocation....... */
9770 for (n
= 0; n
< expr1
->rank
; n
++)
9772 /* Check the shape. */
9773 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9774 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9775 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9776 gfc_array_index_type
,
9777 loop
->to
[n
], loop
->from
[n
]);
9778 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9779 gfc_array_index_type
,
9781 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9782 gfc_array_index_type
,
9784 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9786 tmp
, gfc_index_zero_node
);
9787 tmp
= build3_v (COND_EXPR
, cond
,
9788 build1_v (GOTO_EXPR
, jump_label1
),
9789 build_empty_stmt (input_location
));
9790 gfc_add_expr_to_block (&fblock
, tmp
);
9793 /* ....else jump past the (re)alloc code. */
9794 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9795 gfc_add_expr_to_block (&fblock
, tmp
);
9797 /* Add the label to start automatic (re)allocation. */
9798 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9799 gfc_add_expr_to_block (&fblock
, tmp
);
9801 /* If the lhs has not been allocated, its bounds will not have been
9802 initialized and so its size is set to zero. */
9803 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9804 gfc_init_block (&alloc_block
);
9805 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9806 gfc_init_block (&realloc_block
);
9807 gfc_add_modify (&realloc_block
, size1
,
9808 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9809 tmp
= build3_v (COND_EXPR
, cond_null
,
9810 gfc_finish_block (&alloc_block
),
9811 gfc_finish_block (&realloc_block
));
9812 gfc_add_expr_to_block (&fblock
, tmp
);
9814 /* Get the rhs size and fix it. */
9816 desc2
= rss
->info
->data
.array
.descriptor
;
9820 size2
= gfc_index_one_node
;
9821 for (n
= 0; n
< expr2
->rank
; n
++)
9823 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9824 gfc_array_index_type
,
9825 loop
->to
[n
], loop
->from
[n
]);
9826 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9827 gfc_array_index_type
,
9828 tmp
, gfc_index_one_node
);
9829 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9830 gfc_array_index_type
,
9833 size2
= gfc_evaluate_now (size2
, &fblock
);
9835 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9838 /* If the lhs is deferred length, assume that the element size
9839 changes and force a reallocation. */
9840 if (expr1
->ts
.deferred
)
9841 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
9843 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9845 /* Deallocation of allocatable components will have to occur on
9846 reallocation. Fix the old descriptor now. */
9847 if ((expr1
->ts
.type
== BT_DERIVED
)
9848 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9849 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9851 old_desc
= NULL_TREE
;
9853 /* Now modify the lhs descriptor and the associated scalarizer
9854 variables. F2003 7.4.1.3: "If variable is or becomes an
9855 unallocated allocatable variable, then it is allocated with each
9856 deferred type parameter equal to the corresponding type parameters
9857 of expr , with the shape of expr , and with each lower bound equal
9858 to the corresponding element of LBOUND(expr)."
9859 Reuse size1 to keep a dimension-by-dimension track of the
9860 stride of the new array. */
9861 size1
= gfc_index_one_node
;
9862 offset
= gfc_index_zero_node
;
9864 for (n
= 0; n
< expr2
->rank
; n
++)
9866 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9867 gfc_array_index_type
,
9868 loop
->to
[n
], loop
->from
[n
]);
9869 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9870 gfc_array_index_type
,
9871 tmp
, gfc_index_one_node
);
9873 lbound
= gfc_index_one_node
;
9878 lbd
= get_std_lbound (expr2
, desc2
, n
,
9879 as
->type
== AS_ASSUMED_SIZE
);
9880 ubound
= fold_build2_loc (input_location
,
9882 gfc_array_index_type
,
9884 ubound
= fold_build2_loc (input_location
,
9886 gfc_array_index_type
,
9891 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9894 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9897 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9900 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9902 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9903 gfc_array_index_type
,
9905 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9906 gfc_array_index_type
,
9908 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9909 gfc_array_index_type
,
9913 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9914 the array offset is saved and the info.offset is used for a
9915 running offset. Use the saved_offset instead. */
9916 tmp
= gfc_conv_descriptor_offset (desc
);
9917 gfc_add_modify (&fblock
, tmp
, offset
);
9918 if (linfo
->saved_offset
9919 && VAR_P (linfo
->saved_offset
))
9920 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9922 /* Now set the deltas for the lhs. */
9923 for (n
= 0; n
< expr1
->rank
; n
++)
9925 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9927 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9928 gfc_array_index_type
, tmp
,
9930 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9931 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9934 /* Get the new lhs size in bytes. */
9935 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9937 if (expr2
->ts
.deferred
)
9939 if (VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9940 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9942 tmp
= rss
->info
->string_length
;
9946 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9947 if (!tmp
&& expr2
->expr_type
== EXPR_OP
9948 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
9950 tmp
= concat_str_length (expr2
);
9951 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
9953 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
9956 if (expr1
->ts
.u
.cl
->backend_decl
9957 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
9958 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
9960 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
9962 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
9964 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
9965 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9966 gfc_array_index_type
, tmp
,
9967 expr1
->ts
.u
.cl
->backend_decl
);
9969 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
9970 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
9972 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9973 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9974 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9975 gfc_array_index_type
,
9977 size2
= fold_convert (size_type_node
, size2
);
9978 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9979 size2
, size_one_node
);
9980 size2
= gfc_evaluate_now (size2
, &fblock
);
9982 /* For deferred character length, the 'size' field of the dtype might
9983 have changed so set the dtype. */
9984 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9985 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9988 tmp
= gfc_conv_descriptor_dtype (desc
);
9989 if (expr2
->ts
.u
.cl
->backend_decl
)
9990 type
= gfc_typenode_for_spec (&expr2
->ts
);
9992 type
= gfc_typenode_for_spec (&expr1
->ts
);
9994 gfc_add_modify (&fblock
, tmp
,
9995 gfc_get_dtype_rank_type (expr1
->rank
,type
));
9997 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10000 tmp
= gfc_conv_descriptor_dtype (desc
);
10001 type
= gfc_typenode_for_spec (&expr2
->ts
);
10002 gfc_add_modify (&fblock
, tmp
,
10003 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10004 /* Set the _len field as well... */
10005 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10006 if (expr2
->ts
.type
== BT_CHARACTER
)
10007 gfc_add_modify (&fblock
, tmp
,
10008 fold_convert (TREE_TYPE (tmp
),
10009 TYPE_SIZE_UNIT (type
)));
10011 gfc_add_modify (&fblock
, tmp
,
10012 build_int_cst (TREE_TYPE (tmp
), 0));
10013 /* ...and the vptr. */
10014 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10015 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10016 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10017 gfc_add_modify (&fblock
, tmp
, tmp2
);
10019 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10021 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10022 gfc_get_dtype (TREE_TYPE (desc
)));
10025 /* Realloc expression. Note that the scalarizer uses desc.data
10026 in the array reference - (*desc.data)[<element>]. */
10027 gfc_init_block (&realloc_block
);
10028 gfc_init_se (&caf_se
, NULL
);
10032 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10033 if (token
== NULL_TREE
)
10035 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10036 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10037 tmp
= build_fold_indirect_ref (tmp
);
10038 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10040 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10043 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10045 if ((expr1
->ts
.type
== BT_DERIVED
)
10046 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10048 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10050 gfc_add_expr_to_block (&realloc_block
, tmp
);
10055 tmp
= build_call_expr_loc (input_location
,
10056 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10057 fold_convert (pvoid_type_node
, array1
),
10059 gfc_conv_descriptor_data_set (&realloc_block
,
10064 tmp
= build_call_expr_loc (input_location
,
10065 gfor_fndecl_caf_deregister
, 5, token
,
10066 build_int_cst (integer_type_node
,
10067 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10068 null_pointer_node
, null_pointer_node
,
10069 integer_zero_node
);
10070 gfc_add_expr_to_block (&realloc_block
, tmp
);
10071 tmp
= build_call_expr_loc (input_location
,
10072 gfor_fndecl_caf_register
,
10074 build_int_cst (integer_type_node
,
10075 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10076 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10077 null_pointer_node
, null_pointer_node
,
10078 integer_zero_node
);
10079 gfc_add_expr_to_block (&realloc_block
, tmp
);
10082 if ((expr1
->ts
.type
== BT_DERIVED
)
10083 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10085 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10087 gfc_add_expr_to_block (&realloc_block
, tmp
);
10090 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10091 realloc_expr
= gfc_finish_block (&realloc_block
);
10093 /* Only reallocate if sizes are different. */
10094 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10095 build_empty_stmt (input_location
));
10096 realloc_expr
= tmp
;
10099 /* Malloc expression. */
10100 gfc_init_block (&alloc_block
);
10103 tmp
= build_call_expr_loc (input_location
,
10104 builtin_decl_explicit (BUILT_IN_MALLOC
),
10106 gfc_conv_descriptor_data_set (&alloc_block
,
10111 tmp
= build_call_expr_loc (input_location
,
10112 gfor_fndecl_caf_register
,
10114 build_int_cst (integer_type_node
,
10115 GFC_CAF_COARRAY_ALLOC
),
10116 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10117 null_pointer_node
, null_pointer_node
,
10118 integer_zero_node
);
10119 gfc_add_expr_to_block (&alloc_block
, tmp
);
10123 /* We already set the dtype in the case of deferred character
10124 length arrays and unlimited polymorphic arrays. */
10125 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10126 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10128 && !UNLIMITED_POLY (expr1
))
10130 tmp
= gfc_conv_descriptor_dtype (desc
);
10131 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10134 if ((expr1
->ts
.type
== BT_DERIVED
)
10135 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10137 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10139 gfc_add_expr_to_block (&alloc_block
, tmp
);
10141 alloc_expr
= gfc_finish_block (&alloc_block
);
10143 /* Malloc if not allocated; realloc otherwise. */
10144 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10145 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10148 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10149 gfc_add_expr_to_block (&fblock
, tmp
);
10151 /* Make sure that the scalarizer data pointer is updated. */
10152 if (linfo
->data
&& VAR_P (linfo
->data
))
10154 tmp
= gfc_conv_descriptor_data_get (desc
);
10155 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10158 /* Add the exit label. */
10159 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10160 gfc_add_expr_to_block (&fblock
, tmp
);
10162 return gfc_finish_block (&fblock
);
10166 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10167 Do likewise, recursively if necessary, with the allocatable components of
10171 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10177 stmtblock_t cleanup
;
10180 bool sym_has_alloc_comp
, has_finalizer
;
10182 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10183 || sym
->ts
.type
== BT_CLASS
)
10184 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10185 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10186 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10188 /* Make sure the frontend gets these right. */
10189 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10192 gfc_save_backend_locus (&loc
);
10193 gfc_set_backend_locus (&sym
->declared_at
);
10194 gfc_init_block (&init
);
10196 gcc_assert (VAR_P (sym
->backend_decl
)
10197 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10199 if (sym
->ts
.type
== BT_CHARACTER
10200 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10202 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10203 gfc_trans_vla_type_sizes (sym
, &init
);
10206 /* Dummy, use associated and result variables don't need anything special. */
10207 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10209 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10210 gfc_restore_backend_locus (&loc
);
10214 descriptor
= sym
->backend_decl
;
10216 /* Although static, derived types with default initializers and
10217 allocatable components must not be nulled wholesale; instead they
10218 are treated component by component. */
10219 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10221 /* SAVEd variables are not freed on exit. */
10222 gfc_trans_static_array_pointer (sym
);
10224 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10225 gfc_restore_backend_locus (&loc
);
10229 /* Get the descriptor type. */
10230 type
= TREE_TYPE (sym
->backend_decl
);
10232 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10233 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10235 if (!sym
->attr
.save
10236 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10238 if (sym
->value
== NULL
10239 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10241 rank
= sym
->as
? sym
->as
->rank
: 0;
10242 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10244 gfc_add_expr_to_block (&init
, tmp
);
10247 gfc_init_default_dt (sym
, &init
, false);
10250 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10252 /* If the backend_decl is not a descriptor, we must have a pointer
10254 descriptor
= build_fold_indirect_ref_loc (input_location
,
10255 sym
->backend_decl
);
10256 type
= TREE_TYPE (descriptor
);
10259 /* NULLIFY the data pointer, for non-saved allocatables. */
10260 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10262 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10263 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10265 /* Declare the variable static so its array descriptor stays present
10266 after leaving the scope. It may still be accessed through another
10267 image. This may happen, for example, with the caf_mpi
10269 TREE_STATIC (descriptor
) = 1;
10270 tmp
= gfc_conv_descriptor_token (descriptor
);
10271 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10272 null_pointer_node
));
10276 gfc_restore_backend_locus (&loc
);
10277 gfc_init_block (&cleanup
);
10279 /* Allocatable arrays need to be freed when they go out of scope.
10280 The allocatable components of pointers must not be touched. */
10281 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10282 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10283 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10286 sym
->attr
.referenced
= 1;
10287 e
= gfc_lval_expr_from_sym (sym
);
10288 gfc_add_finalizer_call (&cleanup
, e
);
10291 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10292 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10293 && !sym
->attr
.pointer
&& !sym
->attr
.save
10294 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10297 rank
= sym
->as
? sym
->as
->rank
: 0;
10298 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10299 gfc_add_expr_to_block (&cleanup
, tmp
);
10302 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10303 && !sym
->attr
.save
&& !sym
->attr
.result
10304 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10307 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10308 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10309 NULL_TREE
, NULL_TREE
, true, e
,
10310 sym
->attr
.codimension
10311 ? GFC_CAF_COARRAY_DEREGISTER
10312 : GFC_CAF_COARRAY_NOCOARRAY
);
10315 gfc_add_expr_to_block (&cleanup
, tmp
);
10318 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10319 gfc_finish_block (&cleanup
));
10322 /************ Expression Walking Functions ******************/
10324 /* Walk a variable reference.
10326 Possible extension - multiple component subscripts.
10327 x(:,:) = foo%a(:)%b(:)
10329 forall (i=..., j=...)
10330 x(i,j) = foo%a(j)%b(i)
10332 This adds a fair amount of complexity because you need to deal with more
10333 than one ref. Maybe handle in a similar manner to vector subscripts.
10334 Maybe not worth the effort. */
10338 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10342 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10343 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10346 return gfc_walk_array_ref (ss
, expr
, ref
);
10351 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10357 for (; ref
; ref
= ref
->next
)
10359 if (ref
->type
== REF_SUBSTRING
)
10361 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10362 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10365 /* We're only interested in array sections from now on. */
10366 if (ref
->type
!= REF_ARRAY
)
10374 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10375 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10379 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10380 newss
->info
->data
.array
.ref
= ref
;
10382 /* Make sure array is the same as array(:,:), this way
10383 we don't need to special case all the time. */
10384 ar
->dimen
= ar
->as
->rank
;
10385 for (n
= 0; n
< ar
->dimen
; n
++)
10387 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10389 gcc_assert (ar
->start
[n
] == NULL
);
10390 gcc_assert (ar
->end
[n
] == NULL
);
10391 gcc_assert (ar
->stride
[n
] == NULL
);
10397 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10398 newss
->info
->data
.array
.ref
= ref
;
10400 /* We add SS chains for all the subscripts in the section. */
10401 for (n
= 0; n
< ar
->dimen
; n
++)
10405 switch (ar
->dimen_type
[n
])
10407 case DIMEN_ELEMENT
:
10408 /* Add SS for elemental (scalar) subscripts. */
10409 gcc_assert (ar
->start
[n
]);
10410 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10411 indexss
->loop_chain
= gfc_ss_terminator
;
10412 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10416 /* We don't add anything for sections, just remember this
10417 dimension for later. */
10418 newss
->dim
[newss
->dimen
] = n
;
10423 /* Create a GFC_SS_VECTOR index in which we can store
10424 the vector's descriptor. */
10425 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10427 indexss
->loop_chain
= gfc_ss_terminator
;
10428 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10429 newss
->dim
[newss
->dimen
] = n
;
10434 /* We should know what sort of section it is by now. */
10435 gcc_unreachable ();
10438 /* We should have at least one non-elemental dimension,
10439 unless we are creating a descriptor for a (scalar) coarray. */
10440 gcc_assert (newss
->dimen
> 0
10441 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10446 /* We should know what sort of section it is by now. */
10447 gcc_unreachable ();
10455 /* Walk an expression operator. If only one operand of a binary expression is
10456 scalar, we must also add the scalar term to the SS chain. */
10459 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10464 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10465 if (expr
->value
.op
.op2
== NULL
)
10468 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10470 /* All operands are scalar. Pass back and let the caller deal with it. */
10474 /* All operands require scalarization. */
10475 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10478 /* One of the operands needs scalarization, the other is scalar.
10479 Create a gfc_ss for the scalar expression. */
10482 /* First operand is scalar. We build the chain in reverse order, so
10483 add the scalar SS after the second operand. */
10485 while (head
&& head
->next
!= ss
)
10487 /* Check we haven't somehow broken the chain. */
10489 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10491 else /* head2 == head */
10493 gcc_assert (head2
== head
);
10494 /* Second operand is scalar. */
10495 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10502 /* Reverse a SS chain. */
10505 gfc_reverse_ss (gfc_ss
* ss
)
10510 gcc_assert (ss
!= NULL
);
10512 head
= gfc_ss_terminator
;
10513 while (ss
!= gfc_ss_terminator
)
10516 /* Check we didn't somehow break the chain. */
10517 gcc_assert (next
!= NULL
);
10527 /* Given an expression referring to a procedure, return the symbol of its
10528 interface. We can't get the procedure symbol directly as we have to handle
10529 the case of (deferred) type-bound procedures. */
10532 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10537 if (procedure_ref
== NULL
)
10540 /* Normal procedure case. */
10541 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10542 && procedure_ref
->value
.function
.esym
)
10543 sym
= procedure_ref
->value
.function
.esym
;
10545 sym
= procedure_ref
->symtree
->n
.sym
;
10547 /* Typebound procedure case. */
10548 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10550 if (ref
->type
== REF_COMPONENT
10551 && ref
->u
.c
.component
->attr
.proc_pointer
)
10552 sym
= ref
->u
.c
.component
->ts
.interface
;
10561 /* Walk the arguments of an elemental function.
10562 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10563 it is NULL, we don't do the check and the argument is assumed to be present.
10567 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10568 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10570 gfc_formal_arglist
*dummy_arg
;
10576 head
= gfc_ss_terminator
;
10580 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10585 for (; arg
; arg
= arg
->next
)
10587 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10588 goto loop_continue
;
10590 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10593 /* Scalar argument. */
10594 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10595 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10596 newss
->info
->type
= type
;
10598 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10603 if (dummy_arg
!= NULL
10604 && dummy_arg
->sym
->attr
.optional
10605 && arg
->expr
->expr_type
== EXPR_VARIABLE
10606 && (gfc_expr_attr (arg
->expr
).optional
10607 || gfc_expr_attr (arg
->expr
).allocatable
10608 || gfc_expr_attr (arg
->expr
).pointer
))
10609 newss
->info
->can_be_null_ref
= true;
10615 while (tail
->next
!= gfc_ss_terminator
)
10620 if (dummy_arg
!= NULL
)
10621 dummy_arg
= dummy_arg
->next
;
10626 /* If all the arguments are scalar we don't need the argument SS. */
10627 gfc_free_ss_chain (head
);
10628 /* Pass it back. */
10632 /* Add it onto the existing chain. */
10638 /* Walk a function call. Scalar functions are passed back, and taken out of
10639 scalarization loops. For elemental functions we walk their arguments.
10640 The result of functions returning arrays is stored in a temporary outside
10641 the loop, so that the function is only called once. Hence we do not need
10642 to walk their arguments. */
10645 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10647 gfc_intrinsic_sym
*isym
;
10649 gfc_component
*comp
= NULL
;
10651 isym
= expr
->value
.function
.isym
;
10653 /* Handle intrinsic functions separately. */
10655 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10657 sym
= expr
->value
.function
.esym
;
10659 sym
= expr
->symtree
->n
.sym
;
10661 if (gfc_is_class_array_function (expr
))
10662 return gfc_get_array_ss (ss
, expr
,
10663 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10666 /* A function that returns arrays. */
10667 comp
= gfc_get_proc_ptr_comp (expr
);
10668 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10669 || (comp
&& comp
->attr
.dimension
))
10670 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10672 /* Walk the parameters of an elemental function. For now we always pass
10674 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10676 gfc_ss
*old_ss
= ss
;
10678 ss
= gfc_walk_elemental_function_args (old_ss
,
10679 expr
->value
.function
.actual
,
10680 gfc_get_proc_ifc_for_expr (expr
),
10684 || sym
->attr
.proc_pointer
10685 || sym
->attr
.if_source
!= IFSRC_DECL
10686 || sym
->attr
.array_outer_dependency
))
10687 ss
->info
->array_outer_dependency
= 1;
10690 /* Scalar functions are OK as these are evaluated outside the scalarization
10691 loop. Pass back and let the caller deal with it. */
10696 /* An array temporary is constructed for array constructors. */
10699 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10701 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10705 /* Walk an expression. Add walked expressions to the head of the SS chain.
10706 A wholly scalar expression will not be added. */
10709 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10713 switch (expr
->expr_type
)
10715 case EXPR_VARIABLE
:
10716 head
= gfc_walk_variable_expr (ss
, expr
);
10720 head
= gfc_walk_op_expr (ss
, expr
);
10723 case EXPR_FUNCTION
:
10724 head
= gfc_walk_function_expr (ss
, expr
);
10727 case EXPR_CONSTANT
:
10729 case EXPR_STRUCTURE
:
10730 /* Pass back and let the caller deal with it. */
10734 head
= gfc_walk_array_constructor (ss
, expr
);
10737 case EXPR_SUBSTRING
:
10738 /* Pass back and let the caller deal with it. */
10742 gfc_internal_error ("bad expression type during walk (%d)",
10749 /* Entry point for expression walking.
10750 A return value equal to the passed chain means this is
10751 a scalar expression. It is up to the caller to take whatever action is
10752 necessary to translate these. */
10755 gfc_walk_expr (gfc_expr
* expr
)
10759 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10760 return gfc_reverse_ss (res
);