1 /* Array translation routines
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
80 #include "coretypes.h"
84 #include "gimple-expr.h"
86 #include "fold-const.h"
87 #include "constructor.h"
88 #include "trans-types.h"
89 #include "trans-array.h"
90 #include "trans-const.h"
91 #include "dependency.h"
93 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
95 /* The contents of this structure aren't actually used, just the address. */
96 static gfc_ss gfc_ss_terminator_var
;
97 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
101 gfc_array_dataptr_type (tree desc
)
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
107 /* Build expressions to access the members of an array descriptor.
108 It's surprisingly easy to mess up here, so never access
109 an array descriptor by "brute force", always use these
110 functions. This also avoids problems if we change the format
111 of an array descriptor.
113 To understand these magic numbers, look at the comments
114 before gfc_build_array_type() in trans-types.c.
116 The code within these defines should be the only code which knows the format
117 of an array descriptor.
119 Any code just needing to read obtain the bounds of an array should use
120 gfc_conv_array_* rather than the following functions as these will return
121 know constant values, and work with arrays which do not have descriptors.
123 Don't forget to #undef these! */
126 #define OFFSET_FIELD 1
127 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 4
130 #define CAF_TOKEN_FIELD 5
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc
)
144 type
= TREE_TYPE (desc
);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
147 field
= TYPE_FIELDS (type
);
148 gcc_assert (DATA_FIELD
== 0);
150 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
152 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
157 /* This provides WRITE access to the data field.
159 TUPLES_P is true if we are generating tuples.
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
166 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
170 type
= TREE_TYPE (desc
);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
173 field
= TYPE_FIELDS (type
);
174 gcc_assert (DATA_FIELD
== 0);
176 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
178 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc
)
190 type
= TREE_TYPE (desc
);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
193 field
= TYPE_FIELDS (type
);
194 gcc_assert (DATA_FIELD
== 0);
196 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
198 return gfc_build_addr_expr (NULL_TREE
, t
);
202 gfc_conv_descriptor_offset (tree desc
)
207 type
= TREE_TYPE (desc
);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
210 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
211 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
213 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
214 desc
, field
, NULL_TREE
);
218 gfc_conv_descriptor_offset_get (tree desc
)
220 return gfc_conv_descriptor_offset (desc
);
224 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
227 tree t
= gfc_conv_descriptor_offset (desc
);
228 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
233 gfc_conv_descriptor_dtype (tree desc
)
238 type
= TREE_TYPE (desc
);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
241 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
242 gcc_assert (field
!= NULL_TREE
243 && TREE_TYPE (field
) == get_dtype_type_node ());
245 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
246 desc
, field
, NULL_TREE
);
250 gfc_conv_descriptor_span (tree desc
)
255 type
= TREE_TYPE (desc
);
256 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
258 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
259 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
261 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
262 desc
, field
, NULL_TREE
);
266 gfc_conv_descriptor_span_get (tree desc
)
268 return gfc_conv_descriptor_span (desc
);
272 gfc_conv_descriptor_span_set (stmtblock_t
*block
, tree desc
,
275 tree t
= gfc_conv_descriptor_span (desc
);
276 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
281 gfc_conv_descriptor_rank (tree desc
)
286 dtype
= gfc_conv_descriptor_dtype (desc
);
287 tmp
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype
)), GFC_DTYPE_RANK
);
288 gcc_assert (tmp
!= NULL_TREE
289 && TREE_TYPE (tmp
) == signed_char_type_node
);
290 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
291 dtype
, tmp
, NULL_TREE
);
296 gfc_get_descriptor_dimension (tree desc
)
300 type
= TREE_TYPE (desc
);
301 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
303 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
304 gcc_assert (field
!= NULL_TREE
305 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
306 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
308 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
309 desc
, field
, NULL_TREE
);
314 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
318 tmp
= gfc_get_descriptor_dimension (desc
);
320 return gfc_build_array_ref (tmp
, dim
, NULL
);
325 gfc_conv_descriptor_token (tree desc
)
330 type
= TREE_TYPE (desc
);
331 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
332 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
333 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
335 /* Should be a restricted pointer - except in the finalization wrapper. */
336 gcc_assert (field
!= NULL_TREE
337 && (TREE_TYPE (field
) == prvoid_type_node
338 || TREE_TYPE (field
) == pvoid_type_node
));
340 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
341 desc
, field
, NULL_TREE
);
346 gfc_conv_descriptor_stride (tree desc
, tree dim
)
351 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
352 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
353 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
354 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
356 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
357 tmp
, field
, NULL_TREE
);
362 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
364 tree type
= TREE_TYPE (desc
);
365 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
366 if (integer_zerop (dim
)
367 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
368 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
369 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
370 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
371 return gfc_index_one_node
;
373 return gfc_conv_descriptor_stride (desc
, dim
);
377 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
378 tree dim
, tree value
)
380 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
381 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
385 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
390 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
391 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
392 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
393 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
395 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
396 tmp
, field
, NULL_TREE
);
401 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
403 return gfc_conv_descriptor_lbound (desc
, dim
);
407 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
408 tree dim
, tree value
)
410 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
411 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
415 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
420 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
421 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
422 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
423 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
425 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
426 tmp
, field
, NULL_TREE
);
431 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
433 return gfc_conv_descriptor_ubound (desc
, dim
);
437 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
438 tree dim
, tree value
)
440 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
441 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
444 /* Build a null array descriptor constructor. */
447 gfc_build_null_descriptor (tree type
)
452 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
453 gcc_assert (DATA_FIELD
== 0);
454 field
= TYPE_FIELDS (type
);
456 /* Set a NULL data pointer. */
457 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
458 TREE_CONSTANT (tmp
) = 1;
459 /* All other fields are ignored. */
465 /* Modify a descriptor such that the lbound of a given dimension is the value
466 specified. This also updates ubound and offset accordingly. */
469 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
470 int dim
, tree new_lbound
)
472 tree offs
, ubound
, lbound
, stride
;
473 tree diff
, offs_diff
;
475 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
477 offs
= gfc_conv_descriptor_offset_get (desc
);
478 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
479 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
480 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
482 /* Get difference (new - old) by which to shift stuff. */
483 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
486 /* Shift ubound and offset accordingly. This has to be done before
487 updating the lbound, as they depend on the lbound expression! */
488 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
490 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
491 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
493 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
495 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
497 /* Finally set lbound to value we want. */
498 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
502 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
505 gfc_get_descriptor_offsets_for_info (const_tree desc_type
, tree
*data_off
,
506 tree
*dtype_off
, tree
*dim_off
,
507 tree
*dim_size
, tree
*stride_suboff
,
508 tree
*lower_suboff
, tree
*upper_suboff
)
513 type
= TYPE_MAIN_VARIANT (desc_type
);
514 field
= gfc_advance_chain (TYPE_FIELDS (type
), DATA_FIELD
);
515 *data_off
= byte_position (field
);
516 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
517 *dtype_off
= byte_position (field
);
518 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
519 *dim_off
= byte_position (field
);
520 type
= TREE_TYPE (TREE_TYPE (field
));
521 *dim_size
= TYPE_SIZE_UNIT (type
);
522 field
= gfc_advance_chain (TYPE_FIELDS (type
), STRIDE_SUBFIELD
);
523 *stride_suboff
= byte_position (field
);
524 field
= gfc_advance_chain (TYPE_FIELDS (type
), LBOUND_SUBFIELD
);
525 *lower_suboff
= byte_position (field
);
526 field
= gfc_advance_chain (TYPE_FIELDS (type
), UBOUND_SUBFIELD
);
527 *upper_suboff
= byte_position (field
);
531 /* Cleanup those #defines. */
537 #undef DIMENSION_FIELD
538 #undef CAF_TOKEN_FIELD
539 #undef STRIDE_SUBFIELD
540 #undef LBOUND_SUBFIELD
541 #undef UBOUND_SUBFIELD
544 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
545 flags & 1 = Main loop body.
546 flags & 2 = temp copy loop. */
549 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
551 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
552 ss
->info
->useflags
= flags
;
556 /* Free a gfc_ss chain. */
559 gfc_free_ss_chain (gfc_ss
* ss
)
563 while (ss
!= gfc_ss_terminator
)
565 gcc_assert (ss
!= NULL
);
574 free_ss_info (gfc_ss_info
*ss_info
)
579 if (ss_info
->refcount
> 0)
582 gcc_assert (ss_info
->refcount
== 0);
584 switch (ss_info
->type
)
587 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
588 if (ss_info
->data
.array
.subscript
[n
])
589 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
603 gfc_free_ss (gfc_ss
* ss
)
605 free_ss_info (ss
->info
);
610 /* Creates and initializes an array type gfc_ss struct. */
613 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
616 gfc_ss_info
*ss_info
;
619 ss_info
= gfc_get_ss_info ();
621 ss_info
->type
= type
;
622 ss_info
->expr
= expr
;
628 for (i
= 0; i
< ss
->dimen
; i
++)
635 /* Creates and initializes a temporary type gfc_ss struct. */
638 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
641 gfc_ss_info
*ss_info
;
644 ss_info
= gfc_get_ss_info ();
646 ss_info
->type
= GFC_SS_TEMP
;
647 ss_info
->string_length
= string_length
;
648 ss_info
->data
.temp
.type
= type
;
652 ss
->next
= gfc_ss_terminator
;
654 for (i
= 0; i
< ss
->dimen
; i
++)
661 /* Creates and initializes a scalar type gfc_ss struct. */
664 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
667 gfc_ss_info
*ss_info
;
669 ss_info
= gfc_get_ss_info ();
671 ss_info
->type
= GFC_SS_SCALAR
;
672 ss_info
->expr
= expr
;
682 /* Free all the SS associated with a loop. */
685 gfc_cleanup_loop (gfc_loopinfo
* loop
)
687 gfc_loopinfo
*loop_next
, **ploop
;
692 while (ss
!= gfc_ss_terminator
)
694 gcc_assert (ss
!= NULL
);
695 next
= ss
->loop_chain
;
700 /* Remove reference to self in the parent loop. */
702 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
709 /* Free non-freed nested loops. */
710 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
712 loop_next
= loop
->next
;
713 gfc_cleanup_loop (loop
);
720 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
724 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
728 if (ss
->info
->type
== GFC_SS_SCALAR
729 || ss
->info
->type
== GFC_SS_REFERENCE
730 || ss
->info
->type
== GFC_SS_TEMP
)
733 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
734 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
735 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
740 /* Associate a SS chain with a loop. */
743 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
746 gfc_loopinfo
*nested_loop
;
748 if (head
== gfc_ss_terminator
)
751 set_ss_loop (head
, loop
);
754 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
758 nested_loop
= ss
->nested_ss
->loop
;
760 /* More than one ss can belong to the same loop. Hence, we add the
761 loop to the chain only if it is different from the previously
762 added one, to avoid duplicate nested loops. */
763 if (nested_loop
!= loop
->nested
)
765 gcc_assert (nested_loop
->parent
== NULL
);
766 nested_loop
->parent
= loop
;
768 gcc_assert (nested_loop
->next
== NULL
);
769 nested_loop
->next
= loop
->nested
;
770 loop
->nested
= nested_loop
;
773 gcc_assert (nested_loop
->parent
== loop
);
776 if (ss
->next
== gfc_ss_terminator
)
777 ss
->loop_chain
= loop
->ss
;
779 ss
->loop_chain
= ss
->next
;
781 gcc_assert (ss
== gfc_ss_terminator
);
786 /* Returns true if the expression is an array pointer. */
789 is_pointer_array (tree expr
)
791 if (expr
== NULL_TREE
792 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr
))
793 || GFC_CLASS_TYPE_P (TREE_TYPE (expr
)))
796 if (TREE_CODE (expr
) == VAR_DECL
797 && GFC_DECL_PTR_ARRAY_P (expr
))
800 if (TREE_CODE (expr
) == PARM_DECL
801 && GFC_DECL_PTR_ARRAY_P (expr
))
804 if (TREE_CODE (expr
) == INDIRECT_REF
805 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 0)))
808 /* The field declaration is marked as an pointer array. */
809 if (TREE_CODE (expr
) == COMPONENT_REF
810 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 1))
811 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr
, 1))))
818 /* Return the span of an array. */
821 gfc_get_array_span (tree desc
, gfc_expr
*expr
)
825 if (is_pointer_array (desc
))
826 /* This will have the span field set. */
827 tmp
= gfc_conv_descriptor_span_get (desc
);
828 else if (TREE_CODE (desc
) == COMPONENT_REF
829 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
830 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
832 /* The descriptor is a class _data field and so use the vtable
833 size for the receiving span field. */
834 tmp
= gfc_get_vptr_from_expr (desc
);
835 tmp
= gfc_vptr_size_get (tmp
);
837 else if (expr
&& expr
->expr_type
== EXPR_VARIABLE
838 && expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
839 && expr
->ref
->type
== REF_COMPONENT
840 && expr
->ref
->next
->type
== REF_ARRAY
841 && expr
->ref
->next
->next
== NULL
842 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.dimension
)
844 /* Dummys come in sometimes with the descriptor detached from
845 the class field or declaration. */
846 tmp
= gfc_class_vptr_get (expr
->symtree
->n
.sym
->backend_decl
);
847 tmp
= gfc_vptr_size_get (tmp
);
851 /* If none of the fancy stuff works, the span is the element
852 size of the array. Attempt to deal with unbounded character
853 types if possible. Otherwise, return NULL_TREE. */
854 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
855 if (tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
856 && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) == NULL_TREE
857 || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)))))
859 if (expr
->expr_type
== EXPR_VARIABLE
860 && expr
->ts
.type
== BT_CHARACTER
)
861 tmp
= fold_convert (gfc_array_index_type
,
862 gfc_get_expr_charlen (expr
));
867 tmp
= fold_convert (gfc_array_index_type
,
868 size_in_bytes (tmp
));
874 /* Generate an initializer for a static pointer or allocatable array. */
877 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
881 gcc_assert (TREE_STATIC (sym
->backend_decl
));
882 /* Just zero the data member. */
883 type
= TREE_TYPE (sym
->backend_decl
);
884 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
888 /* If the bounds of SE's loop have not yet been set, see if they can be
889 determined from array spec AS, which is the array spec of a called
890 function. MAPPING maps the callee's dummy arguments to the values
891 that the caller is passing. Add any initialization and finalization
895 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
896 gfc_se
* se
, gfc_array_spec
* as
)
898 int n
, dim
, total_dim
;
907 if (!as
|| as
->type
!= AS_EXPLICIT
)
910 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
912 total_dim
+= ss
->loop
->dimen
;
913 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
915 /* The bound is known, nothing to do. */
916 if (ss
->loop
->to
[n
] != NULL_TREE
)
920 gcc_assert (dim
< as
->rank
);
921 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
923 /* Evaluate the lower bound. */
924 gfc_init_se (&tmpse
, NULL
);
925 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
926 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
927 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
928 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
930 /* ...and the upper bound. */
931 gfc_init_se (&tmpse
, NULL
);
932 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
933 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
934 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
935 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
937 /* Set the upper bound of the loop to UPPER - LOWER. */
938 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
939 gfc_array_index_type
, upper
, lower
);
940 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
941 ss
->loop
->to
[n
] = tmp
;
945 gcc_assert (total_dim
== as
->rank
);
949 /* Generate code to allocate an array temporary, or create a variable to
950 hold the data. If size is NULL, zero the descriptor so that the
951 callee will allocate the array. If DEALLOC is true, also generate code to
952 free the array afterwards.
954 If INITIAL is not NULL, it is packed using internal_pack and the result used
955 as data instead of allocating a fresh, unitialized area of memory.
957 Initialization code is added to PRE and finalization code to POST.
958 DYNAMIC is true if the caller may want to extend the array later
959 using realloc. This prevents us from putting the array on the stack. */
962 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
963 gfc_array_info
* info
, tree size
, tree nelem
,
964 tree initial
, bool dynamic
, bool dealloc
)
970 desc
= info
->descriptor
;
971 info
->offset
= gfc_index_zero_node
;
972 if (size
== NULL_TREE
|| integer_zerop (size
))
974 /* A callee allocated array. */
975 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
980 /* Allocate the temporary. */
981 onstack
= !dynamic
&& initial
== NULL_TREE
982 && (flag_stack_arrays
983 || gfc_can_put_var_on_stack (size
));
987 /* Make a temporary variable to hold the data. */
988 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
989 nelem
, gfc_index_one_node
);
990 tmp
= gfc_evaluate_now (tmp
, pre
);
991 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
993 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
995 tmp
= gfc_create_var (tmp
, "A");
996 /* If we're here only because of -fstack-arrays we have to
997 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
998 if (!gfc_can_put_var_on_stack (size
))
999 gfc_add_expr_to_block (pre
,
1000 fold_build1_loc (input_location
,
1001 DECL_EXPR
, TREE_TYPE (tmp
),
1003 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1004 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1008 /* Allocate memory to hold the data or call internal_pack. */
1009 if (initial
== NULL_TREE
)
1011 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1012 tmp
= gfc_evaluate_now (tmp
, pre
);
1019 stmtblock_t do_copying
;
1021 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1022 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1023 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1024 tmp
= gfc_get_element_type (tmp
);
1025 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1026 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1028 tmp
= build_call_expr_loc (input_location
,
1029 gfor_fndecl_in_pack
, 1, initial
);
1030 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1031 gfc_add_modify (pre
, packed
, tmp
);
1033 tmp
= build_fold_indirect_ref_loc (input_location
,
1035 source_data
= gfc_conv_descriptor_data_get (tmp
);
1037 /* internal_pack may return source->data without any allocation
1038 or copying if it is already packed. If that's the case, we
1039 need to allocate and copy manually. */
1041 gfc_start_block (&do_copying
);
1042 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1043 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1044 gfc_add_modify (&do_copying
, packed
, tmp
);
1045 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1046 gfc_add_expr_to_block (&do_copying
, tmp
);
1048 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1049 logical_type_node
, packed
,
1051 tmp
= gfc_finish_block (&do_copying
);
1052 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1053 build_empty_stmt (input_location
));
1054 gfc_add_expr_to_block (pre
, tmp
);
1056 tmp
= fold_convert (pvoid_type_node
, packed
);
1059 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1062 info
->data
= gfc_conv_descriptor_data_get (desc
);
1064 /* The offset is zero because we create temporaries with a zero
1066 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1068 if (dealloc
&& !onstack
)
1070 /* Free the temporary. */
1071 tmp
= gfc_conv_descriptor_data_get (desc
);
1072 tmp
= gfc_call_free (tmp
);
1073 gfc_add_expr_to_block (post
, tmp
);
1078 /* Get the scalarizer array dimension corresponding to actual array dimension
1081 For example, if SS represents the array ref a(1,:,:,1), it is a
1082 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1083 and 1 for ARRAY_DIM=2.
1084 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1085 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1087 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1088 array. If called on the inner ss, the result would be respectively 0,1,2 for
1089 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1090 for ARRAY_DIM=1,2. */
1093 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1100 for (; ss
; ss
= ss
->parent
)
1101 for (n
= 0; n
< ss
->dimen
; n
++)
1102 if (ss
->dim
[n
] < array_dim
)
1105 return array_ref_dim
;
1110 innermost_ss (gfc_ss
*ss
)
1112 while (ss
->nested_ss
!= NULL
)
1120 /* Get the array reference dimension corresponding to the given loop dimension.
1121 It is different from the true array dimension given by the dim array in
1122 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1123 It is different from the loop dimension in the case of a transposed array.
1127 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1129 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1134 /* Generate code to create and initialize the descriptor for a temporary
1135 array. This is used for both temporaries needed by the scalarizer, and
1136 functions returning arrays. Adjusts the loop variables to be
1137 zero-based, and calculates the loop bounds for callee allocated arrays.
1138 Allocate the array unless it's callee allocated (we have a callee
1139 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1140 NULL_TREE for any n). Also fills in the descriptor, data and offset
1141 fields of info if known. Returns the size of the array, or NULL for a
1142 callee allocated array.
1144 'eltype' == NULL signals that the temporary should be a class object.
1145 The 'initial' expression is used to obtain the size of the dynamic
1146 type; otherwise the allocation and initialization proceeds as for any
1149 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1150 gfc_trans_allocate_array_storage. */
1153 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1154 tree eltype
, tree initial
, bool dynamic
,
1155 bool dealloc
, bool callee_alloc
, locus
* where
)
1159 gfc_array_info
*info
;
1160 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1168 tree class_expr
= NULL_TREE
;
1169 int n
, dim
, tmp_dim
;
1172 /* This signals a class array for which we need the size of the
1173 dynamic type. Generate an eltype and then the class expression. */
1174 if (eltype
== NULL_TREE
&& initial
)
1176 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1177 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1178 eltype
= TREE_TYPE (class_expr
);
1179 eltype
= gfc_get_element_type (eltype
);
1180 /* Obtain the structure (class) expression. */
1181 class_expr
= TREE_OPERAND (class_expr
, 0);
1182 gcc_assert (class_expr
);
1185 memset (from
, 0, sizeof (from
));
1186 memset (to
, 0, sizeof (to
));
1188 info
= &ss
->info
->data
.array
;
1190 gcc_assert (ss
->dimen
> 0);
1191 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1193 if (warn_array_temporaries
&& where
)
1194 gfc_warning (OPT_Warray_temporaries
,
1195 "Creating array temporary at %L", where
);
1197 /* Set the lower bound to zero. */
1198 for (s
= ss
; s
; s
= s
->parent
)
1202 total_dim
+= loop
->dimen
;
1203 for (n
= 0; n
< loop
->dimen
; n
++)
1207 /* Callee allocated arrays may not have a known bound yet. */
1209 loop
->to
[n
] = gfc_evaluate_now (
1210 fold_build2_loc (input_location
, MINUS_EXPR
,
1211 gfc_array_index_type
,
1212 loop
->to
[n
], loop
->from
[n
]),
1214 loop
->from
[n
] = gfc_index_zero_node
;
1216 /* We have just changed the loop bounds, we must clear the
1217 corresponding specloop, so that delta calculation is not skipped
1218 later in gfc_set_delta. */
1219 loop
->specloop
[n
] = NULL
;
1221 /* We are constructing the temporary's descriptor based on the loop
1222 dimensions. As the dimensions may be accessed in arbitrary order
1223 (think of transpose) the size taken from the n'th loop may not map
1224 to the n'th dimension of the array. We need to reconstruct loop
1225 infos in the right order before using it to set the descriptor
1227 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1228 from
[tmp_dim
] = loop
->from
[n
];
1229 to
[tmp_dim
] = loop
->to
[n
];
1231 info
->delta
[dim
] = gfc_index_zero_node
;
1232 info
->start
[dim
] = gfc_index_zero_node
;
1233 info
->end
[dim
] = gfc_index_zero_node
;
1234 info
->stride
[dim
] = gfc_index_one_node
;
1238 /* Initialize the descriptor. */
1240 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1241 GFC_ARRAY_UNKNOWN
, true);
1242 desc
= gfc_create_var (type
, "atmp");
1243 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1245 info
->descriptor
= desc
;
1246 size
= gfc_index_one_node
;
1248 /* Emit a DECL_EXPR for the variable sized array type in
1249 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1250 sizes works correctly. */
1251 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1252 if (! TYPE_NAME (arraytype
))
1253 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1254 NULL_TREE
, arraytype
);
1255 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1256 arraytype
, TYPE_NAME (arraytype
)));
1258 /* Fill in the array dtype. */
1259 tmp
= gfc_conv_descriptor_dtype (desc
);
1260 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1263 Fill in the bounds and stride. This is a packed array, so:
1266 for (n = 0; n < rank; n++)
1269 delta = ubound[n] + 1 - lbound[n];
1270 size = size * delta;
1272 size = size * sizeof(element);
1275 or_expr
= NULL_TREE
;
1277 /* If there is at least one null loop->to[n], it is a callee allocated
1279 for (n
= 0; n
< total_dim
; n
++)
1280 if (to
[n
] == NULL_TREE
)
1286 if (size
== NULL_TREE
)
1287 for (s
= ss
; s
; s
= s
->parent
)
1288 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1290 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1292 /* For a callee allocated array express the loop bounds in terms
1293 of the descriptor fields. */
1294 tmp
= fold_build2_loc (input_location
,
1295 MINUS_EXPR
, gfc_array_index_type
,
1296 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1297 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1298 s
->loop
->to
[n
] = tmp
;
1302 for (n
= 0; n
< total_dim
; n
++)
1304 /* Store the stride and bound components in the descriptor. */
1305 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1307 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1308 gfc_index_zero_node
);
1310 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1312 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1313 gfc_array_index_type
,
1314 to
[n
], gfc_index_one_node
);
1316 /* Check whether the size for this dimension is negative. */
1317 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1318 tmp
, gfc_index_zero_node
);
1319 cond
= gfc_evaluate_now (cond
, pre
);
1324 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1325 logical_type_node
, or_expr
, cond
);
1327 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1328 gfc_array_index_type
, size
, tmp
);
1329 size
= gfc_evaluate_now (size
, pre
);
1333 /* Get the size of the array. */
1334 if (size
&& !callee_alloc
)
1337 /* If or_expr is true, then the extent in at least one
1338 dimension is zero and the size is set to zero. */
1339 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1340 or_expr
, gfc_index_zero_node
, size
);
1343 if (class_expr
== NULL_TREE
)
1344 elemsize
= fold_convert (gfc_array_index_type
,
1345 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1347 elemsize
= gfc_class_vtab_size_get (class_expr
);
1349 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1358 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1364 if (ss
->dimen
> ss
->loop
->temp_dim
)
1365 ss
->loop
->temp_dim
= ss
->dimen
;
1371 /* Return the number of iterations in a loop that starts at START,
1372 ends at END, and has step STEP. */
1375 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1380 type
= TREE_TYPE (step
);
1381 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1382 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1383 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1384 build_int_cst (type
, 1));
1385 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1386 build_int_cst (type
, 0));
1387 return fold_convert (gfc_array_index_type
, tmp
);
1391 /* Extend the data in array DESC by EXTRA elements. */
1394 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1401 if (integer_zerop (extra
))
1404 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1406 /* Add EXTRA to the upper bound. */
1407 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1409 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1411 /* Get the value of the current data pointer. */
1412 arg0
= gfc_conv_descriptor_data_get (desc
);
1414 /* Calculate the new array size. */
1415 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1416 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1417 ubound
, gfc_index_one_node
);
1418 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1419 fold_convert (size_type_node
, tmp
),
1420 fold_convert (size_type_node
, size
));
1422 /* Call the realloc() function. */
1423 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1424 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1428 /* Return true if the bounds of iterator I can only be determined
1432 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1434 return (i
->start
->expr_type
!= EXPR_CONSTANT
1435 || i
->end
->expr_type
!= EXPR_CONSTANT
1436 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1440 /* Split the size of constructor element EXPR into the sum of two terms,
1441 one of which can be determined at compile time and one of which must
1442 be calculated at run time. Set *SIZE to the former and return true
1443 if the latter might be nonzero. */
1446 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1448 if (expr
->expr_type
== EXPR_ARRAY
)
1449 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1450 else if (expr
->rank
> 0)
1452 /* Calculate everything at run time. */
1453 mpz_set_ui (*size
, 0);
1458 /* A single element. */
1459 mpz_set_ui (*size
, 1);
1465 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1466 of array constructor C. */
1469 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1477 mpz_set_ui (*size
, 0);
1482 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1485 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1489 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1492 /* Multiply the static part of the element size by the
1493 number of iterations. */
1494 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1495 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1496 mpz_add_ui (val
, val
, 1);
1497 if (mpz_sgn (val
) > 0)
1498 mpz_mul (len
, len
, val
);
1500 mpz_set_ui (len
, 0);
1502 mpz_add (*size
, *size
, len
);
1511 /* Make sure offset is a variable. */
1514 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1517 /* We should have already created the offset variable. We cannot
1518 create it here because we may be in an inner scope. */
1519 gcc_assert (*offsetvar
!= NULL_TREE
);
1520 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1521 *poffset
= *offsetvar
;
1522 TREE_USED (*offsetvar
) = 1;
1526 /* Variables needed for bounds-checking. */
1527 static bool first_len
;
1528 static tree first_len_val
;
1529 static bool typespec_chararray_ctor
;
1532 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1533 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1537 gfc_conv_expr (se
, expr
);
1539 /* Store the value. */
1540 tmp
= build_fold_indirect_ref_loc (input_location
,
1541 gfc_conv_descriptor_data_get (desc
));
1542 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1544 if (expr
->ts
.type
== BT_CHARACTER
)
1546 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1549 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1550 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1551 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1552 TREE_TYPE (esize
), esize
,
1553 build_int_cst (TREE_TYPE (esize
),
1554 gfc_character_kinds
[i
].bit_size
/ 8));
1556 gfc_conv_string_parameter (se
);
1557 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1559 /* The temporary is an array of pointers. */
1560 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1561 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1565 /* The temporary is an array of string values. */
1566 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1567 /* We know the temporary and the value will be the same length,
1568 so can use memcpy. */
1569 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1570 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1572 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1576 gfc_add_modify (&se
->pre
, first_len_val
,
1577 fold_convert (TREE_TYPE (first_len_val
),
1578 se
->string_length
));
1583 /* Verify that all constructor elements are of the same
1585 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1587 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1588 logical_type_node
, first_len_val
,
1590 gfc_trans_runtime_check
1591 (true, false, cond
, &se
->pre
, &expr
->where
,
1592 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1593 fold_convert (long_integer_type_node
, first_len_val
),
1594 fold_convert (long_integer_type_node
, se
->string_length
));
1598 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1599 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1601 /* Assignment of a CLASS array constructor to a derived type array. */
1602 if (expr
->expr_type
== EXPR_FUNCTION
)
1603 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1604 se
->expr
= gfc_class_data_get (se
->expr
);
1605 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1606 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1607 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1611 /* TODO: Should the frontend already have done this conversion? */
1612 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1613 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1616 gfc_add_block_to_block (pblock
, &se
->pre
);
1617 gfc_add_block_to_block (pblock
, &se
->post
);
1621 /* Add the contents of an array to the constructor. DYNAMIC is as for
1622 gfc_trans_array_constructor_value. */
1625 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1626 tree type ATTRIBUTE_UNUSED
,
1627 tree desc
, gfc_expr
* expr
,
1628 tree
* poffset
, tree
* offsetvar
,
1639 /* We need this to be a variable so we can increment it. */
1640 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1642 gfc_init_se (&se
, NULL
);
1644 /* Walk the array expression. */
1645 ss
= gfc_walk_expr (expr
);
1646 gcc_assert (ss
!= gfc_ss_terminator
);
1648 /* Initialize the scalarizer. */
1649 gfc_init_loopinfo (&loop
);
1650 gfc_add_ss_to_loop (&loop
, ss
);
1652 /* Initialize the loop. */
1653 gfc_conv_ss_startstride (&loop
);
1654 gfc_conv_loop_setup (&loop
, &expr
->where
);
1656 /* Make sure the constructed array has room for the new data. */
1659 /* Set SIZE to the total number of elements in the subarray. */
1660 size
= gfc_index_one_node
;
1661 for (n
= 0; n
< loop
.dimen
; n
++)
1663 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1664 gfc_index_one_node
);
1665 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1666 gfc_array_index_type
, size
, tmp
);
1669 /* Grow the constructed array by SIZE elements. */
1670 gfc_grow_array (&loop
.pre
, desc
, size
);
1673 /* Make the loop body. */
1674 gfc_mark_ss_chain_used (ss
, 1);
1675 gfc_start_scalarized_body (&loop
, &body
);
1676 gfc_copy_loopinfo_to_se (&se
, &loop
);
1679 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1680 gcc_assert (se
.ss
== gfc_ss_terminator
);
1682 /* Increment the offset. */
1683 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1684 *poffset
, gfc_index_one_node
);
1685 gfc_add_modify (&body
, *poffset
, tmp
);
1687 /* Finish the loop. */
1688 gfc_trans_scalarizing_loops (&loop
, &body
);
1689 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1690 tmp
= gfc_finish_block (&loop
.pre
);
1691 gfc_add_expr_to_block (pblock
, tmp
);
1693 gfc_cleanup_loop (&loop
);
1697 /* Assign the values to the elements of an array constructor. DYNAMIC
1698 is true if descriptor DESC only contains enough data for the static
1699 size calculated by gfc_get_array_constructor_size. When true, memory
1700 for the dynamic parts must be allocated using realloc. */
1703 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1704 tree desc
, gfc_constructor_base base
,
1705 tree
* poffset
, tree
* offsetvar
,
1709 tree start
= NULL_TREE
;
1710 tree end
= NULL_TREE
;
1711 tree step
= NULL_TREE
;
1717 tree shadow_loopvar
= NULL_TREE
;
1718 gfc_saved_var saved_loopvar
;
1721 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1723 /* If this is an iterator or an array, the offset must be a variable. */
1724 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1725 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1727 /* Shadowing the iterator avoids changing its value and saves us from
1728 keeping track of it. Further, it makes sure that there's always a
1729 backend-decl for the symbol, even if there wasn't one before,
1730 e.g. in the case of an iterator that appears in a specification
1731 expression in an interface mapping. */
1737 /* Evaluate loop bounds before substituting the loop variable
1738 in case they depend on it. Such a case is invalid, but it is
1739 not more expensive to do the right thing here.
1741 gfc_init_se (&se
, NULL
);
1742 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1743 gfc_add_block_to_block (pblock
, &se
.pre
);
1744 start
= gfc_evaluate_now (se
.expr
, pblock
);
1746 gfc_init_se (&se
, NULL
);
1747 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1748 gfc_add_block_to_block (pblock
, &se
.pre
);
1749 end
= gfc_evaluate_now (se
.expr
, pblock
);
1751 gfc_init_se (&se
, NULL
);
1752 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1753 gfc_add_block_to_block (pblock
, &se
.pre
);
1754 step
= gfc_evaluate_now (se
.expr
, pblock
);
1756 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1757 type
= gfc_typenode_for_spec (&sym
->ts
);
1759 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1760 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1763 gfc_start_block (&body
);
1765 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1767 /* Array constructors can be nested. */
1768 gfc_trans_array_constructor_value (&body
, type
, desc
,
1769 c
->expr
->value
.constructor
,
1770 poffset
, offsetvar
, dynamic
);
1772 else if (c
->expr
->rank
> 0)
1774 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1775 poffset
, offsetvar
, dynamic
);
1779 /* This code really upsets the gimplifier so don't bother for now. */
1786 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1788 p
= gfc_constructor_next (p
);
1793 /* Scalar values. */
1794 gfc_init_se (&se
, NULL
);
1795 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1798 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1799 gfc_array_index_type
,
1800 *poffset
, gfc_index_one_node
);
1804 /* Collect multiple scalar constants into a constructor. */
1805 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1809 HOST_WIDE_INT idx
= 0;
1812 /* Count the number of consecutive scalar constants. */
1813 while (p
&& !(p
->iterator
1814 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1816 gfc_init_se (&se
, NULL
);
1817 gfc_conv_constant (&se
, p
->expr
);
1819 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1820 se
.expr
= fold_convert (type
, se
.expr
);
1821 /* For constant character array constructors we build
1822 an array of pointers. */
1823 else if (POINTER_TYPE_P (type
))
1824 se
.expr
= gfc_build_addr_expr
1825 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1828 CONSTRUCTOR_APPEND_ELT (v
,
1829 build_int_cst (gfc_array_index_type
,
1833 p
= gfc_constructor_next (p
);
1836 bound
= size_int (n
- 1);
1837 /* Create an array type to hold them. */
1838 tmptype
= build_range_type (gfc_array_index_type
,
1839 gfc_index_zero_node
, bound
);
1840 tmptype
= build_array_type (type
, tmptype
);
1842 init
= build_constructor (tmptype
, v
);
1843 TREE_CONSTANT (init
) = 1;
1844 TREE_STATIC (init
) = 1;
1845 /* Create a static variable to hold the data. */
1846 tmp
= gfc_create_var (tmptype
, "data");
1847 TREE_STATIC (tmp
) = 1;
1848 TREE_CONSTANT (tmp
) = 1;
1849 TREE_READONLY (tmp
) = 1;
1850 DECL_INITIAL (tmp
) = init
;
1853 /* Use BUILTIN_MEMCPY to assign the values. */
1854 tmp
= gfc_conv_descriptor_data_get (desc
);
1855 tmp
= build_fold_indirect_ref_loc (input_location
,
1857 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1858 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1859 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1861 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1862 bound
= build_int_cst (size_type_node
, n
* size
);
1863 tmp
= build_call_expr_loc (input_location
,
1864 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1865 3, tmp
, init
, bound
);
1866 gfc_add_expr_to_block (&body
, tmp
);
1868 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1869 gfc_array_index_type
, *poffset
,
1870 build_int_cst (gfc_array_index_type
, n
));
1872 if (!INTEGER_CST_P (*poffset
))
1874 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1875 *poffset
= *offsetvar
;
1879 /* The frontend should already have done any expansions
1883 /* Pass the code as is. */
1884 tmp
= gfc_finish_block (&body
);
1885 gfc_add_expr_to_block (pblock
, tmp
);
1889 /* Build the implied do-loop. */
1890 stmtblock_t implied_do_block
;
1896 loopbody
= gfc_finish_block (&body
);
1898 /* Create a new block that holds the implied-do loop. A temporary
1899 loop-variable is used. */
1900 gfc_start_block(&implied_do_block
);
1902 /* Initialize the loop. */
1903 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1905 /* If this array expands dynamically, and the number of iterations
1906 is not constant, we won't have allocated space for the static
1907 part of C->EXPR's size. Do that now. */
1908 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1910 /* Get the number of iterations. */
1911 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1913 /* Get the static part of C->EXPR's size. */
1914 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1915 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1917 /* Grow the array by TMP * TMP2 elements. */
1918 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1919 gfc_array_index_type
, tmp
, tmp2
);
1920 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1923 /* Generate the loop body. */
1924 exit_label
= gfc_build_label_decl (NULL_TREE
);
1925 gfc_start_block (&body
);
1927 /* Generate the exit condition. Depending on the sign of
1928 the step variable we have to generate the correct
1930 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1931 step
, build_int_cst (TREE_TYPE (step
), 0));
1932 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1933 logical_type_node
, tmp
,
1934 fold_build2_loc (input_location
, GT_EXPR
,
1935 logical_type_node
, shadow_loopvar
, end
),
1936 fold_build2_loc (input_location
, LT_EXPR
,
1937 logical_type_node
, shadow_loopvar
, end
));
1938 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1939 TREE_USED (exit_label
) = 1;
1940 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1941 build_empty_stmt (input_location
));
1942 gfc_add_expr_to_block (&body
, tmp
);
1944 /* The main loop body. */
1945 gfc_add_expr_to_block (&body
, loopbody
);
1947 /* Increase loop variable by step. */
1948 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1949 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1951 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1953 /* Finish the loop. */
1954 tmp
= gfc_finish_block (&body
);
1955 tmp
= build1_v (LOOP_EXPR
, tmp
);
1956 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1958 /* Add the exit label. */
1959 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1960 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1962 /* Finish the implied-do loop. */
1963 tmp
= gfc_finish_block(&implied_do_block
);
1964 gfc_add_expr_to_block(pblock
, tmp
);
1966 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1973 /* The array constructor code can create a string length with an operand
1974 in the form of a temporary variable. This variable will retain its
1975 context (current_function_decl). If we store this length tree in a
1976 gfc_charlen structure which is shared by a variable in another
1977 context, the resulting gfc_charlen structure with a variable in a
1978 different context, we could trip the assertion in expand_expr_real_1
1979 when it sees that a variable has been created in one context and
1980 referenced in another.
1982 If this might be the case, we create a new gfc_charlen structure and
1983 link it into the current namespace. */
1986 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1990 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1993 (*clp
)->backend_decl
= len
;
1996 /* A catch-all to obtain the string length for anything that is not
1997 a substring of non-constant length, a constant, array or variable. */
2000 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
2004 /* Don't bother if we already know the length is a constant. */
2005 if (*len
&& INTEGER_CST_P (*len
))
2008 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2009 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2012 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2013 *len
= e
->ts
.u
.cl
->backend_decl
;
2017 /* Otherwise, be brutal even if inefficient. */
2018 gfc_init_se (&se
, NULL
);
2020 /* No function call, in case of side effects. */
2021 se
.no_function_call
= 1;
2023 gfc_conv_expr (&se
, e
);
2025 gfc_conv_expr_descriptor (&se
, e
);
2027 /* Fix the value. */
2028 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2030 gfc_add_block_to_block (block
, &se
.pre
);
2031 gfc_add_block_to_block (block
, &se
.post
);
2033 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2038 /* Figure out the string length of a variable reference expression.
2039 Used by get_array_ctor_strlen. */
2042 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2048 /* Don't bother if we already know the length is a constant. */
2049 if (*len
&& INTEGER_CST_P (*len
))
2052 ts
= &expr
->symtree
->n
.sym
->ts
;
2053 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2058 /* Array references don't change the string length. */
2062 /* Use the length of the component. */
2063 ts
= &ref
->u
.c
.component
->ts
;
2067 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2068 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2070 /* Note that this might evaluate expr. */
2071 get_array_ctor_all_strlen (block
, expr
, len
);
2074 mpz_init_set_ui (char_len
, 1);
2075 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2076 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2077 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2078 mpz_clear (char_len
);
2086 *len
= ts
->u
.cl
->backend_decl
;
2090 /* Figure out the string length of a character array constructor.
2091 If len is NULL, don't calculate the length; this happens for recursive calls
2092 when a sub-array-constructor is an element but not at the first position,
2093 so when we're not interested in the length.
2094 Returns TRUE if all elements are character constants. */
2097 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2104 if (gfc_constructor_first (base
) == NULL
)
2107 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2111 /* Loop over all constructor elements to find out is_const, but in len we
2112 want to store the length of the first, not the last, element. We can
2113 of course exit the loop as soon as is_const is found to be false. */
2114 for (c
= gfc_constructor_first (base
);
2115 c
&& is_const
; c
= gfc_constructor_next (c
))
2117 switch (c
->expr
->expr_type
)
2120 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2121 *len
= build_int_cstu (gfc_charlen_type_node
,
2122 c
->expr
->value
.character
.length
);
2126 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2133 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2139 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2143 /* After the first iteration, we don't want the length modified. */
2150 /* Check whether the array constructor C consists entirely of constant
2151 elements, and if so returns the number of those elements, otherwise
2152 return zero. Note, an empty or NULL array constructor returns zero. */
2154 unsigned HOST_WIDE_INT
2155 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2157 unsigned HOST_WIDE_INT nelem
= 0;
2159 gfc_constructor
*c
= gfc_constructor_first (base
);
2163 || c
->expr
->rank
> 0
2164 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2166 c
= gfc_constructor_next (c
);
2173 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2174 and the tree type of it's elements, TYPE, return a static constant
2175 variable that is compile-time initialized. */
2178 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2180 tree tmptype
, init
, tmp
;
2181 HOST_WIDE_INT nelem
;
2186 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2188 /* First traverse the constructor list, converting the constants
2189 to tree to build an initializer. */
2191 c
= gfc_constructor_first (expr
->value
.constructor
);
2194 gfc_init_se (&se
, NULL
);
2195 gfc_conv_constant (&se
, c
->expr
);
2196 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2197 se
.expr
= fold_convert (type
, se
.expr
);
2198 else if (POINTER_TYPE_P (type
))
2199 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2201 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2203 c
= gfc_constructor_next (c
);
2207 /* Next determine the tree type for the array. We use the gfortran
2208 front-end's gfc_get_nodesc_array_type in order to create a suitable
2209 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2211 memset (&as
, 0, sizeof (gfc_array_spec
));
2213 as
.rank
= expr
->rank
;
2214 as
.type
= AS_EXPLICIT
;
2217 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2218 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2222 for (i
= 0; i
< expr
->rank
; i
++)
2224 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2225 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2226 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2230 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2232 /* as is not needed anymore. */
2233 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2235 gfc_free_expr (as
.lower
[i
]);
2236 gfc_free_expr (as
.upper
[i
]);
2239 init
= build_constructor (tmptype
, v
);
2241 TREE_CONSTANT (init
) = 1;
2242 TREE_STATIC (init
) = 1;
2244 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2246 DECL_ARTIFICIAL (tmp
) = 1;
2247 DECL_IGNORED_P (tmp
) = 1;
2248 TREE_STATIC (tmp
) = 1;
2249 TREE_CONSTANT (tmp
) = 1;
2250 TREE_READONLY (tmp
) = 1;
2251 DECL_INITIAL (tmp
) = init
;
2258 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2259 This mostly initializes the scalarizer state info structure with the
2260 appropriate values to directly use the array created by the function
2261 gfc_build_constant_array_constructor. */
2264 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2266 gfc_array_info
*info
;
2270 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2272 info
= &ss
->info
->data
.array
;
2274 info
->descriptor
= tmp
;
2275 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2276 info
->offset
= gfc_index_zero_node
;
2278 for (i
= 0; i
< ss
->dimen
; i
++)
2280 info
->delta
[i
] = gfc_index_zero_node
;
2281 info
->start
[i
] = gfc_index_zero_node
;
2282 info
->end
[i
] = gfc_index_zero_node
;
2283 info
->stride
[i
] = gfc_index_one_node
;
2289 get_rank (gfc_loopinfo
*loop
)
2294 for (; loop
; loop
= loop
->parent
)
2295 rank
+= loop
->dimen
;
2301 /* Helper routine of gfc_trans_array_constructor to determine if the
2302 bounds of the loop specified by LOOP are constant and simple enough
2303 to use with trans_constant_array_constructor. Returns the
2304 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2307 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2310 tree size
= gfc_index_one_node
;
2314 total_dim
= get_rank (l
);
2316 for (loop
= l
; loop
; loop
= loop
->parent
)
2318 for (i
= 0; i
< loop
->dimen
; i
++)
2320 /* If the bounds aren't constant, return NULL_TREE. */
2321 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2323 if (!integer_zerop (loop
->from
[i
]))
2325 /* Only allow nonzero "from" in one-dimensional arrays. */
2328 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2329 gfc_array_index_type
,
2330 loop
->to
[i
], loop
->from
[i
]);
2334 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2335 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2336 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2337 gfc_array_index_type
, size
, tmp
);
2346 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2351 gcc_assert (array
->nested_ss
== NULL
);
2353 for (ss
= array
; ss
; ss
= ss
->parent
)
2354 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2355 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2356 return &(ss
->loop
->to
[n
]);
2362 static gfc_loopinfo
*
2363 outermost_loop (gfc_loopinfo
* loop
)
2365 while (loop
->parent
!= NULL
)
2366 loop
= loop
->parent
;
2372 /* Array constructors are handled by constructing a temporary, then using that
2373 within the scalarization loop. This is not optimal, but seems by far the
2377 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2379 gfc_constructor_base c
;
2387 bool old_first_len
, old_typespec_chararray_ctor
;
2388 tree old_first_len_val
;
2389 gfc_loopinfo
*loop
, *outer_loop
;
2390 gfc_ss_info
*ss_info
;
2396 /* Save the old values for nested checking. */
2397 old_first_len
= first_len
;
2398 old_first_len_val
= first_len_val
;
2399 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2402 outer_loop
= outermost_loop (loop
);
2404 expr
= ss_info
->expr
;
2406 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2407 typespec was given for the array constructor. */
2408 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2410 && expr
->ts
.u
.cl
->length_from_typespec
);
2412 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2413 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2415 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2419 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2421 c
= expr
->value
.constructor
;
2422 if (expr
->ts
.type
== BT_CHARACTER
)
2425 bool force_new_cl
= false;
2427 /* get_array_ctor_strlen walks the elements of the constructor, if a
2428 typespec was given, we already know the string length and want the one
2430 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2431 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2435 const_string
= false;
2436 gfc_init_se (&length_se
, NULL
);
2437 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2438 gfc_charlen_type_node
);
2439 ss_info
->string_length
= length_se
.expr
;
2441 /* Check if the character length is negative. If it is, then
2443 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2444 logical_type_node
, ss_info
->string_length
,
2445 build_zero_cst (TREE_TYPE
2446 (ss_info
->string_length
)));
2447 /* Print a warning if bounds checking is enabled. */
2448 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2450 msg
= xasprintf ("Negative character length treated as LEN = 0");
2451 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2456 ss_info
->string_length
2457 = fold_build3_loc (input_location
, COND_EXPR
,
2458 gfc_charlen_type_node
, neg_len
,
2460 (TREE_TYPE (ss_info
->string_length
)),
2461 ss_info
->string_length
);
2462 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2465 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2466 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2470 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2471 &ss_info
->string_length
);
2472 force_new_cl
= true;
2475 /* Complex character array constructors should have been taken care of
2476 and not end up here. */
2477 gcc_assert (ss_info
->string_length
);
2479 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2481 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2483 type
= build_pointer_type (type
);
2486 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2487 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2489 /* See if the constructor determines the loop bounds. */
2492 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2494 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2496 /* We have a multidimensional parameter. */
2497 for (s
= ss
; s
; s
= s
->parent
)
2500 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2502 s
->loop
->from
[n
] = gfc_index_zero_node
;
2503 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2504 gfc_index_integer_kind
);
2505 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2506 gfc_array_index_type
,
2508 gfc_index_one_node
);
2513 if (*loop_ubound0
== NULL_TREE
)
2517 /* We should have a 1-dimensional, zero-based loop. */
2518 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2519 gcc_assert (loop
->dimen
== 1);
2520 gcc_assert (integer_zerop (loop
->from
[0]));
2522 /* Split the constructor size into a static part and a dynamic part.
2523 Allocate the static size up-front and record whether the dynamic
2524 size might be nonzero. */
2526 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2527 mpz_sub_ui (size
, size
, 1);
2528 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2532 /* Special case constant array constructors. */
2535 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2538 tree size
= constant_array_constructor_loop_size (loop
);
2539 if (size
&& compare_tree_int (size
, nelem
) == 0)
2541 trans_constant_array_constructor (ss
, type
);
2547 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2548 NULL_TREE
, dynamic
, true, false, where
);
2550 desc
= ss_info
->data
.array
.descriptor
;
2551 offset
= gfc_index_zero_node
;
2552 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2553 TREE_NO_WARNING (offsetvar
) = 1;
2554 TREE_USED (offsetvar
) = 0;
2555 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2556 &offset
, &offsetvar
, dynamic
);
2558 /* If the array grows dynamically, the upper bound of the loop variable
2559 is determined by the array's final upper bound. */
2562 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2563 gfc_array_index_type
,
2564 offsetvar
, gfc_index_one_node
);
2565 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2566 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2567 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2568 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2570 *loop_ubound0
= tmp
;
2573 if (TREE_USED (offsetvar
))
2574 pushdecl (offsetvar
);
2576 gcc_assert (INTEGER_CST_P (offset
));
2579 /* Disable bound checking for now because it's probably broken. */
2580 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2587 /* Restore old values of globals. */
2588 first_len
= old_first_len
;
2589 first_len_val
= old_first_len_val
;
2590 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2594 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2595 called after evaluating all of INFO's vector dimensions. Go through
2596 each such vector dimension and see if we can now fill in any missing
2600 set_vector_loop_bounds (gfc_ss
* ss
)
2602 gfc_loopinfo
*loop
, *outer_loop
;
2603 gfc_array_info
*info
;
2611 outer_loop
= outermost_loop (ss
->loop
);
2613 info
= &ss
->info
->data
.array
;
2615 for (; ss
; ss
= ss
->parent
)
2619 for (n
= 0; n
< loop
->dimen
; n
++)
2622 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2623 || loop
->to
[n
] != NULL
)
2626 /* Loop variable N indexes vector dimension DIM, and we don't
2627 yet know the upper bound of loop variable N. Set it to the
2628 difference between the vector's upper and lower bounds. */
2629 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2630 gcc_assert (info
->subscript
[dim
]
2631 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2633 gfc_init_se (&se
, NULL
);
2634 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2635 zero
= gfc_rank_cst
[0];
2636 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2637 gfc_array_index_type
,
2638 gfc_conv_descriptor_ubound_get (desc
, zero
),
2639 gfc_conv_descriptor_lbound_get (desc
, zero
));
2640 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2647 /* Tells whether a scalar argument to an elemental procedure is saved out
2648 of a scalarization loop as a value or as a reference. */
2651 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2653 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2656 /* If the actual argument can be absent (in other words, it can
2657 be a NULL reference), don't try to evaluate it; pass instead
2658 the reference directly. */
2659 if (ss_info
->can_be_null_ref
)
2662 /* If the expression is of polymorphic type, it's actual size is not known,
2663 so we avoid copying it anywhere. */
2664 if (ss_info
->data
.scalar
.dummy_arg
2665 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2666 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2669 /* If the expression is a data reference of aggregate type,
2670 and the data reference is not used on the left hand side,
2671 avoid a copy by saving a reference to the content. */
2672 if (!ss_info
->data
.scalar
.needs_temporary
2673 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2674 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2675 && gfc_expr_is_variable (ss_info
->expr
))
2678 /* Otherwise the expression is evaluated to a temporary variable before the
2679 scalarization loop. */
2684 /* Add the pre and post chains for all the scalar expressions in a SS chain
2685 to loop. This is called after the loop parameters have been calculated,
2686 but before the actual scalarizing loops. */
2689 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2692 gfc_loopinfo
*nested_loop
, *outer_loop
;
2694 gfc_ss_info
*ss_info
;
2695 gfc_array_info
*info
;
2699 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2700 arguments could get evaluated multiple times. */
2701 if (ss
->is_alloc_lhs
)
2704 outer_loop
= outermost_loop (loop
);
2706 /* TODO: This can generate bad code if there are ordering dependencies,
2707 e.g., a callee allocated function and an unknown size constructor. */
2708 gcc_assert (ss
!= NULL
);
2710 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2714 /* Cross loop arrays are handled from within the most nested loop. */
2715 if (ss
->nested_ss
!= NULL
)
2719 expr
= ss_info
->expr
;
2720 info
= &ss_info
->data
.array
;
2722 switch (ss_info
->type
)
2725 /* Scalar expression. Evaluate this now. This includes elemental
2726 dimension indices, but not array section bounds. */
2727 gfc_init_se (&se
, NULL
);
2728 gfc_conv_expr (&se
, expr
);
2729 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2731 if (expr
->ts
.type
!= BT_CHARACTER
2732 && !gfc_is_alloc_class_scalar_function (expr
))
2734 /* Move the evaluation of scalar expressions outside the
2735 scalarization loop, except for WHERE assignments. */
2737 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2738 if (!ss_info
->where
)
2739 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2740 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2743 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2745 ss_info
->data
.scalar
.value
= se
.expr
;
2746 ss_info
->string_length
= se
.string_length
;
2749 case GFC_SS_REFERENCE
:
2750 /* Scalar argument to elemental procedure. */
2751 gfc_init_se (&se
, NULL
);
2752 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2753 gfc_conv_expr_reference (&se
, expr
);
2756 /* Evaluate the argument outside the loop and pass
2757 a reference to the value. */
2758 gfc_conv_expr (&se
, expr
);
2761 /* Ensure that a pointer to the string is stored. */
2762 if (expr
->ts
.type
== BT_CHARACTER
)
2763 gfc_conv_string_parameter (&se
);
2765 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2766 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2767 if (gfc_is_class_scalar_expr (expr
))
2768 /* This is necessary because the dynamic type will always be
2769 large than the declared type. In consequence, assigning
2770 the value to a temporary could segfault.
2771 OOP-TODO: see if this is generally correct or is the value
2772 has to be written to an allocated temporary, whose address
2773 is passed via ss_info. */
2774 ss_info
->data
.scalar
.value
= se
.expr
;
2776 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2779 ss_info
->string_length
= se
.string_length
;
2782 case GFC_SS_SECTION
:
2783 /* Add the expressions for scalar and vector subscripts. */
2784 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2785 if (info
->subscript
[n
])
2786 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2788 set_vector_loop_bounds (ss
);
2792 /* Get the vector's descriptor and store it in SS. */
2793 gfc_init_se (&se
, NULL
);
2794 gfc_conv_expr_descriptor (&se
, expr
);
2795 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2796 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2797 info
->descriptor
= se
.expr
;
2800 case GFC_SS_INTRINSIC
:
2801 gfc_add_intrinsic_ss_code (loop
, ss
);
2804 case GFC_SS_FUNCTION
:
2805 /* Array function return value. We call the function and save its
2806 result in a temporary for use inside the loop. */
2807 gfc_init_se (&se
, NULL
);
2810 if (gfc_is_class_array_function (expr
))
2811 expr
->must_finalize
= 1;
2812 gfc_conv_expr (&se
, expr
);
2813 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2814 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2815 ss_info
->string_length
= se
.string_length
;
2818 case GFC_SS_CONSTRUCTOR
:
2819 if (expr
->ts
.type
== BT_CHARACTER
2820 && ss_info
->string_length
== NULL
2822 && expr
->ts
.u
.cl
->length
2823 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2825 gfc_init_se (&se
, NULL
);
2826 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2827 gfc_charlen_type_node
);
2828 ss_info
->string_length
= se
.expr
;
2829 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2830 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2832 trans_array_constructor (ss
, where
);
2836 case GFC_SS_COMPONENT
:
2837 /* Do nothing. These are handled elsewhere. */
2846 for (nested_loop
= loop
->nested
; nested_loop
;
2847 nested_loop
= nested_loop
->next
)
2848 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2852 /* Translate expressions for the descriptor and data pointer of a SS. */
2856 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2859 gfc_ss_info
*ss_info
;
2860 gfc_array_info
*info
;
2864 info
= &ss_info
->data
.array
;
2866 /* Get the descriptor for the array to be scalarized. */
2867 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2868 gfc_init_se (&se
, NULL
);
2869 se
.descriptor_only
= 1;
2870 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2871 gfc_add_block_to_block (block
, &se
.pre
);
2872 info
->descriptor
= se
.expr
;
2873 ss_info
->string_length
= se
.string_length
;
2877 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2878 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2880 /* Emit a DECL_EXPR for the variable sized array type in
2881 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2882 sizes works correctly. */
2883 tree arraytype
= TREE_TYPE (
2884 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2885 if (! TYPE_NAME (arraytype
))
2886 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2887 NULL_TREE
, arraytype
);
2888 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2889 TYPE_NAME (arraytype
)));
2891 /* Also the data pointer. */
2892 tmp
= gfc_conv_array_data (se
.expr
);
2893 /* If this is a variable or address of a variable we use it directly.
2894 Otherwise we must evaluate it now to avoid breaking dependency
2895 analysis by pulling the expressions for elemental array indices
2898 || (TREE_CODE (tmp
) == ADDR_EXPR
2899 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2900 tmp
= gfc_evaluate_now (tmp
, block
);
2903 tmp
= gfc_conv_array_offset (se
.expr
);
2904 info
->offset
= gfc_evaluate_now (tmp
, block
);
2906 /* Make absolutely sure that the saved_offset is indeed saved
2907 so that the variable is still accessible after the loops
2909 info
->saved_offset
= info
->offset
;
2914 /* Initialize a gfc_loopinfo structure. */
2917 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2921 memset (loop
, 0, sizeof (gfc_loopinfo
));
2922 gfc_init_block (&loop
->pre
);
2923 gfc_init_block (&loop
->post
);
2925 /* Initially scalarize in order and default to no loop reversal. */
2926 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2929 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2932 loop
->ss
= gfc_ss_terminator
;
2936 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2940 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2946 /* Return an expression for the data pointer of an array. */
2949 gfc_conv_array_data (tree descriptor
)
2953 type
= TREE_TYPE (descriptor
);
2954 if (GFC_ARRAY_TYPE_P (type
))
2956 if (TREE_CODE (type
) == POINTER_TYPE
)
2960 /* Descriptorless arrays. */
2961 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2965 return gfc_conv_descriptor_data_get (descriptor
);
2969 /* Return an expression for the base offset of an array. */
2972 gfc_conv_array_offset (tree descriptor
)
2976 type
= TREE_TYPE (descriptor
);
2977 if (GFC_ARRAY_TYPE_P (type
))
2978 return GFC_TYPE_ARRAY_OFFSET (type
);
2980 return gfc_conv_descriptor_offset_get (descriptor
);
2984 /* Get an expression for the array stride. */
2987 gfc_conv_array_stride (tree descriptor
, int dim
)
2992 type
= TREE_TYPE (descriptor
);
2994 /* For descriptorless arrays use the array size. */
2995 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2996 if (tmp
!= NULL_TREE
)
2999 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
3004 /* Like gfc_conv_array_stride, but for the lower bound. */
3007 gfc_conv_array_lbound (tree descriptor
, int dim
)
3012 type
= TREE_TYPE (descriptor
);
3014 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3015 if (tmp
!= NULL_TREE
)
3018 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3023 /* Like gfc_conv_array_stride, but for the upper bound. */
3026 gfc_conv_array_ubound (tree descriptor
, int dim
)
3031 type
= TREE_TYPE (descriptor
);
3033 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3034 if (tmp
!= NULL_TREE
)
3037 /* This should only ever happen when passing an assumed shape array
3038 as an actual parameter. The value will never be used. */
3039 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3040 return gfc_index_zero_node
;
3042 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3047 /* Generate code to perform an array index bound check. */
3050 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3051 locus
* where
, bool check_upper
)
3054 tree tmp_lo
, tmp_up
;
3057 const char * name
= NULL
;
3059 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3062 descriptor
= ss
->info
->data
.array
.descriptor
;
3064 index
= gfc_evaluate_now (index
, &se
->pre
);
3066 /* We find a name for the error message. */
3067 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3068 gcc_assert (name
!= NULL
);
3070 if (VAR_P (descriptor
))
3071 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3073 /* If upper bound is present, include both bounds in the error message. */
3076 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3077 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3080 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3081 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3083 msg
= xasprintf ("Index '%%ld' of dimension %d "
3084 "outside of expected range (%%ld:%%ld)", n
+1);
3086 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3088 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3089 fold_convert (long_integer_type_node
, index
),
3090 fold_convert (long_integer_type_node
, tmp_lo
),
3091 fold_convert (long_integer_type_node
, tmp_up
));
3092 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3094 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3095 fold_convert (long_integer_type_node
, index
),
3096 fold_convert (long_integer_type_node
, tmp_lo
),
3097 fold_convert (long_integer_type_node
, tmp_up
));
3102 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3105 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3106 "below lower bound of %%ld", n
+1, name
);
3108 msg
= xasprintf ("Index '%%ld' of dimension %d "
3109 "below lower bound of %%ld", n
+1);
3111 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3113 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3114 fold_convert (long_integer_type_node
, index
),
3115 fold_convert (long_integer_type_node
, tmp_lo
));
3123 /* Return the offset for an index. Performs bound checking for elemental
3124 dimensions. Single element references are processed separately.
3125 DIM is the array dimension, I is the loop dimension. */
3128 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3129 gfc_array_ref
* ar
, tree stride
)
3131 gfc_array_info
*info
;
3136 info
= &ss
->info
->data
.array
;
3138 /* Get the index into the array for this dimension. */
3141 gcc_assert (ar
->type
!= AR_ELEMENT
);
3142 switch (ar
->dimen_type
[dim
])
3144 case DIMEN_THIS_IMAGE
:
3148 /* Elemental dimension. */
3149 gcc_assert (info
->subscript
[dim
]
3150 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3151 /* We've already translated this value outside the loop. */
3152 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3154 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3155 ar
->as
->type
!= AS_ASSUMED_SIZE
3156 || dim
< ar
->dimen
- 1);
3160 gcc_assert (info
&& se
->loop
);
3161 gcc_assert (info
->subscript
[dim
]
3162 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3163 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3165 /* Get a zero-based index into the vector. */
3166 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3167 gfc_array_index_type
,
3168 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3170 /* Multiply the index by the stride. */
3171 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3172 gfc_array_index_type
,
3173 index
, gfc_conv_array_stride (desc
, 0));
3175 /* Read the vector to get an index into info->descriptor. */
3176 data
= build_fold_indirect_ref_loc (input_location
,
3177 gfc_conv_array_data (desc
));
3178 index
= gfc_build_array_ref (data
, index
, NULL
);
3179 index
= gfc_evaluate_now (index
, &se
->pre
);
3180 index
= fold_convert (gfc_array_index_type
, index
);
3182 /* Do any bounds checking on the final info->descriptor index. */
3183 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3184 ar
->as
->type
!= AS_ASSUMED_SIZE
3185 || dim
< ar
->dimen
- 1);
3189 /* Scalarized dimension. */
3190 gcc_assert (info
&& se
->loop
);
3192 /* Multiply the loop variable by the stride and delta. */
3193 index
= se
->loop
->loopvar
[i
];
3194 if (!integer_onep (info
->stride
[dim
]))
3195 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3196 gfc_array_index_type
, index
,
3198 if (!integer_zerop (info
->delta
[dim
]))
3199 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3200 gfc_array_index_type
, index
,
3210 /* Temporary array or derived type component. */
3211 gcc_assert (se
->loop
);
3212 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3214 /* Pointer functions can have stride[0] different from unity.
3215 Use the stride returned by the function call and stored in
3216 the descriptor for the temporary. */
3217 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3218 && se
->ss
->info
->expr
3219 && se
->ss
->info
->expr
->symtree
3220 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3221 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3222 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3225 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3226 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3227 gfc_array_index_type
, index
, info
->delta
[dim
]);
3230 /* Multiply by the stride. */
3231 if (stride
!= NULL
&& !integer_onep (stride
))
3232 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3239 /* Build a scalarized array reference using the vptr 'size'. */
3242 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3247 tree decl
= NULL_TREE
;
3249 gfc_expr
*expr
= se
->ss
->info
->expr
;
3251 gfc_ref
*class_ref
= NULL
;
3254 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3255 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3256 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3261 || (expr
->ts
.type
!= BT_CLASS
3262 && !gfc_is_class_array_function (expr
)
3263 && !gfc_is_class_array_ref (expr
, NULL
)))
3266 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3267 ts
= &expr
->symtree
->n
.sym
->ts
;
3271 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3273 if (ref
->type
== REF_COMPONENT
3274 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3275 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3276 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3278 && ref
->next
->next
->type
== REF_ARRAY
3279 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3281 ts
= &ref
->u
.c
.component
->ts
;
3291 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3292 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3293 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3295 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3297 else if (expr
&& gfc_is_class_array_function (expr
))
3301 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3304 type
= TREE_TYPE (tmp
);
3307 if (GFC_CLASS_TYPE_P (type
))
3309 if (type
!= TYPE_CANONICAL (type
))
3310 type
= TYPE_CANONICAL (type
);
3318 if (decl
== NULL_TREE
)
3321 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3323 else if (class_ref
== NULL
)
3325 if (decl
== NULL_TREE
)
3326 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3327 /* For class arrays the tree containing the class is stored in
3328 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3329 For all others it's sym's backend_decl directly. */
3330 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3331 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3335 /* Remove everything after the last class reference, convert the
3336 expression and then recover its tailend once more. */
3338 ref
= class_ref
->next
;
3339 class_ref
->next
= NULL
;
3340 gfc_init_se (&tmpse
, NULL
);
3341 gfc_conv_expr (&tmpse
, expr
);
3342 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3344 class_ref
->next
= ref
;
3347 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3348 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3350 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3353 size
= gfc_class_vtab_size_get (decl
);
3355 /* For unlimited polymorphic entities then _len component needs to be
3356 multiplied with the size. If no _len component is present, then
3357 gfc_class_len_or_zero_get () return a zero_node. */
3358 tmp
= gfc_class_len_or_zero_get (decl
);
3359 if (!integer_zerop (tmp
))
3360 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3361 fold_convert (TREE_TYPE (index
), size
),
3362 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3363 fold_convert (TREE_TYPE (index
), tmp
),
3364 fold_convert (TREE_TYPE (index
),
3365 integer_one_node
)));
3367 size
= fold_convert (TREE_TYPE (index
), size
);
3369 /* Build the address of the element. */
3370 type
= TREE_TYPE (TREE_TYPE (base
));
3371 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3372 gfc_array_index_type
,
3374 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3375 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3376 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3378 /* Return the element in the se expression. */
3379 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3384 /* Build a scalarized reference to an array. */
3387 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3389 gfc_array_info
*info
;
3390 tree decl
= NULL_TREE
;
3398 expr
= ss
->info
->expr
;
3399 info
= &ss
->info
->data
.array
;
3401 n
= se
->loop
->order
[0];
3405 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3406 /* Add the offset for this dimension to the stored offset for all other
3408 if (info
->offset
&& !integer_zerop (info
->offset
))
3409 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3410 index
, info
->offset
);
3412 base
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3414 /* Use the vptr 'size' field to access the element of a class array. */
3415 if (build_class_array_ref (se
, base
, index
))
3418 if (expr
&& ((is_subref_array (expr
)
3419 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
)))
3420 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3421 || expr
->expr_type
== EXPR_FUNCTION
))))
3422 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3424 /* A pointer array component can be detected from its field decl. Fix
3425 the descriptor, mark the resulting variable decl and pass it to
3426 gfc_build_array_ref. */
3427 if (is_pointer_array (info
->descriptor
)
3428 || (expr
&& expr
->ts
.deferred
&& info
->descriptor
3429 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
))))
3431 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3432 decl
= info
->descriptor
;
3433 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3434 decl
= TREE_OPERAND (info
->descriptor
, 0);
3436 if (decl
== NULL_TREE
)
3437 decl
= info
->descriptor
;
3440 se
->expr
= gfc_build_array_ref (base
, index
, decl
);
3444 /* Translate access of temporary array. */
3447 gfc_conv_tmp_array_ref (gfc_se
* se
)
3449 se
->string_length
= se
->ss
->info
->string_length
;
3450 gfc_conv_scalarized_array_ref (se
, NULL
);
3451 gfc_advance_se_ss_chain (se
);
3454 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3457 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3459 if (TREE_CODE (t
) == INTEGER_CST
)
3460 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3463 if (!integer_zerop (*offset
))
3464 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3465 gfc_array_index_type
, *offset
, t
);
3473 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3479 /* For class arrays the class declaration is stored in the saved
3481 if (INDIRECT_REF_P (desc
)
3482 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3483 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3484 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3485 TREE_OPERAND (desc
, 0)));
3489 /* Class container types do not always have the GFC_CLASS_TYPE_P
3490 but the canonical type does. */
3491 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3492 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3494 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3495 if (TYPE_CANONICAL (type
)
3496 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3497 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3500 tmp
= gfc_conv_array_data (desc
);
3501 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3502 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3507 /* Build an array reference. se->expr already holds the array descriptor.
3508 This should be either a variable, indirect variable reference or component
3509 reference. For arrays which do not have a descriptor, se->expr will be
3511 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3514 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3518 tree offset
, cst_offset
;
3521 tree decl
= NULL_TREE
;
3524 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3525 char *var_name
= NULL
;
3529 gcc_assert (ar
->codimen
);
3531 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3532 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3535 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3536 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3537 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3539 /* Use the actual tree type and not the wrapped coarray. */
3540 if (!se
->want_pointer
)
3541 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3548 /* Handle scalarized references separately. */
3549 if (ar
->type
!= AR_ELEMENT
)
3551 gfc_conv_scalarized_array_ref (se
, ar
);
3552 gfc_advance_se_ss_chain (se
);
3556 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3561 len
= strlen (sym
->name
) + 1;
3562 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3564 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3566 if (ref
->type
== REF_COMPONENT
)
3567 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3570 var_name
= XALLOCAVEC (char, len
);
3571 strcpy (var_name
, sym
->name
);
3573 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3575 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3577 if (ref
->type
== REF_COMPONENT
)
3579 strcat (var_name
, "%%");
3580 strcat (var_name
, ref
->u
.c
.component
->name
);
3585 cst_offset
= offset
= gfc_index_zero_node
;
3586 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3588 /* Calculate the offsets from all the dimensions. Make sure to associate
3589 the final offset so that we form a chain of loop invariant summands. */
3590 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3592 /* Calculate the index for this dimension. */
3593 gfc_init_se (&indexse
, se
);
3594 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3595 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3597 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && ! expr
->no_bounds_check
)
3599 /* Check array bounds. */
3603 /* Evaluate the indexse.expr only once. */
3604 indexse
.expr
= save_expr (indexse
.expr
);
3607 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3608 if (sym
->attr
.temporary
)
3610 gfc_init_se (&tmpse
, se
);
3611 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3612 gfc_array_index_type
);
3613 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3617 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3619 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3620 "below lower bound of %%ld", n
+1, var_name
);
3621 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3622 fold_convert (long_integer_type_node
,
3624 fold_convert (long_integer_type_node
, tmp
));
3627 /* Upper bound, but not for the last dimension of assumed-size
3629 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3631 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3632 if (sym
->attr
.temporary
)
3634 gfc_init_se (&tmpse
, se
);
3635 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3636 gfc_array_index_type
);
3637 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3641 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3642 logical_type_node
, indexse
.expr
, tmp
);
3643 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3644 "above upper bound of %%ld", n
+1, var_name
);
3645 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3646 fold_convert (long_integer_type_node
,
3648 fold_convert (long_integer_type_node
, tmp
));
3653 /* Multiply the index by the stride. */
3654 stride
= gfc_conv_array_stride (se
->expr
, n
);
3655 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3656 indexse
.expr
, stride
);
3658 /* And add it to the total. */
3659 add_to_offset (&cst_offset
, &offset
, tmp
);
3662 if (!integer_zerop (cst_offset
))
3663 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3664 gfc_array_index_type
, offset
, cst_offset
);
3666 /* A pointer array component can be detected from its field decl. Fix
3667 the descriptor, mark the resulting variable decl and pass it to
3669 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3670 && is_pointer_array (se
->expr
))
3672 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3674 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3675 decl
= TREE_OPERAND (se
->expr
, 0);
3679 else if (expr
->ts
.deferred
3680 || (sym
->ts
.type
== BT_CHARACTER
3681 && sym
->attr
.select_type_temporary
))
3683 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3686 if (TREE_CODE (decl
) == INDIRECT_REF
)
3687 decl
= TREE_OPERAND (decl
, 0);
3690 decl
= sym
->backend_decl
;
3692 else if (sym
->ts
.type
== BT_CLASS
)
3695 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3699 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3700 LOOP_DIM dimension (if any) to array's offset. */
3703 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3704 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3707 gfc_array_info
*info
;
3710 info
= &ss
->info
->data
.array
;
3712 gfc_init_se (&se
, NULL
);
3714 se
.expr
= info
->descriptor
;
3715 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3716 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3717 gfc_add_block_to_block (pblock
, &se
.pre
);
3719 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3720 gfc_array_index_type
,
3721 info
->offset
, index
);
3722 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3726 /* Generate the code to be executed immediately before entering a
3727 scalarization loop. */
3730 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3731 stmtblock_t
* pblock
)
3734 gfc_ss_info
*ss_info
;
3735 gfc_array_info
*info
;
3736 gfc_ss_type ss_type
;
3738 gfc_loopinfo
*ploop
;
3742 /* This code will be executed before entering the scalarization loop
3743 for this dimension. */
3744 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3748 if ((ss_info
->useflags
& flag
) == 0)
3751 ss_type
= ss_info
->type
;
3752 if (ss_type
!= GFC_SS_SECTION
3753 && ss_type
!= GFC_SS_FUNCTION
3754 && ss_type
!= GFC_SS_CONSTRUCTOR
3755 && ss_type
!= GFC_SS_COMPONENT
)
3758 info
= &ss_info
->data
.array
;
3760 gcc_assert (dim
< ss
->dimen
);
3761 gcc_assert (ss
->dimen
== loop
->dimen
);
3764 ar
= &info
->ref
->u
.ar
;
3768 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3770 /* If we are in the outermost dimension of this loop, the previous
3771 dimension shall be in the parent loop. */
3772 gcc_assert (ss
->parent
!= NULL
);
3775 ploop
= loop
->parent
;
3777 /* ss and ss->parent are about the same array. */
3778 gcc_assert (ss_info
== pss
->info
);
3786 if (dim
== loop
->dimen
- 1)
3791 /* For the time being, there is no loop reordering. */
3792 gcc_assert (i
== ploop
->order
[i
]);
3793 i
= ploop
->order
[i
];
3795 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3797 stride
= gfc_conv_array_stride (info
->descriptor
,
3798 innermost_ss (ss
)->dim
[i
]);
3800 /* Calculate the stride of the innermost loop. Hopefully this will
3801 allow the backend optimizers to do their stuff more effectively.
3803 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3805 /* For the outermost loop calculate the offset due to any
3806 elemental dimensions. It will have been initialized with the
3807 base offset of the array. */
3810 for (i
= 0; i
< ar
->dimen
; i
++)
3812 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3815 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3820 /* Add the offset for the previous loop dimension. */
3821 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3823 /* Remember this offset for the second loop. */
3824 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3825 info
->saved_offset
= info
->offset
;
3830 /* Start a scalarized expression. Creates a scope and declares loop
3834 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3840 gcc_assert (!loop
->array_parameter
);
3842 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3844 n
= loop
->order
[dim
];
3846 gfc_start_block (&loop
->code
[n
]);
3848 /* Create the loop variable. */
3849 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3851 if (dim
< loop
->temp_dim
)
3855 /* Calculate values that will be constant within this loop. */
3856 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3858 gfc_start_block (pbody
);
3862 /* Generates the actual loop code for a scalarization loop. */
3865 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3866 stmtblock_t
* pbody
)
3877 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3878 | OMPWS_SCALARIZER_BODY
))
3879 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3880 && n
== loop
->dimen
- 1)
3882 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3883 init
= make_tree_vec (1);
3884 cond
= make_tree_vec (1);
3885 incr
= make_tree_vec (1);
3887 /* Cycle statement is implemented with a goto. Exit statement must not
3888 be present for this loop. */
3889 exit_label
= gfc_build_label_decl (NULL_TREE
);
3890 TREE_USED (exit_label
) = 1;
3892 /* Label for cycle statements (if needed). */
3893 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3894 gfc_add_expr_to_block (pbody
, tmp
);
3896 stmt
= make_node (OMP_FOR
);
3898 TREE_TYPE (stmt
) = void_type_node
;
3899 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3901 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3902 OMP_CLAUSE_SCHEDULE
);
3903 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3904 = OMP_CLAUSE_SCHEDULE_STATIC
;
3905 if (ompws_flags
& OMPWS_NOWAIT
)
3906 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3907 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3909 /* Initialize the loopvar. */
3910 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3912 OMP_FOR_INIT (stmt
) = init
;
3913 /* The exit condition. */
3914 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3916 loop
->loopvar
[n
], loop
->to
[n
]);
3917 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3918 OMP_FOR_COND (stmt
) = cond
;
3919 /* Increment the loopvar. */
3920 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3921 loop
->loopvar
[n
], gfc_index_one_node
);
3922 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3923 void_type_node
, loop
->loopvar
[n
], tmp
);
3924 OMP_FOR_INCR (stmt
) = incr
;
3926 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3927 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3931 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3932 && (loop
->temp_ss
== NULL
);
3934 loopbody
= gfc_finish_block (pbody
);
3937 std::swap (loop
->from
[n
], loop
->to
[n
]);
3939 /* Initialize the loopvar. */
3940 if (loop
->loopvar
[n
] != loop
->from
[n
])
3941 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3943 exit_label
= gfc_build_label_decl (NULL_TREE
);
3945 /* Generate the loop body. */
3946 gfc_init_block (&block
);
3948 /* The exit condition. */
3949 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3950 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3951 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3952 TREE_USED (exit_label
) = 1;
3953 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3954 gfc_add_expr_to_block (&block
, tmp
);
3956 /* The main body. */
3957 gfc_add_expr_to_block (&block
, loopbody
);
3959 /* Increment the loopvar. */
3960 tmp
= fold_build2_loc (input_location
,
3961 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3962 gfc_array_index_type
, loop
->loopvar
[n
],
3963 gfc_index_one_node
);
3965 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3967 /* Build the loop. */
3968 tmp
= gfc_finish_block (&block
);
3969 tmp
= build1_v (LOOP_EXPR
, tmp
);
3970 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3972 /* Add the exit label. */
3973 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3974 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3980 /* Finishes and generates the loops for a scalarized expression. */
3983 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3988 stmtblock_t
*pblock
;
3992 /* Generate the loops. */
3993 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3995 n
= loop
->order
[dim
];
3996 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3997 loop
->loopvar
[n
] = NULL_TREE
;
3998 pblock
= &loop
->code
[n
];
4001 tmp
= gfc_finish_block (pblock
);
4002 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4004 /* Clear all the used flags. */
4005 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4006 if (ss
->parent
== NULL
)
4007 ss
->info
->useflags
= 0;
4011 /* Finish the main body of a scalarized expression, and start the secondary
4015 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4019 stmtblock_t
*pblock
;
4023 /* We finish as many loops as are used by the temporary. */
4024 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4026 n
= loop
->order
[dim
];
4027 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4028 loop
->loopvar
[n
] = NULL_TREE
;
4029 pblock
= &loop
->code
[n
];
4032 /* We don't want to finish the outermost loop entirely. */
4033 n
= loop
->order
[loop
->temp_dim
- 1];
4034 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4036 /* Restore the initial offsets. */
4037 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4039 gfc_ss_type ss_type
;
4040 gfc_ss_info
*ss_info
;
4044 if ((ss_info
->useflags
& 2) == 0)
4047 ss_type
= ss_info
->type
;
4048 if (ss_type
!= GFC_SS_SECTION
4049 && ss_type
!= GFC_SS_FUNCTION
4050 && ss_type
!= GFC_SS_CONSTRUCTOR
4051 && ss_type
!= GFC_SS_COMPONENT
)
4054 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4057 /* Restart all the inner loops we just finished. */
4058 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4060 n
= loop
->order
[dim
];
4062 gfc_start_block (&loop
->code
[n
]);
4064 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4066 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4069 /* Start a block for the secondary copying code. */
4070 gfc_start_block (body
);
4074 /* Precalculate (either lower or upper) bound of an array section.
4075 BLOCK: Block in which the (pre)calculation code will go.
4076 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4077 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4078 DESC: Array descriptor from which the bound will be picked if unspecified
4079 (either lower or upper bound according to LBOUND). */
4082 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4083 tree desc
, int dim
, bool lbound
, bool deferred
)
4086 gfc_expr
* input_val
= values
[dim
];
4087 tree
*output
= &bounds
[dim
];
4092 /* Specified section bound. */
4093 gfc_init_se (&se
, NULL
);
4094 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4095 gfc_add_block_to_block (block
, &se
.pre
);
4098 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4100 /* The gfc_conv_array_lbound () routine returns a constant zero for
4101 deferred length arrays, which in the scalarizer wreaks havoc, when
4102 copying to a (newly allocated) one-based array.
4103 Keep returning the actual result in sync for both bounds. */
4104 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4106 gfc_conv_descriptor_ubound_get (desc
,
4111 /* No specific bound specified so use the bound of the array. */
4112 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4113 gfc_conv_array_ubound (desc
, dim
);
4115 *output
= gfc_evaluate_now (*output
, block
);
4119 /* Calculate the lower bound of an array section. */
4122 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4124 gfc_expr
*stride
= NULL
;
4127 gfc_array_info
*info
;
4130 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4132 info
= &ss
->info
->data
.array
;
4133 ar
= &info
->ref
->u
.ar
;
4135 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4137 /* We use a zero-based index to access the vector. */
4138 info
->start
[dim
] = gfc_index_zero_node
;
4139 info
->end
[dim
] = NULL
;
4140 info
->stride
[dim
] = gfc_index_one_node
;
4144 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4145 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4146 desc
= info
->descriptor
;
4147 stride
= ar
->stride
[dim
];
4150 /* Calculate the start of the range. For vector subscripts this will
4151 be the range of the vector. */
4152 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4153 ar
->as
->type
== AS_DEFERRED
);
4155 /* Similarly calculate the end. Although this is not used in the
4156 scalarizer, it is needed when checking bounds and where the end
4157 is an expression with side-effects. */
4158 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4159 ar
->as
->type
== AS_DEFERRED
);
4162 /* Calculate the stride. */
4164 info
->stride
[dim
] = gfc_index_one_node
;
4167 gfc_init_se (&se
, NULL
);
4168 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4169 gfc_add_block_to_block (block
, &se
.pre
);
4170 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4175 /* Calculates the range start and stride for a SS chain. Also gets the
4176 descriptor and data pointer. The range of vector subscripts is the size
4177 of the vector. Array bounds are also checked. */
4180 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4187 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4190 /* Determine the rank of the loop. */
4191 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4193 switch (ss
->info
->type
)
4195 case GFC_SS_SECTION
:
4196 case GFC_SS_CONSTRUCTOR
:
4197 case GFC_SS_FUNCTION
:
4198 case GFC_SS_COMPONENT
:
4199 loop
->dimen
= ss
->dimen
;
4202 /* As usual, lbound and ubound are exceptions!. */
4203 case GFC_SS_INTRINSIC
:
4204 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4206 case GFC_ISYM_LBOUND
:
4207 case GFC_ISYM_UBOUND
:
4208 case GFC_ISYM_LCOBOUND
:
4209 case GFC_ISYM_UCOBOUND
:
4210 case GFC_ISYM_THIS_IMAGE
:
4211 loop
->dimen
= ss
->dimen
;
4223 /* We should have determined the rank of the expression by now. If
4224 not, that's bad news. */
4228 /* Loop over all the SS in the chain. */
4229 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4231 gfc_ss_info
*ss_info
;
4232 gfc_array_info
*info
;
4236 expr
= ss_info
->expr
;
4237 info
= &ss_info
->data
.array
;
4239 if (expr
&& expr
->shape
&& !info
->shape
)
4240 info
->shape
= expr
->shape
;
4242 switch (ss_info
->type
)
4244 case GFC_SS_SECTION
:
4245 /* Get the descriptor for the array. If it is a cross loops array,
4246 we got the descriptor already in the outermost loop. */
4247 if (ss
->parent
== NULL
)
4248 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4249 !loop
->array_parameter
);
4251 for (n
= 0; n
< ss
->dimen
; n
++)
4252 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4255 case GFC_SS_INTRINSIC
:
4256 switch (expr
->value
.function
.isym
->id
)
4258 /* Fall through to supply start and stride. */
4259 case GFC_ISYM_LBOUND
:
4260 case GFC_ISYM_UBOUND
:
4264 /* This is the variant without DIM=... */
4265 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4267 arg
= expr
->value
.function
.actual
->expr
;
4268 if (arg
->rank
== -1)
4273 /* The rank (hence the return value's shape) is unknown,
4274 we have to retrieve it. */
4275 gfc_init_se (&se
, NULL
);
4276 se
.descriptor_only
= 1;
4277 gfc_conv_expr (&se
, arg
);
4278 /* This is a bare variable, so there is no preliminary
4280 gcc_assert (se
.pre
.head
== NULL_TREE
4281 && se
.post
.head
== NULL_TREE
);
4282 rank
= gfc_conv_descriptor_rank (se
.expr
);
4283 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4284 gfc_array_index_type
,
4285 fold_convert (gfc_array_index_type
,
4287 gfc_index_one_node
);
4288 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4289 info
->start
[0] = gfc_index_zero_node
;
4290 info
->stride
[0] = gfc_index_one_node
;
4293 /* Otherwise fall through GFC_SS_FUNCTION. */
4296 case GFC_ISYM_LCOBOUND
:
4297 case GFC_ISYM_UCOBOUND
:
4298 case GFC_ISYM_THIS_IMAGE
:
4306 case GFC_SS_CONSTRUCTOR
:
4307 case GFC_SS_FUNCTION
:
4308 for (n
= 0; n
< ss
->dimen
; n
++)
4310 int dim
= ss
->dim
[n
];
4312 info
->start
[dim
] = gfc_index_zero_node
;
4313 info
->end
[dim
] = gfc_index_zero_node
;
4314 info
->stride
[dim
] = gfc_index_one_node
;
4323 /* The rest is just runtime bounds checking. */
4324 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4327 tree lbound
, ubound
;
4329 tree size
[GFC_MAX_DIMENSIONS
];
4330 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4331 gfc_array_info
*info
;
4335 gfc_start_block (&block
);
4337 for (n
= 0; n
< loop
->dimen
; n
++)
4338 size
[n
] = NULL_TREE
;
4340 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4343 gfc_ss_info
*ss_info
;
4346 const char *expr_name
;
4349 if (ss_info
->type
!= GFC_SS_SECTION
)
4352 /* Catch allocatable lhs in f2003. */
4353 if (flag_realloc_lhs
&& ss
->no_bounds_check
)
4356 expr
= ss_info
->expr
;
4357 expr_loc
= &expr
->where
;
4358 expr_name
= expr
->symtree
->name
;
4360 gfc_start_block (&inner
);
4362 /* TODO: range checking for mapped dimensions. */
4363 info
= &ss_info
->data
.array
;
4365 /* This code only checks ranges. Elemental and vector
4366 dimensions are checked later. */
4367 for (n
= 0; n
< loop
->dimen
; n
++)
4372 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4375 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4376 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4377 check_upper
= false;
4381 /* Zero stride is not allowed. */
4382 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4383 info
->stride
[dim
], gfc_index_zero_node
);
4384 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4385 "of array '%s'", dim
+ 1, expr_name
);
4386 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4390 desc
= info
->descriptor
;
4392 /* This is the run-time equivalent of resolve.c's
4393 check_dimension(). The logical is more readable there
4394 than it is here, with all the trees. */
4395 lbound
= gfc_conv_array_lbound (desc
, dim
);
4396 end
= info
->end
[dim
];
4398 ubound
= gfc_conv_array_ubound (desc
, dim
);
4402 /* non_zerosized is true when the selected range is not
4404 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4405 logical_type_node
, info
->stride
[dim
],
4406 gfc_index_zero_node
);
4407 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4408 info
->start
[dim
], end
);
4409 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4410 logical_type_node
, stride_pos
, tmp
);
4412 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4414 info
->stride
[dim
], gfc_index_zero_node
);
4415 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4416 info
->start
[dim
], end
);
4417 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4420 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4422 stride_pos
, stride_neg
);
4424 /* Check the start of the range against the lower and upper
4425 bounds of the array, if the range is not empty.
4426 If upper bound is present, include both bounds in the
4430 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4432 info
->start
[dim
], lbound
);
4433 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4435 non_zerosized
, tmp
);
4436 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4438 info
->start
[dim
], ubound
);
4439 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4441 non_zerosized
, tmp2
);
4442 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4443 "outside of expected range (%%ld:%%ld)",
4444 dim
+ 1, expr_name
);
4445 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4447 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4448 fold_convert (long_integer_type_node
, lbound
),
4449 fold_convert (long_integer_type_node
, ubound
));
4450 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4452 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4453 fold_convert (long_integer_type_node
, lbound
),
4454 fold_convert (long_integer_type_node
, ubound
));
4459 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4461 info
->start
[dim
], lbound
);
4462 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4463 logical_type_node
, non_zerosized
, tmp
);
4464 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4465 "below lower bound of %%ld",
4466 dim
+ 1, expr_name
);
4467 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4469 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4470 fold_convert (long_integer_type_node
, lbound
));
4474 /* Compute the last element of the range, which is not
4475 necessarily "end" (think 0:5:3, which doesn't contain 5)
4476 and check it against both lower and upper bounds. */
4478 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4479 gfc_array_index_type
, end
,
4481 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4482 gfc_array_index_type
, tmp
,
4484 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4485 gfc_array_index_type
, end
, tmp
);
4486 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4487 logical_type_node
, tmp
, lbound
);
4488 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4489 logical_type_node
, non_zerosized
, tmp2
);
4492 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4493 logical_type_node
, tmp
, ubound
);
4494 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4495 logical_type_node
, non_zerosized
, tmp3
);
4496 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4497 "outside of expected range (%%ld:%%ld)",
4498 dim
+ 1, expr_name
);
4499 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4501 fold_convert (long_integer_type_node
, tmp
),
4502 fold_convert (long_integer_type_node
, ubound
),
4503 fold_convert (long_integer_type_node
, lbound
));
4504 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4506 fold_convert (long_integer_type_node
, tmp
),
4507 fold_convert (long_integer_type_node
, ubound
),
4508 fold_convert (long_integer_type_node
, lbound
));
4513 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4514 "below lower bound of %%ld",
4515 dim
+ 1, expr_name
);
4516 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4518 fold_convert (long_integer_type_node
, tmp
),
4519 fold_convert (long_integer_type_node
, lbound
));
4523 /* Check the section sizes match. */
4524 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4525 gfc_array_index_type
, end
,
4527 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4528 gfc_array_index_type
, tmp
,
4530 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4531 gfc_array_index_type
,
4532 gfc_index_one_node
, tmp
);
4533 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4534 gfc_array_index_type
, tmp
,
4535 build_int_cst (gfc_array_index_type
, 0));
4536 /* We remember the size of the first section, and check all the
4537 others against this. */
4540 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4541 logical_type_node
, tmp
, size
[n
]);
4542 msg
= xasprintf ("Array bound mismatch for dimension %d "
4543 "of array '%s' (%%ld/%%ld)",
4544 dim
+ 1, expr_name
);
4546 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4548 fold_convert (long_integer_type_node
, tmp
),
4549 fold_convert (long_integer_type_node
, size
[n
]));
4554 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4557 tmp
= gfc_finish_block (&inner
);
4559 /* For optional arguments, only check bounds if the argument is
4561 if (expr
->symtree
->n
.sym
->attr
.optional
4562 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4563 tmp
= build3_v (COND_EXPR
,
4564 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4565 tmp
, build_empty_stmt (input_location
));
4567 gfc_add_expr_to_block (&block
, tmp
);
4571 tmp
= gfc_finish_block (&block
);
4572 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4575 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4576 gfc_conv_ss_startstride (loop
);
4579 /* Return true if both symbols could refer to the same data object. Does
4580 not take account of aliasing due to equivalence statements. */
4583 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4584 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4586 /* Aliasing isn't possible if the symbols have different base types. */
4587 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4590 /* Pointers can point to other pointers and target objects. */
4592 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4593 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4596 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4597 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4599 if (lsym_target
&& rsym_target
4600 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4601 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4602 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4603 && (!rsym
->attr
.dimension
4604 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4611 /* Return true if the two SS could be aliased, i.e. both point to the same data
4613 /* TODO: resolve aliases based on frontend expressions. */
4616 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4620 gfc_expr
*lexpr
, *rexpr
;
4623 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4625 lexpr
= lss
->info
->expr
;
4626 rexpr
= rss
->info
->expr
;
4628 lsym
= lexpr
->symtree
->n
.sym
;
4629 rsym
= rexpr
->symtree
->n
.sym
;
4631 lsym_pointer
= lsym
->attr
.pointer
;
4632 lsym_target
= lsym
->attr
.target
;
4633 rsym_pointer
= rsym
->attr
.pointer
;
4634 rsym_target
= rsym
->attr
.target
;
4636 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4637 rsym_pointer
, rsym_target
))
4640 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4641 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4644 /* For derived types we must check all the component types. We can ignore
4645 array references as these will have the same base type as the previous
4647 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4649 if (lref
->type
!= REF_COMPONENT
)
4652 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4653 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4655 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4656 rsym_pointer
, rsym_target
))
4659 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4660 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4662 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4667 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4670 if (rref
->type
!= REF_COMPONENT
)
4673 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4674 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4676 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4677 lsym_pointer
, lsym_target
,
4678 rsym_pointer
, rsym_target
))
4681 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4682 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4684 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4685 &rref
->u
.c
.sym
->ts
))
4687 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4688 &rref
->u
.c
.component
->ts
))
4690 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4691 &rref
->u
.c
.component
->ts
))
4697 lsym_pointer
= lsym
->attr
.pointer
;
4698 lsym_target
= lsym
->attr
.target
;
4699 lsym_pointer
= lsym
->attr
.pointer
;
4700 lsym_target
= lsym
->attr
.target
;
4702 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4704 if (rref
->type
!= REF_COMPONENT
)
4707 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4708 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4710 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4711 lsym_pointer
, lsym_target
,
4712 rsym_pointer
, rsym_target
))
4715 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4716 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4718 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4727 /* Resolve array data dependencies. Creates a temporary if required. */
4728 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4732 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4738 gfc_ss_info
*ss_info
;
4739 gfc_expr
*dest_expr
;
4744 loop
->temp_ss
= NULL
;
4745 dest_expr
= dest
->info
->expr
;
4747 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4750 ss_expr
= ss_info
->expr
;
4752 if (ss_info
->array_outer_dependency
)
4758 if (ss_info
->type
!= GFC_SS_SECTION
)
4760 if (flag_realloc_lhs
4761 && dest_expr
!= ss_expr
4762 && gfc_is_reallocatable_lhs (dest_expr
)
4764 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4766 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4767 if (!nDepend
&& dest_expr
->rank
> 0
4768 && dest_expr
->ts
.type
== BT_CHARACTER
4769 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4771 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4773 if (ss_info
->type
== GFC_SS_REFERENCE
4774 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4775 ss_info
->data
.scalar
.needs_temporary
= 1;
4783 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4785 if (gfc_could_be_alias (dest
, ss
)
4786 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4794 lref
= dest_expr
->ref
;
4795 rref
= ss_expr
->ref
;
4797 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4802 for (i
= 0; i
< dest
->dimen
; i
++)
4803 for (j
= 0; j
< ss
->dimen
; j
++)
4805 && dest
->dim
[i
] == ss
->dim
[j
])
4807 /* If we don't access array elements in the same order,
4808 there is a dependency. */
4813 /* TODO : loop shifting. */
4816 /* Mark the dimensions for LOOP SHIFTING */
4817 for (n
= 0; n
< loop
->dimen
; n
++)
4819 int dim
= dest
->data
.info
.dim
[n
];
4821 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4823 else if (! gfc_is_same_range (&lref
->u
.ar
,
4824 &rref
->u
.ar
, dim
, 0))
4828 /* Put all the dimensions with dependencies in the
4831 for (n
= 0; n
< loop
->dimen
; n
++)
4833 gcc_assert (loop
->order
[n
] == n
);
4835 loop
->order
[dim
++] = n
;
4837 for (n
= 0; n
< loop
->dimen
; n
++)
4840 loop
->order
[dim
++] = n
;
4843 gcc_assert (dim
== loop
->dimen
);
4854 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4855 if (GFC_ARRAY_TYPE_P (base_type
)
4856 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4857 base_type
= gfc_get_element_type (base_type
);
4858 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4860 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4863 loop
->temp_ss
= NULL
;
4867 /* Browse through each array's information from the scalarizer and set the loop
4868 bounds according to the "best" one (per dimension), i.e. the one which
4869 provides the most information (constant bounds, shape, etc.). */
4872 set_loop_bounds (gfc_loopinfo
*loop
)
4874 int n
, dim
, spec_dim
;
4875 gfc_array_info
*info
;
4876 gfc_array_info
*specinfo
;
4880 bool dynamic
[GFC_MAX_DIMENSIONS
];
4883 bool nonoptional_arr
;
4885 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4887 loopspec
= loop
->specloop
;
4890 for (n
= 0; n
< loop
->dimen
; n
++)
4895 /* If there are both optional and nonoptional array arguments, scalarize
4896 over the nonoptional; otherwise, it does not matter as then all
4897 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4899 nonoptional_arr
= false;
4901 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4902 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4903 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4905 nonoptional_arr
= true;
4909 /* We use one SS term, and use that to determine the bounds of the
4910 loop for this dimension. We try to pick the simplest term. */
4911 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4913 gfc_ss_type ss_type
;
4915 ss_type
= ss
->info
->type
;
4916 if (ss_type
== GFC_SS_SCALAR
4917 || ss_type
== GFC_SS_TEMP
4918 || ss_type
== GFC_SS_REFERENCE
4919 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4922 info
= &ss
->info
->data
.array
;
4925 if (loopspec
[n
] != NULL
)
4927 specinfo
= &loopspec
[n
]->info
->data
.array
;
4928 spec_dim
= loopspec
[n
]->dim
[n
];
4932 /* Silence uninitialized warnings. */
4939 gcc_assert (info
->shape
[dim
]);
4940 /* The frontend has worked out the size for us. */
4943 || !integer_zerop (specinfo
->start
[spec_dim
]))
4944 /* Prefer zero-based descriptors if possible. */
4949 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4951 gfc_constructor_base base
;
4952 /* An unknown size constructor will always be rank one.
4953 Higher rank constructors will either have known shape,
4954 or still be wrapped in a call to reshape. */
4955 gcc_assert (loop
->dimen
== 1);
4957 /* Always prefer to use the constructor bounds if the size
4958 can be determined at compile time. Prefer not to otherwise,
4959 since the general case involves realloc, and it's better to
4960 avoid that overhead if possible. */
4961 base
= ss
->info
->expr
->value
.constructor
;
4962 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4963 if (!dynamic
[n
] || !loopspec
[n
])
4968 /* Avoid using an allocatable lhs in an assignment, since
4969 there might be a reallocation coming. */
4970 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4975 /* Criteria for choosing a loop specifier (most important first):
4976 doesn't need realloc
4982 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4984 else if (integer_onep (info
->stride
[dim
])
4985 && !integer_onep (specinfo
->stride
[spec_dim
]))
4987 else if (INTEGER_CST_P (info
->stride
[dim
])
4988 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4990 else if (INTEGER_CST_P (info
->start
[dim
])
4991 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4992 && integer_onep (info
->stride
[dim
])
4993 == integer_onep (specinfo
->stride
[spec_dim
])
4994 && INTEGER_CST_P (info
->stride
[dim
])
4995 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4997 /* We don't work out the upper bound.
4998 else if (INTEGER_CST_P (info->finish[n])
4999 && ! INTEGER_CST_P (specinfo->finish[n]))
5000 loopspec[n] = ss; */
5003 /* We should have found the scalarization loop specifier. If not,
5005 gcc_assert (loopspec
[n
]);
5007 info
= &loopspec
[n
]->info
->data
.array
;
5008 dim
= loopspec
[n
]->dim
[n
];
5010 /* Set the extents of this range. */
5011 cshape
= info
->shape
;
5012 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
5013 && INTEGER_CST_P (info
->stride
[dim
]))
5015 loop
->from
[n
] = info
->start
[dim
];
5016 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5017 mpz_sub_ui (i
, i
, 1);
5018 /* To = from + (size - 1) * stride. */
5019 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5020 if (!integer_onep (info
->stride
[dim
]))
5021 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5022 gfc_array_index_type
, tmp
,
5024 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5025 gfc_array_index_type
,
5026 loop
->from
[n
], tmp
);
5030 loop
->from
[n
] = info
->start
[dim
];
5031 switch (loopspec
[n
]->info
->type
)
5033 case GFC_SS_CONSTRUCTOR
:
5034 /* The upper bound is calculated when we expand the
5036 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5039 case GFC_SS_SECTION
:
5040 /* Use the end expression if it exists and is not constant,
5041 so that it is only evaluated once. */
5042 loop
->to
[n
] = info
->end
[dim
];
5045 case GFC_SS_FUNCTION
:
5046 /* The loop bound will be set when we generate the call. */
5047 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5050 case GFC_SS_INTRINSIC
:
5052 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5054 /* The {l,u}bound of an assumed rank. */
5055 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5056 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5057 && expr
->value
.function
.actual
->next
->expr
== NULL
5058 && expr
->value
.function
.actual
->expr
->rank
== -1);
5060 loop
->to
[n
] = info
->end
[dim
];
5064 case GFC_SS_COMPONENT
:
5066 if (info
->end
[dim
] != NULL_TREE
)
5068 loop
->to
[n
] = info
->end
[dim
];
5080 /* Transform everything so we have a simple incrementing variable. */
5081 if (integer_onep (info
->stride
[dim
]))
5082 info
->delta
[dim
] = gfc_index_zero_node
;
5085 /* Set the delta for this section. */
5086 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5087 /* Number of iterations is (end - start + step) / step.
5088 with start = 0, this simplifies to
5090 for (i = 0; i<=last; i++){...}; */
5091 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5092 gfc_array_index_type
, loop
->to
[n
],
5094 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5095 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5096 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5097 tmp
, build_int_cst (gfc_array_index_type
, -1));
5098 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5099 /* Make the loop variable start at 0. */
5100 loop
->from
[n
] = gfc_index_zero_node
;
5105 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5106 set_loop_bounds (loop
);
5110 /* Initialize the scalarization loop. Creates the loop variables. Determines
5111 the range of the loop variables. Creates a temporary if required.
5112 Also generates code for scalar expressions which have been
5113 moved outside the loop. */
5116 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5121 set_loop_bounds (loop
);
5123 /* Add all the scalar code that can be taken out of the loops.
5124 This may include calculating the loop bounds, so do it before
5125 allocating the temporary. */
5126 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5128 tmp_ss
= loop
->temp_ss
;
5129 /* If we want a temporary then create it. */
5132 gfc_ss_info
*tmp_ss_info
;
5134 tmp_ss_info
= tmp_ss
->info
;
5135 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5136 gcc_assert (loop
->parent
== NULL
);
5138 /* Make absolutely sure that this is a complete type. */
5139 if (tmp_ss_info
->string_length
)
5140 tmp_ss_info
->data
.temp
.type
5141 = gfc_get_character_type_len_for_eltype
5142 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5143 tmp_ss_info
->string_length
);
5145 tmp
= tmp_ss_info
->data
.temp
.type
;
5146 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5147 tmp_ss_info
->type
= GFC_SS_SECTION
;
5149 gcc_assert (tmp_ss
->dimen
!= 0);
5151 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5152 NULL_TREE
, false, true, false, where
);
5155 /* For array parameters we don't have loop variables, so don't calculate the
5157 if (!loop
->array_parameter
)
5158 gfc_set_delta (loop
);
5162 /* Calculates how to transform from loop variables to array indices for each
5163 array: once loop bounds are chosen, sets the difference (DELTA field) between
5164 loop bounds and array reference bounds, for each array info. */
5167 gfc_set_delta (gfc_loopinfo
*loop
)
5169 gfc_ss
*ss
, **loopspec
;
5170 gfc_array_info
*info
;
5174 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5176 loopspec
= loop
->specloop
;
5178 /* Calculate the translation from loop variables to array indices. */
5179 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5181 gfc_ss_type ss_type
;
5183 ss_type
= ss
->info
->type
;
5184 if (ss_type
!= GFC_SS_SECTION
5185 && ss_type
!= GFC_SS_COMPONENT
5186 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5189 info
= &ss
->info
->data
.array
;
5191 for (n
= 0; n
< ss
->dimen
; n
++)
5193 /* If we are specifying the range the delta is already set. */
5194 if (loopspec
[n
] != ss
)
5198 /* Calculate the offset relative to the loop variable.
5199 First multiply by the stride. */
5200 tmp
= loop
->from
[n
];
5201 if (!integer_onep (info
->stride
[dim
]))
5202 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5203 gfc_array_index_type
,
5204 tmp
, info
->stride
[dim
]);
5206 /* Then subtract this from our starting value. */
5207 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5208 gfc_array_index_type
,
5209 info
->start
[dim
], tmp
);
5211 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5216 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5217 gfc_set_delta (loop
);
5221 /* Calculate the size of a given array dimension from the bounds. This
5222 is simply (ubound - lbound + 1) if this expression is positive
5223 or 0 if it is negative (pick either one if it is zero). Optionally
5224 (if or_expr is present) OR the (expression != 0) condition to it. */
5227 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5232 /* Calculate (ubound - lbound + 1). */
5233 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5235 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5236 gfc_index_one_node
);
5238 /* Check whether the size for this dimension is negative. */
5239 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5240 gfc_index_zero_node
);
5241 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5242 gfc_index_zero_node
, res
);
5244 /* Build OR expression. */
5246 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5247 logical_type_node
, *or_expr
, cond
);
5253 /* For an array descriptor, get the total number of elements. This is just
5254 the product of the extents along from_dim to to_dim. */
5257 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5262 res
= gfc_index_one_node
;
5264 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5270 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5271 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5273 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5274 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5282 /* Full size of an array. */
5285 gfc_conv_descriptor_size (tree desc
, int rank
)
5287 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5291 /* Size of a coarray for all dimensions but the last. */
5294 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5296 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5300 /* Fills in an array descriptor, and returns the size of the array.
5301 The size will be a simple_val, ie a variable or a constant. Also
5302 calculates the offset of the base. The pointer argument overflow,
5303 which should be of integer type, will increase in value if overflow
5304 occurs during the size calculation. Returns the size of the array.
5308 for (n = 0; n < rank; n++)
5310 a.lbound[n] = specified_lower_bound;
5311 offset = offset + a.lbond[n] * stride;
5313 a.ubound[n] = specified_upper_bound;
5314 a.stride[n] = stride;
5315 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5316 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5317 stride = stride * size;
5319 for (n = rank; n < rank+corank; n++)
5320 (Set lcobound/ucobound as above.)
5321 element_size = sizeof (array element);
5324 stride = (size_t) stride;
5325 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5326 stride = stride * element_size;
5332 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5333 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5334 stmtblock_t
* descriptor_block
, tree
* overflow
,
5335 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5336 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5349 stmtblock_t thenblock
;
5350 stmtblock_t elseblock
;
5355 type
= TREE_TYPE (descriptor
);
5357 stride
= gfc_index_one_node
;
5358 offset
= gfc_index_zero_node
;
5360 /* Set the dtype before the alloc, because registration of coarrays needs
5362 if (expr
->ts
.type
== BT_CHARACTER
5363 && expr
->ts
.deferred
5364 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5366 type
= gfc_typenode_for_spec (&expr
->ts
);
5367 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5368 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5370 else if (expr
->ts
.type
== BT_CHARACTER
5371 && expr
->ts
.deferred
5372 && TREE_CODE (descriptor
) == COMPONENT_REF
)
5374 /* Deferred character components have their string length tucked away
5375 in a hidden field of the derived type. Obtain that and use it to
5376 set the dtype. The charlen backend decl is zero because the field
5377 type is zero length. */
5380 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5381 if (ref
->type
== REF_COMPONENT
5382 && gfc_deferred_strlen (ref
->u
.c
.component
, &tmp
))
5384 gcc_assert (tmp
!= NULL_TREE
);
5385 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
5386 TREE_OPERAND (descriptor
, 0), tmp
, NULL_TREE
);
5387 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
5388 type
= gfc_get_character_type_len (expr
->ts
.kind
, tmp
);
5389 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5390 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5394 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5395 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5398 or_expr
= logical_false_node
;
5400 for (n
= 0; n
< rank
; n
++)
5405 /* We have 3 possibilities for determining the size of the array:
5406 lower == NULL => lbound = 1, ubound = upper[n]
5407 upper[n] = NULL => lbound = 1, ubound = lower[n]
5408 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5411 /* Set lower bound. */
5412 gfc_init_se (&se
, NULL
);
5413 if (expr3_desc
!= NULL_TREE
)
5415 if (e3_is_array_constr
)
5416 /* The lbound of a constant array [] starts at zero, but when
5417 allocating it, the standard expects the array to start at
5419 se
.expr
= gfc_index_one_node
;
5421 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5424 else if (lower
== NULL
)
5425 se
.expr
= gfc_index_one_node
;
5428 gcc_assert (lower
[n
]);
5431 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5432 gfc_add_block_to_block (pblock
, &se
.pre
);
5436 se
.expr
= gfc_index_one_node
;
5440 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5441 gfc_rank_cst
[n
], se
.expr
);
5442 conv_lbound
= se
.expr
;
5444 /* Work out the offset for this component. */
5445 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5447 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5448 gfc_array_index_type
, offset
, tmp
);
5450 /* Set upper bound. */
5451 gfc_init_se (&se
, NULL
);
5452 if (expr3_desc
!= NULL_TREE
)
5454 if (e3_is_array_constr
)
5456 /* The lbound of a constant array [] starts at zero, but when
5457 allocating it, the standard expects the array to start at
5458 one. Therefore fix the upper bound to be
5459 (desc.ubound - desc.lbound)+ 1. */
5460 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5461 gfc_array_index_type
,
5462 gfc_conv_descriptor_ubound_get (
5463 expr3_desc
, gfc_rank_cst
[n
]),
5464 gfc_conv_descriptor_lbound_get (
5465 expr3_desc
, gfc_rank_cst
[n
]));
5466 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5467 gfc_array_index_type
, tmp
,
5468 gfc_index_one_node
);
5469 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5472 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5477 gcc_assert (ubound
);
5478 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5479 gfc_add_block_to_block (pblock
, &se
.pre
);
5480 if (ubound
->expr_type
== EXPR_FUNCTION
)
5481 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5483 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5484 gfc_rank_cst
[n
], se
.expr
);
5485 conv_ubound
= se
.expr
;
5487 /* Store the stride. */
5488 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5489 gfc_rank_cst
[n
], stride
);
5491 /* Calculate size and check whether extent is negative. */
5492 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5493 size
= gfc_evaluate_now (size
, pblock
);
5495 /* Check whether multiplying the stride by the number of
5496 elements in this dimension would overflow. We must also check
5497 whether the current dimension has zero size in order to avoid
5500 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5501 gfc_array_index_type
,
5502 fold_convert (gfc_array_index_type
,
5503 TYPE_MAX_VALUE (gfc_array_index_type
)),
5505 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5506 logical_type_node
, tmp
, stride
),
5507 PRED_FORTRAN_OVERFLOW
);
5508 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5509 integer_one_node
, integer_zero_node
);
5510 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5511 logical_type_node
, size
,
5512 gfc_index_zero_node
),
5513 PRED_FORTRAN_SIZE_ZERO
);
5514 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5515 integer_zero_node
, tmp
);
5516 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5518 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5520 /* Multiply the stride by the number of elements in this dimension. */
5521 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5522 gfc_array_index_type
, stride
, size
);
5523 stride
= gfc_evaluate_now (stride
, pblock
);
5526 for (n
= rank
; n
< rank
+ corank
; n
++)
5530 /* Set lower bound. */
5531 gfc_init_se (&se
, NULL
);
5532 if (lower
== NULL
|| lower
[n
] == NULL
)
5534 gcc_assert (n
== rank
+ corank
- 1);
5535 se
.expr
= gfc_index_one_node
;
5539 if (ubound
|| n
== rank
+ corank
- 1)
5541 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5542 gfc_add_block_to_block (pblock
, &se
.pre
);
5546 se
.expr
= gfc_index_one_node
;
5550 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5551 gfc_rank_cst
[n
], se
.expr
);
5553 if (n
< rank
+ corank
- 1)
5555 gfc_init_se (&se
, NULL
);
5556 gcc_assert (ubound
);
5557 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5558 gfc_add_block_to_block (pblock
, &se
.pre
);
5559 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5560 gfc_rank_cst
[n
], se
.expr
);
5564 /* The stride is the number of elements in the array, so multiply by the
5565 size of an element to get the total size. Obviously, if there is a
5566 SOURCE expression (expr3) we must use its element size. */
5567 if (expr3_elem_size
!= NULL_TREE
)
5568 tmp
= expr3_elem_size
;
5569 else if (expr3
!= NULL
)
5571 if (expr3
->ts
.type
== BT_CLASS
)
5574 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5575 gfc_add_vptr_component (sz
);
5576 gfc_add_size_component (sz
);
5577 gfc_init_se (&se_sz
, NULL
);
5578 gfc_conv_expr (&se_sz
, sz
);
5584 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5585 tmp
= TYPE_SIZE_UNIT (tmp
);
5589 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5591 /* Convert to size_t. */
5592 element_size
= fold_convert (size_type_node
, tmp
);
5595 return element_size
;
5597 *nelems
= gfc_evaluate_now (stride
, pblock
);
5598 stride
= fold_convert (size_type_node
, stride
);
5600 /* First check for overflow. Since an array of type character can
5601 have zero element_size, we must check for that before
5603 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5605 TYPE_MAX_VALUE (size_type_node
), element_size
);
5606 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5607 logical_type_node
, tmp
, stride
),
5608 PRED_FORTRAN_OVERFLOW
);
5609 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5610 integer_one_node
, integer_zero_node
);
5611 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5612 logical_type_node
, element_size
,
5613 build_int_cst (size_type_node
, 0)),
5614 PRED_FORTRAN_SIZE_ZERO
);
5615 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5616 integer_zero_node
, tmp
);
5617 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5619 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5621 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5622 stride
, element_size
);
5624 if (poffset
!= NULL
)
5626 offset
= gfc_evaluate_now (offset
, pblock
);
5630 if (integer_zerop (or_expr
))
5632 if (integer_onep (or_expr
))
5633 return build_int_cst (size_type_node
, 0);
5635 var
= gfc_create_var (TREE_TYPE (size
), "size");
5636 gfc_start_block (&thenblock
);
5637 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5638 thencase
= gfc_finish_block (&thenblock
);
5640 gfc_start_block (&elseblock
);
5641 gfc_add_modify (&elseblock
, var
, size
);
5642 elsecase
= gfc_finish_block (&elseblock
);
5644 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5645 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5646 gfc_add_expr_to_block (pblock
, tmp
);
5652 /* Retrieve the last ref from the chain. This routine is specific to
5653 gfc_array_allocate ()'s needs. */
5656 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5658 gfc_ref
*ref
, *prev_ref
;
5661 /* Prevent warnings for uninitialized variables. */
5662 prev_ref
= *prev_ref_in
;
5663 while (ref
&& ref
->next
!= NULL
)
5665 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5666 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5671 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5675 *prev_ref_in
= prev_ref
;
5679 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5680 the work for an ALLOCATE statement. */
5684 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5685 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5686 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5687 bool e3_is_array_constr
)
5691 tree offset
= NULL_TREE
;
5692 tree token
= NULL_TREE
;
5695 tree error
= NULL_TREE
;
5696 tree overflow
; /* Boolean storing whether size calculation overflows. */
5697 tree var_overflow
= NULL_TREE
;
5699 tree set_descriptor
;
5700 stmtblock_t set_descriptor_block
;
5701 stmtblock_t elseblock
;
5704 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5705 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5706 non_ulimate_coarray_ptr_comp
;
5710 /* Find the last reference in the chain. */
5711 if (!retrieve_last_ref (&ref
, &prev_ref
))
5714 /* Take the allocatable and coarray properties solely from the expr-ref's
5715 attributes and not from source=-expression. */
5718 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5719 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5720 non_ulimate_coarray_ptr_comp
= false;
5724 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5725 /* Pointer components in coarrayed derived types must be treated
5726 specially in that they are registered without a check if the are
5727 already associated. This does not hold for ultimate coarray
5729 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5730 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5731 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5734 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5735 a coarray. In this case it does not matter whether we are on this_image
5738 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5739 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5746 gcc_assert (coarray
);
5748 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5750 gfc_ref
*old_ref
= ref
;
5751 /* F08:C633: Array shape from expr3. */
5754 /* Find the last reference in the chain. */
5755 if (!retrieve_last_ref (&ref
, &prev_ref
))
5757 if (expr3
->expr_type
== EXPR_FUNCTION
5758 && gfc_expr_attr (expr3
).dimension
)
5763 alloc_w_e3_arr_spec
= true;
5766 /* Figure out the size of the array. */
5767 switch (ref
->u
.ar
.type
)
5773 upper
= ref
->u
.ar
.start
;
5779 lower
= ref
->u
.ar
.start
;
5780 upper
= ref
->u
.ar
.end
;
5784 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5785 || alloc_w_e3_arr_spec
);
5787 lower
= ref
->u
.ar
.as
->lower
;
5788 upper
= ref
->u
.ar
.as
->upper
;
5796 overflow
= integer_zero_node
;
5798 if (expr
->ts
.type
== BT_CHARACTER
5799 && TREE_CODE (se
->string_length
) == COMPONENT_REF
5800 && expr
->ts
.u
.cl
->backend_decl
!= se
->string_length
5801 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5802 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5803 fold_convert (TREE_TYPE (expr
->ts
.u
.cl
->backend_decl
),
5804 se
->string_length
));
5806 gfc_init_block (&set_descriptor_block
);
5807 /* Take the corank only from the actual ref and not from the coref. The
5808 later will mislead the generation of the array dimensions for allocatable/
5809 pointer components in derived types. */
5810 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5811 : ref
->u
.ar
.as
->rank
,
5812 coarray
? ref
->u
.ar
.as
->corank
: 0,
5813 &offset
, lower
, upper
,
5814 &se
->pre
, &set_descriptor_block
, &overflow
,
5815 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5816 e3_is_array_constr
, expr
);
5820 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5821 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5823 if (status
== NULL_TREE
)
5825 /* Generate the block of code handling overflow. */
5826 msg
= gfc_build_addr_expr (pchar_type_node
,
5827 gfc_build_localized_cstring_const
5828 ("Integer overflow when calculating the amount of "
5829 "memory to allocate"));
5830 error
= build_call_expr_loc (input_location
,
5831 gfor_fndecl_runtime_error
, 1, msg
);
5835 tree status_type
= TREE_TYPE (status
);
5836 stmtblock_t set_status_block
;
5838 gfc_start_block (&set_status_block
);
5839 gfc_add_modify (&set_status_block
, status
,
5840 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5841 error
= gfc_finish_block (&set_status_block
);
5845 gfc_start_block (&elseblock
);
5847 /* Allocate memory to store the data. */
5848 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5849 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5851 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5853 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5854 : gfc_conv_descriptor_data_get (se
->expr
);
5855 token
= gfc_conv_descriptor_token (se
->expr
);
5856 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5859 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5860 STRIP_NOPS (pointer
);
5862 /* The allocatable variant takes the old pointer as first argument. */
5864 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5865 status
, errmsg
, errlen
, label_finish
, expr
,
5866 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5867 else if (non_ulimate_coarray_ptr_comp
&& token
)
5868 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5869 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5871 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5873 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5877 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5878 logical_type_node
, var_overflow
, integer_zero_node
),
5879 PRED_FORTRAN_OVERFLOW
);
5880 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5881 error
, gfc_finish_block (&elseblock
));
5884 tmp
= gfc_finish_block (&elseblock
);
5886 gfc_add_expr_to_block (&se
->pre
, tmp
);
5888 /* Update the array descriptors. */
5890 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5892 /* Set the span field for pointer and deferred length character arrays. */
5893 if ((is_pointer_array (se
->expr
)
5894 || (expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (expr
)->attr
.class_pointer
)
5895 || (expr
->ts
.type
== BT_CHARACTER
&& TREE_CODE (se
->string_length
)
5897 || (expr
->ts
.type
== BT_CHARACTER
5898 && (expr
->ts
.deferred
|| VAR_P (expr
->ts
.u
.cl
->backend_decl
))))
5900 if (expr3
&& expr3_elem_size
!= NULL_TREE
)
5901 tmp
= expr3_elem_size
;
5902 else if (se
->string_length
5903 && (TREE_CODE (se
->string_length
) == COMPONENT_REF
5904 || (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)))
5906 if (expr
->ts
.kind
!= 1)
5908 tmp
= build_int_cst (gfc_array_index_type
, expr
->ts
.kind
);
5909 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5910 gfc_array_index_type
, tmp
,
5911 fold_convert (gfc_array_index_type
,
5912 se
->string_length
));
5915 tmp
= se
->string_length
;
5918 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se
->expr
)));
5919 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5920 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5923 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5924 if (status
!= NULL_TREE
)
5926 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5927 logical_type_node
, status
,
5928 build_int_cst (TREE_TYPE (status
), 0));
5929 gfc_add_expr_to_block (&se
->pre
,
5930 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5933 build_empty_stmt (input_location
)));
5936 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5942 /* Create an array constructor from an initialization expression.
5943 We assume the frontend already did any expansions and conversions. */
5946 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5953 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5955 if (expr
->expr_type
== EXPR_VARIABLE
5956 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5957 && expr
->symtree
->n
.sym
->value
)
5958 expr
= expr
->symtree
->n
.sym
->value
;
5960 switch (expr
->expr_type
)
5963 case EXPR_STRUCTURE
:
5964 /* A single scalar or derived type value. Create an array with all
5965 elements equal to that value. */
5966 gfc_init_se (&se
, NULL
);
5968 if (expr
->expr_type
== EXPR_CONSTANT
)
5969 gfc_conv_constant (&se
, expr
);
5971 gfc_conv_structure (&se
, expr
, 1);
5973 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5974 /* This will probably eat buckets of memory for large arrays. */
5977 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5983 /* Create a vector of all the elements. */
5984 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5985 c
; c
= gfc_constructor_next (c
))
5989 /* Problems occur when we get something like
5990 integer :: a(lots) = (/(i, i=1, lots)/) */
5991 gfc_fatal_error ("The number of elements in the array "
5992 "constructor at %L requires an increase of "
5993 "the allowed %d upper limit. See "
5994 "%<-fmax-array-constructor%> option",
5995 &expr
->where
, flag_max_array_constructor
);
5998 if (mpz_cmp_si (c
->offset
, 0) != 0)
5999 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6003 if (mpz_cmp_si (c
->repeat
, 1) > 0)
6009 mpz_add (maxval
, c
->offset
, c
->repeat
);
6010 mpz_sub_ui (maxval
, maxval
, 1);
6011 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6012 if (mpz_cmp_si (c
->offset
, 0) != 0)
6014 mpz_add_ui (maxval
, c
->offset
, 1);
6015 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
6018 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
6020 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
6026 gfc_init_se (&se
, NULL
);
6027 switch (c
->expr
->expr_type
)
6030 gfc_conv_constant (&se
, c
->expr
);
6032 /* See gfortran.dg/charlen_15.f90 for instance. */
6033 if (TREE_CODE (se
.expr
) == STRING_CST
6034 && TREE_CODE (type
) == ARRAY_TYPE
)
6037 while (TREE_CODE (TREE_TYPE (atype
)) == ARRAY_TYPE
)
6038 atype
= TREE_TYPE (atype
);
6039 if (TREE_CODE (TREE_TYPE (atype
)) == INTEGER_TYPE
6040 && tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se
.expr
)))
6041 > tree_to_uhwi (TYPE_SIZE_UNIT (atype
)))
6043 unsigned HOST_WIDE_INT size
6044 = tree_to_uhwi (TYPE_SIZE_UNIT (atype
));
6045 const char *p
= TREE_STRING_POINTER (se
.expr
);
6047 se
.expr
= build_string (size
, p
);
6048 TREE_TYPE (se
.expr
) = atype
;
6053 case EXPR_STRUCTURE
:
6054 gfc_conv_structure (&se
, c
->expr
, 1);
6058 /* Catch those occasional beasts that do not simplify
6059 for one reason or another, assuming that if they are
6060 standard defying the frontend will catch them. */
6061 gfc_conv_expr (&se
, c
->expr
);
6065 if (range
== NULL_TREE
)
6066 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6069 if (index
!= NULL_TREE
)
6070 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
6071 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
6077 return gfc_build_null_descriptor (type
);
6083 /* Create a constructor from the list of elements. */
6084 tmp
= build_constructor (type
, v
);
6085 TREE_CONSTANT (tmp
) = 1;
6090 /* Generate code to evaluate non-constant coarray cobounds. */
6093 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6094 const gfc_symbol
*sym
)
6102 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6104 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6106 /* Evaluate non-constant array bound expressions. */
6107 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6108 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6110 gfc_init_se (&se
, NULL
);
6111 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6112 gfc_add_block_to_block (pblock
, &se
.pre
);
6113 gfc_add_modify (pblock
, lbound
, se
.expr
);
6115 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6116 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6118 gfc_init_se (&se
, NULL
);
6119 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6120 gfc_add_block_to_block (pblock
, &se
.pre
);
6121 gfc_add_modify (pblock
, ubound
, se
.expr
);
6127 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6128 returns the size (in elements) of the array. */
6131 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6132 stmtblock_t
* pblock
)
6145 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6147 size
= gfc_index_one_node
;
6148 offset
= gfc_index_zero_node
;
6149 for (dim
= 0; dim
< as
->rank
; dim
++)
6151 /* Evaluate non-constant array bound expressions. */
6152 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6153 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6155 gfc_init_se (&se
, NULL
);
6156 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6157 gfc_add_block_to_block (pblock
, &se
.pre
);
6158 gfc_add_modify (pblock
, lbound
, se
.expr
);
6160 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6161 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6163 gfc_init_se (&se
, NULL
);
6164 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6165 gfc_add_block_to_block (pblock
, &se
.pre
);
6166 gfc_add_modify (pblock
, ubound
, se
.expr
);
6168 /* The offset of this dimension. offset = offset - lbound * stride. */
6169 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6171 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6174 /* The size of this dimension, and the stride of the next. */
6175 if (dim
+ 1 < as
->rank
)
6176 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6178 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6180 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6182 /* Calculate stride = size * (ubound + 1 - lbound). */
6183 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6184 gfc_array_index_type
,
6185 gfc_index_one_node
, lbound
);
6186 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6187 gfc_array_index_type
, ubound
, tmp
);
6188 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6189 gfc_array_index_type
, size
, tmp
);
6191 gfc_add_modify (pblock
, stride
, tmp
);
6193 stride
= gfc_evaluate_now (tmp
, pblock
);
6195 /* Make sure that negative size arrays are translated
6196 to being zero size. */
6197 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6198 stride
, gfc_index_zero_node
);
6199 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6200 gfc_array_index_type
, tmp
,
6201 stride
, gfc_index_zero_node
);
6202 gfc_add_modify (pblock
, stride
, tmp
);
6208 gfc_trans_array_cobounds (type
, pblock
, sym
);
6209 gfc_trans_vla_type_sizes (sym
, pblock
);
6216 /* Generate code to initialize/allocate an array variable. */
6219 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6220 gfc_wrapped_block
* block
)
6224 tree tmp
= NULL_TREE
;
6231 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6233 /* Do nothing for USEd variables. */
6234 if (sym
->attr
.use_assoc
)
6237 type
= TREE_TYPE (decl
);
6238 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6239 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6241 gfc_init_block (&init
);
6243 /* Evaluate character string length. */
6244 if (sym
->ts
.type
== BT_CHARACTER
6245 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6247 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6249 gfc_trans_vla_type_sizes (sym
, &init
);
6251 /* Emit a DECL_EXPR for this variable, which will cause the
6252 gimplifier to allocate storage, and all that good stuff. */
6253 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6254 gfc_add_expr_to_block (&init
, tmp
);
6259 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6263 type
= TREE_TYPE (type
);
6265 gcc_assert (!sym
->attr
.use_assoc
);
6266 gcc_assert (!TREE_STATIC (decl
));
6267 gcc_assert (!sym
->module
);
6269 if (sym
->ts
.type
== BT_CHARACTER
6270 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6271 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6273 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6275 /* Don't actually allocate space for Cray Pointees. */
6276 if (sym
->attr
.cray_pointee
)
6278 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6279 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6281 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6285 if (flag_stack_arrays
)
6287 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6288 space
= build_decl (sym
->declared_at
.lb
->location
,
6289 VAR_DECL
, create_tmp_var_name ("A"),
6290 TREE_TYPE (TREE_TYPE (decl
)));
6291 gfc_trans_vla_type_sizes (sym
, &init
);
6295 /* The size is the number of elements in the array, so multiply by the
6296 size of an element to get the total size. */
6297 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6298 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6299 size
, fold_convert (gfc_array_index_type
, tmp
));
6301 /* Allocate memory to hold the data. */
6302 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6303 gfc_add_modify (&init
, decl
, tmp
);
6305 /* Free the temporary. */
6306 tmp
= gfc_call_free (decl
);
6310 /* Set offset of the array. */
6311 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6312 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6314 /* Automatic arrays should not have initializers. */
6315 gcc_assert (!sym
->value
);
6317 inittree
= gfc_finish_block (&init
);
6324 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6325 where also space is located. */
6326 gfc_init_block (&init
);
6327 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6328 TREE_TYPE (space
), space
);
6329 gfc_add_expr_to_block (&init
, tmp
);
6330 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6331 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6332 gfc_add_modify (&init
, decl
, addr
);
6333 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6336 gfc_add_init_cleanup (block
, inittree
, tmp
);
6340 /* Generate entry and exit code for g77 calling convention arrays. */
6343 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6353 gfc_save_backend_locus (&loc
);
6354 gfc_set_backend_locus (&sym
->declared_at
);
6356 /* Descriptor type. */
6357 parm
= sym
->backend_decl
;
6358 type
= TREE_TYPE (parm
);
6359 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6361 gfc_start_block (&init
);
6363 if (sym
->ts
.type
== BT_CHARACTER
6364 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6365 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6367 /* Evaluate the bounds of the array. */
6368 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6370 /* Set the offset. */
6371 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6372 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6374 /* Set the pointer itself if we aren't using the parameter directly. */
6375 if (TREE_CODE (parm
) != PARM_DECL
)
6377 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6378 gfc_add_modify (&init
, parm
, tmp
);
6380 stmt
= gfc_finish_block (&init
);
6382 gfc_restore_backend_locus (&loc
);
6384 /* Add the initialization code to the start of the function. */
6386 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6388 tmp
= gfc_conv_expr_present (sym
);
6389 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6392 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6396 /* Modify the descriptor of an array parameter so that it has the
6397 correct lower bound. Also move the upper bound accordingly.
6398 If the array is not packed, it will be copied into a temporary.
6399 For each dimension we set the new lower and upper bounds. Then we copy the
6400 stride and calculate the offset for this dimension. We also work out
6401 what the stride of a packed array would be, and see it the two match.
6402 If the array need repacking, we set the stride to the values we just
6403 calculated, recalculate the offset and copy the array data.
6404 Code is also added to copy the data back at the end of the function.
6408 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6409 gfc_wrapped_block
* block
)
6416 tree stmtInit
, stmtCleanup
;
6423 tree stride
, stride2
;
6433 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6435 /* Do nothing for pointer and allocatable arrays. */
6436 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6437 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6438 || sym
->attr
.allocatable
6439 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6442 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6444 gfc_trans_g77_array (sym
, block
);
6449 gfc_save_backend_locus (&loc
);
6450 /* loc.nextc is not set by save_backend_locus but the location routines
6452 if (loc
.nextc
== NULL
)
6453 loc
.nextc
= loc
.lb
->line
;
6454 gfc_set_backend_locus (&sym
->declared_at
);
6456 /* Descriptor type. */
6457 type
= TREE_TYPE (tmpdesc
);
6458 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6459 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6461 /* For a class array the dummy array descriptor is in the _class
6463 dumdesc
= gfc_class_data_get (dumdesc
);
6465 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6466 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6467 gfc_start_block (&init
);
6469 if (sym
->ts
.type
== BT_CHARACTER
6470 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6471 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6473 checkparm
= (as
->type
== AS_EXPLICIT
6474 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6476 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6477 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6479 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6481 /* For non-constant shape arrays we only check if the first dimension
6482 is contiguous. Repacking higher dimensions wouldn't gain us
6483 anything as we still don't know the array stride. */
6484 partial
= gfc_create_var (logical_type_node
, "partial");
6485 TREE_USED (partial
) = 1;
6486 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6487 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6488 gfc_index_one_node
);
6489 gfc_add_modify (&init
, partial
, tmp
);
6492 partial
= NULL_TREE
;
6494 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6495 here, however I think it does the right thing. */
6498 /* Set the first stride. */
6499 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6500 stride
= gfc_evaluate_now (stride
, &init
);
6502 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6503 stride
, gfc_index_zero_node
);
6504 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6505 tmp
, gfc_index_one_node
, stride
);
6506 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6507 gfc_add_modify (&init
, stride
, tmp
);
6509 /* Allow the user to disable array repacking. */
6510 stmt_unpacked
= NULL_TREE
;
6514 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6515 /* A library call to repack the array if necessary. */
6516 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6517 stmt_unpacked
= build_call_expr_loc (input_location
,
6518 gfor_fndecl_in_pack
, 1, tmp
);
6520 stride
= gfc_index_one_node
;
6522 if (warn_array_temporaries
)
6523 gfc_warning (OPT_Warray_temporaries
,
6524 "Creating array temporary at %L", &loc
);
6527 /* This is for the case where the array data is used directly without
6528 calling the repack function. */
6529 if (no_repack
|| partial
!= NULL_TREE
)
6530 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6532 stmt_packed
= NULL_TREE
;
6534 /* Assign the data pointer. */
6535 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6537 /* Don't repack unknown shape arrays when the first stride is 1. */
6538 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6539 partial
, stmt_packed
, stmt_unpacked
);
6542 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6543 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6545 offset
= gfc_index_zero_node
;
6546 size
= gfc_index_one_node
;
6548 /* Evaluate the bounds of the array. */
6549 for (n
= 0; n
< as
->rank
; n
++)
6551 if (checkparm
|| !as
->upper
[n
])
6553 /* Get the bounds of the actual parameter. */
6554 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6555 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6559 dubound
= NULL_TREE
;
6560 dlbound
= NULL_TREE
;
6563 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6564 if (!INTEGER_CST_P (lbound
))
6566 gfc_init_se (&se
, NULL
);
6567 gfc_conv_expr_type (&se
, as
->lower
[n
],
6568 gfc_array_index_type
);
6569 gfc_add_block_to_block (&init
, &se
.pre
);
6570 gfc_add_modify (&init
, lbound
, se
.expr
);
6573 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6574 /* Set the desired upper bound. */
6577 /* We know what we want the upper bound to be. */
6578 if (!INTEGER_CST_P (ubound
))
6580 gfc_init_se (&se
, NULL
);
6581 gfc_conv_expr_type (&se
, as
->upper
[n
],
6582 gfc_array_index_type
);
6583 gfc_add_block_to_block (&init
, &se
.pre
);
6584 gfc_add_modify (&init
, ubound
, se
.expr
);
6587 /* Check the sizes match. */
6590 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6594 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6595 gfc_array_index_type
, ubound
, lbound
);
6596 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6597 gfc_array_index_type
,
6598 gfc_index_one_node
, temp
);
6599 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6600 gfc_array_index_type
, dubound
,
6602 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6603 gfc_array_index_type
,
6604 gfc_index_one_node
, stride2
);
6605 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6606 gfc_array_index_type
, temp
, stride2
);
6607 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6608 "%%ld instead of %%ld", n
+1, sym
->name
);
6610 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6611 fold_convert (long_integer_type_node
, temp
),
6612 fold_convert (long_integer_type_node
, stride2
));
6619 /* For assumed shape arrays move the upper bound by the same amount
6620 as the lower bound. */
6621 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6622 gfc_array_index_type
, dubound
, dlbound
);
6623 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6624 gfc_array_index_type
, tmp
, lbound
);
6625 gfc_add_modify (&init
, ubound
, tmp
);
6627 /* The offset of this dimension. offset = offset - lbound * stride. */
6628 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6630 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6631 gfc_array_index_type
, offset
, tmp
);
6633 /* The size of this dimension, and the stride of the next. */
6634 if (n
+ 1 < as
->rank
)
6636 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6638 if (no_repack
|| partial
!= NULL_TREE
)
6640 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6642 /* Figure out the stride if not a known constant. */
6643 if (!INTEGER_CST_P (stride
))
6646 stmt_packed
= NULL_TREE
;
6649 /* Calculate stride = size * (ubound + 1 - lbound). */
6650 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6651 gfc_array_index_type
,
6652 gfc_index_one_node
, lbound
);
6653 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6654 gfc_array_index_type
, ubound
, tmp
);
6655 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6656 gfc_array_index_type
, size
, tmp
);
6660 /* Assign the stride. */
6661 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6662 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6663 gfc_array_index_type
, partial
,
6664 stmt_unpacked
, stmt_packed
);
6666 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6667 gfc_add_modify (&init
, stride
, tmp
);
6672 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6674 if (stride
&& !INTEGER_CST_P (stride
))
6676 /* Calculate size = stride * (ubound + 1 - lbound). */
6677 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6678 gfc_array_index_type
,
6679 gfc_index_one_node
, lbound
);
6680 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6681 gfc_array_index_type
,
6683 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6684 gfc_array_index_type
,
6685 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6686 gfc_add_modify (&init
, stride
, tmp
);
6691 gfc_trans_array_cobounds (type
, &init
, sym
);
6693 /* Set the offset. */
6694 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6695 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6697 gfc_trans_vla_type_sizes (sym
, &init
);
6699 stmtInit
= gfc_finish_block (&init
);
6701 /* Only do the entry/initialization code if the arg is present. */
6702 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6703 optional_arg
= (sym
->attr
.optional
6704 || (sym
->ns
->proc_name
->attr
.entry_master
6705 && sym
->attr
.dummy
));
6708 tmp
= gfc_conv_expr_present (sym
);
6709 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6710 build_empty_stmt (input_location
));
6715 stmtCleanup
= NULL_TREE
;
6718 stmtblock_t cleanup
;
6719 gfc_start_block (&cleanup
);
6721 if (sym
->attr
.intent
!= INTENT_IN
)
6723 /* Copy the data back. */
6724 tmp
= build_call_expr_loc (input_location
,
6725 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6726 gfc_add_expr_to_block (&cleanup
, tmp
);
6729 /* Free the temporary. */
6730 tmp
= gfc_call_free (tmpdesc
);
6731 gfc_add_expr_to_block (&cleanup
, tmp
);
6733 stmtCleanup
= gfc_finish_block (&cleanup
);
6735 /* Only do the cleanup if the array was repacked. */
6737 /* For a class array the dummy array descriptor is in the _class
6739 tmp
= gfc_class_data_get (dumdesc
);
6741 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6742 tmp
= gfc_conv_descriptor_data_get (tmp
);
6743 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6745 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6746 build_empty_stmt (input_location
));
6750 tmp
= gfc_conv_expr_present (sym
);
6751 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6752 build_empty_stmt (input_location
));
6756 /* We don't need to free any memory allocated by internal_pack as it will
6757 be freed at the end of the function by pop_context. */
6758 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6760 gfc_restore_backend_locus (&loc
);
6764 /* Calculate the overall offset, including subreferences. */
6766 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6767 bool subref
, gfc_expr
*expr
)
6777 /* If offset is NULL and this is not a subreferenced array, there is
6779 if (offset
== NULL_TREE
)
6782 offset
= gfc_index_zero_node
;
6787 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6789 /* Offset the data pointer for pointer assignments from arrays with
6790 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6793 /* Go past the array reference. */
6794 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6795 if (ref
->type
== REF_ARRAY
&&
6796 ref
->u
.ar
.type
!= AR_ELEMENT
)
6802 /* Calculate the offset for each subsequent subreference. */
6803 for (; ref
; ref
= ref
->next
)
6808 field
= ref
->u
.c
.component
->backend_decl
;
6809 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6810 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6812 tmp
, field
, NULL_TREE
);
6816 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6817 gfc_init_se (&start
, NULL
);
6818 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6819 gfc_add_block_to_block (block
, &start
.pre
);
6820 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6824 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6825 && ref
->u
.ar
.type
== AR_ELEMENT
);
6827 /* TODO - Add bounds checking. */
6828 stride
= gfc_index_one_node
;
6829 index
= gfc_index_zero_node
;
6830 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6835 /* Update the index. */
6836 gfc_init_se (&start
, NULL
);
6837 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6838 itmp
= gfc_evaluate_now (start
.expr
, block
);
6839 gfc_init_se (&start
, NULL
);
6840 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6841 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6842 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6843 gfc_array_index_type
, itmp
, jtmp
);
6844 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6845 gfc_array_index_type
, itmp
, stride
);
6846 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6847 gfc_array_index_type
, itmp
, index
);
6848 index
= gfc_evaluate_now (index
, block
);
6850 /* Update the stride. */
6851 gfc_init_se (&start
, NULL
);
6852 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6853 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6854 gfc_array_index_type
, start
.expr
,
6856 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6857 gfc_array_index_type
,
6858 gfc_index_one_node
, itmp
);
6859 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6860 gfc_array_index_type
, stride
, itmp
);
6861 stride
= gfc_evaluate_now (stride
, block
);
6864 /* Apply the index to obtain the array element. */
6865 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6875 /* Set the target data pointer. */
6876 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6877 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6881 /* gfc_conv_expr_descriptor needs the string length an expression
6882 so that the size of the temporary can be obtained. This is done
6883 by adding up the string lengths of all the elements in the
6884 expression. Function with non-constant expressions have their
6885 string lengths mapped onto the actual arguments using the
6886 interface mapping machinery in trans-expr.c. */
6888 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6890 gfc_interface_mapping mapping
;
6891 gfc_formal_arglist
*formal
;
6892 gfc_actual_arglist
*arg
;
6895 if (expr
->ts
.u
.cl
->length
6896 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6898 if (!expr
->ts
.u
.cl
->backend_decl
)
6899 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6903 switch (expr
->expr_type
)
6906 get_array_charlen (expr
->value
.op
.op1
, se
);
6908 /* For parentheses the expression ts.u.cl is identical. */
6909 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6912 expr
->ts
.u
.cl
->backend_decl
=
6913 gfc_create_var (gfc_charlen_type_node
, "sln");
6915 if (expr
->value
.op
.op2
)
6917 get_array_charlen (expr
->value
.op
.op2
, se
);
6919 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6921 /* Add the string lengths and assign them to the expression
6922 string length backend declaration. */
6923 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6924 fold_build2_loc (input_location
, PLUS_EXPR
,
6925 gfc_charlen_type_node
,
6926 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6927 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6930 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6931 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6935 if (expr
->value
.function
.esym
== NULL
6936 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6938 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6942 /* Map expressions involving the dummy arguments onto the actual
6943 argument expressions. */
6944 gfc_init_interface_mapping (&mapping
);
6945 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6946 arg
= expr
->value
.function
.actual
;
6948 /* Set se = NULL in the calls to the interface mapping, to suppress any
6950 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6955 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6958 gfc_init_se (&tse
, NULL
);
6960 /* Build the expression for the character length and convert it. */
6961 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6963 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6964 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6965 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6966 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6967 TREE_TYPE (tse
.expr
), tse
.expr
,
6968 build_zero_cst (TREE_TYPE (tse
.expr
)));
6969 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6970 gfc_free_interface_mapping (&mapping
);
6974 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6980 /* Helper function to check dimensions. */
6982 transposed_dims (gfc_ss
*ss
)
6986 for (n
= 0; n
< ss
->dimen
; n
++)
6987 if (ss
->dim
[n
] != n
)
6993 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6994 AR_FULL, suitable for the scalarizer. */
6997 walk_coarray (gfc_expr
*e
)
7001 gcc_assert (gfc_get_corank (e
) > 0);
7003 ss
= gfc_walk_expr (e
);
7005 /* Fix scalar coarray. */
7006 if (ss
== gfc_ss_terminator
)
7013 if (ref
->type
== REF_ARRAY
7014 && ref
->u
.ar
.codimen
> 0)
7020 gcc_assert (ref
!= NULL
);
7021 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7022 ref
->u
.ar
.type
= AR_SECTION
;
7023 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
7030 /* Convert an array for passing as an actual argument. Expressions and
7031 vector subscripts are evaluated and stored in a temporary, which is then
7032 passed. For whole arrays the descriptor is passed. For array sections
7033 a modified copy of the descriptor is passed, but using the original data.
7035 This function is also used for array pointer assignments, and there
7038 - se->want_pointer && !se->direct_byref
7039 EXPR is an actual argument. On exit, se->expr contains a
7040 pointer to the array descriptor.
7042 - !se->want_pointer && !se->direct_byref
7043 EXPR is an actual argument to an intrinsic function or the
7044 left-hand side of a pointer assignment. On exit, se->expr
7045 contains the descriptor for EXPR.
7047 - !se->want_pointer && se->direct_byref
7048 EXPR is the right-hand side of a pointer assignment and
7049 se->expr is the descriptor for the previously-evaluated
7050 left-hand side. The function creates an assignment from
7054 The se->force_tmp flag disables the non-copying descriptor optimization
7055 that is used for transpose. It may be used in cases where there is an
7056 alias between the transpose argument and another argument in the same
7060 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
7063 gfc_ss_type ss_type
;
7064 gfc_ss_info
*ss_info
;
7066 gfc_array_info
*info
;
7075 bool subref_array_target
= false;
7076 bool deferred_array_component
= false;
7077 gfc_expr
*arg
, *ss_expr
;
7079 if (se
->want_coarray
)
7080 ss
= walk_coarray (expr
);
7082 ss
= gfc_walk_expr (expr
);
7084 gcc_assert (ss
!= NULL
);
7085 gcc_assert (ss
!= gfc_ss_terminator
);
7088 ss_type
= ss_info
->type
;
7089 ss_expr
= ss_info
->expr
;
7091 /* Special case: TRANSPOSE which needs no temporary. */
7092 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7093 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7095 /* This is a call to transpose which has already been handled by the
7096 scalarizer, so that we just need to get its argument's descriptor. */
7097 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7098 expr
= expr
->value
.function
.actual
->expr
;
7101 /* Special case things we know we can pass easily. */
7102 switch (expr
->expr_type
)
7105 /* If we have a linear array section, we can pass it directly.
7106 Otherwise we need to copy it into a temporary. */
7108 gcc_assert (ss_type
== GFC_SS_SECTION
);
7109 gcc_assert (ss_expr
== expr
);
7110 info
= &ss_info
->data
.array
;
7112 /* Get the descriptor for the array. */
7113 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7114 desc
= info
->descriptor
;
7116 /* The charlen backend decl for deferred character components cannot
7117 be used because it is fixed at zero. Instead, the hidden string
7118 length component is used. */
7119 if (expr
->ts
.type
== BT_CHARACTER
7120 && expr
->ts
.deferred
7121 && TREE_CODE (desc
) == COMPONENT_REF
)
7122 deferred_array_component
= true;
7124 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7125 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7126 && !subref_array_target
;
7133 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7135 /* Create a new descriptor if the array doesn't have one. */
7138 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7140 else if (se
->direct_byref
)
7143 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7145 if (full
&& !transposed_dims (ss
))
7147 if (se
->direct_byref
&& !se
->byref_noassign
)
7149 /* Copy the descriptor for pointer assignments. */
7150 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7152 /* Add any offsets from subreferences. */
7153 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7154 subref_array_target
, expr
);
7156 /* ....and set the span field. */
7157 tmp
= gfc_get_array_span (desc
, expr
);
7158 if (tmp
!= NULL_TREE
&& !integer_zerop (tmp
))
7159 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7161 else if (se
->want_pointer
)
7163 /* We pass full arrays directly. This means that pointers and
7164 allocatable arrays should also work. */
7165 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7172 if (expr
->ts
.type
== BT_CHARACTER
&& !deferred_array_component
)
7173 se
->string_length
= gfc_get_expr_charlen (expr
);
7174 /* The ss_info string length is returned set to the value of the
7175 hidden string length component. */
7176 else if (deferred_array_component
)
7177 se
->string_length
= ss_info
->string_length
;
7179 gfc_free_ss_chain (ss
);
7185 /* A transformational function return value will be a temporary
7186 array descriptor. We still need to go through the scalarizer
7187 to create the descriptor. Elemental functions are handled as
7188 arbitrary expressions, i.e. copy to a temporary. */
7190 if (se
->direct_byref
)
7192 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7194 /* For pointer assignments pass the descriptor directly. */
7198 gcc_assert (se
->ss
== ss
);
7200 if (!is_pointer_array (se
->expr
))
7202 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7203 tmp
= fold_convert (gfc_array_index_type
,
7204 size_in_bytes (tmp
));
7205 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7208 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7209 gfc_conv_expr (se
, expr
);
7211 gfc_free_ss_chain (ss
);
7215 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7217 if (ss_expr
!= expr
)
7218 /* Elemental function. */
7219 gcc_assert ((expr
->value
.function
.esym
!= NULL
7220 && expr
->value
.function
.esym
->attr
.elemental
)
7221 || (expr
->value
.function
.isym
!= NULL
7222 && expr
->value
.function
.isym
->elemental
)
7223 || gfc_inline_intrinsic_function_p (expr
));
7225 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7228 if (expr
->ts
.type
== BT_CHARACTER
7229 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7230 get_array_charlen (expr
, se
);
7236 /* Transformational function. */
7237 info
= &ss_info
->data
.array
;
7243 /* Constant array constructors don't need a temporary. */
7244 if (ss_type
== GFC_SS_CONSTRUCTOR
7245 && expr
->ts
.type
!= BT_CHARACTER
7246 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7249 info
= &ss_info
->data
.array
;
7259 /* Something complicated. Copy it into a temporary. */
7265 /* If we are creating a temporary, we don't need to bother about aliases
7270 gfc_init_loopinfo (&loop
);
7272 /* Associate the SS with the loop. */
7273 gfc_add_ss_to_loop (&loop
, ss
);
7275 /* Tell the scalarizer not to bother creating loop variables, etc. */
7277 loop
.array_parameter
= 1;
7279 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7280 gcc_assert (!se
->direct_byref
);
7282 /* Do we need bounds checking or not? */
7283 ss
->no_bounds_check
= expr
->no_bounds_check
;
7285 /* Setup the scalarizing loops and bounds. */
7286 gfc_conv_ss_startstride (&loop
);
7290 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
7291 get_array_charlen (expr
, se
);
7293 /* Tell the scalarizer to make a temporary. */
7294 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7295 ((expr
->ts
.type
== BT_CHARACTER
)
7296 ? expr
->ts
.u
.cl
->backend_decl
7300 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7301 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7302 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7305 gfc_conv_loop_setup (&loop
, & expr
->where
);
7309 /* Copy into a temporary and pass that. We don't need to copy the data
7310 back because expressions and vector subscripts must be INTENT_IN. */
7311 /* TODO: Optimize passing function return values. */
7316 /* Start the copying loops. */
7317 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7318 gfc_mark_ss_chain_used (ss
, 1);
7319 gfc_start_scalarized_body (&loop
, &block
);
7321 /* Copy each data element. */
7322 gfc_init_se (&lse
, NULL
);
7323 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7324 gfc_init_se (&rse
, NULL
);
7325 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7327 lse
.ss
= loop
.temp_ss
;
7330 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7331 if (expr
->ts
.type
== BT_CHARACTER
)
7333 gfc_conv_expr (&rse
, expr
);
7334 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7335 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7339 gfc_conv_expr_val (&rse
, expr
);
7341 gfc_add_block_to_block (&block
, &rse
.pre
);
7342 gfc_add_block_to_block (&block
, &lse
.pre
);
7344 lse
.string_length
= rse
.string_length
;
7346 deep_copy
= !se
->data_not_needed
7347 && (expr
->expr_type
== EXPR_VARIABLE
7348 || expr
->expr_type
== EXPR_ARRAY
);
7349 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7351 gfc_add_expr_to_block (&block
, tmp
);
7353 /* Finish the copying loops. */
7354 gfc_trans_scalarizing_loops (&loop
, &block
);
7356 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7358 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7360 desc
= info
->descriptor
;
7361 se
->string_length
= ss_info
->string_length
;
7365 /* We pass sections without copying to a temporary. Make a new
7366 descriptor and point it at the section we want. The loop variable
7367 limits will be the limits of the section.
7368 A function may decide to repack the array to speed up access, but
7369 we're not bothered about that here. */
7370 int dim
, ndim
, codim
;
7377 bool onebased
= false, rank_remap
;
7379 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7380 rank_remap
= ss
->dimen
< ndim
;
7382 if (se
->want_coarray
)
7384 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7386 codim
= gfc_get_corank (expr
);
7387 for (n
= 0; n
< codim
- 1; n
++)
7389 /* Make sure we are not lost somehow. */
7390 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7392 /* Make sure the call to gfc_conv_section_startstride won't
7393 generate unnecessary code to calculate stride. */
7394 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7396 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7397 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7398 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7401 gcc_assert (n
== codim
- 1);
7402 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7403 info
->descriptor
, n
+ ndim
, true,
7404 ar
->as
->type
== AS_DEFERRED
);
7405 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7410 /* Set the string_length for a character array. */
7411 if (expr
->ts
.type
== BT_CHARACTER
)
7412 se
->string_length
= gfc_get_expr_charlen (expr
);
7414 /* If we have an array section or are assigning make sure that
7415 the lower bound is 1. References to the full
7416 array should otherwise keep the original bounds. */
7417 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7418 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7419 if (!integer_onep (loop
.from
[dim
]))
7421 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7422 gfc_array_index_type
, gfc_index_one_node
,
7424 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7425 gfc_array_index_type
,
7427 loop
.from
[dim
] = gfc_index_one_node
;
7430 desc
= info
->descriptor
;
7431 if (se
->direct_byref
&& !se
->byref_noassign
)
7433 /* For pointer assignments we fill in the destination. */
7435 parmtype
= TREE_TYPE (parm
);
7439 /* Otherwise make a new one. */
7440 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7441 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7443 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7445 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7446 loop
.from
, loop
.to
, 0,
7447 GFC_ARRAY_UNKNOWN
, false);
7448 parm
= gfc_create_var (parmtype
, "parm");
7450 /* When expression is a class object, then add the class' handle to
7452 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7454 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7457 /* class_expr can be NULL, when no _class ref is in expr.
7458 We must not fix this here with a gfc_fix_class_ref (). */
7461 gfc_init_se (&classse
, NULL
);
7462 gfc_conv_expr (&classse
, class_expr
);
7463 gfc_free_expr (class_expr
);
7465 gcc_assert (classse
.pre
.head
== NULL_TREE
7466 && classse
.post
.head
== NULL_TREE
);
7467 gfc_allocate_lang_decl (parm
);
7468 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7473 /* Set the span field. */
7474 tmp
= gfc_get_array_span (desc
, expr
);
7475 if (tmp
!= NULL_TREE
)
7476 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7478 offset
= gfc_index_zero_node
;
7480 /* The following can be somewhat confusing. We have two
7481 descriptors, a new one and the original array.
7482 {parm, parmtype, dim} refer to the new one.
7483 {desc, type, n, loop} refer to the original, which maybe
7484 a descriptorless array.
7485 The bounds of the scalarization are the bounds of the section.
7486 We don't have to worry about numeric overflows when calculating
7487 the offsets because all elements are within the array data. */
7489 /* Set the dtype. */
7490 tmp
= gfc_conv_descriptor_dtype (parm
);
7491 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7493 /* Set offset for assignments to pointer only to zero if it is not
7495 if ((se
->direct_byref
|| se
->use_offset
)
7496 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7497 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7498 base
= gfc_index_zero_node
;
7499 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7500 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7504 for (n
= 0; n
< ndim
; n
++)
7506 stride
= gfc_conv_array_stride (desc
, n
);
7508 /* Work out the offset. */
7510 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7512 gcc_assert (info
->subscript
[n
]
7513 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7514 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7518 /* Evaluate and remember the start of the section. */
7519 start
= info
->start
[n
];
7520 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7523 tmp
= gfc_conv_array_lbound (desc
, n
);
7524 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7526 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7528 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7532 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7534 /* For elemental dimensions, we only need the offset. */
7538 /* Vector subscripts need copying and are handled elsewhere. */
7540 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7542 /* look for the corresponding scalarizer dimension: dim. */
7543 for (dim
= 0; dim
< ndim
; dim
++)
7544 if (ss
->dim
[dim
] == n
)
7547 /* loop exited early: the DIM being looked for has been found. */
7548 gcc_assert (dim
< ndim
);
7550 /* Set the new lower bound. */
7551 from
= loop
.from
[dim
];
7554 onebased
= integer_onep (from
);
7555 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7556 gfc_rank_cst
[dim
], from
);
7558 /* Set the new upper bound. */
7559 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7560 gfc_rank_cst
[dim
], to
);
7562 /* Multiply the stride by the section stride to get the
7564 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7565 gfc_array_index_type
,
7566 stride
, info
->stride
[n
]);
7568 if ((se
->direct_byref
|| se
->use_offset
)
7569 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7570 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7572 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7573 TREE_TYPE (base
), base
, stride
);
7575 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7578 tmp
= gfc_conv_array_lbound (desc
, n
);
7579 toonebased
= integer_onep (tmp
);
7580 // lb(arr) - from (- start + 1)
7581 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7582 TREE_TYPE (base
), tmp
, from
);
7583 if (onebased
&& toonebased
)
7585 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7586 TREE_TYPE (base
), tmp
, start
);
7587 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7588 TREE_TYPE (base
), tmp
,
7589 gfc_index_one_node
);
7591 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7592 TREE_TYPE (base
), tmp
,
7593 gfc_conv_array_stride (desc
, n
));
7594 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7595 TREE_TYPE (base
), tmp
, base
);
7598 /* Store the new stride. */
7599 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7600 gfc_rank_cst
[dim
], stride
);
7603 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7605 from
= loop
.from
[n
];
7607 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7608 gfc_rank_cst
[n
], from
);
7609 if (n
< loop
.dimen
+ codim
- 1)
7610 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7611 gfc_rank_cst
[n
], to
);
7614 if (se
->data_not_needed
)
7615 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7616 gfc_index_zero_node
);
7618 /* Point the data pointer at the 1st element in the section. */
7619 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7620 subref_array_target
, expr
);
7622 /* Force the offset to be -1, when the lower bound of the highest
7623 dimension is one and the symbol is present and is not a
7624 pointer/allocatable or associated. */
7625 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7626 && !se
->data_not_needed
)
7627 || (se
->use_offset
&& base
!= NULL_TREE
))
7629 /* Set the offset depending on base. */
7630 tmp
= rank_remap
&& !se
->direct_byref
?
7631 fold_build2_loc (input_location
, PLUS_EXPR
,
7632 gfc_array_index_type
, base
,
7635 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7637 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7638 && !se
->data_not_needed
7639 && (!rank_remap
|| se
->use_offset
))
7641 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7642 gfc_conv_descriptor_offset_get (desc
));
7644 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7646 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7647 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7648 && !expr
->symtree
->n
.sym
->attr
.allocatable
7649 && !expr
->symtree
->n
.sym
->attr
.pointer
7650 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7651 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7653 /* Set the offset to -1. */
7655 mpz_init_set_si (minus_one
, -1);
7656 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7657 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7661 /* Only the callee knows what the correct offset it, so just set
7663 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7668 /* For class arrays add the class tree into the saved descriptor to
7669 enable getting of _vptr and the like. */
7670 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7671 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7673 gfc_allocate_lang_decl (desc
);
7674 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7675 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7676 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7677 : expr
->symtree
->n
.sym
->backend_decl
;
7679 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7680 && IS_CLASS_ARRAY (expr
))
7683 gfc_allocate_lang_decl (desc
);
7684 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7685 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7686 vtype
= gfc_class_vptr_get (tmp
);
7687 gfc_add_modify (&se
->pre
, vtype
,
7688 gfc_build_addr_expr (TREE_TYPE (vtype
),
7689 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7691 if (!se
->direct_byref
|| se
->byref_noassign
)
7693 /* Get a pointer to the new descriptor. */
7694 if (se
->want_pointer
)
7695 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7700 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7701 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7703 /* Cleanup the scalarizer. */
7704 gfc_cleanup_loop (&loop
);
7707 /* Helper function for gfc_conv_array_parameter if array size needs to be
7711 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7714 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7715 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7716 else if (expr
->rank
> 1)
7717 *size
= build_call_expr_loc (input_location
,
7718 gfor_fndecl_size0
, 1,
7719 gfc_build_addr_expr (NULL
, desc
));
7722 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7723 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7725 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7726 gfc_array_index_type
, ubound
, lbound
);
7727 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7728 *size
, gfc_index_one_node
);
7729 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7730 *size
, gfc_index_zero_node
);
7732 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7733 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7734 *size
, fold_convert (gfc_array_index_type
, elem
));
7737 /* Convert an array for passing as an actual parameter. */
7738 /* TODO: Optimize passing g77 arrays. */
7741 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7742 const gfc_symbol
*fsym
, const char *proc_name
,
7747 tree tmp
= NULL_TREE
;
7749 tree parent
= DECL_CONTEXT (current_function_decl
);
7750 bool full_array_var
;
7751 bool this_array_result
;
7754 bool array_constructor
;
7755 bool good_allocatable
;
7756 bool ultimate_ptr_comp
;
7757 bool ultimate_alloc_comp
;
7762 ultimate_ptr_comp
= false;
7763 ultimate_alloc_comp
= false;
7765 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7767 if (ref
->next
== NULL
)
7770 if (ref
->type
== REF_COMPONENT
)
7772 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7773 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7777 full_array_var
= false;
7780 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7781 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7783 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7785 /* The symbol should have an array specification. */
7786 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7788 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7790 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7791 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7792 se
->string_length
= tmp
;
7795 /* Is this the result of the enclosing procedure? */
7796 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7797 if (this_array_result
7798 && (sym
->backend_decl
!= current_function_decl
)
7799 && (sym
->backend_decl
!= parent
))
7800 this_array_result
= false;
7802 /* Passing address of the array if it is not pointer or assumed-shape. */
7803 if (full_array_var
&& g77
&& !this_array_result
7804 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7806 tmp
= gfc_get_symbol_decl (sym
);
7808 if (sym
->ts
.type
== BT_CHARACTER
)
7809 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7811 if (!sym
->attr
.pointer
7813 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7814 && sym
->as
->type
!= AS_DEFERRED
7815 && sym
->as
->type
!= AS_ASSUMED_RANK
7816 && !sym
->attr
.allocatable
)
7818 /* Some variables are declared directly, others are declared as
7819 pointers and allocated on the heap. */
7820 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7823 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7825 array_parameter_size (tmp
, expr
, size
);
7829 if (sym
->attr
.allocatable
)
7831 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7833 gfc_conv_expr_descriptor (se
, expr
);
7837 array_parameter_size (tmp
, expr
, size
);
7838 se
->expr
= gfc_conv_array_data (tmp
);
7843 /* A convenient reduction in scope. */
7844 contiguous
= g77
&& !this_array_result
&& contiguous
;
7846 /* There is no need to pack and unpack the array, if it is contiguous
7847 and not a deferred- or assumed-shape array, or if it is simply
7849 no_pack
= ((sym
&& sym
->as
7850 && !sym
->attr
.pointer
7851 && sym
->as
->type
!= AS_DEFERRED
7852 && sym
->as
->type
!= AS_ASSUMED_RANK
7853 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7855 (ref
&& ref
->u
.ar
.as
7856 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7857 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7858 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7860 gfc_is_simply_contiguous (expr
, false, true));
7862 no_pack
= contiguous
&& no_pack
;
7864 /* Array constructors are always contiguous and do not need packing. */
7865 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7867 /* Same is true of contiguous sections from allocatable variables. */
7868 good_allocatable
= contiguous
7870 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7872 /* Or ultimate allocatable components. */
7873 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7875 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7877 gfc_conv_expr_descriptor (se
, expr
);
7878 /* Deallocate the allocatable components of structures that are
7880 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7881 && expr
->ts
.u
.derived
->attr
.alloc_comp
7882 && expr
->expr_type
!= EXPR_VARIABLE
)
7884 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7886 /* The components shall be deallocated before their containing entity. */
7887 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7889 if (expr
->ts
.type
== BT_CHARACTER
)
7890 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7892 array_parameter_size (se
->expr
, expr
, size
);
7893 se
->expr
= gfc_conv_array_data (se
->expr
);
7897 if (this_array_result
)
7899 /* Result of the enclosing function. */
7900 gfc_conv_expr_descriptor (se
, expr
);
7902 array_parameter_size (se
->expr
, expr
, size
);
7903 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7905 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7906 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7907 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7914 /* Every other type of array. */
7915 se
->want_pointer
= 1;
7916 gfc_conv_expr_descriptor (se
, expr
);
7919 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7924 /* Deallocate the allocatable components of structures that are
7925 not variable, for descriptorless arguments.
7926 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7927 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7928 && expr
->ts
.u
.derived
->attr
.alloc_comp
7929 && expr
->expr_type
!= EXPR_VARIABLE
)
7931 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7932 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7934 /* The components shall be deallocated before their containing entity. */
7935 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7938 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7939 && !gfc_is_simply_contiguous (expr
, false, true)))
7941 tree origptr
= NULL_TREE
;
7945 /* For contiguous arrays, save the original value of the descriptor. */
7948 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7949 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7950 tmp
= gfc_conv_array_data (tmp
);
7951 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7952 TREE_TYPE (origptr
), origptr
,
7953 fold_convert (TREE_TYPE (origptr
), tmp
));
7954 gfc_add_expr_to_block (&se
->pre
, tmp
);
7957 /* Repack the array. */
7958 if (warn_array_temporaries
)
7961 gfc_warning (OPT_Warray_temporaries
,
7962 "Creating array temporary at %L for argument %qs",
7963 &expr
->where
, fsym
->name
);
7965 gfc_warning (OPT_Warray_temporaries
,
7966 "Creating array temporary at %L", &expr
->where
);
7969 ptr
= build_call_expr_loc (input_location
,
7970 gfor_fndecl_in_pack
, 1, desc
);
7972 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7974 tmp
= gfc_conv_expr_present (sym
);
7975 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7976 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7977 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7980 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7982 /* Use the packed data for the actual argument, except for contiguous arrays,
7983 where the descriptor's data component is set. */
7988 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7990 gfc_ss
* ss
= gfc_walk_expr (expr
);
7991 if (!transposed_dims (ss
))
7992 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7995 tree old_field
, new_field
;
7997 /* The original descriptor has transposed dims so we can't reuse
7998 it directly; we have to create a new one. */
7999 tree old_desc
= tmp
;
8000 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
8002 old_field
= gfc_conv_descriptor_dtype (old_desc
);
8003 new_field
= gfc_conv_descriptor_dtype (new_desc
);
8004 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8006 old_field
= gfc_conv_descriptor_offset (old_desc
);
8007 new_field
= gfc_conv_descriptor_offset (new_desc
);
8008 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8010 for (int i
= 0; i
< expr
->rank
; i
++)
8012 old_field
= gfc_conv_descriptor_dimension (old_desc
,
8013 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
8014 new_field
= gfc_conv_descriptor_dimension (new_desc
,
8016 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8019 if (flag_coarray
== GFC_FCOARRAY_LIB
8020 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
8021 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
8022 == GFC_ARRAY_ALLOCATABLE
)
8024 old_field
= gfc_conv_descriptor_token (old_desc
);
8025 new_field
= gfc_conv_descriptor_token (new_desc
);
8026 gfc_add_modify (&se
->pre
, new_field
, old_field
);
8029 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
8030 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
8035 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
8039 if (fsym
&& proc_name
)
8040 msg
= xasprintf ("An array temporary was created for argument "
8041 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
8043 msg
= xasprintf ("An array temporary was created");
8045 tmp
= build_fold_indirect_ref_loc (input_location
,
8047 tmp
= gfc_conv_array_data (tmp
);
8048 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8049 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8051 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8052 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8054 gfc_conv_expr_present (sym
), tmp
);
8056 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
8061 gfc_start_block (&block
);
8063 /* Copy the data back. */
8064 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
8066 tmp
= build_call_expr_loc (input_location
,
8067 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
8068 gfc_add_expr_to_block (&block
, tmp
);
8071 /* Free the temporary. */
8072 tmp
= gfc_call_free (ptr
);
8073 gfc_add_expr_to_block (&block
, tmp
);
8075 stmt
= gfc_finish_block (&block
);
8077 gfc_init_block (&block
);
8078 /* Only if it was repacked. This code needs to be executed before the
8079 loop cleanup code. */
8080 tmp
= build_fold_indirect_ref_loc (input_location
,
8082 tmp
= gfc_conv_array_data (tmp
);
8083 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8084 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
8086 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
8087 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8089 gfc_conv_expr_present (sym
), tmp
);
8091 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
8093 gfc_add_expr_to_block (&block
, tmp
);
8094 gfc_add_block_to_block (&block
, &se
->post
);
8096 gfc_init_block (&se
->post
);
8098 /* Reset the descriptor pointer. */
8101 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8102 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8105 gfc_add_block_to_block (&se
->post
, &block
);
8110 /* This helper function calculates the size in words of a full array. */
8113 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8118 idx
= gfc_rank_cst
[rank
- 1];
8119 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8120 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8121 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8123 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8124 tmp
, gfc_index_one_node
);
8125 tmp
= gfc_evaluate_now (tmp
, block
);
8127 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8128 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8130 return gfc_evaluate_now (tmp
, block
);
8134 /* Allocate dest to the same size as src, and copy src -> dest.
8135 If no_malloc is set, only the copy is done. */
8138 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8139 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8140 tree add_when_allocated
)
8149 /* If the source is null, set the destination to null. Then,
8150 allocate memory to the destination. */
8151 gfc_init_block (&block
);
8153 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8155 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8156 null_data
= gfc_finish_block (&block
);
8158 gfc_init_block (&block
);
8159 if (str_sz
!= NULL_TREE
)
8162 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8166 tmp
= gfc_call_malloc (&block
, type
, size
);
8167 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8172 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8173 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8174 fold_convert (size_type_node
, size
));
8175 gfc_add_expr_to_block (&block
, tmp
);
8180 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8181 null_data
= gfc_finish_block (&block
);
8183 gfc_init_block (&block
);
8185 nelems
= gfc_full_array_size (&block
, src
, rank
);
8187 nelems
= gfc_index_one_node
;
8189 if (str_sz
!= NULL_TREE
)
8190 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8192 tmp
= fold_convert (gfc_array_index_type
,
8193 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8194 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8198 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8199 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8200 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8203 /* We know the temporary and the value will be the same length,
8204 so can use memcpy. */
8207 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8208 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8209 gfc_conv_descriptor_data_get (dest
),
8210 gfc_conv_descriptor_data_get (src
),
8211 fold_convert (size_type_node
, size
));
8212 gfc_add_expr_to_block (&block
, tmp
);
8216 gfc_add_expr_to_block (&block
, add_when_allocated
);
8217 tmp
= gfc_finish_block (&block
);
8219 /* Null the destination if the source is null; otherwise do
8220 the allocate and copy. */
8221 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8224 null_cond
= gfc_conv_descriptor_data_get (src
);
8226 null_cond
= convert (pvoid_type_node
, null_cond
);
8227 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8228 null_cond
, null_pointer_node
);
8229 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8233 /* Allocate dest to the same size as src, and copy data src -> dest. */
8236 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8237 tree add_when_allocated
)
8239 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8240 NULL_TREE
, add_when_allocated
);
8244 /* Copy data src -> dest. */
8247 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8249 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8250 NULL_TREE
, NULL_TREE
);
8253 /* Allocate dest to the same size as src, but don't copy anything. */
8256 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8258 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8259 NULL_TREE
, NULL_TREE
);
8264 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8265 tree type
, int rank
)
8272 stmtblock_t block
, globalblock
;
8274 /* If the source is null, set the destination to null. Then,
8275 allocate memory to the destination. */
8276 gfc_init_block (&block
);
8277 gfc_init_block (&globalblock
);
8279 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8282 symbol_attribute attr
;
8285 gfc_init_se (&se
, NULL
);
8286 gfc_clear_attr (&attr
);
8287 attr
.allocatable
= 1;
8288 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8289 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8290 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8292 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8293 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8294 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8295 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8296 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8297 null_data
= gfc_finish_block (&block
);
8299 gfc_init_block (&block
);
8301 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8302 fold_convert (size_type_node
, size
),
8303 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8304 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8305 GFC_CAF_COARRAY_ALLOC
);
8307 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8308 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8309 fold_convert (size_type_node
, size
));
8310 gfc_add_expr_to_block (&block
, tmp
);
8314 /* Set the rank or unitialized memory access may be reported. */
8315 tmp
= gfc_conv_descriptor_rank (dest
);
8316 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8319 nelems
= gfc_full_array_size (&block
, src
, rank
);
8321 nelems
= integer_one_node
;
8323 tmp
= fold_convert (size_type_node
,
8324 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8325 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8326 fold_convert (size_type_node
, nelems
), tmp
);
8328 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8329 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8331 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8332 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8333 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8334 null_data
= gfc_finish_block (&block
);
8336 gfc_init_block (&block
);
8337 gfc_allocate_using_caf_lib (&block
, dest
,
8338 fold_convert (size_type_node
, size
),
8339 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8340 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8341 GFC_CAF_COARRAY_ALLOC
);
8343 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8344 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8345 gfc_conv_descriptor_data_get (dest
),
8346 gfc_conv_descriptor_data_get (src
),
8347 fold_convert (size_type_node
, size
));
8348 gfc_add_expr_to_block (&block
, tmp
);
8351 tmp
= gfc_finish_block (&block
);
8353 /* Null the destination if the source is null; otherwise do
8354 the register and copy. */
8355 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8358 null_cond
= gfc_conv_descriptor_data_get (src
);
8360 null_cond
= convert (pvoid_type_node
, null_cond
);
8361 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8362 null_cond
, null_pointer_node
);
8363 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8365 return gfc_finish_block (&globalblock
);
8369 /* Helper function to abstract whether coarray processing is enabled. */
8372 caf_enabled (int caf_mode
)
8374 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8375 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8379 /* Helper function to abstract whether coarray processing is enabled
8380 and we are in a derived type coarray. */
8383 caf_in_coarray (int caf_mode
)
8385 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8386 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8387 return (caf_mode
& pat
) == pat
;
8391 /* Helper function to abstract whether coarray is to deallocate only. */
8394 gfc_caf_is_dealloc_only (int caf_mode
)
8396 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8397 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8401 /* Recursively traverse an object of derived type, generating code to
8402 deallocate, nullify or copy allocatable components. This is the work horse
8403 function for the functions named in this enum. */
8405 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8406 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8407 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8409 static gfc_actual_arglist
*pdt_param_list
;
8412 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8413 tree dest
, int rank
, int purpose
, int caf_mode
)
8417 stmtblock_t fnblock
;
8418 stmtblock_t loopbody
;
8419 stmtblock_t tmpblock
;
8430 tree null_cond
= NULL_TREE
;
8431 tree add_when_allocated
;
8432 tree dealloc_fndecl
;
8436 symbol_attribute
*attr
;
8437 bool deallocate_called
;
8439 gfc_init_block (&fnblock
);
8441 decl_type
= TREE_TYPE (decl
);
8443 if ((POINTER_TYPE_P (decl_type
))
8444 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8446 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8447 /* Deref dest in sync with decl, but only when it is not NULL. */
8449 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8451 /* Update the decl_type because it got dereferenced. */
8452 decl_type
= TREE_TYPE (decl
);
8455 /* If this is an array of derived types with allocatable components
8456 build a loop and recursively call this function. */
8457 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8458 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8460 tmp
= gfc_conv_array_data (decl
);
8461 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8463 /* Get the number of elements - 1 and set the counter. */
8464 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8466 /* Use the descriptor for an allocatable array. Since this
8467 is a full array reference, we only need the descriptor
8468 information from dimension = rank. */
8469 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8470 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8471 gfc_array_index_type
, tmp
,
8472 gfc_index_one_node
);
8474 null_cond
= gfc_conv_descriptor_data_get (decl
);
8475 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8476 logical_type_node
, null_cond
,
8477 build_int_cst (TREE_TYPE (null_cond
), 0));
8481 /* Otherwise use the TYPE_DOMAIN information. */
8482 tmp
= array_type_nelts (decl_type
);
8483 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8486 /* Remember that this is, in fact, the no. of elements - 1. */
8487 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8488 index
= gfc_create_var (gfc_array_index_type
, "S");
8490 /* Build the body of the loop. */
8491 gfc_init_block (&loopbody
);
8493 vref
= gfc_build_array_ref (var
, index
, NULL
);
8495 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8496 && !caf_enabled (caf_mode
))
8498 tmp
= build_fold_indirect_ref_loc (input_location
,
8499 gfc_conv_array_data (dest
));
8500 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8501 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8502 COPY_ALLOC_COMP
, 0);
8505 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8508 gfc_add_expr_to_block (&loopbody
, tmp
);
8510 /* Build the loop and return. */
8511 gfc_init_loopinfo (&loop
);
8513 loop
.from
[0] = gfc_index_zero_node
;
8514 loop
.loopvar
[0] = index
;
8515 loop
.to
[0] = nelems
;
8516 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8517 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8519 tmp
= gfc_finish_block (&fnblock
);
8520 /* When copying allocateable components, the above implements the
8521 deep copy. Nevertheless is a deep copy only allowed, when the current
8522 component is allocated, for which code will be generated in
8523 gfc_duplicate_allocatable (), where the deep copy code is just added
8524 into the if's body, by adding tmp (the deep copy code) as last
8525 argument to gfc_duplicate_allocatable (). */
8526 if (purpose
== COPY_ALLOC_COMP
8527 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8528 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8530 else if (null_cond
!= NULL_TREE
)
8531 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8532 build_empty_stmt (input_location
));
8537 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8539 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8540 DEALLOCATE_PDT_COMP
, 0);
8541 gfc_add_expr_to_block (&fnblock
, tmp
);
8543 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8545 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8546 NULLIFY_ALLOC_COMP
, 0);
8547 gfc_add_expr_to_block (&fnblock
, tmp
);
8550 /* Otherwise, act on the components or recursively call self to
8551 act on a chain of components. */
8552 for (c
= der_type
->components
; c
; c
= c
->next
)
8554 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8555 || c
->ts
.type
== BT_CLASS
)
8556 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8557 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8558 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8560 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8561 && c
->ts
.u
.derived
->attr
.pdt_type
;
8563 cdecl = c
->backend_decl
;
8564 ctype
= TREE_TYPE (cdecl);
8568 case DEALLOCATE_ALLOC_COMP
:
8570 gfc_init_block (&tmpblock
);
8572 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8573 decl
, cdecl, NULL_TREE
);
8575 /* Shortcut to get the attributes of the component. */
8576 if (c
->ts
.type
== BT_CLASS
)
8578 attr
= &CLASS_DATA (c
)->attr
;
8579 if (attr
->class_pointer
)
8589 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8590 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8591 /* Call the finalizer, which will free the memory and nullify the
8592 pointer of an array. */
8593 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8594 caf_enabled (caf_mode
))
8597 deallocate_called
= false;
8599 /* Add the _class ref for classes. */
8600 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8601 comp
= gfc_class_data_get (comp
);
8603 add_when_allocated
= NULL_TREE
;
8604 if (cmp_has_alloc_comps
8605 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8607 && !deallocate_called
)
8609 /* Add checked deallocation of the components. This code is
8610 obviously added because the finalizer is not trusted to free
8612 if (c
->ts
.type
== BT_CLASS
)
8614 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8616 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8617 comp
, NULL_TREE
, rank
, purpose
,
8622 rank
= c
->as
? c
->as
->rank
: 0;
8623 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8630 if (attr
->allocatable
&& !same_type
8631 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8633 /* Handle all types of components besides components of the
8634 same_type as the current one, because those would create an
8637 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8638 ? (gfc_caf_is_dealloc_only (caf_mode
)
8639 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8640 : GFC_CAF_COARRAY_DEREGISTER
)
8641 : GFC_CAF_COARRAY_NOCOARRAY
;
8643 caf_token
= NULL_TREE
;
8644 /* Coarray components are handled directly by
8645 deallocate_with_status. */
8646 if (!attr
->codimension
8647 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8650 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8651 TREE_TYPE (c
->caf_token
),
8652 decl
, c
->caf_token
, NULL_TREE
);
8653 else if (attr
->dimension
&& !attr
->proc_pointer
)
8654 caf_token
= gfc_conv_descriptor_token (comp
);
8656 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8657 /* When this is an array but not in conjunction with a coarray
8658 then add the data-ref. For coarray'ed arrays the data-ref
8659 is added by deallocate_with_status. */
8660 comp
= gfc_conv_descriptor_data_get (comp
);
8662 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8663 NULL_TREE
, NULL_TREE
, true,
8664 NULL
, caf_dereg_mode
,
8665 add_when_allocated
, caf_token
);
8667 gfc_add_expr_to_block (&tmpblock
, tmp
);
8669 else if (attr
->allocatable
&& !attr
->codimension
8670 && !deallocate_called
)
8672 /* Case of recursive allocatable derived types. */
8676 stmtblock_t dealloc_block
;
8678 gfc_init_block (&dealloc_block
);
8679 if (add_when_allocated
)
8680 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8682 /* Convert the component into a rank 1 descriptor type. */
8683 if (attr
->dimension
)
8685 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8686 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8687 c
->ts
.type
== BT_CLASS
8688 ? CLASS_DATA (c
)->as
->rank
8693 tmp
= TREE_TYPE (comp
);
8694 ubound
= build_int_cst (gfc_array_index_type
, 1);
8697 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8699 GFC_ARRAY_ALLOCATABLE
, false);
8701 cdesc
= gfc_create_var (cdesc
, "cdesc");
8702 DECL_ARTIFICIAL (cdesc
) = 1;
8704 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8705 gfc_get_dtype_rank_type (1, tmp
));
8706 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8707 gfc_index_zero_node
,
8708 gfc_index_one_node
);
8709 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8710 gfc_index_zero_node
,
8711 gfc_index_one_node
);
8712 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8713 gfc_index_zero_node
, ubound
);
8715 if (attr
->dimension
)
8716 comp
= gfc_conv_descriptor_data_get (comp
);
8718 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8720 /* Now call the deallocator. */
8721 vtab
= gfc_find_vtab (&c
->ts
);
8722 if (vtab
->backend_decl
== NULL
)
8723 gfc_get_symbol_decl (vtab
);
8724 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8725 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8726 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8728 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8729 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8730 logical_type_node
, tmp
,
8732 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8734 tmp
= build_call_expr_loc (input_location
,
8737 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8739 tmp
= gfc_finish_block (&dealloc_block
);
8741 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8742 void_type_node
, is_allocated
, tmp
,
8743 build_empty_stmt (input_location
));
8745 gfc_add_expr_to_block (&tmpblock
, tmp
);
8747 else if (add_when_allocated
)
8748 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8750 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8751 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8753 /* Finally, reset the vptr to the declared type vtable and, if
8754 necessary reset the _len field.
8756 First recover the reference to the component and obtain
8758 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8759 decl
, cdecl, NULL_TREE
);
8760 tmp
= gfc_class_vptr_get (comp
);
8762 if (UNLIMITED_POLY (c
))
8764 /* Both vptr and _len field should be nulled. */
8765 gfc_add_modify (&tmpblock
, tmp
,
8766 build_int_cst (TREE_TYPE (tmp
), 0));
8767 tmp
= gfc_class_len_get (comp
);
8768 gfc_add_modify (&tmpblock
, tmp
,
8769 build_int_cst (TREE_TYPE (tmp
), 0));
8773 /* Build the vtable address and set the vptr with it. */
8776 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8777 vtab
= vtable
->backend_decl
;
8778 if (vtab
== NULL_TREE
)
8779 vtab
= gfc_get_symbol_decl (vtable
);
8780 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8781 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8782 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8786 /* Now add the deallocation of this component. */
8787 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8790 case NULLIFY_ALLOC_COMP
:
8792 - allocatable components (regular or in class)
8793 - components that have allocatable components
8794 - pointer components when in a coarray.
8795 Skip everything else especially proc_pointers, which may come
8796 coupled with the regular pointer attribute. */
8797 if (c
->attr
.proc_pointer
8798 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8799 && CLASS_DATA (c
)->attr
.allocatable
)
8800 || (cmp_has_alloc_comps
8801 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8802 || (c
->ts
.type
== BT_CLASS
8803 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8804 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8807 /* Process class components first, because they always have the
8808 pointer-attribute set which would be caught wrong else. */
8809 if (c
->ts
.type
== BT_CLASS
8810 && (CLASS_DATA (c
)->attr
.allocatable
8811 || CLASS_DATA (c
)->attr
.class_pointer
))
8813 /* Allocatable CLASS components. */
8814 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8815 decl
, cdecl, NULL_TREE
);
8817 comp
= gfc_class_data_get (comp
);
8818 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8819 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8823 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8824 void_type_node
, comp
,
8825 build_int_cst (TREE_TYPE (comp
), 0));
8826 gfc_add_expr_to_block (&fnblock
, tmp
);
8828 cmp_has_alloc_comps
= false;
8830 /* Coarrays need the component to be nulled before the api-call
8832 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8834 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8835 decl
, cdecl, NULL_TREE
);
8836 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8837 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8840 gfc_add_modify (&fnblock
, comp
,
8841 build_int_cst (TREE_TYPE (comp
), 0));
8842 if (gfc_deferred_strlen (c
, &comp
))
8844 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8846 decl
, comp
, NULL_TREE
);
8847 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8848 TREE_TYPE (comp
), comp
,
8849 build_int_cst (TREE_TYPE (comp
), 0));
8850 gfc_add_expr_to_block (&fnblock
, tmp
);
8852 cmp_has_alloc_comps
= false;
8855 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
8857 /* Register a component of a derived type coarray with the
8858 coarray library. Do not register ultimate component
8859 coarrays here. They are treated like regular coarrays and
8860 are either allocated on all images or on none. */
8863 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8864 decl
, cdecl, NULL_TREE
);
8865 if (c
->attr
.dimension
)
8867 /* Set the dtype, because caf_register needs it. */
8868 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8869 gfc_get_dtype (TREE_TYPE (comp
)));
8870 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8871 decl
, cdecl, NULL_TREE
);
8872 token
= gfc_conv_descriptor_token (tmp
);
8878 gfc_init_se (&se
, NULL
);
8879 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8880 pvoid_type_node
, decl
, c
->caf_token
,
8882 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8883 c
->ts
.type
== BT_CLASS
8884 ? CLASS_DATA (c
)->attr
8886 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8889 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8890 gfc_build_addr_expr (NULL_TREE
,
8892 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8893 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8896 if (cmp_has_alloc_comps
)
8898 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8899 decl
, cdecl, NULL_TREE
);
8900 rank
= c
->as
? c
->as
->rank
: 0;
8901 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8902 rank
, purpose
, caf_mode
);
8903 gfc_add_expr_to_block (&fnblock
, tmp
);
8907 case REASSIGN_CAF_COMP
:
8908 if (caf_enabled (caf_mode
)
8909 && (c
->attr
.codimension
8910 || (c
->ts
.type
== BT_CLASS
8911 && (CLASS_DATA (c
)->attr
.coarray_comp
8912 || caf_in_coarray (caf_mode
)))
8913 || (c
->ts
.type
== BT_DERIVED
8914 && (c
->ts
.u
.derived
->attr
.coarray_comp
8915 || caf_in_coarray (caf_mode
))))
8918 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8919 decl
, cdecl, NULL_TREE
);
8920 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8921 dest
, cdecl, NULL_TREE
);
8923 if (c
->attr
.codimension
)
8925 if (c
->ts
.type
== BT_CLASS
)
8927 comp
= gfc_class_data_get (comp
);
8928 dcmp
= gfc_class_data_get (dcmp
);
8930 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8931 gfc_conv_descriptor_data_get (comp
));
8935 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8936 rank
, purpose
, caf_mode
8937 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8938 gfc_add_expr_to_block (&fnblock
, tmp
);
8943 case COPY_ALLOC_COMP
:
8944 if (c
->attr
.pointer
|| c
->attr
.proc_pointer
)
8947 /* We need source and destination components. */
8948 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8950 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8952 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8954 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8962 dst_data
= gfc_class_data_get (dcmp
);
8963 src_data
= gfc_class_data_get (comp
);
8964 size
= fold_convert (size_type_node
,
8965 gfc_class_vtab_size_get (comp
));
8967 if (CLASS_DATA (c
)->attr
.dimension
)
8969 nelems
= gfc_conv_descriptor_size (src_data
,
8970 CLASS_DATA (c
)->as
->rank
);
8971 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8972 size_type_node
, size
,
8973 fold_convert (size_type_node
,
8977 nelems
= build_int_cst (size_type_node
, 1);
8979 if (CLASS_DATA (c
)->attr
.dimension
8980 || CLASS_DATA (c
)->attr
.codimension
)
8982 src_data
= gfc_conv_descriptor_data_get (src_data
);
8983 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8986 gfc_init_block (&tmpblock
);
8988 gfc_add_modify (&tmpblock
, gfc_class_vptr_get (dcmp
),
8989 gfc_class_vptr_get (comp
));
8991 /* Copy the unlimited '_len' field. If it is greater than zero
8992 (ie. a character(_len)), multiply it by size and use this
8993 for the malloc call. */
8994 if (UNLIMITED_POLY (c
))
8997 gfc_add_modify (&tmpblock
, gfc_class_len_get (dcmp
),
8998 gfc_class_len_get (comp
));
9000 size
= gfc_evaluate_now (size
, &tmpblock
);
9001 tmp
= gfc_class_len_get (comp
);
9002 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9003 size_type_node
, size
,
9004 fold_convert (size_type_node
, tmp
));
9005 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9006 logical_type_node
, tmp
,
9007 build_zero_cst (TREE_TYPE (tmp
)));
9008 size
= fold_build3_loc (input_location
, COND_EXPR
,
9009 size_type_node
, tmp
, ctmp
, size
);
9010 size
= gfc_evaluate_now (size
, &tmpblock
);
9013 /* Coarray component have to have the same allocation status and
9014 shape/type-parameter/effective-type on the LHS and RHS of an
9015 intrinsic assignment. Hence, we did not deallocated them - and
9016 do not allocate them here. */
9017 if (!CLASS_DATA (c
)->attr
.codimension
)
9019 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
9020 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
9021 gfc_add_modify (&tmpblock
, dst_data
,
9022 fold_convert (TREE_TYPE (dst_data
), tmp
));
9025 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
9026 UNLIMITED_POLY (c
));
9027 gfc_add_expr_to_block (&tmpblock
, tmp
);
9028 tmp
= gfc_finish_block (&tmpblock
);
9030 gfc_init_block (&tmpblock
);
9031 gfc_add_modify (&tmpblock
, dst_data
,
9032 fold_convert (TREE_TYPE (dst_data
),
9033 null_pointer_node
));
9034 null_data
= gfc_finish_block (&tmpblock
);
9036 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9037 logical_type_node
, src_data
,
9040 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
9045 /* To implement guarded deep copy, i.e., deep copy only allocatable
9046 components that are really allocated, the deep copy code has to
9047 be generated first and then added to the if-block in
9048 gfc_duplicate_allocatable (). */
9049 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
9051 rank
= c
->as
? c
->as
->rank
: 0;
9052 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
9053 gfc_add_modify (&fnblock
, dcmp
, tmp
);
9054 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
9060 add_when_allocated
= NULL_TREE
;
9062 if (gfc_deferred_strlen (c
, &tmp
))
9066 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
9068 decl
, len
, NULL_TREE
);
9069 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
9071 dest
, len
, NULL_TREE
);
9072 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9073 TREE_TYPE (len
), len
, tmp
);
9074 gfc_add_expr_to_block (&fnblock
, tmp
);
9075 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
9076 /* This component can not have allocatable components,
9077 therefore add_when_allocated of duplicate_allocatable ()
9079 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9080 false, false, size
, NULL_TREE
);
9081 gfc_add_expr_to_block (&fnblock
, tmp
);
9083 else if (c
->attr
.pdt_array
)
9085 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
9086 c
->as
? c
->as
->rank
: 0,
9087 false, false, NULL_TREE
, NULL_TREE
);
9088 gfc_add_expr_to_block (&fnblock
, tmp
);
9090 else if ((c
->attr
.allocatable
)
9091 && !c
->attr
.proc_pointer
&& !same_type
9092 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
9093 || caf_in_coarray (caf_mode
)))
9095 rank
= c
->as
? c
->as
->rank
: 0;
9096 if (c
->attr
.codimension
)
9097 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
9098 else if (flag_coarray
== GFC_FCOARRAY_LIB
9099 && caf_in_coarray (caf_mode
))
9101 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
9102 : fold_build3_loc (input_location
,
9104 pvoid_type_node
, dest
,
9107 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
9111 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
9112 add_when_allocated
);
9113 gfc_add_expr_to_block (&fnblock
, tmp
);
9116 if (cmp_has_alloc_comps
|| is_pdt_type
)
9117 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
9121 case ALLOCATE_PDT_COMP
:
9123 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9124 decl
, cdecl, NULL_TREE
);
9126 /* Set the PDT KIND and LEN fields. */
9127 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9130 gfc_expr
*c_expr
= NULL
;
9131 gfc_actual_arglist
*param
= pdt_param_list
;
9132 gfc_init_se (&tse
, NULL
);
9133 for (; param
; param
= param
->next
)
9134 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9135 c_expr
= param
->expr
;
9138 c_expr
= c
->initializer
;
9142 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9143 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9147 if (c
->attr
.pdt_string
)
9150 gfc_init_se (&tse
, NULL
);
9151 tree strlen
= NULL_TREE
;
9152 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9153 /* Convert the parameterized string length to its value. The
9154 string length is stored in a hidden field in the same way as
9155 deferred string lengths. */
9156 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9157 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9159 gfc_conv_expr_type (&tse
, e
,
9160 TREE_TYPE (strlen
));
9161 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9163 decl
, strlen
, NULL_TREE
);
9164 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9165 c
->ts
.u
.cl
->backend_decl
= strlen
;
9169 /* Scalar parameterized strings can be allocated now. */
9172 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9173 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9174 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9175 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9176 gfc_add_modify (&fnblock
, comp
, tmp
);
9180 /* Allocate parameterized arrays of parameterized derived types. */
9181 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9182 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9183 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9186 if (c
->ts
.type
== BT_CLASS
)
9187 comp
= gfc_class_data_get (comp
);
9189 if (c
->attr
.pdt_array
)
9193 tree size
= gfc_index_one_node
;
9194 tree offset
= gfc_index_zero_node
;
9198 /* This chunk takes the expressions for 'lower' and 'upper'
9199 in the arrayspec and substitutes in the expressions for
9200 the parameters from 'pdt_param_list'. The descriptor
9201 fields can then be filled from the values so obtained. */
9202 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9203 for (i
= 0; i
< c
->as
->rank
; i
++)
9205 gfc_init_se (&tse
, NULL
);
9206 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9207 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9208 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9211 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9214 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9215 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9216 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9219 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9222 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9225 size
= gfc_evaluate_now (size
, &fnblock
);
9226 offset
= fold_build2_loc (input_location
,
9228 gfc_array_index_type
,
9230 offset
= gfc_evaluate_now (offset
, &fnblock
);
9231 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9232 gfc_array_index_type
,
9234 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9235 gfc_array_index_type
,
9236 tmp
, gfc_index_one_node
);
9237 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9238 gfc_array_index_type
, size
, tmp
);
9240 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9241 if (c
->ts
.type
== BT_CLASS
)
9243 tmp
= gfc_get_vptr_from_expr (comp
);
9244 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9245 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9246 tmp
= gfc_vptr_size_get (tmp
);
9249 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9250 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9251 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9252 gfc_array_index_type
, size
, tmp
);
9253 size
= gfc_evaluate_now (size
, &fnblock
);
9254 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9255 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9256 tmp
= gfc_conv_descriptor_dtype (comp
);
9257 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9259 if (c
->initializer
&& c
->initializer
->rank
)
9261 gfc_init_se (&tse
, NULL
);
9262 e
= gfc_copy_expr (c
->initializer
);
9263 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9264 gfc_conv_expr_descriptor (&tse
, e
);
9265 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9267 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9268 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9269 gfc_conv_descriptor_data_get (comp
),
9270 gfc_conv_descriptor_data_get (tse
.expr
),
9271 fold_convert (size_type_node
, size
));
9272 gfc_add_expr_to_block (&fnblock
, tmp
);
9273 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9277 /* Recurse in to PDT components. */
9278 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9279 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9280 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9282 bool is_deferred
= false;
9283 gfc_actual_arglist
*tail
= c
->param_list
;
9285 for (; tail
; tail
= tail
->next
)
9289 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9290 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9291 c
->as
? c
->as
->rank
: 0,
9293 gfc_add_expr_to_block (&fnblock
, tmp
);
9298 case DEALLOCATE_PDT_COMP
:
9299 /* Deallocate array or parameterized string length components
9300 of parameterized derived types. */
9301 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9302 && !c
->attr
.pdt_string
9303 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9304 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9307 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9308 decl
, cdecl, NULL_TREE
);
9309 if (c
->ts
.type
== BT_CLASS
)
9310 comp
= gfc_class_data_get (comp
);
9312 /* Recurse in to PDT components. */
9313 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9314 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9315 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9317 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9318 c
->as
? c
->as
->rank
: 0);
9319 gfc_add_expr_to_block (&fnblock
, tmp
);
9322 if (c
->attr
.pdt_array
)
9324 tmp
= gfc_conv_descriptor_data_get (comp
);
9325 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9326 logical_type_node
, tmp
,
9327 build_int_cst (TREE_TYPE (tmp
), 0));
9328 tmp
= gfc_call_free (tmp
);
9329 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9330 build_empty_stmt (input_location
));
9331 gfc_add_expr_to_block (&fnblock
, tmp
);
9332 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9334 else if (c
->attr
.pdt_string
)
9336 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9337 logical_type_node
, comp
,
9338 build_int_cst (TREE_TYPE (comp
), 0));
9339 tmp
= gfc_call_free (comp
);
9340 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9341 build_empty_stmt (input_location
));
9342 gfc_add_expr_to_block (&fnblock
, tmp
);
9343 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9344 gfc_add_modify (&fnblock
, comp
, tmp
);
9349 case CHECK_PDT_DUMMY
:
9351 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9352 decl
, cdecl, NULL_TREE
);
9353 if (c
->ts
.type
== BT_CLASS
)
9354 comp
= gfc_class_data_get (comp
);
9356 /* Recurse in to PDT components. */
9357 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9358 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9360 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9361 c
->as
? c
->as
->rank
: 0,
9363 gfc_add_expr_to_block (&fnblock
, tmp
);
9366 if (!c
->attr
.pdt_len
)
9371 gfc_expr
*c_expr
= NULL
;
9372 gfc_actual_arglist
*param
= pdt_param_list
;
9374 gfc_init_se (&tse
, NULL
);
9375 for (; param
; param
= param
->next
)
9376 if (!strcmp (c
->name
, param
->name
)
9377 && param
->spec_type
== SPEC_EXPLICIT
)
9378 c_expr
= param
->expr
;
9382 tree error
, cond
, cname
;
9383 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9384 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9387 cname
= gfc_build_cstring_const (c
->name
);
9388 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9389 error
= gfc_trans_runtime_error (true, NULL
,
9390 "The value of the PDT LEN "
9391 "parameter '%s' does not "
9392 "agree with that in the "
9393 "dummy declaration",
9395 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9396 void_type_node
, cond
, error
,
9397 build_empty_stmt (input_location
));
9398 gfc_add_expr_to_block (&fnblock
, tmp
);
9409 return gfc_finish_block (&fnblock
);
9412 /* Recursively traverse an object of derived type, generating code to
9413 nullify allocatable components. */
9416 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9419 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9421 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9425 /* Recursively traverse an object of derived type, generating code to
9426 deallocate allocatable components. */
9429 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9432 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9433 DEALLOCATE_ALLOC_COMP
,
9434 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9438 /* Recursively traverse an object of derived type, generating code to
9439 deallocate allocatable components. But do not deallocate coarrays.
9440 To be used for intrinsic assignment, which may not change the allocation
9441 status of coarrays. */
9444 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9446 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9447 DEALLOCATE_ALLOC_COMP
, 0);
9452 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9454 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9455 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9459 /* Recursively traverse an object of derived type, generating code to
9460 copy it and its allocatable components. */
9463 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9466 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9471 /* Recursively traverse an object of derived type, generating code to
9472 copy only its allocatable components. */
9475 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9477 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9478 COPY_ONLY_ALLOC_COMP
, 0);
9482 /* Recursively traverse an object of paramterized derived type, generating
9483 code to allocate parameterized components. */
9486 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9487 gfc_actual_arglist
*param_list
)
9490 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9491 pdt_param_list
= param_list
;
9492 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9493 ALLOCATE_PDT_COMP
, 0);
9494 pdt_param_list
= old_param_list
;
9498 /* Recursively traverse an object of paramterized derived type, generating
9499 code to deallocate parameterized components. */
9502 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9504 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9505 DEALLOCATE_PDT_COMP
, 0);
9509 /* Recursively traverse a dummy of paramterized derived type to check the
9510 values of LEN parameters. */
9513 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9514 gfc_actual_arglist
*param_list
)
9517 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9518 pdt_param_list
= param_list
;
9519 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9520 CHECK_PDT_DUMMY
, 0);
9521 pdt_param_list
= old_param_list
;
9526 /* Returns the value of LBOUND for an expression. This could be broken out
9527 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9528 called by gfc_alloc_allocatable_for_assignment. */
9530 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9535 tree cond
, cond1
, cond3
, cond4
;
9539 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9541 tmp
= gfc_rank_cst
[dim
];
9542 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9543 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9544 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9545 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9547 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9548 stride
, gfc_index_zero_node
);
9549 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9550 logical_type_node
, cond3
, cond1
);
9551 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9552 stride
, gfc_index_zero_node
);
9554 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9555 tmp
, build_int_cst (gfc_array_index_type
,
9558 cond
= logical_false_node
;
9560 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9561 logical_type_node
, cond3
, cond4
);
9562 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9563 logical_type_node
, cond
, cond1
);
9565 return fold_build3_loc (input_location
, COND_EXPR
,
9566 gfc_array_index_type
, cond
,
9567 lbound
, gfc_index_one_node
);
9570 if (expr
->expr_type
== EXPR_FUNCTION
)
9572 /* A conversion function, so use the argument. */
9573 gcc_assert (expr
->value
.function
.isym
9574 && expr
->value
.function
.isym
->conversion
);
9575 expr
= expr
->value
.function
.actual
->expr
;
9578 if (expr
->expr_type
== EXPR_VARIABLE
)
9580 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9581 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9583 if (ref
->type
== REF_COMPONENT
9584 && ref
->u
.c
.component
->as
9586 && ref
->next
->u
.ar
.type
== AR_FULL
)
9587 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9589 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9592 return gfc_index_one_node
;
9596 /* Returns true if an expression represents an lhs that can be reallocated
9600 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9608 sym
= expr
->symtree
->n
.sym
;
9610 if (sym
->attr
.associate_var
&& !expr
->ref
)
9613 /* An allocatable class variable with no reference. */
9614 if (sym
->ts
.type
== BT_CLASS
9615 && !sym
->attr
.associate_var
9616 && CLASS_DATA (sym
)->attr
.allocatable
9617 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
9618 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9619 && expr
->ref
->next
== NULL
)
9622 /* An allocatable variable. */
9623 if (sym
->attr
.allocatable
9624 && !sym
->attr
.associate_var
9626 && expr
->ref
->type
== REF_ARRAY
9627 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9630 /* All that can be left are allocatable components. */
9631 if ((sym
->ts
.type
!= BT_DERIVED
9632 && sym
->ts
.type
!= BT_CLASS
)
9633 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9636 /* Find a component ref followed by an array reference. */
9637 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9639 && ref
->type
== REF_COMPONENT
9640 && ref
->next
->type
== REF_ARRAY
9641 && !ref
->next
->next
)
9647 /* Return true if valid reallocatable lhs. */
9648 if (ref
->u
.c
.component
->attr
.allocatable
9649 && ref
->next
->u
.ar
.type
== AR_FULL
)
9657 concat_str_length (gfc_expr
* expr
)
9664 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9665 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9666 if (len1
== NULL_TREE
)
9668 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9669 len1
= concat_str_length (expr
->value
.op
.op1
);
9670 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9671 len1
= build_int_cst (gfc_charlen_type_node
,
9672 expr
->value
.op
.op1
->value
.character
.length
);
9673 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9675 gfc_init_se (&se
, NULL
);
9676 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9682 gfc_init_se (&se
, NULL
);
9683 se
.want_pointer
= 1;
9684 se
.descriptor_only
= 1;
9685 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9686 len1
= se
.string_length
;
9690 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9691 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9692 if (len2
== NULL_TREE
)
9694 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9695 len2
= concat_str_length (expr
->value
.op
.op2
);
9696 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9697 len2
= build_int_cst (gfc_charlen_type_node
,
9698 expr
->value
.op
.op2
->value
.character
.length
);
9699 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9701 gfc_init_se (&se
, NULL
);
9702 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9708 gfc_init_se (&se
, NULL
);
9709 se
.want_pointer
= 1;
9710 se
.descriptor_only
= 1;
9711 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9712 len2
= se
.string_length
;
9716 gcc_assert(len1
&& len2
);
9717 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9718 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9720 return fold_build2_loc (input_location
, PLUS_EXPR
,
9721 gfc_charlen_type_node
, len1
, len2
);
9725 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9729 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9733 stmtblock_t realloc_block
;
9734 stmtblock_t alloc_block
;
9738 gfc_array_info
*linfo
;
9760 gfc_array_spec
* as
;
9761 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9762 && gfc_caf_attr (expr1
, true).codimension
);
9766 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9767 Find the lhs expression in the loop chain and set expr1 and
9768 expr2 accordingly. */
9769 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9772 /* Find the ss for the lhs. */
9774 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9775 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9777 if (lss
== gfc_ss_terminator
)
9779 expr1
= lss
->info
->expr
;
9782 /* Bail out if this is not a valid allocate on assignment. */
9783 if (!gfc_is_reallocatable_lhs (expr1
)
9784 || (expr2
&& !expr2
->rank
))
9787 /* Find the ss for the lhs. */
9789 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9790 if (lss
->info
->expr
== expr1
)
9793 if (lss
== gfc_ss_terminator
)
9796 linfo
= &lss
->info
->data
.array
;
9798 /* Find an ss for the rhs. For operator expressions, we see the
9799 ss's for the operands. Any one of these will do. */
9801 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9802 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9805 if (expr2
&& rss
== gfc_ss_terminator
)
9808 /* Ensure that the string length from the current scope is used. */
9809 if (expr2
->ts
.type
== BT_CHARACTER
9810 && expr2
->expr_type
== EXPR_FUNCTION
9811 && !expr2
->value
.function
.isym
)
9812 expr2
->ts
.u
.cl
->backend_decl
= rss
->info
->string_length
;
9814 gfc_start_block (&fblock
);
9816 /* Since the lhs is allocatable, this must be a descriptor type.
9817 Get the data and array size. */
9818 desc
= linfo
->descriptor
;
9819 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9820 array1
= gfc_conv_descriptor_data_get (desc
);
9822 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9823 deallocated if expr is an array of different shape or any of the
9824 corresponding length type parameter values of variable and expr
9825 differ." This assures F95 compatibility. */
9826 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9827 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9829 /* Allocate if data is NULL. */
9830 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9831 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9833 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9835 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9837 lss
->info
->string_length
,
9838 rss
->info
->string_length
);
9839 cond_null
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9840 logical_type_node
, tmp
, cond_null
);
9843 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9845 tmp
= build3_v (COND_EXPR
, cond_null
,
9846 build1_v (GOTO_EXPR
, jump_label1
),
9847 build_empty_stmt (input_location
));
9848 gfc_add_expr_to_block (&fblock
, tmp
);
9850 /* Get arrayspec if expr is a full array. */
9851 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9852 && expr2
->value
.function
.isym
9853 && expr2
->value
.function
.isym
->conversion
)
9855 /* For conversion functions, take the arg. */
9856 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9857 as
= gfc_get_full_arrayspec_from_expr (arg
);
9860 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9864 /* If the lhs shape is not the same as the rhs jump to setting the
9865 bounds and doing the reallocation....... */
9866 for (n
= 0; n
< expr1
->rank
; n
++)
9868 /* Check the shape. */
9869 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9870 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9871 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9872 gfc_array_index_type
,
9873 loop
->to
[n
], loop
->from
[n
]);
9874 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9875 gfc_array_index_type
,
9877 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9878 gfc_array_index_type
,
9880 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9882 tmp
, gfc_index_zero_node
);
9883 tmp
= build3_v (COND_EXPR
, cond
,
9884 build1_v (GOTO_EXPR
, jump_label1
),
9885 build_empty_stmt (input_location
));
9886 gfc_add_expr_to_block (&fblock
, tmp
);
9889 /* ....else jump past the (re)alloc code. */
9890 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9891 gfc_add_expr_to_block (&fblock
, tmp
);
9893 /* Add the label to start automatic (re)allocation. */
9894 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9895 gfc_add_expr_to_block (&fblock
, tmp
);
9897 /* If the lhs has not been allocated, its bounds will not have been
9898 initialized and so its size is set to zero. */
9899 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9900 gfc_init_block (&alloc_block
);
9901 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9902 gfc_init_block (&realloc_block
);
9903 gfc_add_modify (&realloc_block
, size1
,
9904 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9905 tmp
= build3_v (COND_EXPR
, cond_null
,
9906 gfc_finish_block (&alloc_block
),
9907 gfc_finish_block (&realloc_block
));
9908 gfc_add_expr_to_block (&fblock
, tmp
);
9910 /* Get the rhs size and fix it. */
9912 desc2
= rss
->info
->data
.array
.descriptor
;
9916 size2
= gfc_index_one_node
;
9917 for (n
= 0; n
< expr2
->rank
; n
++)
9919 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9920 gfc_array_index_type
,
9921 loop
->to
[n
], loop
->from
[n
]);
9922 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9923 gfc_array_index_type
,
9924 tmp
, gfc_index_one_node
);
9925 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9926 gfc_array_index_type
,
9929 size2
= gfc_evaluate_now (size2
, &fblock
);
9931 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9934 /* If the lhs is deferred length, assume that the element size
9935 changes and force a reallocation. */
9936 if (expr1
->ts
.deferred
)
9937 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
9939 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9941 /* Deallocation of allocatable components will have to occur on
9942 reallocation. Fix the old descriptor now. */
9943 if ((expr1
->ts
.type
== BT_DERIVED
)
9944 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9945 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9947 old_desc
= NULL_TREE
;
9949 /* Now modify the lhs descriptor and the associated scalarizer
9950 variables. F2003 7.4.1.3: "If variable is or becomes an
9951 unallocated allocatable variable, then it is allocated with each
9952 deferred type parameter equal to the corresponding type parameters
9953 of expr , with the shape of expr , and with each lower bound equal
9954 to the corresponding element of LBOUND(expr)."
9955 Reuse size1 to keep a dimension-by-dimension track of the
9956 stride of the new array. */
9957 size1
= gfc_index_one_node
;
9958 offset
= gfc_index_zero_node
;
9960 for (n
= 0; n
< expr2
->rank
; n
++)
9962 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9963 gfc_array_index_type
,
9964 loop
->to
[n
], loop
->from
[n
]);
9965 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9966 gfc_array_index_type
,
9967 tmp
, gfc_index_one_node
);
9969 lbound
= gfc_index_one_node
;
9974 lbd
= get_std_lbound (expr2
, desc2
, n
,
9975 as
->type
== AS_ASSUMED_SIZE
);
9976 ubound
= fold_build2_loc (input_location
,
9978 gfc_array_index_type
,
9980 ubound
= fold_build2_loc (input_location
,
9982 gfc_array_index_type
,
9987 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9990 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9993 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9996 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9998 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9999 gfc_array_index_type
,
10001 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10002 gfc_array_index_type
,
10004 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
10005 gfc_array_index_type
,
10009 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
10010 the array offset is saved and the info.offset is used for a
10011 running offset. Use the saved_offset instead. */
10012 tmp
= gfc_conv_descriptor_offset (desc
);
10013 gfc_add_modify (&fblock
, tmp
, offset
);
10014 if (linfo
->saved_offset
10015 && VAR_P (linfo
->saved_offset
))
10016 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
10018 /* Now set the deltas for the lhs. */
10019 for (n
= 0; n
< expr1
->rank
; n
++)
10021 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10023 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10024 gfc_array_index_type
, tmp
,
10026 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
10027 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
10030 /* Get the new lhs size in bytes. */
10031 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10033 if (expr2
->ts
.deferred
)
10035 if (expr2
->ts
.u
.cl
->backend_decl
10036 && VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
10037 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10039 tmp
= rss
->info
->string_length
;
10043 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
10044 if (!tmp
&& expr2
->expr_type
== EXPR_OP
10045 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10047 tmp
= concat_str_length (expr2
);
10048 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10050 else if (!tmp
&& expr2
->ts
.u
.cl
->length
)
10053 gfc_init_se (&tmpse
, NULL
);
10054 gfc_conv_expr_type (&tmpse
, expr2
->ts
.u
.cl
->length
,
10055 gfc_charlen_type_node
);
10057 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
10059 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
10062 if (expr1
->ts
.u
.cl
->backend_decl
10063 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
10064 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
10066 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
10068 if (expr1
->ts
.kind
> 1)
10069 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10071 tmp
, build_int_cst (TREE_TYPE (tmp
),
10074 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
10076 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
10077 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10078 gfc_array_index_type
, tmp
,
10079 expr1
->ts
.u
.cl
->backend_decl
);
10081 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10082 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2
->ts
));
10084 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10085 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10087 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10088 gfc_conv_descriptor_span_set (&fblock
, desc
, tmp
);
10090 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
10091 gfc_array_index_type
,
10093 size2
= fold_convert (size_type_node
, size2
);
10094 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10095 size2
, size_one_node
);
10096 size2
= gfc_evaluate_now (size2
, &fblock
);
10098 /* For deferred character length, the 'size' field of the dtype might
10099 have changed so set the dtype. */
10100 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10101 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10104 tmp
= gfc_conv_descriptor_dtype (desc
);
10105 if (expr2
->ts
.u
.cl
->backend_decl
)
10106 type
= gfc_typenode_for_spec (&expr2
->ts
);
10108 type
= gfc_typenode_for_spec (&expr1
->ts
);
10110 gfc_add_modify (&fblock
, tmp
,
10111 gfc_get_dtype_rank_type (expr1
->rank
,type
));
10113 else if (UNLIMITED_POLY (expr1
) && expr2
->ts
.type
!= BT_CLASS
)
10116 tmp
= gfc_conv_descriptor_dtype (desc
);
10117 type
= gfc_typenode_for_spec (&expr2
->ts
);
10118 gfc_add_modify (&fblock
, tmp
,
10119 gfc_get_dtype_rank_type (expr2
->rank
,type
));
10120 /* Set the _len field as well... */
10121 tmp
= gfc_class_len_get (TREE_OPERAND (desc
, 0));
10122 if (expr2
->ts
.type
== BT_CHARACTER
)
10123 gfc_add_modify (&fblock
, tmp
,
10124 fold_convert (TREE_TYPE (tmp
),
10125 TYPE_SIZE_UNIT (type
)));
10127 gfc_add_modify (&fblock
, tmp
,
10128 build_int_cst (TREE_TYPE (tmp
), 0));
10129 /* ...and the vptr. */
10130 tmp
= gfc_class_vptr_get (TREE_OPERAND (desc
, 0));
10131 tmp2
= gfc_get_symbol_decl (gfc_find_vtab (&expr2
->ts
));
10132 tmp2
= gfc_build_addr_expr (TREE_TYPE (tmp
), tmp2
);
10133 gfc_add_modify (&fblock
, tmp
, tmp2
);
10135 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
10137 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
10138 gfc_get_dtype (TREE_TYPE (desc
)));
10141 /* Realloc expression. Note that the scalarizer uses desc.data
10142 in the array reference - (*desc.data)[<element>]. */
10143 gfc_init_block (&realloc_block
);
10144 gfc_init_se (&caf_se
, NULL
);
10148 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
10149 if (token
== NULL_TREE
)
10151 tmp
= gfc_get_tree_for_caf_expr (expr1
);
10152 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
10153 tmp
= build_fold_indirect_ref (tmp
);
10154 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
10156 token
= gfc_build_addr_expr (NULL_TREE
, token
);
10159 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
10161 if ((expr1
->ts
.type
== BT_DERIVED
)
10162 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10164 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
10166 gfc_add_expr_to_block (&realloc_block
, tmp
);
10171 tmp
= build_call_expr_loc (input_location
,
10172 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10173 fold_convert (pvoid_type_node
, array1
),
10175 gfc_conv_descriptor_data_set (&realloc_block
,
10180 tmp
= build_call_expr_loc (input_location
,
10181 gfor_fndecl_caf_deregister
, 5, token
,
10182 build_int_cst (integer_type_node
,
10183 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
10184 null_pointer_node
, null_pointer_node
,
10185 integer_zero_node
);
10186 gfc_add_expr_to_block (&realloc_block
, tmp
);
10187 tmp
= build_call_expr_loc (input_location
,
10188 gfor_fndecl_caf_register
,
10190 build_int_cst (integer_type_node
,
10191 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10192 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10193 null_pointer_node
, null_pointer_node
,
10194 integer_zero_node
);
10195 gfc_add_expr_to_block (&realloc_block
, tmp
);
10198 if ((expr1
->ts
.type
== BT_DERIVED
)
10199 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10201 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10203 gfc_add_expr_to_block (&realloc_block
, tmp
);
10206 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10207 realloc_expr
= gfc_finish_block (&realloc_block
);
10209 /* Only reallocate if sizes are different. */
10210 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10211 build_empty_stmt (input_location
));
10212 realloc_expr
= tmp
;
10215 /* Malloc expression. */
10216 gfc_init_block (&alloc_block
);
10219 tmp
= build_call_expr_loc (input_location
,
10220 builtin_decl_explicit (BUILT_IN_MALLOC
),
10222 gfc_conv_descriptor_data_set (&alloc_block
,
10227 tmp
= build_call_expr_loc (input_location
,
10228 gfor_fndecl_caf_register
,
10230 build_int_cst (integer_type_node
,
10231 GFC_CAF_COARRAY_ALLOC
),
10232 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10233 null_pointer_node
, null_pointer_node
,
10234 integer_zero_node
);
10235 gfc_add_expr_to_block (&alloc_block
, tmp
);
10239 /* We already set the dtype in the case of deferred character
10240 length arrays and unlimited polymorphic arrays. */
10241 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10242 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10244 && !UNLIMITED_POLY (expr1
))
10246 tmp
= gfc_conv_descriptor_dtype (desc
);
10247 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10250 if ((expr1
->ts
.type
== BT_DERIVED
)
10251 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10253 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10255 gfc_add_expr_to_block (&alloc_block
, tmp
);
10257 alloc_expr
= gfc_finish_block (&alloc_block
);
10259 /* Malloc if not allocated; realloc otherwise. */
10260 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10261 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10264 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10265 gfc_add_expr_to_block (&fblock
, tmp
);
10267 /* Make sure that the scalarizer data pointer is updated. */
10268 if (linfo
->data
&& VAR_P (linfo
->data
))
10270 tmp
= gfc_conv_descriptor_data_get (desc
);
10271 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10274 /* Add the exit label. */
10275 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10276 gfc_add_expr_to_block (&fblock
, tmp
);
10278 return gfc_finish_block (&fblock
);
10282 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10283 Do likewise, recursively if necessary, with the allocatable components of
10287 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10293 stmtblock_t cleanup
;
10296 bool sym_has_alloc_comp
, has_finalizer
;
10298 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10299 || sym
->ts
.type
== BT_CLASS
)
10300 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10301 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10302 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10304 /* Make sure the frontend gets these right. */
10305 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10308 gfc_save_backend_locus (&loc
);
10309 gfc_set_backend_locus (&sym
->declared_at
);
10310 gfc_init_block (&init
);
10312 gcc_assert (VAR_P (sym
->backend_decl
)
10313 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10315 if (sym
->ts
.type
== BT_CHARACTER
10316 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10318 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10319 gfc_trans_vla_type_sizes (sym
, &init
);
10322 /* Dummy, use associated and result variables don't need anything special. */
10323 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10325 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10326 gfc_restore_backend_locus (&loc
);
10330 descriptor
= sym
->backend_decl
;
10332 /* Although static, derived types with default initializers and
10333 allocatable components must not be nulled wholesale; instead they
10334 are treated component by component. */
10335 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10337 /* SAVEd variables are not freed on exit. */
10338 gfc_trans_static_array_pointer (sym
);
10340 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10341 gfc_restore_backend_locus (&loc
);
10345 /* Get the descriptor type. */
10346 type
= TREE_TYPE (sym
->backend_decl
);
10348 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10349 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10351 if (!sym
->attr
.save
10352 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10354 if (sym
->value
== NULL
10355 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10357 rank
= sym
->as
? sym
->as
->rank
: 0;
10358 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10360 gfc_add_expr_to_block (&init
, tmp
);
10363 gfc_init_default_dt (sym
, &init
, false);
10366 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10368 /* If the backend_decl is not a descriptor, we must have a pointer
10370 descriptor
= build_fold_indirect_ref_loc (input_location
,
10371 sym
->backend_decl
);
10372 type
= TREE_TYPE (descriptor
);
10375 /* NULLIFY the data pointer, for non-saved allocatables. */
10376 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10378 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10379 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10381 /* Declare the variable static so its array descriptor stays present
10382 after leaving the scope. It may still be accessed through another
10383 image. This may happen, for example, with the caf_mpi
10385 TREE_STATIC (descriptor
) = 1;
10386 tmp
= gfc_conv_descriptor_token (descriptor
);
10387 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10388 null_pointer_node
));
10392 gfc_restore_backend_locus (&loc
);
10393 gfc_init_block (&cleanup
);
10395 /* Allocatable arrays need to be freed when they go out of scope.
10396 The allocatable components of pointers must not be touched. */
10397 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10398 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10399 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10402 sym
->attr
.referenced
= 1;
10403 e
= gfc_lval_expr_from_sym (sym
);
10404 gfc_add_finalizer_call (&cleanup
, e
);
10407 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10408 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10409 && !sym
->attr
.pointer
&& !sym
->attr
.save
10410 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10413 rank
= sym
->as
? sym
->as
->rank
: 0;
10414 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10415 gfc_add_expr_to_block (&cleanup
, tmp
);
10418 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10419 && !sym
->attr
.save
&& !sym
->attr
.result
10420 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10423 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10424 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10425 NULL_TREE
, NULL_TREE
, true, e
,
10426 sym
->attr
.codimension
10427 ? GFC_CAF_COARRAY_DEREGISTER
10428 : GFC_CAF_COARRAY_NOCOARRAY
);
10431 gfc_add_expr_to_block (&cleanup
, tmp
);
10434 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10435 gfc_finish_block (&cleanup
));
10438 /************ Expression Walking Functions ******************/
10440 /* Walk a variable reference.
10442 Possible extension - multiple component subscripts.
10443 x(:,:) = foo%a(:)%b(:)
10445 forall (i=..., j=...)
10446 x(i,j) = foo%a(j)%b(i)
10448 This adds a fair amount of complexity because you need to deal with more
10449 than one ref. Maybe handle in a similar manner to vector subscripts.
10450 Maybe not worth the effort. */
10454 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10458 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10459 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10462 return gfc_walk_array_ref (ss
, expr
, ref
);
10467 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10473 for (; ref
; ref
= ref
->next
)
10475 if (ref
->type
== REF_SUBSTRING
)
10477 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10478 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10481 /* We're only interested in array sections from now on. */
10482 if (ref
->type
!= REF_ARRAY
)
10490 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10491 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10495 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10496 newss
->info
->data
.array
.ref
= ref
;
10498 /* Make sure array is the same as array(:,:), this way
10499 we don't need to special case all the time. */
10500 ar
->dimen
= ar
->as
->rank
;
10501 for (n
= 0; n
< ar
->dimen
; n
++)
10503 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10505 gcc_assert (ar
->start
[n
] == NULL
);
10506 gcc_assert (ar
->end
[n
] == NULL
);
10507 gcc_assert (ar
->stride
[n
] == NULL
);
10513 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10514 newss
->info
->data
.array
.ref
= ref
;
10516 /* We add SS chains for all the subscripts in the section. */
10517 for (n
= 0; n
< ar
->dimen
; n
++)
10521 switch (ar
->dimen_type
[n
])
10523 case DIMEN_ELEMENT
:
10524 /* Add SS for elemental (scalar) subscripts. */
10525 gcc_assert (ar
->start
[n
]);
10526 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10527 indexss
->loop_chain
= gfc_ss_terminator
;
10528 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10532 /* We don't add anything for sections, just remember this
10533 dimension for later. */
10534 newss
->dim
[newss
->dimen
] = n
;
10539 /* Create a GFC_SS_VECTOR index in which we can store
10540 the vector's descriptor. */
10541 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10543 indexss
->loop_chain
= gfc_ss_terminator
;
10544 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10545 newss
->dim
[newss
->dimen
] = n
;
10550 /* We should know what sort of section it is by now. */
10551 gcc_unreachable ();
10554 /* We should have at least one non-elemental dimension,
10555 unless we are creating a descriptor for a (scalar) coarray. */
10556 gcc_assert (newss
->dimen
> 0
10557 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10562 /* We should know what sort of section it is by now. */
10563 gcc_unreachable ();
10571 /* Walk an expression operator. If only one operand of a binary expression is
10572 scalar, we must also add the scalar term to the SS chain. */
10575 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10580 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10581 if (expr
->value
.op
.op2
== NULL
)
10584 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10586 /* All operands are scalar. Pass back and let the caller deal with it. */
10590 /* All operands require scalarization. */
10591 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10594 /* One of the operands needs scalarization, the other is scalar.
10595 Create a gfc_ss for the scalar expression. */
10598 /* First operand is scalar. We build the chain in reverse order, so
10599 add the scalar SS after the second operand. */
10601 while (head
&& head
->next
!= ss
)
10603 /* Check we haven't somehow broken the chain. */
10605 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10607 else /* head2 == head */
10609 gcc_assert (head2
== head
);
10610 /* Second operand is scalar. */
10611 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10618 /* Reverse a SS chain. */
10621 gfc_reverse_ss (gfc_ss
* ss
)
10626 gcc_assert (ss
!= NULL
);
10628 head
= gfc_ss_terminator
;
10629 while (ss
!= gfc_ss_terminator
)
10632 /* Check we didn't somehow break the chain. */
10633 gcc_assert (next
!= NULL
);
10643 /* Given an expression referring to a procedure, return the symbol of its
10644 interface. We can't get the procedure symbol directly as we have to handle
10645 the case of (deferred) type-bound procedures. */
10648 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10653 if (procedure_ref
== NULL
)
10656 /* Normal procedure case. */
10657 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10658 && procedure_ref
->value
.function
.esym
)
10659 sym
= procedure_ref
->value
.function
.esym
;
10661 sym
= procedure_ref
->symtree
->n
.sym
;
10663 /* Typebound procedure case. */
10664 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10666 if (ref
->type
== REF_COMPONENT
10667 && ref
->u
.c
.component
->attr
.proc_pointer
)
10668 sym
= ref
->u
.c
.component
->ts
.interface
;
10677 /* Walk the arguments of an elemental function.
10678 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10679 it is NULL, we don't do the check and the argument is assumed to be present.
10683 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10684 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10686 gfc_formal_arglist
*dummy_arg
;
10692 head
= gfc_ss_terminator
;
10696 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10701 for (; arg
; arg
= arg
->next
)
10703 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10704 goto loop_continue
;
10706 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10709 /* Scalar argument. */
10710 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10711 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10712 newss
->info
->type
= type
;
10714 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10719 if (dummy_arg
!= NULL
10720 && dummy_arg
->sym
->attr
.optional
10721 && arg
->expr
->expr_type
== EXPR_VARIABLE
10722 && (gfc_expr_attr (arg
->expr
).optional
10723 || gfc_expr_attr (arg
->expr
).allocatable
10724 || gfc_expr_attr (arg
->expr
).pointer
))
10725 newss
->info
->can_be_null_ref
= true;
10731 while (tail
->next
!= gfc_ss_terminator
)
10736 if (dummy_arg
!= NULL
)
10737 dummy_arg
= dummy_arg
->next
;
10742 /* If all the arguments are scalar we don't need the argument SS. */
10743 gfc_free_ss_chain (head
);
10744 /* Pass it back. */
10748 /* Add it onto the existing chain. */
10754 /* Walk a function call. Scalar functions are passed back, and taken out of
10755 scalarization loops. For elemental functions we walk their arguments.
10756 The result of functions returning arrays is stored in a temporary outside
10757 the loop, so that the function is only called once. Hence we do not need
10758 to walk their arguments. */
10761 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10763 gfc_intrinsic_sym
*isym
;
10765 gfc_component
*comp
= NULL
;
10767 isym
= expr
->value
.function
.isym
;
10769 /* Handle intrinsic functions separately. */
10771 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10773 sym
= expr
->value
.function
.esym
;
10775 sym
= expr
->symtree
->n
.sym
;
10777 if (gfc_is_class_array_function (expr
))
10778 return gfc_get_array_ss (ss
, expr
,
10779 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10782 /* A function that returns arrays. */
10783 comp
= gfc_get_proc_ptr_comp (expr
);
10784 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10785 || (comp
&& comp
->attr
.dimension
))
10786 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10788 /* Walk the parameters of an elemental function. For now we always pass
10790 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10792 gfc_ss
*old_ss
= ss
;
10794 ss
= gfc_walk_elemental_function_args (old_ss
,
10795 expr
->value
.function
.actual
,
10796 gfc_get_proc_ifc_for_expr (expr
),
10800 || sym
->attr
.proc_pointer
10801 || sym
->attr
.if_source
!= IFSRC_DECL
10802 || sym
->attr
.array_outer_dependency
))
10803 ss
->info
->array_outer_dependency
= 1;
10806 /* Scalar functions are OK as these are evaluated outside the scalarization
10807 loop. Pass back and let the caller deal with it. */
10812 /* An array temporary is constructed for array constructors. */
10815 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10817 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10821 /* Walk an expression. Add walked expressions to the head of the SS chain.
10822 A wholly scalar expression will not be added. */
10825 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10829 switch (expr
->expr_type
)
10831 case EXPR_VARIABLE
:
10832 head
= gfc_walk_variable_expr (ss
, expr
);
10836 head
= gfc_walk_op_expr (ss
, expr
);
10839 case EXPR_FUNCTION
:
10840 head
= gfc_walk_function_expr (ss
, expr
);
10843 case EXPR_CONSTANT
:
10845 case EXPR_STRUCTURE
:
10846 /* Pass back and let the caller deal with it. */
10850 head
= gfc_walk_array_constructor (ss
, expr
);
10853 case EXPR_SUBSTRING
:
10854 /* Pass back and let the caller deal with it. */
10858 gfc_internal_error ("bad expression type during walk (%d)",
10865 /* Entry point for expression walking.
10866 A return value equal to the passed chain means this is
10867 a scalar expression. It is up to the caller to take whatever action is
10868 necessary to translate these. */
10871 gfc_walk_expr (gfc_expr
* expr
)
10875 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10876 return gfc_reverse_ss (res
);