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 get_array_span (tree desc
, gfc_expr
*expr
)
825 if (is_pointer_array (desc
))
826 /* This will have the span field set. */
827 tmp
= gfc_conv_descriptor_span_get (desc
);
828 else if (TREE_CODE (desc
) == COMPONENT_REF
829 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
830 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
832 /* The descriptor is a class _data field and so use the vtable
833 size for the receiving span field. */
834 tmp
= gfc_get_vptr_from_expr (desc
);
835 tmp
= gfc_vptr_size_get (tmp
);
837 else if (expr
&& expr
->expr_type
== EXPR_VARIABLE
838 && expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
839 && expr
->ref
->type
== REF_COMPONENT
840 && expr
->ref
->next
->type
== REF_ARRAY
841 && expr
->ref
->next
->next
== NULL
842 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.dimension
)
844 /* Dummys come in sometimes with the descriptor detached from
845 the class field or declaration. */
846 tmp
= gfc_class_vptr_get (expr
->symtree
->n
.sym
->backend_decl
);
847 tmp
= gfc_vptr_size_get (tmp
);
851 /* If none of the fancy stuff works, the span is the element
852 size of the array. */
853 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
854 tmp
= fold_convert (gfc_array_index_type
,
855 size_in_bytes (tmp
));
861 /* Generate an initializer for a static pointer or allocatable array. */
864 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
868 gcc_assert (TREE_STATIC (sym
->backend_decl
));
869 /* Just zero the data member. */
870 type
= TREE_TYPE (sym
->backend_decl
);
871 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
875 /* If the bounds of SE's loop have not yet been set, see if they can be
876 determined from array spec AS, which is the array spec of a called
877 function. MAPPING maps the callee's dummy arguments to the values
878 that the caller is passing. Add any initialization and finalization
882 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
883 gfc_se
* se
, gfc_array_spec
* as
)
885 int n
, dim
, total_dim
;
894 if (!as
|| as
->type
!= AS_EXPLICIT
)
897 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
899 total_dim
+= ss
->loop
->dimen
;
900 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
902 /* The bound is known, nothing to do. */
903 if (ss
->loop
->to
[n
] != NULL_TREE
)
907 gcc_assert (dim
< as
->rank
);
908 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
910 /* Evaluate the lower bound. */
911 gfc_init_se (&tmpse
, NULL
);
912 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
913 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
914 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
915 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
917 /* ...and the upper bound. */
918 gfc_init_se (&tmpse
, NULL
);
919 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
920 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
921 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
922 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
924 /* Set the upper bound of the loop to UPPER - LOWER. */
925 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
926 gfc_array_index_type
, upper
, lower
);
927 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
928 ss
->loop
->to
[n
] = tmp
;
932 gcc_assert (total_dim
== as
->rank
);
936 /* Generate code to allocate an array temporary, or create a variable to
937 hold the data. If size is NULL, zero the descriptor so that the
938 callee will allocate the array. If DEALLOC is true, also generate code to
939 free the array afterwards.
941 If INITIAL is not NULL, it is packed using internal_pack and the result used
942 as data instead of allocating a fresh, unitialized area of memory.
944 Initialization code is added to PRE and finalization code to POST.
945 DYNAMIC is true if the caller may want to extend the array later
946 using realloc. This prevents us from putting the array on the stack. */
949 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
950 gfc_array_info
* info
, tree size
, tree nelem
,
951 tree initial
, bool dynamic
, bool dealloc
)
957 desc
= info
->descriptor
;
958 info
->offset
= gfc_index_zero_node
;
959 if (size
== NULL_TREE
|| integer_zerop (size
))
961 /* A callee allocated array. */
962 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
967 /* Allocate the temporary. */
968 onstack
= !dynamic
&& initial
== NULL_TREE
969 && (flag_stack_arrays
970 || gfc_can_put_var_on_stack (size
));
974 /* Make a temporary variable to hold the data. */
975 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
976 nelem
, gfc_index_one_node
);
977 tmp
= gfc_evaluate_now (tmp
, pre
);
978 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
980 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
982 tmp
= gfc_create_var (tmp
, "A");
983 /* If we're here only because of -fstack-arrays we have to
984 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
985 if (!gfc_can_put_var_on_stack (size
))
986 gfc_add_expr_to_block (pre
,
987 fold_build1_loc (input_location
,
988 DECL_EXPR
, TREE_TYPE (tmp
),
990 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
991 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
995 /* Allocate memory to hold the data or call internal_pack. */
996 if (initial
== NULL_TREE
)
998 tmp
= gfc_call_malloc (pre
, NULL
, size
);
999 tmp
= gfc_evaluate_now (tmp
, pre
);
1006 stmtblock_t do_copying
;
1008 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1009 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1010 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1011 tmp
= gfc_get_element_type (tmp
);
1012 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1013 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1015 tmp
= build_call_expr_loc (input_location
,
1016 gfor_fndecl_in_pack
, 1, initial
);
1017 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1018 gfc_add_modify (pre
, packed
, tmp
);
1020 tmp
= build_fold_indirect_ref_loc (input_location
,
1022 source_data
= gfc_conv_descriptor_data_get (tmp
);
1024 /* internal_pack may return source->data without any allocation
1025 or copying if it is already packed. If that's the case, we
1026 need to allocate and copy manually. */
1028 gfc_start_block (&do_copying
);
1029 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1030 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1031 gfc_add_modify (&do_copying
, packed
, tmp
);
1032 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1033 gfc_add_expr_to_block (&do_copying
, tmp
);
1035 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1036 logical_type_node
, packed
,
1038 tmp
= gfc_finish_block (&do_copying
);
1039 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1040 build_empty_stmt (input_location
));
1041 gfc_add_expr_to_block (pre
, tmp
);
1043 tmp
= fold_convert (pvoid_type_node
, packed
);
1046 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1049 info
->data
= gfc_conv_descriptor_data_get (desc
);
1051 /* The offset is zero because we create temporaries with a zero
1053 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1055 if (dealloc
&& !onstack
)
1057 /* Free the temporary. */
1058 tmp
= gfc_conv_descriptor_data_get (desc
);
1059 tmp
= gfc_call_free (tmp
);
1060 gfc_add_expr_to_block (post
, tmp
);
1065 /* Get the scalarizer array dimension corresponding to actual array dimension
1068 For example, if SS represents the array ref a(1,:,:,1), it is a
1069 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1070 and 1 for ARRAY_DIM=2.
1071 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1072 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1074 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1075 array. If called on the inner ss, the result would be respectively 0,1,2 for
1076 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1077 for ARRAY_DIM=1,2. */
1080 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1087 for (; ss
; ss
= ss
->parent
)
1088 for (n
= 0; n
< ss
->dimen
; n
++)
1089 if (ss
->dim
[n
] < array_dim
)
1092 return array_ref_dim
;
1097 innermost_ss (gfc_ss
*ss
)
1099 while (ss
->nested_ss
!= NULL
)
1107 /* Get the array reference dimension corresponding to the given loop dimension.
1108 It is different from the true array dimension given by the dim array in
1109 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1110 It is different from the loop dimension in the case of a transposed array.
1114 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1116 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1121 /* Generate code to create and initialize the descriptor for a temporary
1122 array. This is used for both temporaries needed by the scalarizer, and
1123 functions returning arrays. Adjusts the loop variables to be
1124 zero-based, and calculates the loop bounds for callee allocated arrays.
1125 Allocate the array unless it's callee allocated (we have a callee
1126 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1127 NULL_TREE for any n). Also fills in the descriptor, data and offset
1128 fields of info if known. Returns the size of the array, or NULL for a
1129 callee allocated array.
1131 'eltype' == NULL signals that the temporary should be a class object.
1132 The 'initial' expression is used to obtain the size of the dynamic
1133 type; otherwise the allocation and initialization proceeds as for any
1136 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1137 gfc_trans_allocate_array_storage. */
1140 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1141 tree eltype
, tree initial
, bool dynamic
,
1142 bool dealloc
, bool callee_alloc
, locus
* where
)
1146 gfc_array_info
*info
;
1147 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1155 tree class_expr
= NULL_TREE
;
1156 int n
, dim
, tmp_dim
;
1159 /* This signals a class array for which we need the size of the
1160 dynamic type. Generate an eltype and then the class expression. */
1161 if (eltype
== NULL_TREE
&& initial
)
1163 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1164 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1165 eltype
= TREE_TYPE (class_expr
);
1166 eltype
= gfc_get_element_type (eltype
);
1167 /* Obtain the structure (class) expression. */
1168 class_expr
= TREE_OPERAND (class_expr
, 0);
1169 gcc_assert (class_expr
);
1172 memset (from
, 0, sizeof (from
));
1173 memset (to
, 0, sizeof (to
));
1175 info
= &ss
->info
->data
.array
;
1177 gcc_assert (ss
->dimen
> 0);
1178 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1180 if (warn_array_temporaries
&& where
)
1181 gfc_warning (OPT_Warray_temporaries
,
1182 "Creating array temporary at %L", where
);
1184 /* Set the lower bound to zero. */
1185 for (s
= ss
; s
; s
= s
->parent
)
1189 total_dim
+= loop
->dimen
;
1190 for (n
= 0; n
< loop
->dimen
; n
++)
1194 /* Callee allocated arrays may not have a known bound yet. */
1196 loop
->to
[n
] = gfc_evaluate_now (
1197 fold_build2_loc (input_location
, MINUS_EXPR
,
1198 gfc_array_index_type
,
1199 loop
->to
[n
], loop
->from
[n
]),
1201 loop
->from
[n
] = gfc_index_zero_node
;
1203 /* We have just changed the loop bounds, we must clear the
1204 corresponding specloop, so that delta calculation is not skipped
1205 later in gfc_set_delta. */
1206 loop
->specloop
[n
] = NULL
;
1208 /* We are constructing the temporary's descriptor based on the loop
1209 dimensions. As the dimensions may be accessed in arbitrary order
1210 (think of transpose) the size taken from the n'th loop may not map
1211 to the n'th dimension of the array. We need to reconstruct loop
1212 infos in the right order before using it to set the descriptor
1214 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1215 from
[tmp_dim
] = loop
->from
[n
];
1216 to
[tmp_dim
] = loop
->to
[n
];
1218 info
->delta
[dim
] = gfc_index_zero_node
;
1219 info
->start
[dim
] = gfc_index_zero_node
;
1220 info
->end
[dim
] = gfc_index_zero_node
;
1221 info
->stride
[dim
] = gfc_index_one_node
;
1225 /* Initialize the descriptor. */
1227 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1228 GFC_ARRAY_UNKNOWN
, true);
1229 desc
= gfc_create_var (type
, "atmp");
1230 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1232 info
->descriptor
= desc
;
1233 size
= gfc_index_one_node
;
1235 /* Emit a DECL_EXPR for the variable sized array type in
1236 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1237 sizes works correctly. */
1238 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1239 if (! TYPE_NAME (arraytype
))
1240 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1241 NULL_TREE
, arraytype
);
1242 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1243 arraytype
, TYPE_NAME (arraytype
)));
1245 /* Fill in the array dtype. */
1246 tmp
= gfc_conv_descriptor_dtype (desc
);
1247 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1250 Fill in the bounds and stride. This is a packed array, so:
1253 for (n = 0; n < rank; n++)
1256 delta = ubound[n] + 1 - lbound[n];
1257 size = size * delta;
1259 size = size * sizeof(element);
1262 or_expr
= NULL_TREE
;
1264 /* If there is at least one null loop->to[n], it is a callee allocated
1266 for (n
= 0; n
< total_dim
; n
++)
1267 if (to
[n
] == NULL_TREE
)
1273 if (size
== NULL_TREE
)
1274 for (s
= ss
; s
; s
= s
->parent
)
1275 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1277 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1279 /* For a callee allocated array express the loop bounds in terms
1280 of the descriptor fields. */
1281 tmp
= fold_build2_loc (input_location
,
1282 MINUS_EXPR
, gfc_array_index_type
,
1283 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1284 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1285 s
->loop
->to
[n
] = tmp
;
1289 for (n
= 0; n
< total_dim
; n
++)
1291 /* Store the stride and bound components in the descriptor. */
1292 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1294 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1295 gfc_index_zero_node
);
1297 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1299 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1300 gfc_array_index_type
,
1301 to
[n
], gfc_index_one_node
);
1303 /* Check whether the size for this dimension is negative. */
1304 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1305 tmp
, gfc_index_zero_node
);
1306 cond
= gfc_evaluate_now (cond
, pre
);
1311 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1312 logical_type_node
, or_expr
, cond
);
1314 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1315 gfc_array_index_type
, size
, tmp
);
1316 size
= gfc_evaluate_now (size
, pre
);
1320 /* Get the size of the array. */
1321 if (size
&& !callee_alloc
)
1324 /* If or_expr is true, then the extent in at least one
1325 dimension is zero and the size is set to zero. */
1326 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1327 or_expr
, gfc_index_zero_node
, size
);
1330 if (class_expr
== NULL_TREE
)
1331 elemsize
= fold_convert (gfc_array_index_type
,
1332 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1334 elemsize
= gfc_class_vtab_size_get (class_expr
);
1336 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1345 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1351 if (ss
->dimen
> ss
->loop
->temp_dim
)
1352 ss
->loop
->temp_dim
= ss
->dimen
;
1358 /* Return the number of iterations in a loop that starts at START,
1359 ends at END, and has step STEP. */
1362 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1367 type
= TREE_TYPE (step
);
1368 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1369 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1370 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1371 build_int_cst (type
, 1));
1372 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1373 build_int_cst (type
, 0));
1374 return fold_convert (gfc_array_index_type
, tmp
);
1378 /* Extend the data in array DESC by EXTRA elements. */
1381 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1388 if (integer_zerop (extra
))
1391 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1393 /* Add EXTRA to the upper bound. */
1394 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1396 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1398 /* Get the value of the current data pointer. */
1399 arg0
= gfc_conv_descriptor_data_get (desc
);
1401 /* Calculate the new array size. */
1402 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1403 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1404 ubound
, gfc_index_one_node
);
1405 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1406 fold_convert (size_type_node
, tmp
),
1407 fold_convert (size_type_node
, size
));
1409 /* Call the realloc() function. */
1410 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1411 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1415 /* Return true if the bounds of iterator I can only be determined
1419 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1421 return (i
->start
->expr_type
!= EXPR_CONSTANT
1422 || i
->end
->expr_type
!= EXPR_CONSTANT
1423 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1427 /* Split the size of constructor element EXPR into the sum of two terms,
1428 one of which can be determined at compile time and one of which must
1429 be calculated at run time. Set *SIZE to the former and return true
1430 if the latter might be nonzero. */
1433 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1435 if (expr
->expr_type
== EXPR_ARRAY
)
1436 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1437 else if (expr
->rank
> 0)
1439 /* Calculate everything at run time. */
1440 mpz_set_ui (*size
, 0);
1445 /* A single element. */
1446 mpz_set_ui (*size
, 1);
1452 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1453 of array constructor C. */
1456 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1464 mpz_set_ui (*size
, 0);
1469 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1472 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1476 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1479 /* Multiply the static part of the element size by the
1480 number of iterations. */
1481 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1482 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1483 mpz_add_ui (val
, val
, 1);
1484 if (mpz_sgn (val
) > 0)
1485 mpz_mul (len
, len
, val
);
1487 mpz_set_ui (len
, 0);
1489 mpz_add (*size
, *size
, len
);
1498 /* Make sure offset is a variable. */
1501 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1504 /* We should have already created the offset variable. We cannot
1505 create it here because we may be in an inner scope. */
1506 gcc_assert (*offsetvar
!= NULL_TREE
);
1507 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1508 *poffset
= *offsetvar
;
1509 TREE_USED (*offsetvar
) = 1;
1513 /* Variables needed for bounds-checking. */
1514 static bool first_len
;
1515 static tree first_len_val
;
1516 static bool typespec_chararray_ctor
;
1519 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1520 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1524 gfc_conv_expr (se
, expr
);
1526 /* Store the value. */
1527 tmp
= build_fold_indirect_ref_loc (input_location
,
1528 gfc_conv_descriptor_data_get (desc
));
1529 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1531 if (expr
->ts
.type
== BT_CHARACTER
)
1533 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1536 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1537 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1538 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1539 TREE_TYPE (esize
), esize
,
1540 build_int_cst (TREE_TYPE (esize
),
1541 gfc_character_kinds
[i
].bit_size
/ 8));
1543 gfc_conv_string_parameter (se
);
1544 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1546 /* The temporary is an array of pointers. */
1547 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1548 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1552 /* The temporary is an array of string values. */
1553 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1554 /* We know the temporary and the value will be the same length,
1555 so can use memcpy. */
1556 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1557 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1559 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1563 gfc_add_modify (&se
->pre
, first_len_val
,
1564 fold_convert (TREE_TYPE (first_len_val
),
1565 se
->string_length
));
1570 /* Verify that all constructor elements are of the same
1572 tree rhs
= fold_convert (TREE_TYPE (first_len_val
),
1574 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1575 logical_type_node
, first_len_val
,
1577 gfc_trans_runtime_check
1578 (true, false, cond
, &se
->pre
, &expr
->where
,
1579 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1580 fold_convert (long_integer_type_node
, first_len_val
),
1581 fold_convert (long_integer_type_node
, se
->string_length
));
1585 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1586 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1588 /* Assignment of a CLASS array constructor to a derived type array. */
1589 if (expr
->expr_type
== EXPR_FUNCTION
)
1590 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1591 se
->expr
= gfc_class_data_get (se
->expr
);
1592 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1593 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1594 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1598 /* TODO: Should the frontend already have done this conversion? */
1599 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1600 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1603 gfc_add_block_to_block (pblock
, &se
->pre
);
1604 gfc_add_block_to_block (pblock
, &se
->post
);
1608 /* Add the contents of an array to the constructor. DYNAMIC is as for
1609 gfc_trans_array_constructor_value. */
1612 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1613 tree type ATTRIBUTE_UNUSED
,
1614 tree desc
, gfc_expr
* expr
,
1615 tree
* poffset
, tree
* offsetvar
,
1626 /* We need this to be a variable so we can increment it. */
1627 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1629 gfc_init_se (&se
, NULL
);
1631 /* Walk the array expression. */
1632 ss
= gfc_walk_expr (expr
);
1633 gcc_assert (ss
!= gfc_ss_terminator
);
1635 /* Initialize the scalarizer. */
1636 gfc_init_loopinfo (&loop
);
1637 gfc_add_ss_to_loop (&loop
, ss
);
1639 /* Initialize the loop. */
1640 gfc_conv_ss_startstride (&loop
);
1641 gfc_conv_loop_setup (&loop
, &expr
->where
);
1643 /* Make sure the constructed array has room for the new data. */
1646 /* Set SIZE to the total number of elements in the subarray. */
1647 size
= gfc_index_one_node
;
1648 for (n
= 0; n
< loop
.dimen
; n
++)
1650 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1651 gfc_index_one_node
);
1652 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1653 gfc_array_index_type
, size
, tmp
);
1656 /* Grow the constructed array by SIZE elements. */
1657 gfc_grow_array (&loop
.pre
, desc
, size
);
1660 /* Make the loop body. */
1661 gfc_mark_ss_chain_used (ss
, 1);
1662 gfc_start_scalarized_body (&loop
, &body
);
1663 gfc_copy_loopinfo_to_se (&se
, &loop
);
1666 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1667 gcc_assert (se
.ss
== gfc_ss_terminator
);
1669 /* Increment the offset. */
1670 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1671 *poffset
, gfc_index_one_node
);
1672 gfc_add_modify (&body
, *poffset
, tmp
);
1674 /* Finish the loop. */
1675 gfc_trans_scalarizing_loops (&loop
, &body
);
1676 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1677 tmp
= gfc_finish_block (&loop
.pre
);
1678 gfc_add_expr_to_block (pblock
, tmp
);
1680 gfc_cleanup_loop (&loop
);
1684 /* Assign the values to the elements of an array constructor. DYNAMIC
1685 is true if descriptor DESC only contains enough data for the static
1686 size calculated by gfc_get_array_constructor_size. When true, memory
1687 for the dynamic parts must be allocated using realloc. */
1690 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1691 tree desc
, gfc_constructor_base base
,
1692 tree
* poffset
, tree
* offsetvar
,
1696 tree start
= NULL_TREE
;
1697 tree end
= NULL_TREE
;
1698 tree step
= NULL_TREE
;
1704 tree shadow_loopvar
= NULL_TREE
;
1705 gfc_saved_var saved_loopvar
;
1708 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1710 /* If this is an iterator or an array, the offset must be a variable. */
1711 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1712 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1714 /* Shadowing the iterator avoids changing its value and saves us from
1715 keeping track of it. Further, it makes sure that there's always a
1716 backend-decl for the symbol, even if there wasn't one before,
1717 e.g. in the case of an iterator that appears in a specification
1718 expression in an interface mapping. */
1724 /* Evaluate loop bounds before substituting the loop variable
1725 in case they depend on it. Such a case is invalid, but it is
1726 not more expensive to do the right thing here.
1728 gfc_init_se (&se
, NULL
);
1729 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1730 gfc_add_block_to_block (pblock
, &se
.pre
);
1731 start
= gfc_evaluate_now (se
.expr
, pblock
);
1733 gfc_init_se (&se
, NULL
);
1734 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1735 gfc_add_block_to_block (pblock
, &se
.pre
);
1736 end
= gfc_evaluate_now (se
.expr
, pblock
);
1738 gfc_init_se (&se
, NULL
);
1739 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1740 gfc_add_block_to_block (pblock
, &se
.pre
);
1741 step
= gfc_evaluate_now (se
.expr
, pblock
);
1743 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1744 type
= gfc_typenode_for_spec (&sym
->ts
);
1746 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1747 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1750 gfc_start_block (&body
);
1752 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1754 /* Array constructors can be nested. */
1755 gfc_trans_array_constructor_value (&body
, type
, desc
,
1756 c
->expr
->value
.constructor
,
1757 poffset
, offsetvar
, dynamic
);
1759 else if (c
->expr
->rank
> 0)
1761 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1762 poffset
, offsetvar
, dynamic
);
1766 /* This code really upsets the gimplifier so don't bother for now. */
1773 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1775 p
= gfc_constructor_next (p
);
1780 /* Scalar values. */
1781 gfc_init_se (&se
, NULL
);
1782 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1785 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1786 gfc_array_index_type
,
1787 *poffset
, gfc_index_one_node
);
1791 /* Collect multiple scalar constants into a constructor. */
1792 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1796 HOST_WIDE_INT idx
= 0;
1799 /* Count the number of consecutive scalar constants. */
1800 while (p
&& !(p
->iterator
1801 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1803 gfc_init_se (&se
, NULL
);
1804 gfc_conv_constant (&se
, p
->expr
);
1806 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1807 se
.expr
= fold_convert (type
, se
.expr
);
1808 /* For constant character array constructors we build
1809 an array of pointers. */
1810 else if (POINTER_TYPE_P (type
))
1811 se
.expr
= gfc_build_addr_expr
1812 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1815 CONSTRUCTOR_APPEND_ELT (v
,
1816 build_int_cst (gfc_array_index_type
,
1820 p
= gfc_constructor_next (p
);
1823 bound
= size_int (n
- 1);
1824 /* Create an array type to hold them. */
1825 tmptype
= build_range_type (gfc_array_index_type
,
1826 gfc_index_zero_node
, bound
);
1827 tmptype
= build_array_type (type
, tmptype
);
1829 init
= build_constructor (tmptype
, v
);
1830 TREE_CONSTANT (init
) = 1;
1831 TREE_STATIC (init
) = 1;
1832 /* Create a static variable to hold the data. */
1833 tmp
= gfc_create_var (tmptype
, "data");
1834 TREE_STATIC (tmp
) = 1;
1835 TREE_CONSTANT (tmp
) = 1;
1836 TREE_READONLY (tmp
) = 1;
1837 DECL_INITIAL (tmp
) = init
;
1840 /* Use BUILTIN_MEMCPY to assign the values. */
1841 tmp
= gfc_conv_descriptor_data_get (desc
);
1842 tmp
= build_fold_indirect_ref_loc (input_location
,
1844 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1845 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1846 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1848 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1849 bound
= build_int_cst (size_type_node
, n
* size
);
1850 tmp
= build_call_expr_loc (input_location
,
1851 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1852 3, tmp
, init
, bound
);
1853 gfc_add_expr_to_block (&body
, tmp
);
1855 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1856 gfc_array_index_type
, *poffset
,
1857 build_int_cst (gfc_array_index_type
, n
));
1859 if (!INTEGER_CST_P (*poffset
))
1861 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1862 *poffset
= *offsetvar
;
1866 /* The frontend should already have done any expansions
1870 /* Pass the code as is. */
1871 tmp
= gfc_finish_block (&body
);
1872 gfc_add_expr_to_block (pblock
, tmp
);
1876 /* Build the implied do-loop. */
1877 stmtblock_t implied_do_block
;
1883 loopbody
= gfc_finish_block (&body
);
1885 /* Create a new block that holds the implied-do loop. A temporary
1886 loop-variable is used. */
1887 gfc_start_block(&implied_do_block
);
1889 /* Initialize the loop. */
1890 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1892 /* If this array expands dynamically, and the number of iterations
1893 is not constant, we won't have allocated space for the static
1894 part of C->EXPR's size. Do that now. */
1895 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1897 /* Get the number of iterations. */
1898 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1900 /* Get the static part of C->EXPR's size. */
1901 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1902 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1904 /* Grow the array by TMP * TMP2 elements. */
1905 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1906 gfc_array_index_type
, tmp
, tmp2
);
1907 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1910 /* Generate the loop body. */
1911 exit_label
= gfc_build_label_decl (NULL_TREE
);
1912 gfc_start_block (&body
);
1914 /* Generate the exit condition. Depending on the sign of
1915 the step variable we have to generate the correct
1917 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1918 step
, build_int_cst (TREE_TYPE (step
), 0));
1919 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1920 logical_type_node
, tmp
,
1921 fold_build2_loc (input_location
, GT_EXPR
,
1922 logical_type_node
, shadow_loopvar
, end
),
1923 fold_build2_loc (input_location
, LT_EXPR
,
1924 logical_type_node
, shadow_loopvar
, end
));
1925 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1926 TREE_USED (exit_label
) = 1;
1927 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1928 build_empty_stmt (input_location
));
1929 gfc_add_expr_to_block (&body
, tmp
);
1931 /* The main loop body. */
1932 gfc_add_expr_to_block (&body
, loopbody
);
1934 /* Increase loop variable by step. */
1935 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1936 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1938 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1940 /* Finish the loop. */
1941 tmp
= gfc_finish_block (&body
);
1942 tmp
= build1_v (LOOP_EXPR
, tmp
);
1943 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1945 /* Add the exit label. */
1946 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1947 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1949 /* Finish the implied-do loop. */
1950 tmp
= gfc_finish_block(&implied_do_block
);
1951 gfc_add_expr_to_block(pblock
, tmp
);
1953 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1960 /* The array constructor code can create a string length with an operand
1961 in the form of a temporary variable. This variable will retain its
1962 context (current_function_decl). If we store this length tree in a
1963 gfc_charlen structure which is shared by a variable in another
1964 context, the resulting gfc_charlen structure with a variable in a
1965 different context, we could trip the assertion in expand_expr_real_1
1966 when it sees that a variable has been created in one context and
1967 referenced in another.
1969 If this might be the case, we create a new gfc_charlen structure and
1970 link it into the current namespace. */
1973 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1977 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1980 (*clp
)->backend_decl
= len
;
1983 /* A catch-all to obtain the string length for anything that is not
1984 a substring of non-constant length, a constant, array or variable. */
1987 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1991 /* Don't bother if we already know the length is a constant. */
1992 if (*len
&& INTEGER_CST_P (*len
))
1995 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1996 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1999 gfc_conv_const_charlen (e
->ts
.u
.cl
);
2000 *len
= e
->ts
.u
.cl
->backend_decl
;
2004 /* Otherwise, be brutal even if inefficient. */
2005 gfc_init_se (&se
, NULL
);
2007 /* No function call, in case of side effects. */
2008 se
.no_function_call
= 1;
2010 gfc_conv_expr (&se
, e
);
2012 gfc_conv_expr_descriptor (&se
, e
);
2014 /* Fix the value. */
2015 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2017 gfc_add_block_to_block (block
, &se
.pre
);
2018 gfc_add_block_to_block (block
, &se
.post
);
2020 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2025 /* Figure out the string length of a variable reference expression.
2026 Used by get_array_ctor_strlen. */
2029 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2035 /* Don't bother if we already know the length is a constant. */
2036 if (*len
&& INTEGER_CST_P (*len
))
2039 ts
= &expr
->symtree
->n
.sym
->ts
;
2040 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2045 /* Array references don't change the string length. */
2049 /* Use the length of the component. */
2050 ts
= &ref
->u
.c
.component
->ts
;
2054 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2055 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2057 /* Note that this might evaluate expr. */
2058 get_array_ctor_all_strlen (block
, expr
, len
);
2061 mpz_init_set_ui (char_len
, 1);
2062 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2063 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2064 *len
= gfc_conv_mpz_to_tree_type (char_len
, gfc_charlen_type_node
);
2065 mpz_clear (char_len
);
2073 *len
= ts
->u
.cl
->backend_decl
;
2077 /* Figure out the string length of a character array constructor.
2078 If len is NULL, don't calculate the length; this happens for recursive calls
2079 when a sub-array-constructor is an element but not at the first position,
2080 so when we're not interested in the length.
2081 Returns TRUE if all elements are character constants. */
2084 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2091 if (gfc_constructor_first (base
) == NULL
)
2094 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2098 /* Loop over all constructor elements to find out is_const, but in len we
2099 want to store the length of the first, not the last, element. We can
2100 of course exit the loop as soon as is_const is found to be false. */
2101 for (c
= gfc_constructor_first (base
);
2102 c
&& is_const
; c
= gfc_constructor_next (c
))
2104 switch (c
->expr
->expr_type
)
2107 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2108 *len
= build_int_cstu (gfc_charlen_type_node
,
2109 c
->expr
->value
.character
.length
);
2113 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2120 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2126 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2130 /* After the first iteration, we don't want the length modified. */
2137 /* Check whether the array constructor C consists entirely of constant
2138 elements, and if so returns the number of those elements, otherwise
2139 return zero. Note, an empty or NULL array constructor returns zero. */
2141 unsigned HOST_WIDE_INT
2142 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2144 unsigned HOST_WIDE_INT nelem
= 0;
2146 gfc_constructor
*c
= gfc_constructor_first (base
);
2150 || c
->expr
->rank
> 0
2151 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2153 c
= gfc_constructor_next (c
);
2160 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2161 and the tree type of it's elements, TYPE, return a static constant
2162 variable that is compile-time initialized. */
2165 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2167 tree tmptype
, init
, tmp
;
2168 HOST_WIDE_INT nelem
;
2173 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2175 /* First traverse the constructor list, converting the constants
2176 to tree to build an initializer. */
2178 c
= gfc_constructor_first (expr
->value
.constructor
);
2181 gfc_init_se (&se
, NULL
);
2182 gfc_conv_constant (&se
, c
->expr
);
2183 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2184 se
.expr
= fold_convert (type
, se
.expr
);
2185 else if (POINTER_TYPE_P (type
))
2186 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2188 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2190 c
= gfc_constructor_next (c
);
2194 /* Next determine the tree type for the array. We use the gfortran
2195 front-end's gfc_get_nodesc_array_type in order to create a suitable
2196 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2198 memset (&as
, 0, sizeof (gfc_array_spec
));
2200 as
.rank
= expr
->rank
;
2201 as
.type
= AS_EXPLICIT
;
2204 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2205 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2209 for (i
= 0; i
< expr
->rank
; i
++)
2211 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2212 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2213 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2217 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2219 /* as is not needed anymore. */
2220 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2222 gfc_free_expr (as
.lower
[i
]);
2223 gfc_free_expr (as
.upper
[i
]);
2226 init
= build_constructor (tmptype
, v
);
2228 TREE_CONSTANT (init
) = 1;
2229 TREE_STATIC (init
) = 1;
2231 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2233 DECL_ARTIFICIAL (tmp
) = 1;
2234 DECL_IGNORED_P (tmp
) = 1;
2235 TREE_STATIC (tmp
) = 1;
2236 TREE_CONSTANT (tmp
) = 1;
2237 TREE_READONLY (tmp
) = 1;
2238 DECL_INITIAL (tmp
) = init
;
2245 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2246 This mostly initializes the scalarizer state info structure with the
2247 appropriate values to directly use the array created by the function
2248 gfc_build_constant_array_constructor. */
2251 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2253 gfc_array_info
*info
;
2257 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2259 info
= &ss
->info
->data
.array
;
2261 info
->descriptor
= tmp
;
2262 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2263 info
->offset
= gfc_index_zero_node
;
2265 for (i
= 0; i
< ss
->dimen
; i
++)
2267 info
->delta
[i
] = gfc_index_zero_node
;
2268 info
->start
[i
] = gfc_index_zero_node
;
2269 info
->end
[i
] = gfc_index_zero_node
;
2270 info
->stride
[i
] = gfc_index_one_node
;
2276 get_rank (gfc_loopinfo
*loop
)
2281 for (; loop
; loop
= loop
->parent
)
2282 rank
+= loop
->dimen
;
2288 /* Helper routine of gfc_trans_array_constructor to determine if the
2289 bounds of the loop specified by LOOP are constant and simple enough
2290 to use with trans_constant_array_constructor. Returns the
2291 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2294 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2297 tree size
= gfc_index_one_node
;
2301 total_dim
= get_rank (l
);
2303 for (loop
= l
; loop
; loop
= loop
->parent
)
2305 for (i
= 0; i
< loop
->dimen
; i
++)
2307 /* If the bounds aren't constant, return NULL_TREE. */
2308 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2310 if (!integer_zerop (loop
->from
[i
]))
2312 /* Only allow nonzero "from" in one-dimensional arrays. */
2315 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2316 gfc_array_index_type
,
2317 loop
->to
[i
], loop
->from
[i
]);
2321 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2322 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2323 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2324 gfc_array_index_type
, size
, tmp
);
2333 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2338 gcc_assert (array
->nested_ss
== NULL
);
2340 for (ss
= array
; ss
; ss
= ss
->parent
)
2341 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2342 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2343 return &(ss
->loop
->to
[n
]);
2349 static gfc_loopinfo
*
2350 outermost_loop (gfc_loopinfo
* loop
)
2352 while (loop
->parent
!= NULL
)
2353 loop
= loop
->parent
;
2359 /* Array constructors are handled by constructing a temporary, then using that
2360 within the scalarization loop. This is not optimal, but seems by far the
2364 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2366 gfc_constructor_base c
;
2374 bool old_first_len
, old_typespec_chararray_ctor
;
2375 tree old_first_len_val
;
2376 gfc_loopinfo
*loop
, *outer_loop
;
2377 gfc_ss_info
*ss_info
;
2383 /* Save the old values for nested checking. */
2384 old_first_len
= first_len
;
2385 old_first_len_val
= first_len_val
;
2386 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2389 outer_loop
= outermost_loop (loop
);
2391 expr
= ss_info
->expr
;
2393 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2394 typespec was given for the array constructor. */
2395 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2397 && expr
->ts
.u
.cl
->length_from_typespec
);
2399 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2400 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2402 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2406 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2408 c
= expr
->value
.constructor
;
2409 if (expr
->ts
.type
== BT_CHARACTER
)
2412 bool force_new_cl
= false;
2414 /* get_array_ctor_strlen walks the elements of the constructor, if a
2415 typespec was given, we already know the string length and want the one
2417 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2418 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2422 const_string
= false;
2423 gfc_init_se (&length_se
, NULL
);
2424 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2425 gfc_charlen_type_node
);
2426 ss_info
->string_length
= length_se
.expr
;
2428 /* Check if the character length is negative. If it is, then
2430 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2431 logical_type_node
, ss_info
->string_length
,
2432 build_zero_cst (TREE_TYPE
2433 (ss_info
->string_length
)));
2434 /* Print a warning if bounds checking is enabled. */
2435 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2437 msg
= xasprintf ("Negative character length treated as LEN = 0");
2438 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2443 ss_info
->string_length
2444 = fold_build3_loc (input_location
, COND_EXPR
,
2445 gfc_charlen_type_node
, neg_len
,
2447 (TREE_TYPE (ss_info
->string_length
)),
2448 ss_info
->string_length
);
2449 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2452 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2453 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2457 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2458 &ss_info
->string_length
);
2459 force_new_cl
= true;
2462 /* Complex character array constructors should have been taken care of
2463 and not end up here. */
2464 gcc_assert (ss_info
->string_length
);
2466 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2468 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2470 type
= build_pointer_type (type
);
2473 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2474 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2476 /* See if the constructor determines the loop bounds. */
2479 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2481 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2483 /* We have a multidimensional parameter. */
2484 for (s
= ss
; s
; s
= s
->parent
)
2487 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2489 s
->loop
->from
[n
] = gfc_index_zero_node
;
2490 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2491 gfc_index_integer_kind
);
2492 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2493 gfc_array_index_type
,
2495 gfc_index_one_node
);
2500 if (*loop_ubound0
== NULL_TREE
)
2504 /* We should have a 1-dimensional, zero-based loop. */
2505 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2506 gcc_assert (loop
->dimen
== 1);
2507 gcc_assert (integer_zerop (loop
->from
[0]));
2509 /* Split the constructor size into a static part and a dynamic part.
2510 Allocate the static size up-front and record whether the dynamic
2511 size might be nonzero. */
2513 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2514 mpz_sub_ui (size
, size
, 1);
2515 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2519 /* Special case constant array constructors. */
2522 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2525 tree size
= constant_array_constructor_loop_size (loop
);
2526 if (size
&& compare_tree_int (size
, nelem
) == 0)
2528 trans_constant_array_constructor (ss
, type
);
2534 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2535 NULL_TREE
, dynamic
, true, false, where
);
2537 desc
= ss_info
->data
.array
.descriptor
;
2538 offset
= gfc_index_zero_node
;
2539 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2540 TREE_NO_WARNING (offsetvar
) = 1;
2541 TREE_USED (offsetvar
) = 0;
2542 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2543 &offset
, &offsetvar
, dynamic
);
2545 /* If the array grows dynamically, the upper bound of the loop variable
2546 is determined by the array's final upper bound. */
2549 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2550 gfc_array_index_type
,
2551 offsetvar
, gfc_index_one_node
);
2552 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2553 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2554 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2555 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2557 *loop_ubound0
= tmp
;
2560 if (TREE_USED (offsetvar
))
2561 pushdecl (offsetvar
);
2563 gcc_assert (INTEGER_CST_P (offset
));
2566 /* Disable bound checking for now because it's probably broken. */
2567 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2574 /* Restore old values of globals. */
2575 first_len
= old_first_len
;
2576 first_len_val
= old_first_len_val
;
2577 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2581 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2582 called after evaluating all of INFO's vector dimensions. Go through
2583 each such vector dimension and see if we can now fill in any missing
2587 set_vector_loop_bounds (gfc_ss
* ss
)
2589 gfc_loopinfo
*loop
, *outer_loop
;
2590 gfc_array_info
*info
;
2598 outer_loop
= outermost_loop (ss
->loop
);
2600 info
= &ss
->info
->data
.array
;
2602 for (; ss
; ss
= ss
->parent
)
2606 for (n
= 0; n
< loop
->dimen
; n
++)
2609 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2610 || loop
->to
[n
] != NULL
)
2613 /* Loop variable N indexes vector dimension DIM, and we don't
2614 yet know the upper bound of loop variable N. Set it to the
2615 difference between the vector's upper and lower bounds. */
2616 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2617 gcc_assert (info
->subscript
[dim
]
2618 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2620 gfc_init_se (&se
, NULL
);
2621 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2622 zero
= gfc_rank_cst
[0];
2623 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2624 gfc_array_index_type
,
2625 gfc_conv_descriptor_ubound_get (desc
, zero
),
2626 gfc_conv_descriptor_lbound_get (desc
, zero
));
2627 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2634 /* Tells whether a scalar argument to an elemental procedure is saved out
2635 of a scalarization loop as a value or as a reference. */
2638 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2640 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2643 /* If the actual argument can be absent (in other words, it can
2644 be a NULL reference), don't try to evaluate it; pass instead
2645 the reference directly. */
2646 if (ss_info
->can_be_null_ref
)
2649 /* If the expression is of polymorphic type, it's actual size is not known,
2650 so we avoid copying it anywhere. */
2651 if (ss_info
->data
.scalar
.dummy_arg
2652 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2653 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2656 /* If the expression is a data reference of aggregate type,
2657 and the data reference is not used on the left hand side,
2658 avoid a copy by saving a reference to the content. */
2659 if (!ss_info
->data
.scalar
.needs_temporary
2660 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2661 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2662 && gfc_expr_is_variable (ss_info
->expr
))
2665 /* Otherwise the expression is evaluated to a temporary variable before the
2666 scalarization loop. */
2671 /* Add the pre and post chains for all the scalar expressions in a SS chain
2672 to loop. This is called after the loop parameters have been calculated,
2673 but before the actual scalarizing loops. */
2676 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2679 gfc_loopinfo
*nested_loop
, *outer_loop
;
2681 gfc_ss_info
*ss_info
;
2682 gfc_array_info
*info
;
2686 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2687 arguments could get evaluated multiple times. */
2688 if (ss
->is_alloc_lhs
)
2691 outer_loop
= outermost_loop (loop
);
2693 /* TODO: This can generate bad code if there are ordering dependencies,
2694 e.g., a callee allocated function and an unknown size constructor. */
2695 gcc_assert (ss
!= NULL
);
2697 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2701 /* Cross loop arrays are handled from within the most nested loop. */
2702 if (ss
->nested_ss
!= NULL
)
2706 expr
= ss_info
->expr
;
2707 info
= &ss_info
->data
.array
;
2709 switch (ss_info
->type
)
2712 /* Scalar expression. Evaluate this now. This includes elemental
2713 dimension indices, but not array section bounds. */
2714 gfc_init_se (&se
, NULL
);
2715 gfc_conv_expr (&se
, expr
);
2716 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2718 if (expr
->ts
.type
!= BT_CHARACTER
2719 && !gfc_is_alloc_class_scalar_function (expr
))
2721 /* Move the evaluation of scalar expressions outside the
2722 scalarization loop, except for WHERE assignments. */
2724 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2725 if (!ss_info
->where
)
2726 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2727 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2730 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2732 ss_info
->data
.scalar
.value
= se
.expr
;
2733 ss_info
->string_length
= se
.string_length
;
2736 case GFC_SS_REFERENCE
:
2737 /* Scalar argument to elemental procedure. */
2738 gfc_init_se (&se
, NULL
);
2739 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2740 gfc_conv_expr_reference (&se
, expr
);
2743 /* Evaluate the argument outside the loop and pass
2744 a reference to the value. */
2745 gfc_conv_expr (&se
, expr
);
2748 /* Ensure that a pointer to the string is stored. */
2749 if (expr
->ts
.type
== BT_CHARACTER
)
2750 gfc_conv_string_parameter (&se
);
2752 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2753 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2754 if (gfc_is_class_scalar_expr (expr
))
2755 /* This is necessary because the dynamic type will always be
2756 large than the declared type. In consequence, assigning
2757 the value to a temporary could segfault.
2758 OOP-TODO: see if this is generally correct or is the value
2759 has to be written to an allocated temporary, whose address
2760 is passed via ss_info. */
2761 ss_info
->data
.scalar
.value
= se
.expr
;
2763 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2766 ss_info
->string_length
= se
.string_length
;
2769 case GFC_SS_SECTION
:
2770 /* Add the expressions for scalar and vector subscripts. */
2771 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2772 if (info
->subscript
[n
])
2773 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2775 set_vector_loop_bounds (ss
);
2779 /* Get the vector's descriptor and store it in SS. */
2780 gfc_init_se (&se
, NULL
);
2781 gfc_conv_expr_descriptor (&se
, expr
);
2782 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2783 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2784 info
->descriptor
= se
.expr
;
2787 case GFC_SS_INTRINSIC
:
2788 gfc_add_intrinsic_ss_code (loop
, ss
);
2791 case GFC_SS_FUNCTION
:
2792 /* Array function return value. We call the function and save its
2793 result in a temporary for use inside the loop. */
2794 gfc_init_se (&se
, NULL
);
2797 if (gfc_is_class_array_function (expr
))
2798 expr
->must_finalize
= 1;
2799 gfc_conv_expr (&se
, expr
);
2800 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2801 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2802 ss_info
->string_length
= se
.string_length
;
2805 case GFC_SS_CONSTRUCTOR
:
2806 if (expr
->ts
.type
== BT_CHARACTER
2807 && ss_info
->string_length
== NULL
2809 && expr
->ts
.u
.cl
->length
2810 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2812 gfc_init_se (&se
, NULL
);
2813 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2814 gfc_charlen_type_node
);
2815 ss_info
->string_length
= se
.expr
;
2816 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2817 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2819 trans_array_constructor (ss
, where
);
2823 case GFC_SS_COMPONENT
:
2824 /* Do nothing. These are handled elsewhere. */
2833 for (nested_loop
= loop
->nested
; nested_loop
;
2834 nested_loop
= nested_loop
->next
)
2835 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2839 /* Translate expressions for the descriptor and data pointer of a SS. */
2843 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2846 gfc_ss_info
*ss_info
;
2847 gfc_array_info
*info
;
2851 info
= &ss_info
->data
.array
;
2853 /* Get the descriptor for the array to be scalarized. */
2854 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2855 gfc_init_se (&se
, NULL
);
2856 se
.descriptor_only
= 1;
2857 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2858 gfc_add_block_to_block (block
, &se
.pre
);
2859 info
->descriptor
= se
.expr
;
2860 ss_info
->string_length
= se
.string_length
;
2864 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2865 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2867 /* Emit a DECL_EXPR for the variable sized array type in
2868 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2869 sizes works correctly. */
2870 tree arraytype
= TREE_TYPE (
2871 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2872 if (! TYPE_NAME (arraytype
))
2873 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2874 NULL_TREE
, arraytype
);
2875 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2876 TYPE_NAME (arraytype
)));
2878 /* Also the data pointer. */
2879 tmp
= gfc_conv_array_data (se
.expr
);
2880 /* If this is a variable or address of a variable we use it directly.
2881 Otherwise we must evaluate it now to avoid breaking dependency
2882 analysis by pulling the expressions for elemental array indices
2885 || (TREE_CODE (tmp
) == ADDR_EXPR
2886 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2887 tmp
= gfc_evaluate_now (tmp
, block
);
2890 tmp
= gfc_conv_array_offset (se
.expr
);
2891 info
->offset
= gfc_evaluate_now (tmp
, block
);
2893 /* Make absolutely sure that the saved_offset is indeed saved
2894 so that the variable is still accessible after the loops
2896 info
->saved_offset
= info
->offset
;
2901 /* Initialize a gfc_loopinfo structure. */
2904 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2908 memset (loop
, 0, sizeof (gfc_loopinfo
));
2909 gfc_init_block (&loop
->pre
);
2910 gfc_init_block (&loop
->post
);
2912 /* Initially scalarize in order and default to no loop reversal. */
2913 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2916 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2919 loop
->ss
= gfc_ss_terminator
;
2923 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2927 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2933 /* Return an expression for the data pointer of an array. */
2936 gfc_conv_array_data (tree descriptor
)
2940 type
= TREE_TYPE (descriptor
);
2941 if (GFC_ARRAY_TYPE_P (type
))
2943 if (TREE_CODE (type
) == POINTER_TYPE
)
2947 /* Descriptorless arrays. */
2948 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2952 return gfc_conv_descriptor_data_get (descriptor
);
2956 /* Return an expression for the base offset of an array. */
2959 gfc_conv_array_offset (tree descriptor
)
2963 type
= TREE_TYPE (descriptor
);
2964 if (GFC_ARRAY_TYPE_P (type
))
2965 return GFC_TYPE_ARRAY_OFFSET (type
);
2967 return gfc_conv_descriptor_offset_get (descriptor
);
2971 /* Get an expression for the array stride. */
2974 gfc_conv_array_stride (tree descriptor
, int dim
)
2979 type
= TREE_TYPE (descriptor
);
2981 /* For descriptorless arrays use the array size. */
2982 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2983 if (tmp
!= NULL_TREE
)
2986 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2991 /* Like gfc_conv_array_stride, but for the lower bound. */
2994 gfc_conv_array_lbound (tree descriptor
, int dim
)
2999 type
= TREE_TYPE (descriptor
);
3001 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3002 if (tmp
!= NULL_TREE
)
3005 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3010 /* Like gfc_conv_array_stride, but for the upper bound. */
3013 gfc_conv_array_ubound (tree descriptor
, int dim
)
3018 type
= TREE_TYPE (descriptor
);
3020 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3021 if (tmp
!= NULL_TREE
)
3024 /* This should only ever happen when passing an assumed shape array
3025 as an actual parameter. The value will never be used. */
3026 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3027 return gfc_index_zero_node
;
3029 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3034 /* Generate code to perform an array index bound check. */
3037 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3038 locus
* where
, bool check_upper
)
3041 tree tmp_lo
, tmp_up
;
3044 const char * name
= NULL
;
3046 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3049 descriptor
= ss
->info
->data
.array
.descriptor
;
3051 index
= gfc_evaluate_now (index
, &se
->pre
);
3053 /* We find a name for the error message. */
3054 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3055 gcc_assert (name
!= NULL
);
3057 if (VAR_P (descriptor
))
3058 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3060 /* If upper bound is present, include both bounds in the error message. */
3063 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3064 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3067 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3068 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3070 msg
= xasprintf ("Index '%%ld' of dimension %d "
3071 "outside of expected range (%%ld:%%ld)", n
+1);
3073 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3075 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3076 fold_convert (long_integer_type_node
, index
),
3077 fold_convert (long_integer_type_node
, tmp_lo
),
3078 fold_convert (long_integer_type_node
, tmp_up
));
3079 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3081 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3082 fold_convert (long_integer_type_node
, index
),
3083 fold_convert (long_integer_type_node
, tmp_lo
),
3084 fold_convert (long_integer_type_node
, tmp_up
));
3089 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3092 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3093 "below lower bound of %%ld", n
+1, name
);
3095 msg
= xasprintf ("Index '%%ld' of dimension %d "
3096 "below lower bound of %%ld", n
+1);
3098 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3100 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3101 fold_convert (long_integer_type_node
, index
),
3102 fold_convert (long_integer_type_node
, tmp_lo
));
3110 /* Return the offset for an index. Performs bound checking for elemental
3111 dimensions. Single element references are processed separately.
3112 DIM is the array dimension, I is the loop dimension. */
3115 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3116 gfc_array_ref
* ar
, tree stride
)
3118 gfc_array_info
*info
;
3123 info
= &ss
->info
->data
.array
;
3125 /* Get the index into the array for this dimension. */
3128 gcc_assert (ar
->type
!= AR_ELEMENT
);
3129 switch (ar
->dimen_type
[dim
])
3131 case DIMEN_THIS_IMAGE
:
3135 /* Elemental dimension. */
3136 gcc_assert (info
->subscript
[dim
]
3137 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3138 /* We've already translated this value outside the loop. */
3139 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3141 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3142 ar
->as
->type
!= AS_ASSUMED_SIZE
3143 || dim
< ar
->dimen
- 1);
3147 gcc_assert (info
&& se
->loop
);
3148 gcc_assert (info
->subscript
[dim
]
3149 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3150 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3152 /* Get a zero-based index into the vector. */
3153 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3154 gfc_array_index_type
,
3155 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3157 /* Multiply the index by the stride. */
3158 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3159 gfc_array_index_type
,
3160 index
, gfc_conv_array_stride (desc
, 0));
3162 /* Read the vector to get an index into info->descriptor. */
3163 data
= build_fold_indirect_ref_loc (input_location
,
3164 gfc_conv_array_data (desc
));
3165 index
= gfc_build_array_ref (data
, index
, NULL
);
3166 index
= gfc_evaluate_now (index
, &se
->pre
);
3167 index
= fold_convert (gfc_array_index_type
, index
);
3169 /* Do any bounds checking on the final info->descriptor index. */
3170 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3171 ar
->as
->type
!= AS_ASSUMED_SIZE
3172 || dim
< ar
->dimen
- 1);
3176 /* Scalarized dimension. */
3177 gcc_assert (info
&& se
->loop
);
3179 /* Multiply the loop variable by the stride and delta. */
3180 index
= se
->loop
->loopvar
[i
];
3181 if (!integer_onep (info
->stride
[dim
]))
3182 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3183 gfc_array_index_type
, index
,
3185 if (!integer_zerop (info
->delta
[dim
]))
3186 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3187 gfc_array_index_type
, index
,
3197 /* Temporary array or derived type component. */
3198 gcc_assert (se
->loop
);
3199 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3201 /* Pointer functions can have stride[0] different from unity.
3202 Use the stride returned by the function call and stored in
3203 the descriptor for the temporary. */
3204 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3205 && se
->ss
->info
->expr
3206 && se
->ss
->info
->expr
->symtree
3207 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3208 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3209 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3212 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3213 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3214 gfc_array_index_type
, index
, info
->delta
[dim
]);
3217 /* Multiply by the stride. */
3218 if (!integer_onep (stride
))
3219 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3226 /* Build a scalarized array reference using the vptr 'size'. */
3229 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3234 tree decl
= NULL_TREE
;
3236 gfc_expr
*expr
= se
->ss
->info
->expr
;
3238 gfc_ref
*class_ref
= NULL
;
3241 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3242 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3243 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3248 || (expr
->ts
.type
!= BT_CLASS
3249 && !gfc_is_class_array_function (expr
)
3250 && !gfc_is_class_array_ref (expr
, NULL
)))
3253 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3254 ts
= &expr
->symtree
->n
.sym
->ts
;
3258 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3260 if (ref
->type
== REF_COMPONENT
3261 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3262 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3263 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3265 && ref
->next
->next
->type
== REF_ARRAY
3266 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3268 ts
= &ref
->u
.c
.component
->ts
;
3278 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3279 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3280 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3282 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3284 else if (expr
&& gfc_is_class_array_function (expr
))
3288 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3291 type
= TREE_TYPE (tmp
);
3294 if (GFC_CLASS_TYPE_P (type
))
3296 if (type
!= TYPE_CANONICAL (type
))
3297 type
= TYPE_CANONICAL (type
);
3305 if (decl
== NULL_TREE
)
3308 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3310 else if (class_ref
== NULL
)
3312 if (decl
== NULL_TREE
)
3313 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3314 /* For class arrays the tree containing the class is stored in
3315 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3316 For all others it's sym's backend_decl directly. */
3317 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3318 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3322 /* Remove everything after the last class reference, convert the
3323 expression and then recover its tailend once more. */
3325 ref
= class_ref
->next
;
3326 class_ref
->next
= NULL
;
3327 gfc_init_se (&tmpse
, NULL
);
3328 gfc_conv_expr (&tmpse
, expr
);
3329 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3331 class_ref
->next
= ref
;
3334 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3335 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3337 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3340 size
= gfc_class_vtab_size_get (decl
);
3342 /* For unlimited polymorphic entities then _len component needs to be
3343 multiplied with the size. If no _len component is present, then
3344 gfc_class_len_or_zero_get () return a zero_node. */
3345 tmp
= gfc_class_len_or_zero_get (decl
);
3346 if (!integer_zerop (tmp
))
3347 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3348 fold_convert (TREE_TYPE (index
), size
),
3349 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3350 fold_convert (TREE_TYPE (index
), tmp
),
3351 fold_convert (TREE_TYPE (index
),
3352 integer_one_node
)));
3354 size
= fold_convert (TREE_TYPE (index
), size
);
3356 /* Build the address of the element. */
3357 type
= TREE_TYPE (TREE_TYPE (base
));
3358 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3359 gfc_array_index_type
,
3361 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3362 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3363 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3365 /* Return the element in the se expression. */
3366 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3371 /* Build a scalarized reference to an array. */
3374 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3376 gfc_array_info
*info
;
3377 tree decl
= NULL_TREE
;
3385 expr
= ss
->info
->expr
;
3386 info
= &ss
->info
->data
.array
;
3388 n
= se
->loop
->order
[0];
3392 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3393 /* Add the offset for this dimension to the stored offset for all other
3395 if (info
->offset
&& !integer_zerop (info
->offset
))
3396 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3397 index
, info
->offset
);
3399 if (expr
&& ((is_subref_array (expr
)
3400 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
)))
3401 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3402 || expr
->expr_type
== EXPR_FUNCTION
))))
3403 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3405 /* A pointer array component can be detected from its field decl. Fix
3406 the descriptor, mark the resulting variable decl and pass it to
3407 gfc_build_array_ref. */
3408 if (is_pointer_array (info
->descriptor
))
3410 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3412 decl
= gfc_evaluate_now (info
->descriptor
, &se
->pre
);
3413 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
3414 TREE_USED (decl
) = 1;
3416 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3417 decl
= TREE_OPERAND (info
->descriptor
, 0);
3419 if (decl
== NULL_TREE
)
3420 decl
= info
->descriptor
;
3423 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3425 /* Use the vptr 'size' field to access a class the element of a class
3427 if (build_class_array_ref (se
, tmp
, index
))
3430 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3434 /* Translate access of temporary array. */
3437 gfc_conv_tmp_array_ref (gfc_se
* se
)
3439 se
->string_length
= se
->ss
->info
->string_length
;
3440 gfc_conv_scalarized_array_ref (se
, NULL
);
3441 gfc_advance_se_ss_chain (se
);
3444 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3447 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3449 if (TREE_CODE (t
) == INTEGER_CST
)
3450 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3453 if (!integer_zerop (*offset
))
3454 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3455 gfc_array_index_type
, *offset
, t
);
3463 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3469 /* For class arrays the class declaration is stored in the saved
3471 if (INDIRECT_REF_P (desc
)
3472 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3473 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3474 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3475 TREE_OPERAND (desc
, 0)));
3479 /* Class container types do not always have the GFC_CLASS_TYPE_P
3480 but the canonical type does. */
3481 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3482 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3484 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3485 if (TYPE_CANONICAL (type
)
3486 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3487 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3490 tmp
= gfc_conv_array_data (desc
);
3491 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3492 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3497 /* Build an array reference. se->expr already holds the array descriptor.
3498 This should be either a variable, indirect variable reference or component
3499 reference. For arrays which do not have a descriptor, se->expr will be
3501 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3504 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3508 tree offset
, cst_offset
;
3511 tree decl
= NULL_TREE
;
3514 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3515 char *var_name
= NULL
;
3519 gcc_assert (ar
->codimen
);
3521 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3522 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3525 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3526 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3527 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3529 /* Use the actual tree type and not the wrapped coarray. */
3530 if (!se
->want_pointer
)
3531 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3538 /* Handle scalarized references separately. */
3539 if (ar
->type
!= AR_ELEMENT
)
3541 gfc_conv_scalarized_array_ref (se
, ar
);
3542 gfc_advance_se_ss_chain (se
);
3546 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3551 len
= strlen (sym
->name
) + 1;
3552 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3554 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3556 if (ref
->type
== REF_COMPONENT
)
3557 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3560 var_name
= XALLOCAVEC (char, len
);
3561 strcpy (var_name
, sym
->name
);
3563 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3565 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3567 if (ref
->type
== REF_COMPONENT
)
3569 strcat (var_name
, "%%");
3570 strcat (var_name
, ref
->u
.c
.component
->name
);
3575 cst_offset
= offset
= gfc_index_zero_node
;
3576 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3578 /* Calculate the offsets from all the dimensions. Make sure to associate
3579 the final offset so that we form a chain of loop invariant summands. */
3580 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3582 /* Calculate the index for this dimension. */
3583 gfc_init_se (&indexse
, se
);
3584 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3585 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3587 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3589 /* Check array bounds. */
3593 /* Evaluate the indexse.expr only once. */
3594 indexse
.expr
= save_expr (indexse
.expr
);
3597 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3598 if (sym
->attr
.temporary
)
3600 gfc_init_se (&tmpse
, se
);
3601 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3602 gfc_array_index_type
);
3603 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3607 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3609 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3610 "below lower bound of %%ld", n
+1, var_name
);
3611 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3612 fold_convert (long_integer_type_node
,
3614 fold_convert (long_integer_type_node
, tmp
));
3617 /* Upper bound, but not for the last dimension of assumed-size
3619 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3621 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3622 if (sym
->attr
.temporary
)
3624 gfc_init_se (&tmpse
, se
);
3625 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3626 gfc_array_index_type
);
3627 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3631 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3632 logical_type_node
, indexse
.expr
, tmp
);
3633 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3634 "above upper bound of %%ld", n
+1, var_name
);
3635 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3636 fold_convert (long_integer_type_node
,
3638 fold_convert (long_integer_type_node
, tmp
));
3643 /* Multiply the index by the stride. */
3644 stride
= gfc_conv_array_stride (se
->expr
, n
);
3645 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3646 indexse
.expr
, stride
);
3648 /* And add it to the total. */
3649 add_to_offset (&cst_offset
, &offset
, tmp
);
3652 if (!integer_zerop (cst_offset
))
3653 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3654 gfc_array_index_type
, offset
, cst_offset
);
3656 /* A pointer array component can be detected from its field decl. Fix
3657 the descriptor, mark the resulting variable decl and pass it to
3659 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3660 && is_pointer_array (se
->expr
))
3662 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3664 decl
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3665 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
3666 TREE_USED (decl
) = 1;
3668 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3669 decl
= TREE_OPERAND (se
->expr
, 0);
3673 else if (expr
->ts
.deferred
3674 || (sym
->ts
.type
== BT_CHARACTER
3675 && sym
->attr
.select_type_temporary
))
3676 decl
= sym
->backend_decl
;
3677 else if (sym
->ts
.type
== BT_CLASS
)
3680 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3684 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3685 LOOP_DIM dimension (if any) to array's offset. */
3688 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3689 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3692 gfc_array_info
*info
;
3695 info
= &ss
->info
->data
.array
;
3697 gfc_init_se (&se
, NULL
);
3699 se
.expr
= info
->descriptor
;
3700 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3701 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3702 gfc_add_block_to_block (pblock
, &se
.pre
);
3704 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3705 gfc_array_index_type
,
3706 info
->offset
, index
);
3707 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3711 /* Generate the code to be executed immediately before entering a
3712 scalarization loop. */
3715 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3716 stmtblock_t
* pblock
)
3719 gfc_ss_info
*ss_info
;
3720 gfc_array_info
*info
;
3721 gfc_ss_type ss_type
;
3723 gfc_loopinfo
*ploop
;
3727 /* This code will be executed before entering the scalarization loop
3728 for this dimension. */
3729 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3733 if ((ss_info
->useflags
& flag
) == 0)
3736 ss_type
= ss_info
->type
;
3737 if (ss_type
!= GFC_SS_SECTION
3738 && ss_type
!= GFC_SS_FUNCTION
3739 && ss_type
!= GFC_SS_CONSTRUCTOR
3740 && ss_type
!= GFC_SS_COMPONENT
)
3743 info
= &ss_info
->data
.array
;
3745 gcc_assert (dim
< ss
->dimen
);
3746 gcc_assert (ss
->dimen
== loop
->dimen
);
3749 ar
= &info
->ref
->u
.ar
;
3753 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3755 /* If we are in the outermost dimension of this loop, the previous
3756 dimension shall be in the parent loop. */
3757 gcc_assert (ss
->parent
!= NULL
);
3760 ploop
= loop
->parent
;
3762 /* ss and ss->parent are about the same array. */
3763 gcc_assert (ss_info
== pss
->info
);
3771 if (dim
== loop
->dimen
- 1)
3776 /* For the time being, there is no loop reordering. */
3777 gcc_assert (i
== ploop
->order
[i
]);
3778 i
= ploop
->order
[i
];
3780 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3782 stride
= gfc_conv_array_stride (info
->descriptor
,
3783 innermost_ss (ss
)->dim
[i
]);
3785 /* Calculate the stride of the innermost loop. Hopefully this will
3786 allow the backend optimizers to do their stuff more effectively.
3788 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3790 /* For the outermost loop calculate the offset due to any
3791 elemental dimensions. It will have been initialized with the
3792 base offset of the array. */
3795 for (i
= 0; i
< ar
->dimen
; i
++)
3797 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3800 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3805 /* Add the offset for the previous loop dimension. */
3806 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3808 /* Remember this offset for the second loop. */
3809 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3810 info
->saved_offset
= info
->offset
;
3815 /* Start a scalarized expression. Creates a scope and declares loop
3819 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3825 gcc_assert (!loop
->array_parameter
);
3827 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3829 n
= loop
->order
[dim
];
3831 gfc_start_block (&loop
->code
[n
]);
3833 /* Create the loop variable. */
3834 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3836 if (dim
< loop
->temp_dim
)
3840 /* Calculate values that will be constant within this loop. */
3841 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3843 gfc_start_block (pbody
);
3847 /* Generates the actual loop code for a scalarization loop. */
3850 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3851 stmtblock_t
* pbody
)
3862 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3863 | OMPWS_SCALARIZER_BODY
))
3864 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3865 && n
== loop
->dimen
- 1)
3867 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3868 init
= make_tree_vec (1);
3869 cond
= make_tree_vec (1);
3870 incr
= make_tree_vec (1);
3872 /* Cycle statement is implemented with a goto. Exit statement must not
3873 be present for this loop. */
3874 exit_label
= gfc_build_label_decl (NULL_TREE
);
3875 TREE_USED (exit_label
) = 1;
3877 /* Label for cycle statements (if needed). */
3878 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3879 gfc_add_expr_to_block (pbody
, tmp
);
3881 stmt
= make_node (OMP_FOR
);
3883 TREE_TYPE (stmt
) = void_type_node
;
3884 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3886 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3887 OMP_CLAUSE_SCHEDULE
);
3888 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3889 = OMP_CLAUSE_SCHEDULE_STATIC
;
3890 if (ompws_flags
& OMPWS_NOWAIT
)
3891 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3892 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3894 /* Initialize the loopvar. */
3895 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3897 OMP_FOR_INIT (stmt
) = init
;
3898 /* The exit condition. */
3899 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3901 loop
->loopvar
[n
], loop
->to
[n
]);
3902 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3903 OMP_FOR_COND (stmt
) = cond
;
3904 /* Increment the loopvar. */
3905 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3906 loop
->loopvar
[n
], gfc_index_one_node
);
3907 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3908 void_type_node
, loop
->loopvar
[n
], tmp
);
3909 OMP_FOR_INCR (stmt
) = incr
;
3911 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3912 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3916 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3917 && (loop
->temp_ss
== NULL
);
3919 loopbody
= gfc_finish_block (pbody
);
3922 std::swap (loop
->from
[n
], loop
->to
[n
]);
3924 /* Initialize the loopvar. */
3925 if (loop
->loopvar
[n
] != loop
->from
[n
])
3926 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3928 exit_label
= gfc_build_label_decl (NULL_TREE
);
3930 /* Generate the loop body. */
3931 gfc_init_block (&block
);
3933 /* The exit condition. */
3934 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3935 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3936 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3937 TREE_USED (exit_label
) = 1;
3938 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3939 gfc_add_expr_to_block (&block
, tmp
);
3941 /* The main body. */
3942 gfc_add_expr_to_block (&block
, loopbody
);
3944 /* Increment the loopvar. */
3945 tmp
= fold_build2_loc (input_location
,
3946 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3947 gfc_array_index_type
, loop
->loopvar
[n
],
3948 gfc_index_one_node
);
3950 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3952 /* Build the loop. */
3953 tmp
= gfc_finish_block (&block
);
3954 tmp
= build1_v (LOOP_EXPR
, tmp
);
3955 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3957 /* Add the exit label. */
3958 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3959 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3965 /* Finishes and generates the loops for a scalarized expression. */
3968 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3973 stmtblock_t
*pblock
;
3977 /* Generate the loops. */
3978 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3980 n
= loop
->order
[dim
];
3981 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3982 loop
->loopvar
[n
] = NULL_TREE
;
3983 pblock
= &loop
->code
[n
];
3986 tmp
= gfc_finish_block (pblock
);
3987 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3989 /* Clear all the used flags. */
3990 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3991 if (ss
->parent
== NULL
)
3992 ss
->info
->useflags
= 0;
3996 /* Finish the main body of a scalarized expression, and start the secondary
4000 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4004 stmtblock_t
*pblock
;
4008 /* We finish as many loops as are used by the temporary. */
4009 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4011 n
= loop
->order
[dim
];
4012 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4013 loop
->loopvar
[n
] = NULL_TREE
;
4014 pblock
= &loop
->code
[n
];
4017 /* We don't want to finish the outermost loop entirely. */
4018 n
= loop
->order
[loop
->temp_dim
- 1];
4019 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4021 /* Restore the initial offsets. */
4022 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4024 gfc_ss_type ss_type
;
4025 gfc_ss_info
*ss_info
;
4029 if ((ss_info
->useflags
& 2) == 0)
4032 ss_type
= ss_info
->type
;
4033 if (ss_type
!= GFC_SS_SECTION
4034 && ss_type
!= GFC_SS_FUNCTION
4035 && ss_type
!= GFC_SS_CONSTRUCTOR
4036 && ss_type
!= GFC_SS_COMPONENT
)
4039 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4042 /* Restart all the inner loops we just finished. */
4043 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4045 n
= loop
->order
[dim
];
4047 gfc_start_block (&loop
->code
[n
]);
4049 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4051 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4054 /* Start a block for the secondary copying code. */
4055 gfc_start_block (body
);
4059 /* Precalculate (either lower or upper) bound of an array section.
4060 BLOCK: Block in which the (pre)calculation code will go.
4061 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4062 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4063 DESC: Array descriptor from which the bound will be picked if unspecified
4064 (either lower or upper bound according to LBOUND). */
4067 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4068 tree desc
, int dim
, bool lbound
, bool deferred
)
4071 gfc_expr
* input_val
= values
[dim
];
4072 tree
*output
= &bounds
[dim
];
4077 /* Specified section bound. */
4078 gfc_init_se (&se
, NULL
);
4079 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4080 gfc_add_block_to_block (block
, &se
.pre
);
4083 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4085 /* The gfc_conv_array_lbound () routine returns a constant zero for
4086 deferred length arrays, which in the scalarizer wreaks havoc, when
4087 copying to a (newly allocated) one-based array.
4088 Keep returning the actual result in sync for both bounds. */
4089 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4091 gfc_conv_descriptor_ubound_get (desc
,
4096 /* No specific bound specified so use the bound of the array. */
4097 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4098 gfc_conv_array_ubound (desc
, dim
);
4100 *output
= gfc_evaluate_now (*output
, block
);
4104 /* Calculate the lower bound of an array section. */
4107 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4109 gfc_expr
*stride
= NULL
;
4112 gfc_array_info
*info
;
4115 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4117 info
= &ss
->info
->data
.array
;
4118 ar
= &info
->ref
->u
.ar
;
4120 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4122 /* We use a zero-based index to access the vector. */
4123 info
->start
[dim
] = gfc_index_zero_node
;
4124 info
->end
[dim
] = NULL
;
4125 info
->stride
[dim
] = gfc_index_one_node
;
4129 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4130 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4131 desc
= info
->descriptor
;
4132 stride
= ar
->stride
[dim
];
4135 /* Calculate the start of the range. For vector subscripts this will
4136 be the range of the vector. */
4137 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4138 ar
->as
->type
== AS_DEFERRED
);
4140 /* Similarly calculate the end. Although this is not used in the
4141 scalarizer, it is needed when checking bounds and where the end
4142 is an expression with side-effects. */
4143 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4144 ar
->as
->type
== AS_DEFERRED
);
4147 /* Calculate the stride. */
4149 info
->stride
[dim
] = gfc_index_one_node
;
4152 gfc_init_se (&se
, NULL
);
4153 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4154 gfc_add_block_to_block (block
, &se
.pre
);
4155 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4160 /* Calculates the range start and stride for a SS chain. Also gets the
4161 descriptor and data pointer. The range of vector subscripts is the size
4162 of the vector. Array bounds are also checked. */
4165 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4172 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4175 /* Determine the rank of the loop. */
4176 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4178 switch (ss
->info
->type
)
4180 case GFC_SS_SECTION
:
4181 case GFC_SS_CONSTRUCTOR
:
4182 case GFC_SS_FUNCTION
:
4183 case GFC_SS_COMPONENT
:
4184 loop
->dimen
= ss
->dimen
;
4187 /* As usual, lbound and ubound are exceptions!. */
4188 case GFC_SS_INTRINSIC
:
4189 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4191 case GFC_ISYM_LBOUND
:
4192 case GFC_ISYM_UBOUND
:
4193 case GFC_ISYM_LCOBOUND
:
4194 case GFC_ISYM_UCOBOUND
:
4195 case GFC_ISYM_THIS_IMAGE
:
4196 loop
->dimen
= ss
->dimen
;
4208 /* We should have determined the rank of the expression by now. If
4209 not, that's bad news. */
4213 /* Loop over all the SS in the chain. */
4214 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4216 gfc_ss_info
*ss_info
;
4217 gfc_array_info
*info
;
4221 expr
= ss_info
->expr
;
4222 info
= &ss_info
->data
.array
;
4224 if (expr
&& expr
->shape
&& !info
->shape
)
4225 info
->shape
= expr
->shape
;
4227 switch (ss_info
->type
)
4229 case GFC_SS_SECTION
:
4230 /* Get the descriptor for the array. If it is a cross loops array,
4231 we got the descriptor already in the outermost loop. */
4232 if (ss
->parent
== NULL
)
4233 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4234 !loop
->array_parameter
);
4236 for (n
= 0; n
< ss
->dimen
; n
++)
4237 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4240 case GFC_SS_INTRINSIC
:
4241 switch (expr
->value
.function
.isym
->id
)
4243 /* Fall through to supply start and stride. */
4244 case GFC_ISYM_LBOUND
:
4245 case GFC_ISYM_UBOUND
:
4249 /* This is the variant without DIM=... */
4250 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4252 arg
= expr
->value
.function
.actual
->expr
;
4253 if (arg
->rank
== -1)
4258 /* The rank (hence the return value's shape) is unknown,
4259 we have to retrieve it. */
4260 gfc_init_se (&se
, NULL
);
4261 se
.descriptor_only
= 1;
4262 gfc_conv_expr (&se
, arg
);
4263 /* This is a bare variable, so there is no preliminary
4265 gcc_assert (se
.pre
.head
== NULL_TREE
4266 && se
.post
.head
== NULL_TREE
);
4267 rank
= gfc_conv_descriptor_rank (se
.expr
);
4268 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4269 gfc_array_index_type
,
4270 fold_convert (gfc_array_index_type
,
4272 gfc_index_one_node
);
4273 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4274 info
->start
[0] = gfc_index_zero_node
;
4275 info
->stride
[0] = gfc_index_one_node
;
4278 /* Otherwise fall through GFC_SS_FUNCTION. */
4281 case GFC_ISYM_LCOBOUND
:
4282 case GFC_ISYM_UCOBOUND
:
4283 case GFC_ISYM_THIS_IMAGE
:
4291 case GFC_SS_CONSTRUCTOR
:
4292 case GFC_SS_FUNCTION
:
4293 for (n
= 0; n
< ss
->dimen
; n
++)
4295 int dim
= ss
->dim
[n
];
4297 info
->start
[dim
] = gfc_index_zero_node
;
4298 info
->end
[dim
] = gfc_index_zero_node
;
4299 info
->stride
[dim
] = gfc_index_one_node
;
4308 /* The rest is just runtime bound checking. */
4309 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4312 tree lbound
, ubound
;
4314 tree size
[GFC_MAX_DIMENSIONS
];
4315 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4316 gfc_array_info
*info
;
4320 gfc_start_block (&block
);
4322 for (n
= 0; n
< loop
->dimen
; n
++)
4323 size
[n
] = NULL_TREE
;
4325 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4328 gfc_ss_info
*ss_info
;
4331 const char *expr_name
;
4334 if (ss_info
->type
!= GFC_SS_SECTION
)
4337 /* Catch allocatable lhs in f2003. */
4338 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
4341 expr
= ss_info
->expr
;
4342 expr_loc
= &expr
->where
;
4343 expr_name
= expr
->symtree
->name
;
4345 gfc_start_block (&inner
);
4347 /* TODO: range checking for mapped dimensions. */
4348 info
= &ss_info
->data
.array
;
4350 /* This code only checks ranges. Elemental and vector
4351 dimensions are checked later. */
4352 for (n
= 0; n
< loop
->dimen
; n
++)
4357 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4360 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4361 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4362 check_upper
= false;
4366 /* Zero stride is not allowed. */
4367 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4368 info
->stride
[dim
], gfc_index_zero_node
);
4369 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4370 "of array '%s'", dim
+ 1, expr_name
);
4371 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4375 desc
= info
->descriptor
;
4377 /* This is the run-time equivalent of resolve.c's
4378 check_dimension(). The logical is more readable there
4379 than it is here, with all the trees. */
4380 lbound
= gfc_conv_array_lbound (desc
, dim
);
4381 end
= info
->end
[dim
];
4383 ubound
= gfc_conv_array_ubound (desc
, dim
);
4387 /* non_zerosized is true when the selected range is not
4389 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4390 logical_type_node
, info
->stride
[dim
],
4391 gfc_index_zero_node
);
4392 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4393 info
->start
[dim
], end
);
4394 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4395 logical_type_node
, stride_pos
, tmp
);
4397 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4399 info
->stride
[dim
], gfc_index_zero_node
);
4400 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4401 info
->start
[dim
], end
);
4402 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4405 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4407 stride_pos
, stride_neg
);
4409 /* Check the start of the range against the lower and upper
4410 bounds of the array, if the range is not empty.
4411 If upper bound is present, include both bounds in the
4415 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4417 info
->start
[dim
], lbound
);
4418 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4420 non_zerosized
, tmp
);
4421 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4423 info
->start
[dim
], ubound
);
4424 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4426 non_zerosized
, tmp2
);
4427 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4428 "outside of expected range (%%ld:%%ld)",
4429 dim
+ 1, expr_name
);
4430 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4432 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4433 fold_convert (long_integer_type_node
, lbound
),
4434 fold_convert (long_integer_type_node
, ubound
));
4435 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4437 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4438 fold_convert (long_integer_type_node
, lbound
),
4439 fold_convert (long_integer_type_node
, ubound
));
4444 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4446 info
->start
[dim
], lbound
);
4447 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4448 logical_type_node
, non_zerosized
, tmp
);
4449 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4450 "below lower bound of %%ld",
4451 dim
+ 1, expr_name
);
4452 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4454 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4455 fold_convert (long_integer_type_node
, lbound
));
4459 /* Compute the last element of the range, which is not
4460 necessarily "end" (think 0:5:3, which doesn't contain 5)
4461 and check it against both lower and upper bounds. */
4463 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4464 gfc_array_index_type
, end
,
4466 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4467 gfc_array_index_type
, tmp
,
4469 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4470 gfc_array_index_type
, end
, tmp
);
4471 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4472 logical_type_node
, tmp
, lbound
);
4473 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4474 logical_type_node
, non_zerosized
, tmp2
);
4477 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4478 logical_type_node
, tmp
, ubound
);
4479 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4480 logical_type_node
, non_zerosized
, tmp3
);
4481 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4482 "outside of expected range (%%ld:%%ld)",
4483 dim
+ 1, expr_name
);
4484 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4486 fold_convert (long_integer_type_node
, tmp
),
4487 fold_convert (long_integer_type_node
, ubound
),
4488 fold_convert (long_integer_type_node
, lbound
));
4489 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4491 fold_convert (long_integer_type_node
, tmp
),
4492 fold_convert (long_integer_type_node
, ubound
),
4493 fold_convert (long_integer_type_node
, lbound
));
4498 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4499 "below lower bound of %%ld",
4500 dim
+ 1, expr_name
);
4501 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4503 fold_convert (long_integer_type_node
, tmp
),
4504 fold_convert (long_integer_type_node
, lbound
));
4508 /* Check the section sizes match. */
4509 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4510 gfc_array_index_type
, end
,
4512 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4513 gfc_array_index_type
, tmp
,
4515 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4516 gfc_array_index_type
,
4517 gfc_index_one_node
, tmp
);
4518 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4519 gfc_array_index_type
, tmp
,
4520 build_int_cst (gfc_array_index_type
, 0));
4521 /* We remember the size of the first section, and check all the
4522 others against this. */
4525 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4526 logical_type_node
, tmp
, size
[n
]);
4527 msg
= xasprintf ("Array bound mismatch for dimension %d "
4528 "of array '%s' (%%ld/%%ld)",
4529 dim
+ 1, expr_name
);
4531 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4533 fold_convert (long_integer_type_node
, tmp
),
4534 fold_convert (long_integer_type_node
, size
[n
]));
4539 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4542 tmp
= gfc_finish_block (&inner
);
4544 /* For optional arguments, only check bounds if the argument is
4546 if (expr
->symtree
->n
.sym
->attr
.optional
4547 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4548 tmp
= build3_v (COND_EXPR
,
4549 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4550 tmp
, build_empty_stmt (input_location
));
4552 gfc_add_expr_to_block (&block
, tmp
);
4556 tmp
= gfc_finish_block (&block
);
4557 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4560 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4561 gfc_conv_ss_startstride (loop
);
4564 /* Return true if both symbols could refer to the same data object. Does
4565 not take account of aliasing due to equivalence statements. */
4568 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4569 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4571 /* Aliasing isn't possible if the symbols have different base types. */
4572 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4575 /* Pointers can point to other pointers and target objects. */
4577 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4578 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4581 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4582 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4584 if (lsym_target
&& rsym_target
4585 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4586 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4587 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4588 && (!rsym
->attr
.dimension
4589 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4596 /* Return true if the two SS could be aliased, i.e. both point to the same data
4598 /* TODO: resolve aliases based on frontend expressions. */
4601 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4605 gfc_expr
*lexpr
, *rexpr
;
4608 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4610 lexpr
= lss
->info
->expr
;
4611 rexpr
= rss
->info
->expr
;
4613 lsym
= lexpr
->symtree
->n
.sym
;
4614 rsym
= rexpr
->symtree
->n
.sym
;
4616 lsym_pointer
= lsym
->attr
.pointer
;
4617 lsym_target
= lsym
->attr
.target
;
4618 rsym_pointer
= rsym
->attr
.pointer
;
4619 rsym_target
= rsym
->attr
.target
;
4621 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4622 rsym_pointer
, rsym_target
))
4625 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4626 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4629 /* For derived types we must check all the component types. We can ignore
4630 array references as these will have the same base type as the previous
4632 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4634 if (lref
->type
!= REF_COMPONENT
)
4637 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4638 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4640 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4641 rsym_pointer
, rsym_target
))
4644 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4645 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4647 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4652 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4655 if (rref
->type
!= REF_COMPONENT
)
4658 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4659 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4661 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4662 lsym_pointer
, lsym_target
,
4663 rsym_pointer
, rsym_target
))
4666 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4667 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4669 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4670 &rref
->u
.c
.sym
->ts
))
4672 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4673 &rref
->u
.c
.component
->ts
))
4675 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4676 &rref
->u
.c
.component
->ts
))
4682 lsym_pointer
= lsym
->attr
.pointer
;
4683 lsym_target
= lsym
->attr
.target
;
4684 lsym_pointer
= lsym
->attr
.pointer
;
4685 lsym_target
= lsym
->attr
.target
;
4687 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4689 if (rref
->type
!= REF_COMPONENT
)
4692 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4693 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4695 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4696 lsym_pointer
, lsym_target
,
4697 rsym_pointer
, rsym_target
))
4700 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4701 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4703 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4712 /* Resolve array data dependencies. Creates a temporary if required. */
4713 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4717 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4723 gfc_ss_info
*ss_info
;
4724 gfc_expr
*dest_expr
;
4729 loop
->temp_ss
= NULL
;
4730 dest_expr
= dest
->info
->expr
;
4732 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4735 ss_expr
= ss_info
->expr
;
4737 if (ss_info
->array_outer_dependency
)
4743 if (ss_info
->type
!= GFC_SS_SECTION
)
4745 if (flag_realloc_lhs
4746 && dest_expr
!= ss_expr
4747 && gfc_is_reallocatable_lhs (dest_expr
)
4749 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4751 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4752 if (!nDepend
&& dest_expr
->rank
> 0
4753 && dest_expr
->ts
.type
== BT_CHARACTER
4754 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4756 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4758 if (ss_info
->type
== GFC_SS_REFERENCE
4759 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4760 ss_info
->data
.scalar
.needs_temporary
= 1;
4768 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4770 if (gfc_could_be_alias (dest
, ss
)
4771 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4779 lref
= dest_expr
->ref
;
4780 rref
= ss_expr
->ref
;
4782 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4787 for (i
= 0; i
< dest
->dimen
; i
++)
4788 for (j
= 0; j
< ss
->dimen
; j
++)
4790 && dest
->dim
[i
] == ss
->dim
[j
])
4792 /* If we don't access array elements in the same order,
4793 there is a dependency. */
4798 /* TODO : loop shifting. */
4801 /* Mark the dimensions for LOOP SHIFTING */
4802 for (n
= 0; n
< loop
->dimen
; n
++)
4804 int dim
= dest
->data
.info
.dim
[n
];
4806 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4808 else if (! gfc_is_same_range (&lref
->u
.ar
,
4809 &rref
->u
.ar
, dim
, 0))
4813 /* Put all the dimensions with dependencies in the
4816 for (n
= 0; n
< loop
->dimen
; n
++)
4818 gcc_assert (loop
->order
[n
] == n
);
4820 loop
->order
[dim
++] = n
;
4822 for (n
= 0; n
< loop
->dimen
; n
++)
4825 loop
->order
[dim
++] = n
;
4828 gcc_assert (dim
== loop
->dimen
);
4839 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4840 if (GFC_ARRAY_TYPE_P (base_type
)
4841 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4842 base_type
= gfc_get_element_type (base_type
);
4843 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4845 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4848 loop
->temp_ss
= NULL
;
4852 /* Browse through each array's information from the scalarizer and set the loop
4853 bounds according to the "best" one (per dimension), i.e. the one which
4854 provides the most information (constant bounds, shape, etc.). */
4857 set_loop_bounds (gfc_loopinfo
*loop
)
4859 int n
, dim
, spec_dim
;
4860 gfc_array_info
*info
;
4861 gfc_array_info
*specinfo
;
4865 bool dynamic
[GFC_MAX_DIMENSIONS
];
4868 bool nonoptional_arr
;
4870 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4872 loopspec
= loop
->specloop
;
4875 for (n
= 0; n
< loop
->dimen
; n
++)
4880 /* If there are both optional and nonoptional array arguments, scalarize
4881 over the nonoptional; otherwise, it does not matter as then all
4882 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4884 nonoptional_arr
= false;
4886 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4887 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4888 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4890 nonoptional_arr
= true;
4894 /* We use one SS term, and use that to determine the bounds of the
4895 loop for this dimension. We try to pick the simplest term. */
4896 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4898 gfc_ss_type ss_type
;
4900 ss_type
= ss
->info
->type
;
4901 if (ss_type
== GFC_SS_SCALAR
4902 || ss_type
== GFC_SS_TEMP
4903 || ss_type
== GFC_SS_REFERENCE
4904 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4907 info
= &ss
->info
->data
.array
;
4910 if (loopspec
[n
] != NULL
)
4912 specinfo
= &loopspec
[n
]->info
->data
.array
;
4913 spec_dim
= loopspec
[n
]->dim
[n
];
4917 /* Silence uninitialized warnings. */
4924 gcc_assert (info
->shape
[dim
]);
4925 /* The frontend has worked out the size for us. */
4928 || !integer_zerop (specinfo
->start
[spec_dim
]))
4929 /* Prefer zero-based descriptors if possible. */
4934 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4936 gfc_constructor_base base
;
4937 /* An unknown size constructor will always be rank one.
4938 Higher rank constructors will either have known shape,
4939 or still be wrapped in a call to reshape. */
4940 gcc_assert (loop
->dimen
== 1);
4942 /* Always prefer to use the constructor bounds if the size
4943 can be determined at compile time. Prefer not to otherwise,
4944 since the general case involves realloc, and it's better to
4945 avoid that overhead if possible. */
4946 base
= ss
->info
->expr
->value
.constructor
;
4947 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4948 if (!dynamic
[n
] || !loopspec
[n
])
4953 /* Avoid using an allocatable lhs in an assignment, since
4954 there might be a reallocation coming. */
4955 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4960 /* Criteria for choosing a loop specifier (most important first):
4961 doesn't need realloc
4967 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4969 else if (integer_onep (info
->stride
[dim
])
4970 && !integer_onep (specinfo
->stride
[spec_dim
]))
4972 else if (INTEGER_CST_P (info
->stride
[dim
])
4973 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4975 else if (INTEGER_CST_P (info
->start
[dim
])
4976 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4977 && integer_onep (info
->stride
[dim
])
4978 == integer_onep (specinfo
->stride
[spec_dim
])
4979 && INTEGER_CST_P (info
->stride
[dim
])
4980 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4982 /* We don't work out the upper bound.
4983 else if (INTEGER_CST_P (info->finish[n])
4984 && ! INTEGER_CST_P (specinfo->finish[n]))
4985 loopspec[n] = ss; */
4988 /* We should have found the scalarization loop specifier. If not,
4990 gcc_assert (loopspec
[n
]);
4992 info
= &loopspec
[n
]->info
->data
.array
;
4993 dim
= loopspec
[n
]->dim
[n
];
4995 /* Set the extents of this range. */
4996 cshape
= info
->shape
;
4997 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4998 && INTEGER_CST_P (info
->stride
[dim
]))
5000 loop
->from
[n
] = info
->start
[dim
];
5001 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
5002 mpz_sub_ui (i
, i
, 1);
5003 /* To = from + (size - 1) * stride. */
5004 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5005 if (!integer_onep (info
->stride
[dim
]))
5006 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5007 gfc_array_index_type
, tmp
,
5009 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5010 gfc_array_index_type
,
5011 loop
->from
[n
], tmp
);
5015 loop
->from
[n
] = info
->start
[dim
];
5016 switch (loopspec
[n
]->info
->type
)
5018 case GFC_SS_CONSTRUCTOR
:
5019 /* The upper bound is calculated when we expand the
5021 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5024 case GFC_SS_SECTION
:
5025 /* Use the end expression if it exists and is not constant,
5026 so that it is only evaluated once. */
5027 loop
->to
[n
] = info
->end
[dim
];
5030 case GFC_SS_FUNCTION
:
5031 /* The loop bound will be set when we generate the call. */
5032 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5035 case GFC_SS_INTRINSIC
:
5037 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5039 /* The {l,u}bound of an assumed rank. */
5040 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5041 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5042 && expr
->value
.function
.actual
->next
->expr
== NULL
5043 && expr
->value
.function
.actual
->expr
->rank
== -1);
5045 loop
->to
[n
] = info
->end
[dim
];
5049 case GFC_SS_COMPONENT
:
5051 if (info
->end
[dim
] != NULL_TREE
)
5053 loop
->to
[n
] = info
->end
[dim
];
5065 /* Transform everything so we have a simple incrementing variable. */
5066 if (integer_onep (info
->stride
[dim
]))
5067 info
->delta
[dim
] = gfc_index_zero_node
;
5070 /* Set the delta for this section. */
5071 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5072 /* Number of iterations is (end - start + step) / step.
5073 with start = 0, this simplifies to
5075 for (i = 0; i<=last; i++){...}; */
5076 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5077 gfc_array_index_type
, loop
->to
[n
],
5079 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5080 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5081 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5082 tmp
, build_int_cst (gfc_array_index_type
, -1));
5083 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5084 /* Make the loop variable start at 0. */
5085 loop
->from
[n
] = gfc_index_zero_node
;
5090 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5091 set_loop_bounds (loop
);
5095 /* Initialize the scalarization loop. Creates the loop variables. Determines
5096 the range of the loop variables. Creates a temporary if required.
5097 Also generates code for scalar expressions which have been
5098 moved outside the loop. */
5101 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5106 set_loop_bounds (loop
);
5108 /* Add all the scalar code that can be taken out of the loops.
5109 This may include calculating the loop bounds, so do it before
5110 allocating the temporary. */
5111 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5113 tmp_ss
= loop
->temp_ss
;
5114 /* If we want a temporary then create it. */
5117 gfc_ss_info
*tmp_ss_info
;
5119 tmp_ss_info
= tmp_ss
->info
;
5120 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5121 gcc_assert (loop
->parent
== NULL
);
5123 /* Make absolutely sure that this is a complete type. */
5124 if (tmp_ss_info
->string_length
)
5125 tmp_ss_info
->data
.temp
.type
5126 = gfc_get_character_type_len_for_eltype
5127 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5128 tmp_ss_info
->string_length
);
5130 tmp
= tmp_ss_info
->data
.temp
.type
;
5131 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5132 tmp_ss_info
->type
= GFC_SS_SECTION
;
5134 gcc_assert (tmp_ss
->dimen
!= 0);
5136 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5137 NULL_TREE
, false, true, false, where
);
5140 /* For array parameters we don't have loop variables, so don't calculate the
5142 if (!loop
->array_parameter
)
5143 gfc_set_delta (loop
);
5147 /* Calculates how to transform from loop variables to array indices for each
5148 array: once loop bounds are chosen, sets the difference (DELTA field) between
5149 loop bounds and array reference bounds, for each array info. */
5152 gfc_set_delta (gfc_loopinfo
*loop
)
5154 gfc_ss
*ss
, **loopspec
;
5155 gfc_array_info
*info
;
5159 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5161 loopspec
= loop
->specloop
;
5163 /* Calculate the translation from loop variables to array indices. */
5164 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5166 gfc_ss_type ss_type
;
5168 ss_type
= ss
->info
->type
;
5169 if (ss_type
!= GFC_SS_SECTION
5170 && ss_type
!= GFC_SS_COMPONENT
5171 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5174 info
= &ss
->info
->data
.array
;
5176 for (n
= 0; n
< ss
->dimen
; n
++)
5178 /* If we are specifying the range the delta is already set. */
5179 if (loopspec
[n
] != ss
)
5183 /* Calculate the offset relative to the loop variable.
5184 First multiply by the stride. */
5185 tmp
= loop
->from
[n
];
5186 if (!integer_onep (info
->stride
[dim
]))
5187 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5188 gfc_array_index_type
,
5189 tmp
, info
->stride
[dim
]);
5191 /* Then subtract this from our starting value. */
5192 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5193 gfc_array_index_type
,
5194 info
->start
[dim
], tmp
);
5196 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5201 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5202 gfc_set_delta (loop
);
5206 /* Calculate the size of a given array dimension from the bounds. This
5207 is simply (ubound - lbound + 1) if this expression is positive
5208 or 0 if it is negative (pick either one if it is zero). Optionally
5209 (if or_expr is present) OR the (expression != 0) condition to it. */
5212 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5217 /* Calculate (ubound - lbound + 1). */
5218 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5220 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5221 gfc_index_one_node
);
5223 /* Check whether the size for this dimension is negative. */
5224 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5225 gfc_index_zero_node
);
5226 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5227 gfc_index_zero_node
, res
);
5229 /* Build OR expression. */
5231 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5232 logical_type_node
, *or_expr
, cond
);
5238 /* For an array descriptor, get the total number of elements. This is just
5239 the product of the extents along from_dim to to_dim. */
5242 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5247 res
= gfc_index_one_node
;
5249 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5255 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5256 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5258 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5259 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5267 /* Full size of an array. */
5270 gfc_conv_descriptor_size (tree desc
, int rank
)
5272 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5276 /* Size of a coarray for all dimensions but the last. */
5279 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5281 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5285 /* Fills in an array descriptor, and returns the size of the array.
5286 The size will be a simple_val, ie a variable or a constant. Also
5287 calculates the offset of the base. The pointer argument overflow,
5288 which should be of integer type, will increase in value if overflow
5289 occurs during the size calculation. Returns the size of the array.
5293 for (n = 0; n < rank; n++)
5295 a.lbound[n] = specified_lower_bound;
5296 offset = offset + a.lbond[n] * stride;
5298 a.ubound[n] = specified_upper_bound;
5299 a.stride[n] = stride;
5300 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5301 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5302 stride = stride * size;
5304 for (n = rank; n < rank+corank; n++)
5305 (Set lcobound/ucobound as above.)
5306 element_size = sizeof (array element);
5309 stride = (size_t) stride;
5310 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5311 stride = stride * element_size;
5317 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5318 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5319 stmtblock_t
* descriptor_block
, tree
* overflow
,
5320 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5321 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5334 stmtblock_t thenblock
;
5335 stmtblock_t elseblock
;
5340 type
= TREE_TYPE (descriptor
);
5342 stride
= gfc_index_one_node
;
5343 offset
= gfc_index_zero_node
;
5345 /* Set the dtype before the alloc, because registration of coarrays needs
5347 if (expr
->ts
.type
== BT_CHARACTER
5348 && expr
->ts
.deferred
5349 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5351 type
= gfc_typenode_for_spec (&expr
->ts
);
5352 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5353 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5357 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5358 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5361 or_expr
= logical_false_node
;
5363 for (n
= 0; n
< rank
; n
++)
5368 /* We have 3 possibilities for determining the size of the array:
5369 lower == NULL => lbound = 1, ubound = upper[n]
5370 upper[n] = NULL => lbound = 1, ubound = lower[n]
5371 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5374 /* Set lower bound. */
5375 gfc_init_se (&se
, NULL
);
5376 if (expr3_desc
!= NULL_TREE
)
5378 if (e3_is_array_constr
)
5379 /* The lbound of a constant array [] starts at zero, but when
5380 allocating it, the standard expects the array to start at
5382 se
.expr
= gfc_index_one_node
;
5384 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5387 else if (lower
== NULL
)
5388 se
.expr
= gfc_index_one_node
;
5391 gcc_assert (lower
[n
]);
5394 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5395 gfc_add_block_to_block (pblock
, &se
.pre
);
5399 se
.expr
= gfc_index_one_node
;
5403 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5404 gfc_rank_cst
[n
], se
.expr
);
5405 conv_lbound
= se
.expr
;
5407 /* Work out the offset for this component. */
5408 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5410 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5411 gfc_array_index_type
, offset
, tmp
);
5413 /* Set upper bound. */
5414 gfc_init_se (&se
, NULL
);
5415 if (expr3_desc
!= NULL_TREE
)
5417 if (e3_is_array_constr
)
5419 /* The lbound of a constant array [] starts at zero, but when
5420 allocating it, the standard expects the array to start at
5421 one. Therefore fix the upper bound to be
5422 (desc.ubound - desc.lbound)+ 1. */
5423 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5424 gfc_array_index_type
,
5425 gfc_conv_descriptor_ubound_get (
5426 expr3_desc
, gfc_rank_cst
[n
]),
5427 gfc_conv_descriptor_lbound_get (
5428 expr3_desc
, gfc_rank_cst
[n
]));
5429 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5430 gfc_array_index_type
, tmp
,
5431 gfc_index_one_node
);
5432 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5435 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5440 gcc_assert (ubound
);
5441 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5442 gfc_add_block_to_block (pblock
, &se
.pre
);
5443 if (ubound
->expr_type
== EXPR_FUNCTION
)
5444 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5446 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5447 gfc_rank_cst
[n
], se
.expr
);
5448 conv_ubound
= se
.expr
;
5450 /* Store the stride. */
5451 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5452 gfc_rank_cst
[n
], stride
);
5454 /* Calculate size and check whether extent is negative. */
5455 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5456 size
= gfc_evaluate_now (size
, pblock
);
5458 /* Check whether multiplying the stride by the number of
5459 elements in this dimension would overflow. We must also check
5460 whether the current dimension has zero size in order to avoid
5463 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5464 gfc_array_index_type
,
5465 fold_convert (gfc_array_index_type
,
5466 TYPE_MAX_VALUE (gfc_array_index_type
)),
5468 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5469 logical_type_node
, tmp
, stride
),
5470 PRED_FORTRAN_OVERFLOW
);
5471 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5472 integer_one_node
, integer_zero_node
);
5473 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5474 logical_type_node
, size
,
5475 gfc_index_zero_node
),
5476 PRED_FORTRAN_SIZE_ZERO
);
5477 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5478 integer_zero_node
, tmp
);
5479 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5481 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5483 /* Multiply the stride by the number of elements in this dimension. */
5484 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5485 gfc_array_index_type
, stride
, size
);
5486 stride
= gfc_evaluate_now (stride
, pblock
);
5489 for (n
= rank
; n
< rank
+ corank
; n
++)
5493 /* Set lower bound. */
5494 gfc_init_se (&se
, NULL
);
5495 if (lower
== NULL
|| lower
[n
] == NULL
)
5497 gcc_assert (n
== rank
+ corank
- 1);
5498 se
.expr
= gfc_index_one_node
;
5502 if (ubound
|| n
== rank
+ corank
- 1)
5504 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5505 gfc_add_block_to_block (pblock
, &se
.pre
);
5509 se
.expr
= gfc_index_one_node
;
5513 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5514 gfc_rank_cst
[n
], se
.expr
);
5516 if (n
< rank
+ corank
- 1)
5518 gfc_init_se (&se
, NULL
);
5519 gcc_assert (ubound
);
5520 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5521 gfc_add_block_to_block (pblock
, &se
.pre
);
5522 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5523 gfc_rank_cst
[n
], se
.expr
);
5527 /* The stride is the number of elements in the array, so multiply by the
5528 size of an element to get the total size. Obviously, if there is a
5529 SOURCE expression (expr3) we must use its element size. */
5530 if (expr3_elem_size
!= NULL_TREE
)
5531 tmp
= expr3_elem_size
;
5532 else if (expr3
!= NULL
)
5534 if (expr3
->ts
.type
== BT_CLASS
)
5537 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5538 gfc_add_vptr_component (sz
);
5539 gfc_add_size_component (sz
);
5540 gfc_init_se (&se_sz
, NULL
);
5541 gfc_conv_expr (&se_sz
, sz
);
5547 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5548 tmp
= TYPE_SIZE_UNIT (tmp
);
5552 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5554 /* Convert to size_t. */
5555 element_size
= fold_convert (size_type_node
, tmp
);
5558 return element_size
;
5560 *nelems
= gfc_evaluate_now (stride
, pblock
);
5561 stride
= fold_convert (size_type_node
, stride
);
5563 /* First check for overflow. Since an array of type character can
5564 have zero element_size, we must check for that before
5566 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5568 TYPE_MAX_VALUE (size_type_node
), element_size
);
5569 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5570 logical_type_node
, tmp
, stride
),
5571 PRED_FORTRAN_OVERFLOW
);
5572 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5573 integer_one_node
, integer_zero_node
);
5574 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5575 logical_type_node
, element_size
,
5576 build_int_cst (size_type_node
, 0)),
5577 PRED_FORTRAN_SIZE_ZERO
);
5578 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5579 integer_zero_node
, tmp
);
5580 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5582 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5584 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5585 stride
, element_size
);
5587 if (poffset
!= NULL
)
5589 offset
= gfc_evaluate_now (offset
, pblock
);
5593 if (integer_zerop (or_expr
))
5595 if (integer_onep (or_expr
))
5596 return build_int_cst (size_type_node
, 0);
5598 var
= gfc_create_var (TREE_TYPE (size
), "size");
5599 gfc_start_block (&thenblock
);
5600 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5601 thencase
= gfc_finish_block (&thenblock
);
5603 gfc_start_block (&elseblock
);
5604 gfc_add_modify (&elseblock
, var
, size
);
5605 elsecase
= gfc_finish_block (&elseblock
);
5607 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5608 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5609 gfc_add_expr_to_block (pblock
, tmp
);
5615 /* Retrieve the last ref from the chain. This routine is specific to
5616 gfc_array_allocate ()'s needs. */
5619 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5621 gfc_ref
*ref
, *prev_ref
;
5624 /* Prevent warnings for uninitialized variables. */
5625 prev_ref
= *prev_ref_in
;
5626 while (ref
&& ref
->next
!= NULL
)
5628 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5629 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5634 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5638 *prev_ref_in
= prev_ref
;
5642 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5643 the work for an ALLOCATE statement. */
5647 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5648 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5649 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5650 bool e3_is_array_constr
)
5654 tree offset
= NULL_TREE
;
5655 tree token
= NULL_TREE
;
5658 tree error
= NULL_TREE
;
5659 tree overflow
; /* Boolean storing whether size calculation overflows. */
5660 tree var_overflow
= NULL_TREE
;
5662 tree set_descriptor
;
5663 stmtblock_t set_descriptor_block
;
5664 stmtblock_t elseblock
;
5667 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5668 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5669 non_ulimate_coarray_ptr_comp
;
5673 /* Find the last reference in the chain. */
5674 if (!retrieve_last_ref (&ref
, &prev_ref
))
5677 /* Take the allocatable and coarray properties solely from the expr-ref's
5678 attributes and not from source=-expression. */
5681 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5682 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5683 non_ulimate_coarray_ptr_comp
= false;
5687 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5688 /* Pointer components in coarrayed derived types must be treated
5689 specially in that they are registered without a check if the are
5690 already associated. This does not hold for ultimate coarray
5692 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5693 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5694 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5697 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5698 a coarray. In this case it does not matter whether we are on this_image
5701 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5702 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5709 gcc_assert (coarray
);
5711 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5713 gfc_ref
*old_ref
= ref
;
5714 /* F08:C633: Array shape from expr3. */
5717 /* Find the last reference in the chain. */
5718 if (!retrieve_last_ref (&ref
, &prev_ref
))
5720 if (expr3
->expr_type
== EXPR_FUNCTION
5721 && gfc_expr_attr (expr3
).dimension
)
5726 alloc_w_e3_arr_spec
= true;
5729 /* Figure out the size of the array. */
5730 switch (ref
->u
.ar
.type
)
5736 upper
= ref
->u
.ar
.start
;
5742 lower
= ref
->u
.ar
.start
;
5743 upper
= ref
->u
.ar
.end
;
5747 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5748 || alloc_w_e3_arr_spec
);
5750 lower
= ref
->u
.ar
.as
->lower
;
5751 upper
= ref
->u
.ar
.as
->upper
;
5759 overflow
= integer_zero_node
;
5761 gfc_init_block (&set_descriptor_block
);
5762 /* Take the corank only from the actual ref and not from the coref. The
5763 later will mislead the generation of the array dimensions for allocatable/
5764 pointer components in derived types. */
5765 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5766 : ref
->u
.ar
.as
->rank
,
5767 coarray
? ref
->u
.ar
.as
->corank
: 0,
5768 &offset
, lower
, upper
,
5769 &se
->pre
, &set_descriptor_block
, &overflow
,
5770 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5771 e3_is_array_constr
, expr
);
5775 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5776 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5778 if (status
== NULL_TREE
)
5780 /* Generate the block of code handling overflow. */
5781 msg
= gfc_build_addr_expr (pchar_type_node
,
5782 gfc_build_localized_cstring_const
5783 ("Integer overflow when calculating the amount of "
5784 "memory to allocate"));
5785 error
= build_call_expr_loc (input_location
,
5786 gfor_fndecl_runtime_error
, 1, msg
);
5790 tree status_type
= TREE_TYPE (status
);
5791 stmtblock_t set_status_block
;
5793 gfc_start_block (&set_status_block
);
5794 gfc_add_modify (&set_status_block
, status
,
5795 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5796 error
= gfc_finish_block (&set_status_block
);
5800 gfc_start_block (&elseblock
);
5802 /* Allocate memory to store the data. */
5803 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5804 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5806 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5808 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5809 : gfc_conv_descriptor_data_get (se
->expr
);
5810 token
= gfc_conv_descriptor_token (se
->expr
);
5811 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5814 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5815 STRIP_NOPS (pointer
);
5817 /* The allocatable variant takes the old pointer as first argument. */
5819 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5820 status
, errmsg
, errlen
, label_finish
, expr
,
5821 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5822 else if (non_ulimate_coarray_ptr_comp
&& token
)
5823 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5824 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5826 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5828 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5832 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5833 logical_type_node
, var_overflow
, integer_zero_node
),
5834 PRED_FORTRAN_OVERFLOW
);
5835 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5836 error
, gfc_finish_block (&elseblock
));
5839 tmp
= gfc_finish_block (&elseblock
);
5841 gfc_add_expr_to_block (&se
->pre
, tmp
);
5843 /* Update the array descriptors. */
5845 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5847 /* Pointer arrays need the span field to be set. */
5848 if (is_pointer_array (se
->expr
)
5849 || (expr
->ts
.type
== BT_CLASS
5850 && CLASS_DATA (expr
)->attr
.class_pointer
))
5852 if (expr3
&& expr3_elem_size
!= NULL_TREE
)
5853 tmp
= expr3_elem_size
;
5855 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se
->expr
)));
5856 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5857 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5860 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5861 if (status
!= NULL_TREE
)
5863 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5864 logical_type_node
, status
,
5865 build_int_cst (TREE_TYPE (status
), 0));
5866 gfc_add_expr_to_block (&se
->pre
,
5867 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5870 build_empty_stmt (input_location
)));
5873 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5879 /* Create an array constructor from an initialization expression.
5880 We assume the frontend already did any expansions and conversions. */
5883 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5890 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5892 if (expr
->expr_type
== EXPR_VARIABLE
5893 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5894 && expr
->symtree
->n
.sym
->value
)
5895 expr
= expr
->symtree
->n
.sym
->value
;
5897 switch (expr
->expr_type
)
5900 case EXPR_STRUCTURE
:
5901 /* A single scalar or derived type value. Create an array with all
5902 elements equal to that value. */
5903 gfc_init_se (&se
, NULL
);
5905 if (expr
->expr_type
== EXPR_CONSTANT
)
5906 gfc_conv_constant (&se
, expr
);
5908 gfc_conv_structure (&se
, expr
, 1);
5910 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5911 /* This will probably eat buckets of memory for large arrays. */
5914 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5920 /* Create a vector of all the elements. */
5921 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5922 c
; c
= gfc_constructor_next (c
))
5926 /* Problems occur when we get something like
5927 integer :: a(lots) = (/(i, i=1, lots)/) */
5928 gfc_fatal_error ("The number of elements in the array "
5929 "constructor at %L requires an increase of "
5930 "the allowed %d upper limit. See "
5931 "%<-fmax-array-constructor%> option",
5932 &expr
->where
, flag_max_array_constructor
);
5935 if (mpz_cmp_si (c
->offset
, 0) != 0)
5936 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5940 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5946 mpz_add (maxval
, c
->offset
, c
->repeat
);
5947 mpz_sub_ui (maxval
, maxval
, 1);
5948 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5949 if (mpz_cmp_si (c
->offset
, 0) != 0)
5951 mpz_add_ui (maxval
, c
->offset
, 1);
5952 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5955 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5957 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5963 gfc_init_se (&se
, NULL
);
5964 switch (c
->expr
->expr_type
)
5967 gfc_conv_constant (&se
, c
->expr
);
5970 case EXPR_STRUCTURE
:
5971 gfc_conv_structure (&se
, c
->expr
, 1);
5975 /* Catch those occasional beasts that do not simplify
5976 for one reason or another, assuming that if they are
5977 standard defying the frontend will catch them. */
5978 gfc_conv_expr (&se
, c
->expr
);
5982 if (range
== NULL_TREE
)
5983 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5986 if (index
!= NULL_TREE
)
5987 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5988 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5994 return gfc_build_null_descriptor (type
);
6000 /* Create a constructor from the list of elements. */
6001 tmp
= build_constructor (type
, v
);
6002 TREE_CONSTANT (tmp
) = 1;
6007 /* Generate code to evaluate non-constant coarray cobounds. */
6010 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
6011 const gfc_symbol
*sym
)
6019 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6021 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6023 /* Evaluate non-constant array bound expressions. */
6024 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6025 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6027 gfc_init_se (&se
, NULL
);
6028 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6029 gfc_add_block_to_block (pblock
, &se
.pre
);
6030 gfc_add_modify (pblock
, lbound
, se
.expr
);
6032 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6033 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6035 gfc_init_se (&se
, NULL
);
6036 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6037 gfc_add_block_to_block (pblock
, &se
.pre
);
6038 gfc_add_modify (pblock
, ubound
, se
.expr
);
6044 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6045 returns the size (in elements) of the array. */
6048 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6049 stmtblock_t
* pblock
)
6062 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6064 size
= gfc_index_one_node
;
6065 offset
= gfc_index_zero_node
;
6066 for (dim
= 0; dim
< as
->rank
; dim
++)
6068 /* Evaluate non-constant array bound expressions. */
6069 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6070 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6072 gfc_init_se (&se
, NULL
);
6073 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6074 gfc_add_block_to_block (pblock
, &se
.pre
);
6075 gfc_add_modify (pblock
, lbound
, se
.expr
);
6077 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6078 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6080 gfc_init_se (&se
, NULL
);
6081 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6082 gfc_add_block_to_block (pblock
, &se
.pre
);
6083 gfc_add_modify (pblock
, ubound
, se
.expr
);
6085 /* The offset of this dimension. offset = offset - lbound * stride. */
6086 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6088 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6091 /* The size of this dimension, and the stride of the next. */
6092 if (dim
+ 1 < as
->rank
)
6093 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6095 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6097 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6099 /* Calculate stride = size * (ubound + 1 - lbound). */
6100 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6101 gfc_array_index_type
,
6102 gfc_index_one_node
, lbound
);
6103 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6104 gfc_array_index_type
, ubound
, tmp
);
6105 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6106 gfc_array_index_type
, size
, tmp
);
6108 gfc_add_modify (pblock
, stride
, tmp
);
6110 stride
= gfc_evaluate_now (tmp
, pblock
);
6112 /* Make sure that negative size arrays are translated
6113 to being zero size. */
6114 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6115 stride
, gfc_index_zero_node
);
6116 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6117 gfc_array_index_type
, tmp
,
6118 stride
, gfc_index_zero_node
);
6119 gfc_add_modify (pblock
, stride
, tmp
);
6125 gfc_trans_array_cobounds (type
, pblock
, sym
);
6126 gfc_trans_vla_type_sizes (sym
, pblock
);
6133 /* Generate code to initialize/allocate an array variable. */
6136 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6137 gfc_wrapped_block
* block
)
6141 tree tmp
= NULL_TREE
;
6148 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6150 /* Do nothing for USEd variables. */
6151 if (sym
->attr
.use_assoc
)
6154 type
= TREE_TYPE (decl
);
6155 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6156 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6158 gfc_init_block (&init
);
6160 /* Evaluate character string length. */
6161 if (sym
->ts
.type
== BT_CHARACTER
6162 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6164 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6166 gfc_trans_vla_type_sizes (sym
, &init
);
6168 /* Emit a DECL_EXPR for this variable, which will cause the
6169 gimplifier to allocate storage, and all that good stuff. */
6170 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6171 gfc_add_expr_to_block (&init
, tmp
);
6176 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6180 type
= TREE_TYPE (type
);
6182 gcc_assert (!sym
->attr
.use_assoc
);
6183 gcc_assert (!TREE_STATIC (decl
));
6184 gcc_assert (!sym
->module
);
6186 if (sym
->ts
.type
== BT_CHARACTER
6187 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6188 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6190 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6192 /* Don't actually allocate space for Cray Pointees. */
6193 if (sym
->attr
.cray_pointee
)
6195 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6196 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6198 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6202 if (flag_stack_arrays
)
6204 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6205 space
= build_decl (sym
->declared_at
.lb
->location
,
6206 VAR_DECL
, create_tmp_var_name ("A"),
6207 TREE_TYPE (TREE_TYPE (decl
)));
6208 gfc_trans_vla_type_sizes (sym
, &init
);
6212 /* The size is the number of elements in the array, so multiply by the
6213 size of an element to get the total size. */
6214 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6215 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6216 size
, fold_convert (gfc_array_index_type
, tmp
));
6218 /* Allocate memory to hold the data. */
6219 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6220 gfc_add_modify (&init
, decl
, tmp
);
6222 /* Free the temporary. */
6223 tmp
= gfc_call_free (decl
);
6227 /* Set offset of the array. */
6228 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6229 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6231 /* Automatic arrays should not have initializers. */
6232 gcc_assert (!sym
->value
);
6234 inittree
= gfc_finish_block (&init
);
6241 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6242 where also space is located. */
6243 gfc_init_block (&init
);
6244 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6245 TREE_TYPE (space
), space
);
6246 gfc_add_expr_to_block (&init
, tmp
);
6247 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6248 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6249 gfc_add_modify (&init
, decl
, addr
);
6250 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6253 gfc_add_init_cleanup (block
, inittree
, tmp
);
6257 /* Generate entry and exit code for g77 calling convention arrays. */
6260 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6270 gfc_save_backend_locus (&loc
);
6271 gfc_set_backend_locus (&sym
->declared_at
);
6273 /* Descriptor type. */
6274 parm
= sym
->backend_decl
;
6275 type
= TREE_TYPE (parm
);
6276 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6278 gfc_start_block (&init
);
6280 if (sym
->ts
.type
== BT_CHARACTER
6281 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6282 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6284 /* Evaluate the bounds of the array. */
6285 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6287 /* Set the offset. */
6288 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6289 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6291 /* Set the pointer itself if we aren't using the parameter directly. */
6292 if (TREE_CODE (parm
) != PARM_DECL
)
6294 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6295 gfc_add_modify (&init
, parm
, tmp
);
6297 stmt
= gfc_finish_block (&init
);
6299 gfc_restore_backend_locus (&loc
);
6301 /* Add the initialization code to the start of the function. */
6303 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6305 tmp
= gfc_conv_expr_present (sym
);
6306 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6309 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6313 /* Modify the descriptor of an array parameter so that it has the
6314 correct lower bound. Also move the upper bound accordingly.
6315 If the array is not packed, it will be copied into a temporary.
6316 For each dimension we set the new lower and upper bounds. Then we copy the
6317 stride and calculate the offset for this dimension. We also work out
6318 what the stride of a packed array would be, and see it the two match.
6319 If the array need repacking, we set the stride to the values we just
6320 calculated, recalculate the offset and copy the array data.
6321 Code is also added to copy the data back at the end of the function.
6325 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6326 gfc_wrapped_block
* block
)
6333 tree stmtInit
, stmtCleanup
;
6340 tree stride
, stride2
;
6350 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6352 /* Do nothing for pointer and allocatable arrays. */
6353 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6354 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6355 || sym
->attr
.allocatable
6356 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6359 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6361 gfc_trans_g77_array (sym
, block
);
6366 gfc_save_backend_locus (&loc
);
6367 /* loc.nextc is not set by save_backend_locus but the location routines
6369 if (loc
.nextc
== NULL
)
6370 loc
.nextc
= loc
.lb
->line
;
6371 gfc_set_backend_locus (&sym
->declared_at
);
6373 /* Descriptor type. */
6374 type
= TREE_TYPE (tmpdesc
);
6375 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6376 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6378 /* For a class array the dummy array descriptor is in the _class
6380 dumdesc
= gfc_class_data_get (dumdesc
);
6382 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6383 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6384 gfc_start_block (&init
);
6386 if (sym
->ts
.type
== BT_CHARACTER
6387 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6388 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6390 checkparm
= (as
->type
== AS_EXPLICIT
6391 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6393 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6394 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6396 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6398 /* For non-constant shape arrays we only check if the first dimension
6399 is contiguous. Repacking higher dimensions wouldn't gain us
6400 anything as we still don't know the array stride. */
6401 partial
= gfc_create_var (logical_type_node
, "partial");
6402 TREE_USED (partial
) = 1;
6403 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6404 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6405 gfc_index_one_node
);
6406 gfc_add_modify (&init
, partial
, tmp
);
6409 partial
= NULL_TREE
;
6411 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6412 here, however I think it does the right thing. */
6415 /* Set the first stride. */
6416 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6417 stride
= gfc_evaluate_now (stride
, &init
);
6419 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6420 stride
, gfc_index_zero_node
);
6421 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6422 tmp
, gfc_index_one_node
, stride
);
6423 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6424 gfc_add_modify (&init
, stride
, tmp
);
6426 /* Allow the user to disable array repacking. */
6427 stmt_unpacked
= NULL_TREE
;
6431 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6432 /* A library call to repack the array if necessary. */
6433 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6434 stmt_unpacked
= build_call_expr_loc (input_location
,
6435 gfor_fndecl_in_pack
, 1, tmp
);
6437 stride
= gfc_index_one_node
;
6439 if (warn_array_temporaries
)
6440 gfc_warning (OPT_Warray_temporaries
,
6441 "Creating array temporary at %L", &loc
);
6444 /* This is for the case where the array data is used directly without
6445 calling the repack function. */
6446 if (no_repack
|| partial
!= NULL_TREE
)
6447 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6449 stmt_packed
= NULL_TREE
;
6451 /* Assign the data pointer. */
6452 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6454 /* Don't repack unknown shape arrays when the first stride is 1. */
6455 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6456 partial
, stmt_packed
, stmt_unpacked
);
6459 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6460 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6462 offset
= gfc_index_zero_node
;
6463 size
= gfc_index_one_node
;
6465 /* Evaluate the bounds of the array. */
6466 for (n
= 0; n
< as
->rank
; n
++)
6468 if (checkparm
|| !as
->upper
[n
])
6470 /* Get the bounds of the actual parameter. */
6471 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6472 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6476 dubound
= NULL_TREE
;
6477 dlbound
= NULL_TREE
;
6480 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6481 if (!INTEGER_CST_P (lbound
))
6483 gfc_init_se (&se
, NULL
);
6484 gfc_conv_expr_type (&se
, as
->lower
[n
],
6485 gfc_array_index_type
);
6486 gfc_add_block_to_block (&init
, &se
.pre
);
6487 gfc_add_modify (&init
, lbound
, se
.expr
);
6490 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6491 /* Set the desired upper bound. */
6494 /* We know what we want the upper bound to be. */
6495 if (!INTEGER_CST_P (ubound
))
6497 gfc_init_se (&se
, NULL
);
6498 gfc_conv_expr_type (&se
, as
->upper
[n
],
6499 gfc_array_index_type
);
6500 gfc_add_block_to_block (&init
, &se
.pre
);
6501 gfc_add_modify (&init
, ubound
, se
.expr
);
6504 /* Check the sizes match. */
6507 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6511 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6512 gfc_array_index_type
, ubound
, lbound
);
6513 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6514 gfc_array_index_type
,
6515 gfc_index_one_node
, temp
);
6516 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6517 gfc_array_index_type
, dubound
,
6519 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6520 gfc_array_index_type
,
6521 gfc_index_one_node
, stride2
);
6522 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6523 gfc_array_index_type
, temp
, stride2
);
6524 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6525 "%%ld instead of %%ld", n
+1, sym
->name
);
6527 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6528 fold_convert (long_integer_type_node
, temp
),
6529 fold_convert (long_integer_type_node
, stride2
));
6536 /* For assumed shape arrays move the upper bound by the same amount
6537 as the lower bound. */
6538 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6539 gfc_array_index_type
, dubound
, dlbound
);
6540 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6541 gfc_array_index_type
, tmp
, lbound
);
6542 gfc_add_modify (&init
, ubound
, tmp
);
6544 /* The offset of this dimension. offset = offset - lbound * stride. */
6545 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6547 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6548 gfc_array_index_type
, offset
, tmp
);
6550 /* The size of this dimension, and the stride of the next. */
6551 if (n
+ 1 < as
->rank
)
6553 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6555 if (no_repack
|| partial
!= NULL_TREE
)
6557 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6559 /* Figure out the stride if not a known constant. */
6560 if (!INTEGER_CST_P (stride
))
6563 stmt_packed
= NULL_TREE
;
6566 /* Calculate stride = size * (ubound + 1 - lbound). */
6567 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6568 gfc_array_index_type
,
6569 gfc_index_one_node
, lbound
);
6570 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6571 gfc_array_index_type
, ubound
, tmp
);
6572 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6573 gfc_array_index_type
, size
, tmp
);
6577 /* Assign the stride. */
6578 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6579 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6580 gfc_array_index_type
, partial
,
6581 stmt_unpacked
, stmt_packed
);
6583 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6584 gfc_add_modify (&init
, stride
, tmp
);
6589 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6591 if (stride
&& !INTEGER_CST_P (stride
))
6593 /* Calculate size = stride * (ubound + 1 - lbound). */
6594 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6595 gfc_array_index_type
,
6596 gfc_index_one_node
, lbound
);
6597 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6598 gfc_array_index_type
,
6600 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6601 gfc_array_index_type
,
6602 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6603 gfc_add_modify (&init
, stride
, tmp
);
6608 gfc_trans_array_cobounds (type
, &init
, sym
);
6610 /* Set the offset. */
6611 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6612 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6614 gfc_trans_vla_type_sizes (sym
, &init
);
6616 stmtInit
= gfc_finish_block (&init
);
6618 /* Only do the entry/initialization code if the arg is present. */
6619 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6620 optional_arg
= (sym
->attr
.optional
6621 || (sym
->ns
->proc_name
->attr
.entry_master
6622 && sym
->attr
.dummy
));
6625 tmp
= gfc_conv_expr_present (sym
);
6626 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6627 build_empty_stmt (input_location
));
6632 stmtCleanup
= NULL_TREE
;
6635 stmtblock_t cleanup
;
6636 gfc_start_block (&cleanup
);
6638 if (sym
->attr
.intent
!= INTENT_IN
)
6640 /* Copy the data back. */
6641 tmp
= build_call_expr_loc (input_location
,
6642 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6643 gfc_add_expr_to_block (&cleanup
, tmp
);
6646 /* Free the temporary. */
6647 tmp
= gfc_call_free (tmpdesc
);
6648 gfc_add_expr_to_block (&cleanup
, tmp
);
6650 stmtCleanup
= gfc_finish_block (&cleanup
);
6652 /* Only do the cleanup if the array was repacked. */
6654 /* For a class array the dummy array descriptor is in the _class
6656 tmp
= gfc_class_data_get (dumdesc
);
6658 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6659 tmp
= gfc_conv_descriptor_data_get (tmp
);
6660 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6662 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6663 build_empty_stmt (input_location
));
6667 tmp
= gfc_conv_expr_present (sym
);
6668 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6669 build_empty_stmt (input_location
));
6673 /* We don't need to free any memory allocated by internal_pack as it will
6674 be freed at the end of the function by pop_context. */
6675 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6677 gfc_restore_backend_locus (&loc
);
6681 /* Calculate the overall offset, including subreferences. */
6683 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6684 bool subref
, gfc_expr
*expr
)
6694 /* If offset is NULL and this is not a subreferenced array, there is
6696 if (offset
== NULL_TREE
)
6699 offset
= gfc_index_zero_node
;
6704 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6706 /* Offset the data pointer for pointer assignments from arrays with
6707 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6710 /* Go past the array reference. */
6711 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6712 if (ref
->type
== REF_ARRAY
&&
6713 ref
->u
.ar
.type
!= AR_ELEMENT
)
6719 /* Calculate the offset for each subsequent subreference. */
6720 for (; ref
; ref
= ref
->next
)
6725 field
= ref
->u
.c
.component
->backend_decl
;
6726 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6727 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6729 tmp
, field
, NULL_TREE
);
6733 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6734 gfc_init_se (&start
, NULL
);
6735 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6736 gfc_add_block_to_block (block
, &start
.pre
);
6737 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6741 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6742 && ref
->u
.ar
.type
== AR_ELEMENT
);
6744 /* TODO - Add bounds checking. */
6745 stride
= gfc_index_one_node
;
6746 index
= gfc_index_zero_node
;
6747 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6752 /* Update the index. */
6753 gfc_init_se (&start
, NULL
);
6754 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6755 itmp
= gfc_evaluate_now (start
.expr
, block
);
6756 gfc_init_se (&start
, NULL
);
6757 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6758 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6759 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6760 gfc_array_index_type
, itmp
, jtmp
);
6761 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6762 gfc_array_index_type
, itmp
, stride
);
6763 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6764 gfc_array_index_type
, itmp
, index
);
6765 index
= gfc_evaluate_now (index
, block
);
6767 /* Update the stride. */
6768 gfc_init_se (&start
, NULL
);
6769 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6770 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6771 gfc_array_index_type
, start
.expr
,
6773 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6774 gfc_array_index_type
,
6775 gfc_index_one_node
, itmp
);
6776 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6777 gfc_array_index_type
, stride
, itmp
);
6778 stride
= gfc_evaluate_now (stride
, block
);
6781 /* Apply the index to obtain the array element. */
6782 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6792 /* Set the target data pointer. */
6793 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6794 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6798 /* gfc_conv_expr_descriptor needs the string length an expression
6799 so that the size of the temporary can be obtained. This is done
6800 by adding up the string lengths of all the elements in the
6801 expression. Function with non-constant expressions have their
6802 string lengths mapped onto the actual arguments using the
6803 interface mapping machinery in trans-expr.c. */
6805 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6807 gfc_interface_mapping mapping
;
6808 gfc_formal_arglist
*formal
;
6809 gfc_actual_arglist
*arg
;
6812 if (expr
->ts
.u
.cl
->length
6813 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6815 if (!expr
->ts
.u
.cl
->backend_decl
)
6816 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6820 switch (expr
->expr_type
)
6823 get_array_charlen (expr
->value
.op
.op1
, se
);
6825 /* For parentheses the expression ts.u.cl is identical. */
6826 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6829 expr
->ts
.u
.cl
->backend_decl
=
6830 gfc_create_var (gfc_charlen_type_node
, "sln");
6832 if (expr
->value
.op
.op2
)
6834 get_array_charlen (expr
->value
.op
.op2
, se
);
6836 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6838 /* Add the string lengths and assign them to the expression
6839 string length backend declaration. */
6840 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6841 fold_build2_loc (input_location
, PLUS_EXPR
,
6842 gfc_charlen_type_node
,
6843 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6844 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6847 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6848 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6852 if (expr
->value
.function
.esym
== NULL
6853 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6855 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6859 /* Map expressions involving the dummy arguments onto the actual
6860 argument expressions. */
6861 gfc_init_interface_mapping (&mapping
);
6862 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6863 arg
= expr
->value
.function
.actual
;
6865 /* Set se = NULL in the calls to the interface mapping, to suppress any
6867 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6872 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6875 gfc_init_se (&tse
, NULL
);
6877 /* Build the expression for the character length and convert it. */
6878 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6880 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6881 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6882 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6883 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6884 TREE_TYPE (tse
.expr
), tse
.expr
,
6885 build_zero_cst (TREE_TYPE (tse
.expr
)));
6886 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6887 gfc_free_interface_mapping (&mapping
);
6891 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6897 /* Helper function to check dimensions. */
6899 transposed_dims (gfc_ss
*ss
)
6903 for (n
= 0; n
< ss
->dimen
; n
++)
6904 if (ss
->dim
[n
] != n
)
6910 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6911 AR_FULL, suitable for the scalarizer. */
6914 walk_coarray (gfc_expr
*e
)
6918 gcc_assert (gfc_get_corank (e
) > 0);
6920 ss
= gfc_walk_expr (e
);
6922 /* Fix scalar coarray. */
6923 if (ss
== gfc_ss_terminator
)
6930 if (ref
->type
== REF_ARRAY
6931 && ref
->u
.ar
.codimen
> 0)
6937 gcc_assert (ref
!= NULL
);
6938 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6939 ref
->u
.ar
.type
= AR_SECTION
;
6940 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6947 /* Convert an array for passing as an actual argument. Expressions and
6948 vector subscripts are evaluated and stored in a temporary, which is then
6949 passed. For whole arrays the descriptor is passed. For array sections
6950 a modified copy of the descriptor is passed, but using the original data.
6952 This function is also used for array pointer assignments, and there
6955 - se->want_pointer && !se->direct_byref
6956 EXPR is an actual argument. On exit, se->expr contains a
6957 pointer to the array descriptor.
6959 - !se->want_pointer && !se->direct_byref
6960 EXPR is an actual argument to an intrinsic function or the
6961 left-hand side of a pointer assignment. On exit, se->expr
6962 contains the descriptor for EXPR.
6964 - !se->want_pointer && se->direct_byref
6965 EXPR is the right-hand side of a pointer assignment and
6966 se->expr is the descriptor for the previously-evaluated
6967 left-hand side. The function creates an assignment from
6971 The se->force_tmp flag disables the non-copying descriptor optimization
6972 that is used for transpose. It may be used in cases where there is an
6973 alias between the transpose argument and another argument in the same
6977 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6980 gfc_ss_type ss_type
;
6981 gfc_ss_info
*ss_info
;
6983 gfc_array_info
*info
;
6992 bool subref_array_target
= false;
6993 gfc_expr
*arg
, *ss_expr
;
6995 if (se
->want_coarray
)
6996 ss
= walk_coarray (expr
);
6998 ss
= gfc_walk_expr (expr
);
7000 gcc_assert (ss
!= NULL
);
7001 gcc_assert (ss
!= gfc_ss_terminator
);
7004 ss_type
= ss_info
->type
;
7005 ss_expr
= ss_info
->expr
;
7007 /* Special case: TRANSPOSE which needs no temporary. */
7008 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
7009 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
)) != NULL
)
7011 /* This is a call to transpose which has already been handled by the
7012 scalarizer, so that we just need to get its argument's descriptor. */
7013 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7014 expr
= expr
->value
.function
.actual
->expr
;
7017 /* Special case things we know we can pass easily. */
7018 switch (expr
->expr_type
)
7021 /* If we have a linear array section, we can pass it directly.
7022 Otherwise we need to copy it into a temporary. */
7024 gcc_assert (ss_type
== GFC_SS_SECTION
);
7025 gcc_assert (ss_expr
== expr
);
7026 info
= &ss_info
->data
.array
;
7028 /* Get the descriptor for the array. */
7029 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7030 desc
= info
->descriptor
;
7032 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7033 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7034 && !subref_array_target
;
7041 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7043 /* Create a new descriptor if the array doesn't have one. */
7046 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7048 else if (se
->direct_byref
)
7051 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7053 if (full
&& !transposed_dims (ss
))
7055 if (se
->direct_byref
&& !se
->byref_noassign
)
7057 /* Copy the descriptor for pointer assignments. */
7058 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7060 /* Add any offsets from subreferences. */
7061 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7062 subref_array_target
, expr
);
7064 /* ....and set the span field. */
7065 tmp
= get_array_span (desc
, expr
);
7066 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7068 else if (se
->want_pointer
)
7070 /* We pass full arrays directly. This means that pointers and
7071 allocatable arrays should also work. */
7072 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7079 if (expr
->ts
.type
== BT_CHARACTER
)
7080 se
->string_length
= gfc_get_expr_charlen (expr
);
7082 gfc_free_ss_chain (ss
);
7088 /* A transformational function return value will be a temporary
7089 array descriptor. We still need to go through the scalarizer
7090 to create the descriptor. Elemental functions are handled as
7091 arbitrary expressions, i.e. copy to a temporary. */
7093 if (se
->direct_byref
)
7095 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7097 /* For pointer assignments pass the descriptor directly. */
7101 gcc_assert (se
->ss
== ss
);
7103 if (!is_pointer_array (se
->expr
))
7105 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7106 tmp
= fold_convert (gfc_array_index_type
,
7107 size_in_bytes (tmp
));
7108 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7111 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7112 gfc_conv_expr (se
, expr
);
7114 gfc_free_ss_chain (ss
);
7118 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7120 if (ss_expr
!= expr
)
7121 /* Elemental function. */
7122 gcc_assert ((expr
->value
.function
.esym
!= NULL
7123 && expr
->value
.function
.esym
->attr
.elemental
)
7124 || (expr
->value
.function
.isym
!= NULL
7125 && expr
->value
.function
.isym
->elemental
)
7126 || gfc_inline_intrinsic_function_p (expr
));
7128 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7131 if (expr
->ts
.type
== BT_CHARACTER
7132 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7133 get_array_charlen (expr
, se
);
7139 /* Transformational function. */
7140 info
= &ss_info
->data
.array
;
7146 /* Constant array constructors don't need a temporary. */
7147 if (ss_type
== GFC_SS_CONSTRUCTOR
7148 && expr
->ts
.type
!= BT_CHARACTER
7149 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7152 info
= &ss_info
->data
.array
;
7162 /* Something complicated. Copy it into a temporary. */
7168 /* If we are creating a temporary, we don't need to bother about aliases
7173 gfc_init_loopinfo (&loop
);
7175 /* Associate the SS with the loop. */
7176 gfc_add_ss_to_loop (&loop
, ss
);
7178 /* Tell the scalarizer not to bother creating loop variables, etc. */
7180 loop
.array_parameter
= 1;
7182 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7183 gcc_assert (!se
->direct_byref
);
7185 /* Setup the scalarizing loops and bounds. */
7186 gfc_conv_ss_startstride (&loop
);
7190 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
7191 get_array_charlen (expr
, se
);
7193 /* Tell the scalarizer to make a temporary. */
7194 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7195 ((expr
->ts
.type
== BT_CHARACTER
)
7196 ? expr
->ts
.u
.cl
->backend_decl
7200 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7201 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7202 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7205 gfc_conv_loop_setup (&loop
, & expr
->where
);
7209 /* Copy into a temporary and pass that. We don't need to copy the data
7210 back because expressions and vector subscripts must be INTENT_IN. */
7211 /* TODO: Optimize passing function return values. */
7216 /* Start the copying loops. */
7217 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7218 gfc_mark_ss_chain_used (ss
, 1);
7219 gfc_start_scalarized_body (&loop
, &block
);
7221 /* Copy each data element. */
7222 gfc_init_se (&lse
, NULL
);
7223 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7224 gfc_init_se (&rse
, NULL
);
7225 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7227 lse
.ss
= loop
.temp_ss
;
7230 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7231 if (expr
->ts
.type
== BT_CHARACTER
)
7233 gfc_conv_expr (&rse
, expr
);
7234 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7235 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7239 gfc_conv_expr_val (&rse
, expr
);
7241 gfc_add_block_to_block (&block
, &rse
.pre
);
7242 gfc_add_block_to_block (&block
, &lse
.pre
);
7244 lse
.string_length
= rse
.string_length
;
7246 deep_copy
= !se
->data_not_needed
7247 && (expr
->expr_type
== EXPR_VARIABLE
7248 || expr
->expr_type
== EXPR_ARRAY
);
7249 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7251 gfc_add_expr_to_block (&block
, tmp
);
7253 /* Finish the copying loops. */
7254 gfc_trans_scalarizing_loops (&loop
, &block
);
7256 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7258 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7260 desc
= info
->descriptor
;
7261 se
->string_length
= ss_info
->string_length
;
7265 /* We pass sections without copying to a temporary. Make a new
7266 descriptor and point it at the section we want. The loop variable
7267 limits will be the limits of the section.
7268 A function may decide to repack the array to speed up access, but
7269 we're not bothered about that here. */
7270 int dim
, ndim
, codim
;
7277 bool onebased
= false, rank_remap
;
7279 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7280 rank_remap
= ss
->dimen
< ndim
;
7282 if (se
->want_coarray
)
7284 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7286 codim
= gfc_get_corank (expr
);
7287 for (n
= 0; n
< codim
- 1; n
++)
7289 /* Make sure we are not lost somehow. */
7290 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7292 /* Make sure the call to gfc_conv_section_startstride won't
7293 generate unnecessary code to calculate stride. */
7294 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7296 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7297 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7298 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7301 gcc_assert (n
== codim
- 1);
7302 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7303 info
->descriptor
, n
+ ndim
, true,
7304 ar
->as
->type
== AS_DEFERRED
);
7305 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7310 /* Set the string_length for a character array. */
7311 if (expr
->ts
.type
== BT_CHARACTER
)
7312 se
->string_length
= gfc_get_expr_charlen (expr
);
7314 /* If we have an array section or are assigning make sure that
7315 the lower bound is 1. References to the full
7316 array should otherwise keep the original bounds. */
7317 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7318 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7319 if (!integer_onep (loop
.from
[dim
]))
7321 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7322 gfc_array_index_type
, gfc_index_one_node
,
7324 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7325 gfc_array_index_type
,
7327 loop
.from
[dim
] = gfc_index_one_node
;
7330 desc
= info
->descriptor
;
7331 if (se
->direct_byref
&& !se
->byref_noassign
)
7333 /* For pointer assignments we fill in the destination.... */
7335 parmtype
= TREE_TYPE (parm
);
7337 /* ....and set the span field. */
7338 tmp
= get_array_span (desc
, expr
);
7339 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7343 /* Otherwise make a new one. */
7344 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7345 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7346 loop
.from
, loop
.to
, 0,
7347 GFC_ARRAY_UNKNOWN
, false);
7348 parm
= gfc_create_var (parmtype
, "parm");
7350 /* When expression is a class object, then add the class' handle to
7352 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7354 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7357 /* class_expr can be NULL, when no _class ref is in expr.
7358 We must not fix this here with a gfc_fix_class_ref (). */
7361 gfc_init_se (&classse
, NULL
);
7362 gfc_conv_expr (&classse
, class_expr
);
7363 gfc_free_expr (class_expr
);
7365 gcc_assert (classse
.pre
.head
== NULL_TREE
7366 && classse
.post
.head
== NULL_TREE
);
7367 gfc_allocate_lang_decl (parm
);
7368 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7373 offset
= gfc_index_zero_node
;
7375 /* The following can be somewhat confusing. We have two
7376 descriptors, a new one and the original array.
7377 {parm, parmtype, dim} refer to the new one.
7378 {desc, type, n, loop} refer to the original, which maybe
7379 a descriptorless array.
7380 The bounds of the scalarization are the bounds of the section.
7381 We don't have to worry about numeric overflows when calculating
7382 the offsets because all elements are within the array data. */
7384 /* Set the dtype. */
7385 tmp
= gfc_conv_descriptor_dtype (parm
);
7386 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7388 /* Set offset for assignments to pointer only to zero if it is not
7390 if ((se
->direct_byref
|| se
->use_offset
)
7391 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7392 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7393 base
= gfc_index_zero_node
;
7394 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7395 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7399 for (n
= 0; n
< ndim
; n
++)
7401 stride
= gfc_conv_array_stride (desc
, n
);
7403 /* Work out the offset. */
7405 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7407 gcc_assert (info
->subscript
[n
]
7408 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7409 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7413 /* Evaluate and remember the start of the section. */
7414 start
= info
->start
[n
];
7415 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7418 tmp
= gfc_conv_array_lbound (desc
, n
);
7419 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7421 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7423 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7427 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7429 /* For elemental dimensions, we only need the offset. */
7433 /* Vector subscripts need copying and are handled elsewhere. */
7435 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7437 /* look for the corresponding scalarizer dimension: dim. */
7438 for (dim
= 0; dim
< ndim
; dim
++)
7439 if (ss
->dim
[dim
] == n
)
7442 /* loop exited early: the DIM being looked for has been found. */
7443 gcc_assert (dim
< ndim
);
7445 /* Set the new lower bound. */
7446 from
= loop
.from
[dim
];
7449 onebased
= integer_onep (from
);
7450 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7451 gfc_rank_cst
[dim
], from
);
7453 /* Set the new upper bound. */
7454 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7455 gfc_rank_cst
[dim
], to
);
7457 /* Multiply the stride by the section stride to get the
7459 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7460 gfc_array_index_type
,
7461 stride
, info
->stride
[n
]);
7463 if ((se
->direct_byref
|| se
->use_offset
)
7464 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7465 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7467 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7468 TREE_TYPE (base
), base
, stride
);
7470 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7473 tmp
= gfc_conv_array_lbound (desc
, n
);
7474 toonebased
= integer_onep (tmp
);
7475 // lb(arr) - from (- start + 1)
7476 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7477 TREE_TYPE (base
), tmp
, from
);
7478 if (onebased
&& toonebased
)
7480 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7481 TREE_TYPE (base
), tmp
, start
);
7482 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7483 TREE_TYPE (base
), tmp
,
7484 gfc_index_one_node
);
7486 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7487 TREE_TYPE (base
), tmp
,
7488 gfc_conv_array_stride (desc
, n
));
7489 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7490 TREE_TYPE (base
), tmp
, base
);
7493 /* Store the new stride. */
7494 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7495 gfc_rank_cst
[dim
], stride
);
7498 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7500 from
= loop
.from
[n
];
7502 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7503 gfc_rank_cst
[n
], from
);
7504 if (n
< loop
.dimen
+ codim
- 1)
7505 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7506 gfc_rank_cst
[n
], to
);
7509 if (se
->data_not_needed
)
7510 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7511 gfc_index_zero_node
);
7513 /* Point the data pointer at the 1st element in the section. */
7514 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7515 subref_array_target
, expr
);
7517 /* Force the offset to be -1, when the lower bound of the highest
7518 dimension is one and the symbol is present and is not a
7519 pointer/allocatable or associated. */
7520 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7521 && !se
->data_not_needed
)
7522 || (se
->use_offset
&& base
!= NULL_TREE
))
7524 /* Set the offset depending on base. */
7525 tmp
= rank_remap
&& !se
->direct_byref
?
7526 fold_build2_loc (input_location
, PLUS_EXPR
,
7527 gfc_array_index_type
, base
,
7530 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7532 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7533 && !se
->data_not_needed
7534 && (!rank_remap
|| se
->use_offset
))
7536 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7537 gfc_conv_descriptor_offset_get (desc
));
7539 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7541 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7542 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7543 && !expr
->symtree
->n
.sym
->attr
.allocatable
7544 && !expr
->symtree
->n
.sym
->attr
.pointer
7545 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7546 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7548 /* Set the offset to -1. */
7550 mpz_init_set_si (minus_one
, -1);
7551 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7552 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7556 /* Only the callee knows what the correct offset it, so just set
7558 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7563 /* For class arrays add the class tree into the saved descriptor to
7564 enable getting of _vptr and the like. */
7565 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7566 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7568 gfc_allocate_lang_decl (desc
);
7569 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7570 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7571 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7572 : expr
->symtree
->n
.sym
->backend_decl
;
7574 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7575 && IS_CLASS_ARRAY (expr
))
7578 gfc_allocate_lang_decl (desc
);
7579 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7580 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7581 vtype
= gfc_class_vptr_get (tmp
);
7582 gfc_add_modify (&se
->pre
, vtype
,
7583 gfc_build_addr_expr (TREE_TYPE (vtype
),
7584 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7586 if (!se
->direct_byref
|| se
->byref_noassign
)
7588 /* Get a pointer to the new descriptor. */
7589 if (se
->want_pointer
)
7590 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7595 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7596 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7598 /* Cleanup the scalarizer. */
7599 gfc_cleanup_loop (&loop
);
7602 /* Helper function for gfc_conv_array_parameter if array size needs to be
7606 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7609 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7610 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7611 else if (expr
->rank
> 1)
7612 *size
= build_call_expr_loc (input_location
,
7613 gfor_fndecl_size0
, 1,
7614 gfc_build_addr_expr (NULL
, desc
));
7617 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7618 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7620 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7621 gfc_array_index_type
, ubound
, lbound
);
7622 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7623 *size
, gfc_index_one_node
);
7624 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7625 *size
, gfc_index_zero_node
);
7627 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7628 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7629 *size
, fold_convert (gfc_array_index_type
, elem
));
7632 /* Convert an array for passing as an actual parameter. */
7633 /* TODO: Optimize passing g77 arrays. */
7636 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7637 const gfc_symbol
*fsym
, const char *proc_name
,
7642 tree tmp
= NULL_TREE
;
7644 tree parent
= DECL_CONTEXT (current_function_decl
);
7645 bool full_array_var
;
7646 bool this_array_result
;
7649 bool array_constructor
;
7650 bool good_allocatable
;
7651 bool ultimate_ptr_comp
;
7652 bool ultimate_alloc_comp
;
7657 ultimate_ptr_comp
= false;
7658 ultimate_alloc_comp
= false;
7660 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7662 if (ref
->next
== NULL
)
7665 if (ref
->type
== REF_COMPONENT
)
7667 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7668 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7672 full_array_var
= false;
7675 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7676 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7678 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7680 /* The symbol should have an array specification. */
7681 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7683 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7685 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7686 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7687 se
->string_length
= tmp
;
7690 /* Is this the result of the enclosing procedure? */
7691 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7692 if (this_array_result
7693 && (sym
->backend_decl
!= current_function_decl
)
7694 && (sym
->backend_decl
!= parent
))
7695 this_array_result
= false;
7697 /* Passing address of the array if it is not pointer or assumed-shape. */
7698 if (full_array_var
&& g77
&& !this_array_result
7699 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7701 tmp
= gfc_get_symbol_decl (sym
);
7703 if (sym
->ts
.type
== BT_CHARACTER
)
7704 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7706 if (!sym
->attr
.pointer
7708 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7709 && sym
->as
->type
!= AS_DEFERRED
7710 && sym
->as
->type
!= AS_ASSUMED_RANK
7711 && !sym
->attr
.allocatable
)
7713 /* Some variables are declared directly, others are declared as
7714 pointers and allocated on the heap. */
7715 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7718 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7720 array_parameter_size (tmp
, expr
, size
);
7724 if (sym
->attr
.allocatable
)
7726 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7728 gfc_conv_expr_descriptor (se
, expr
);
7732 array_parameter_size (tmp
, expr
, size
);
7733 se
->expr
= gfc_conv_array_data (tmp
);
7738 /* A convenient reduction in scope. */
7739 contiguous
= g77
&& !this_array_result
&& contiguous
;
7741 /* There is no need to pack and unpack the array, if it is contiguous
7742 and not a deferred- or assumed-shape array, or if it is simply
7744 no_pack
= ((sym
&& sym
->as
7745 && !sym
->attr
.pointer
7746 && sym
->as
->type
!= AS_DEFERRED
7747 && sym
->as
->type
!= AS_ASSUMED_RANK
7748 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7750 (ref
&& ref
->u
.ar
.as
7751 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7752 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7753 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7755 gfc_is_simply_contiguous (expr
, false, true));
7757 no_pack
= contiguous
&& no_pack
;
7759 /* Array constructors are always contiguous and do not need packing. */
7760 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7762 /* Same is true of contiguous sections from allocatable variables. */
7763 good_allocatable
= contiguous
7765 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7767 /* Or ultimate allocatable components. */
7768 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7770 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7772 gfc_conv_expr_descriptor (se
, expr
);
7773 /* Deallocate the allocatable components of structures that are
7775 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7776 && expr
->ts
.u
.derived
->attr
.alloc_comp
7777 && expr
->expr_type
!= EXPR_VARIABLE
)
7779 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7781 /* The components shall be deallocated before their containing entity. */
7782 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7784 if (expr
->ts
.type
== BT_CHARACTER
)
7785 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7787 array_parameter_size (se
->expr
, expr
, size
);
7788 se
->expr
= gfc_conv_array_data (se
->expr
);
7792 if (this_array_result
)
7794 /* Result of the enclosing function. */
7795 gfc_conv_expr_descriptor (se
, expr
);
7797 array_parameter_size (se
->expr
, expr
, size
);
7798 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7800 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7801 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7802 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7809 /* Every other type of array. */
7810 se
->want_pointer
= 1;
7811 gfc_conv_expr_descriptor (se
, expr
);
7814 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7819 /* Deallocate the allocatable components of structures that are
7820 not variable, for descriptorless arguments.
7821 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7822 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7823 && expr
->ts
.u
.derived
->attr
.alloc_comp
7824 && expr
->expr_type
!= EXPR_VARIABLE
)
7826 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7827 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7829 /* The components shall be deallocated before their containing entity. */
7830 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7833 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7834 && !gfc_is_simply_contiguous (expr
, false, true)))
7836 tree origptr
= NULL_TREE
;
7840 /* For contiguous arrays, save the original value of the descriptor. */
7843 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7844 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7845 tmp
= gfc_conv_array_data (tmp
);
7846 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7847 TREE_TYPE (origptr
), origptr
,
7848 fold_convert (TREE_TYPE (origptr
), tmp
));
7849 gfc_add_expr_to_block (&se
->pre
, tmp
);
7852 /* Repack the array. */
7853 if (warn_array_temporaries
)
7856 gfc_warning (OPT_Warray_temporaries
,
7857 "Creating array temporary at %L for argument %qs",
7858 &expr
->where
, fsym
->name
);
7860 gfc_warning (OPT_Warray_temporaries
,
7861 "Creating array temporary at %L", &expr
->where
);
7864 ptr
= build_call_expr_loc (input_location
,
7865 gfor_fndecl_in_pack
, 1, desc
);
7867 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7869 tmp
= gfc_conv_expr_present (sym
);
7870 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7871 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7872 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7875 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7877 /* Use the packed data for the actual argument, except for contiguous arrays,
7878 where the descriptor's data component is set. */
7883 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7885 gfc_ss
* ss
= gfc_walk_expr (expr
);
7886 if (!transposed_dims (ss
))
7887 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7890 tree old_field
, new_field
;
7892 /* The original descriptor has transposed dims so we can't reuse
7893 it directly; we have to create a new one. */
7894 tree old_desc
= tmp
;
7895 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7897 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7898 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7899 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7901 old_field
= gfc_conv_descriptor_offset (old_desc
);
7902 new_field
= gfc_conv_descriptor_offset (new_desc
);
7903 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7905 for (int i
= 0; i
< expr
->rank
; i
++)
7907 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7908 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7909 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7911 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7914 if (flag_coarray
== GFC_FCOARRAY_LIB
7915 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7916 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7917 == GFC_ARRAY_ALLOCATABLE
)
7919 old_field
= gfc_conv_descriptor_token (old_desc
);
7920 new_field
= gfc_conv_descriptor_token (new_desc
);
7921 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7924 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7925 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7930 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7934 if (fsym
&& proc_name
)
7935 msg
= xasprintf ("An array temporary was created for argument "
7936 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7938 msg
= xasprintf ("An array temporary was created");
7940 tmp
= build_fold_indirect_ref_loc (input_location
,
7942 tmp
= gfc_conv_array_data (tmp
);
7943 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7944 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7946 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7947 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7949 gfc_conv_expr_present (sym
), tmp
);
7951 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7956 gfc_start_block (&block
);
7958 /* Copy the data back. */
7959 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7961 tmp
= build_call_expr_loc (input_location
,
7962 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7963 gfc_add_expr_to_block (&block
, tmp
);
7966 /* Free the temporary. */
7967 tmp
= gfc_call_free (ptr
);
7968 gfc_add_expr_to_block (&block
, tmp
);
7970 stmt
= gfc_finish_block (&block
);
7972 gfc_init_block (&block
);
7973 /* Only if it was repacked. This code needs to be executed before the
7974 loop cleanup code. */
7975 tmp
= build_fold_indirect_ref_loc (input_location
,
7977 tmp
= gfc_conv_array_data (tmp
);
7978 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7979 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7981 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7982 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7984 gfc_conv_expr_present (sym
), tmp
);
7986 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7988 gfc_add_expr_to_block (&block
, tmp
);
7989 gfc_add_block_to_block (&block
, &se
->post
);
7991 gfc_init_block (&se
->post
);
7993 /* Reset the descriptor pointer. */
7996 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7997 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8000 gfc_add_block_to_block (&se
->post
, &block
);
8005 /* This helper function calculates the size in words of a full array. */
8008 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8013 idx
= gfc_rank_cst
[rank
- 1];
8014 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8015 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8016 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8018 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8019 tmp
, gfc_index_one_node
);
8020 tmp
= gfc_evaluate_now (tmp
, block
);
8022 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8023 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8025 return gfc_evaluate_now (tmp
, block
);
8029 /* Allocate dest to the same size as src, and copy src -> dest.
8030 If no_malloc is set, only the copy is done. */
8033 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8034 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8035 tree add_when_allocated
)
8044 /* If the source is null, set the destination to null. Then,
8045 allocate memory to the destination. */
8046 gfc_init_block (&block
);
8048 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8050 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8051 null_data
= gfc_finish_block (&block
);
8053 gfc_init_block (&block
);
8054 if (str_sz
!= NULL_TREE
)
8057 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8061 tmp
= gfc_call_malloc (&block
, type
, size
);
8062 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8067 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8068 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8069 fold_convert (size_type_node
, size
));
8070 gfc_add_expr_to_block (&block
, tmp
);
8075 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8076 null_data
= gfc_finish_block (&block
);
8078 gfc_init_block (&block
);
8080 nelems
= gfc_full_array_size (&block
, src
, rank
);
8082 nelems
= gfc_index_one_node
;
8084 if (str_sz
!= NULL_TREE
)
8085 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8087 tmp
= fold_convert (gfc_array_index_type
,
8088 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8089 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8093 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8094 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8095 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8098 /* We know the temporary and the value will be the same length,
8099 so can use memcpy. */
8102 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8103 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8104 gfc_conv_descriptor_data_get (dest
),
8105 gfc_conv_descriptor_data_get (src
),
8106 fold_convert (size_type_node
, size
));
8107 gfc_add_expr_to_block (&block
, tmp
);
8111 gfc_add_expr_to_block (&block
, add_when_allocated
);
8112 tmp
= gfc_finish_block (&block
);
8114 /* Null the destination if the source is null; otherwise do
8115 the allocate and copy. */
8116 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8119 null_cond
= gfc_conv_descriptor_data_get (src
);
8121 null_cond
= convert (pvoid_type_node
, null_cond
);
8122 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8123 null_cond
, null_pointer_node
);
8124 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8128 /* Allocate dest to the same size as src, and copy data src -> dest. */
8131 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8132 tree add_when_allocated
)
8134 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8135 NULL_TREE
, add_when_allocated
);
8139 /* Copy data src -> dest. */
8142 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8144 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8145 NULL_TREE
, NULL_TREE
);
8148 /* Allocate dest to the same size as src, but don't copy anything. */
8151 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8153 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8154 NULL_TREE
, NULL_TREE
);
8159 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8160 tree type
, int rank
)
8167 stmtblock_t block
, globalblock
;
8169 /* If the source is null, set the destination to null. Then,
8170 allocate memory to the destination. */
8171 gfc_init_block (&block
);
8172 gfc_init_block (&globalblock
);
8174 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8177 symbol_attribute attr
;
8180 gfc_init_se (&se
, NULL
);
8181 gfc_clear_attr (&attr
);
8182 attr
.allocatable
= 1;
8183 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8184 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8185 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8187 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8188 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8189 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8190 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8191 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8192 null_data
= gfc_finish_block (&block
);
8194 gfc_init_block (&block
);
8196 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8197 fold_convert (size_type_node
, size
),
8198 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8199 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8200 GFC_CAF_COARRAY_ALLOC
);
8202 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8203 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8204 fold_convert (size_type_node
, size
));
8205 gfc_add_expr_to_block (&block
, tmp
);
8209 /* Set the rank or unitialized memory access may be reported. */
8210 tmp
= gfc_conv_descriptor_rank (dest
);
8211 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8214 nelems
= gfc_full_array_size (&block
, src
, rank
);
8216 nelems
= integer_one_node
;
8218 tmp
= fold_convert (size_type_node
,
8219 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8220 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8221 fold_convert (size_type_node
, nelems
), tmp
);
8223 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8224 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8226 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8227 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8228 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8229 null_data
= gfc_finish_block (&block
);
8231 gfc_init_block (&block
);
8232 gfc_allocate_using_caf_lib (&block
, dest
,
8233 fold_convert (size_type_node
, size
),
8234 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8235 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8236 GFC_CAF_COARRAY_ALLOC
);
8238 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8239 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8240 gfc_conv_descriptor_data_get (dest
),
8241 gfc_conv_descriptor_data_get (src
),
8242 fold_convert (size_type_node
, size
));
8243 gfc_add_expr_to_block (&block
, tmp
);
8246 tmp
= gfc_finish_block (&block
);
8248 /* Null the destination if the source is null; otherwise do
8249 the register and copy. */
8250 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8253 null_cond
= gfc_conv_descriptor_data_get (src
);
8255 null_cond
= convert (pvoid_type_node
, null_cond
);
8256 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8257 null_cond
, null_pointer_node
);
8258 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8260 return gfc_finish_block (&globalblock
);
8264 /* Helper function to abstract whether coarray processing is enabled. */
8267 caf_enabled (int caf_mode
)
8269 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8270 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8274 /* Helper function to abstract whether coarray processing is enabled
8275 and we are in a derived type coarray. */
8278 caf_in_coarray (int caf_mode
)
8280 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8281 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8282 return (caf_mode
& pat
) == pat
;
8286 /* Helper function to abstract whether coarray is to deallocate only. */
8289 gfc_caf_is_dealloc_only (int caf_mode
)
8291 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8292 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8296 /* Recursively traverse an object of derived type, generating code to
8297 deallocate, nullify or copy allocatable components. This is the work horse
8298 function for the functions named in this enum. */
8300 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8301 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8302 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8304 static gfc_actual_arglist
*pdt_param_list
;
8307 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8308 tree dest
, int rank
, int purpose
, int caf_mode
)
8312 stmtblock_t fnblock
;
8313 stmtblock_t loopbody
;
8314 stmtblock_t tmpblock
;
8325 tree null_cond
= NULL_TREE
;
8326 tree add_when_allocated
;
8327 tree dealloc_fndecl
;
8331 symbol_attribute
*attr
;
8332 bool deallocate_called
;
8334 gfc_init_block (&fnblock
);
8336 decl_type
= TREE_TYPE (decl
);
8338 if ((POINTER_TYPE_P (decl_type
))
8339 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8341 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8342 /* Deref dest in sync with decl, but only when it is not NULL. */
8344 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8346 /* Update the decl_type because it got dereferenced. */
8347 decl_type
= TREE_TYPE (decl
);
8350 /* If this is an array of derived types with allocatable components
8351 build a loop and recursively call this function. */
8352 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8353 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8355 tmp
= gfc_conv_array_data (decl
);
8356 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8358 /* Get the number of elements - 1 and set the counter. */
8359 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8361 /* Use the descriptor for an allocatable array. Since this
8362 is a full array reference, we only need the descriptor
8363 information from dimension = rank. */
8364 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8365 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8366 gfc_array_index_type
, tmp
,
8367 gfc_index_one_node
);
8369 null_cond
= gfc_conv_descriptor_data_get (decl
);
8370 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8371 logical_type_node
, null_cond
,
8372 build_int_cst (TREE_TYPE (null_cond
), 0));
8376 /* Otherwise use the TYPE_DOMAIN information. */
8377 tmp
= array_type_nelts (decl_type
);
8378 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8381 /* Remember that this is, in fact, the no. of elements - 1. */
8382 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8383 index
= gfc_create_var (gfc_array_index_type
, "S");
8385 /* Build the body of the loop. */
8386 gfc_init_block (&loopbody
);
8388 vref
= gfc_build_array_ref (var
, index
, NULL
);
8390 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8391 && !caf_enabled (caf_mode
))
8393 tmp
= build_fold_indirect_ref_loc (input_location
,
8394 gfc_conv_array_data (dest
));
8395 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8396 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8397 COPY_ALLOC_COMP
, 0);
8400 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8403 gfc_add_expr_to_block (&loopbody
, tmp
);
8405 /* Build the loop and return. */
8406 gfc_init_loopinfo (&loop
);
8408 loop
.from
[0] = gfc_index_zero_node
;
8409 loop
.loopvar
[0] = index
;
8410 loop
.to
[0] = nelems
;
8411 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8412 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8414 tmp
= gfc_finish_block (&fnblock
);
8415 /* When copying allocateable components, the above implements the
8416 deep copy. Nevertheless is a deep copy only allowed, when the current
8417 component is allocated, for which code will be generated in
8418 gfc_duplicate_allocatable (), where the deep copy code is just added
8419 into the if's body, by adding tmp (the deep copy code) as last
8420 argument to gfc_duplicate_allocatable (). */
8421 if (purpose
== COPY_ALLOC_COMP
8422 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8423 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8425 else if (null_cond
!= NULL_TREE
)
8426 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8427 build_empty_stmt (input_location
));
8432 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8434 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8435 DEALLOCATE_PDT_COMP
, 0);
8436 gfc_add_expr_to_block (&fnblock
, tmp
);
8438 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8440 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8441 NULLIFY_ALLOC_COMP
, 0);
8442 gfc_add_expr_to_block (&fnblock
, tmp
);
8445 /* Otherwise, act on the components or recursively call self to
8446 act on a chain of components. */
8447 for (c
= der_type
->components
; c
; c
= c
->next
)
8449 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8450 || c
->ts
.type
== BT_CLASS
)
8451 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8452 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8453 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8455 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8456 && c
->ts
.u
.derived
->attr
.pdt_type
;
8458 cdecl = c
->backend_decl
;
8459 ctype
= TREE_TYPE (cdecl);
8463 case DEALLOCATE_ALLOC_COMP
:
8465 gfc_init_block (&tmpblock
);
8467 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8468 decl
, cdecl, NULL_TREE
);
8470 /* Shortcut to get the attributes of the component. */
8471 if (c
->ts
.type
== BT_CLASS
)
8473 attr
= &CLASS_DATA (c
)->attr
;
8474 if (attr
->class_pointer
)
8484 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8485 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8486 /* Call the finalizer, which will free the memory and nullify the
8487 pointer of an array. */
8488 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8489 caf_enabled (caf_mode
))
8492 deallocate_called
= false;
8494 /* Add the _class ref for classes. */
8495 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8496 comp
= gfc_class_data_get (comp
);
8498 add_when_allocated
= NULL_TREE
;
8499 if (cmp_has_alloc_comps
8500 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8502 && !deallocate_called
)
8504 /* Add checked deallocation of the components. This code is
8505 obviously added because the finalizer is not trusted to free
8507 if (c
->ts
.type
== BT_CLASS
)
8509 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8511 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8512 comp
, NULL_TREE
, rank
, purpose
,
8517 rank
= c
->as
? c
->as
->rank
: 0;
8518 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8525 if (attr
->allocatable
&& !same_type
8526 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8528 /* Handle all types of components besides components of the
8529 same_type as the current one, because those would create an
8532 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8533 ? (gfc_caf_is_dealloc_only (caf_mode
)
8534 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8535 : GFC_CAF_COARRAY_DEREGISTER
)
8536 : GFC_CAF_COARRAY_NOCOARRAY
;
8538 caf_token
= NULL_TREE
;
8539 /* Coarray components are handled directly by
8540 deallocate_with_status. */
8541 if (!attr
->codimension
8542 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8545 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8546 TREE_TYPE (c
->caf_token
),
8547 decl
, c
->caf_token
, NULL_TREE
);
8548 else if (attr
->dimension
&& !attr
->proc_pointer
)
8549 caf_token
= gfc_conv_descriptor_token (comp
);
8551 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8552 /* When this is an array but not in conjunction with a coarray
8553 then add the data-ref. For coarray'ed arrays the data-ref
8554 is added by deallocate_with_status. */
8555 comp
= gfc_conv_descriptor_data_get (comp
);
8557 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8558 NULL_TREE
, NULL_TREE
, true,
8559 NULL
, caf_dereg_mode
,
8560 add_when_allocated
, caf_token
);
8562 gfc_add_expr_to_block (&tmpblock
, tmp
);
8564 else if (attr
->allocatable
&& !attr
->codimension
8565 && !deallocate_called
)
8567 /* Case of recursive allocatable derived types. */
8571 stmtblock_t dealloc_block
;
8573 gfc_init_block (&dealloc_block
);
8574 if (add_when_allocated
)
8575 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8577 /* Convert the component into a rank 1 descriptor type. */
8578 if (attr
->dimension
)
8580 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8581 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8582 c
->ts
.type
== BT_CLASS
8583 ? CLASS_DATA (c
)->as
->rank
8588 tmp
= TREE_TYPE (comp
);
8589 ubound
= build_int_cst (gfc_array_index_type
, 1);
8592 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8594 GFC_ARRAY_ALLOCATABLE
, false);
8596 cdesc
= gfc_create_var (cdesc
, "cdesc");
8597 DECL_ARTIFICIAL (cdesc
) = 1;
8599 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8600 gfc_get_dtype_rank_type (1, tmp
));
8601 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8602 gfc_index_zero_node
,
8603 gfc_index_one_node
);
8604 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8605 gfc_index_zero_node
,
8606 gfc_index_one_node
);
8607 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8608 gfc_index_zero_node
, ubound
);
8610 if (attr
->dimension
)
8611 comp
= gfc_conv_descriptor_data_get (comp
);
8613 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8615 /* Now call the deallocator. */
8616 vtab
= gfc_find_vtab (&c
->ts
);
8617 if (vtab
->backend_decl
== NULL
)
8618 gfc_get_symbol_decl (vtab
);
8619 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8620 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8621 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8623 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8624 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8625 logical_type_node
, tmp
,
8627 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8629 tmp
= build_call_expr_loc (input_location
,
8632 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8634 tmp
= gfc_finish_block (&dealloc_block
);
8636 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8637 void_type_node
, is_allocated
, tmp
,
8638 build_empty_stmt (input_location
));
8640 gfc_add_expr_to_block (&tmpblock
, tmp
);
8642 else if (add_when_allocated
)
8643 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8645 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8646 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8648 /* Finally, reset the vptr to the declared type vtable and, if
8649 necessary reset the _len field.
8651 First recover the reference to the component and obtain
8653 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8654 decl
, cdecl, NULL_TREE
);
8655 tmp
= gfc_class_vptr_get (comp
);
8657 if (UNLIMITED_POLY (c
))
8659 /* Both vptr and _len field should be nulled. */
8660 gfc_add_modify (&tmpblock
, tmp
,
8661 build_int_cst (TREE_TYPE (tmp
), 0));
8662 tmp
= gfc_class_len_get (comp
);
8663 gfc_add_modify (&tmpblock
, tmp
,
8664 build_int_cst (TREE_TYPE (tmp
), 0));
8668 /* Build the vtable address and set the vptr with it. */
8671 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8672 vtab
= vtable
->backend_decl
;
8673 if (vtab
== NULL_TREE
)
8674 vtab
= gfc_get_symbol_decl (vtable
);
8675 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8676 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8677 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8681 /* Now add the deallocation of this component. */
8682 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8685 case NULLIFY_ALLOC_COMP
:
8687 - allocatable components (regular or in class)
8688 - components that have allocatable components
8689 - pointer components when in a coarray.
8690 Skip everything else especially proc_pointers, which may come
8691 coupled with the regular pointer attribute. */
8692 if (c
->attr
.proc_pointer
8693 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8694 && CLASS_DATA (c
)->attr
.allocatable
)
8695 || (cmp_has_alloc_comps
8696 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8697 || (c
->ts
.type
== BT_CLASS
8698 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8699 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8702 /* Process class components first, because they always have the
8703 pointer-attribute set which would be caught wrong else. */
8704 if (c
->ts
.type
== BT_CLASS
8705 && (CLASS_DATA (c
)->attr
.allocatable
8706 || CLASS_DATA (c
)->attr
.class_pointer
))
8708 /* Allocatable CLASS components. */
8709 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8710 decl
, cdecl, NULL_TREE
);
8712 comp
= gfc_class_data_get (comp
);
8713 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8714 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8718 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8719 void_type_node
, comp
,
8720 build_int_cst (TREE_TYPE (comp
), 0));
8721 gfc_add_expr_to_block (&fnblock
, tmp
);
8723 cmp_has_alloc_comps
= false;
8725 /* Coarrays need the component to be nulled before the api-call
8727 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8729 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8730 decl
, cdecl, NULL_TREE
);
8731 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8732 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8735 gfc_add_modify (&fnblock
, comp
,
8736 build_int_cst (TREE_TYPE (comp
), 0));
8737 if (gfc_deferred_strlen (c
, &comp
))
8739 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8741 decl
, comp
, NULL_TREE
);
8742 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8743 TREE_TYPE (comp
), comp
,
8744 build_int_cst (TREE_TYPE (comp
), 0));
8745 gfc_add_expr_to_block (&fnblock
, tmp
);
8747 cmp_has_alloc_comps
= false;
8750 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
8752 /* Register a component of a derived type coarray with the
8753 coarray library. Do not register ultimate component
8754 coarrays here. They are treated like regular coarrays and
8755 are either allocated on all images or on none. */
8758 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8759 decl
, cdecl, NULL_TREE
);
8760 if (c
->attr
.dimension
)
8762 /* Set the dtype, because caf_register needs it. */
8763 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8764 gfc_get_dtype (TREE_TYPE (comp
)));
8765 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8766 decl
, cdecl, NULL_TREE
);
8767 token
= gfc_conv_descriptor_token (tmp
);
8773 gfc_init_se (&se
, NULL
);
8774 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8775 pvoid_type_node
, decl
, c
->caf_token
,
8777 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8778 c
->ts
.type
== BT_CLASS
8779 ? CLASS_DATA (c
)->attr
8781 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8784 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8785 gfc_build_addr_expr (NULL_TREE
,
8787 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8788 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8791 if (cmp_has_alloc_comps
)
8793 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8794 decl
, cdecl, NULL_TREE
);
8795 rank
= c
->as
? c
->as
->rank
: 0;
8796 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8797 rank
, purpose
, caf_mode
);
8798 gfc_add_expr_to_block (&fnblock
, tmp
);
8802 case REASSIGN_CAF_COMP
:
8803 if (caf_enabled (caf_mode
)
8804 && (c
->attr
.codimension
8805 || (c
->ts
.type
== BT_CLASS
8806 && (CLASS_DATA (c
)->attr
.coarray_comp
8807 || caf_in_coarray (caf_mode
)))
8808 || (c
->ts
.type
== BT_DERIVED
8809 && (c
->ts
.u
.derived
->attr
.coarray_comp
8810 || caf_in_coarray (caf_mode
))))
8813 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8814 decl
, cdecl, NULL_TREE
);
8815 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8816 dest
, cdecl, NULL_TREE
);
8818 if (c
->attr
.codimension
)
8820 if (c
->ts
.type
== BT_CLASS
)
8822 comp
= gfc_class_data_get (comp
);
8823 dcmp
= gfc_class_data_get (dcmp
);
8825 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8826 gfc_conv_descriptor_data_get (comp
));
8830 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8831 rank
, purpose
, caf_mode
8832 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8833 gfc_add_expr_to_block (&fnblock
, tmp
);
8838 case COPY_ALLOC_COMP
:
8839 if (c
->attr
.pointer
)
8842 /* We need source and destination components. */
8843 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8845 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8847 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8849 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8857 dst_data
= gfc_class_data_get (dcmp
);
8858 src_data
= gfc_class_data_get (comp
);
8859 size
= fold_convert (size_type_node
,
8860 gfc_class_vtab_size_get (comp
));
8862 if (CLASS_DATA (c
)->attr
.dimension
)
8864 nelems
= gfc_conv_descriptor_size (src_data
,
8865 CLASS_DATA (c
)->as
->rank
);
8866 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8867 size_type_node
, size
,
8868 fold_convert (size_type_node
,
8872 nelems
= build_int_cst (size_type_node
, 1);
8874 if (CLASS_DATA (c
)->attr
.dimension
8875 || CLASS_DATA (c
)->attr
.codimension
)
8877 src_data
= gfc_conv_descriptor_data_get (src_data
);
8878 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8881 gfc_init_block (&tmpblock
);
8883 /* Coarray component have to have the same allocation status and
8884 shape/type-parameter/effective-type on the LHS and RHS of an
8885 intrinsic assignment. Hence, we did not deallocated them - and
8886 do not allocate them here. */
8887 if (!CLASS_DATA (c
)->attr
.codimension
)
8889 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8890 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8891 gfc_add_modify (&tmpblock
, dst_data
,
8892 fold_convert (TREE_TYPE (dst_data
), tmp
));
8895 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8896 UNLIMITED_POLY (c
));
8897 gfc_add_expr_to_block (&tmpblock
, tmp
);
8898 tmp
= gfc_finish_block (&tmpblock
);
8900 gfc_init_block (&tmpblock
);
8901 gfc_add_modify (&tmpblock
, dst_data
,
8902 fold_convert (TREE_TYPE (dst_data
),
8903 null_pointer_node
));
8904 null_data
= gfc_finish_block (&tmpblock
);
8906 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8907 logical_type_node
, src_data
,
8910 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8915 /* To implement guarded deep copy, i.e., deep copy only allocatable
8916 components that are really allocated, the deep copy code has to
8917 be generated first and then added to the if-block in
8918 gfc_duplicate_allocatable (). */
8919 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
8921 rank
= c
->as
? c
->as
->rank
: 0;
8922 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8923 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8924 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8930 add_when_allocated
= NULL_TREE
;
8932 if (gfc_deferred_strlen (c
, &tmp
))
8936 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8938 decl
, len
, NULL_TREE
);
8939 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8941 dest
, len
, NULL_TREE
);
8942 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8943 TREE_TYPE (len
), len
, tmp
);
8944 gfc_add_expr_to_block (&fnblock
, tmp
);
8945 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8946 /* This component can not have allocatable components,
8947 therefore add_when_allocated of duplicate_allocatable ()
8949 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8950 false, false, size
, NULL_TREE
);
8951 gfc_add_expr_to_block (&fnblock
, tmp
);
8953 else if (c
->attr
.pdt_array
)
8955 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
8956 c
->as
? c
->as
->rank
: 0,
8957 false, false, NULL_TREE
, NULL_TREE
);
8958 gfc_add_expr_to_block (&fnblock
, tmp
);
8960 else if ((c
->attr
.allocatable
)
8961 && !c
->attr
.proc_pointer
&& !same_type
8962 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
8963 || caf_in_coarray (caf_mode
)))
8965 rank
= c
->as
? c
->as
->rank
: 0;
8966 if (c
->attr
.codimension
)
8967 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8968 else if (flag_coarray
== GFC_FCOARRAY_LIB
8969 && caf_in_coarray (caf_mode
))
8971 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
8972 : fold_build3_loc (input_location
,
8974 pvoid_type_node
, dest
,
8977 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
8981 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8982 add_when_allocated
);
8983 gfc_add_expr_to_block (&fnblock
, tmp
);
8986 if (cmp_has_alloc_comps
|| is_pdt_type
)
8987 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8991 case ALLOCATE_PDT_COMP
:
8993 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8994 decl
, cdecl, NULL_TREE
);
8996 /* Set the PDT KIND and LEN fields. */
8997 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9000 gfc_expr
*c_expr
= NULL
;
9001 gfc_actual_arglist
*param
= pdt_param_list
;
9002 gfc_init_se (&tse
, NULL
);
9003 for (; param
; param
= param
->next
)
9004 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9005 c_expr
= param
->expr
;
9008 c_expr
= c
->initializer
;
9012 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9013 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9017 if (c
->attr
.pdt_string
)
9020 gfc_init_se (&tse
, NULL
);
9021 tree strlen
= NULL_TREE
;
9022 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9023 /* Convert the parameterized string length to its value. The
9024 string length is stored in a hidden field in the same way as
9025 deferred string lengths. */
9026 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9027 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9029 gfc_conv_expr_type (&tse
, e
,
9030 TREE_TYPE (strlen
));
9031 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9033 decl
, strlen
, NULL_TREE
);
9034 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9035 c
->ts
.u
.cl
->backend_decl
= strlen
;
9039 /* Scalar parameterized strings can be allocated now. */
9042 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9043 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9044 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9045 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9046 gfc_add_modify (&fnblock
, comp
, tmp
);
9050 /* Allocate parameterized arrays of parameterized derived types. */
9051 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9052 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9053 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9056 if (c
->ts
.type
== BT_CLASS
)
9057 comp
= gfc_class_data_get (comp
);
9059 if (c
->attr
.pdt_array
)
9063 tree size
= gfc_index_one_node
;
9064 tree offset
= gfc_index_zero_node
;
9068 /* This chunk takes the expressions for 'lower' and 'upper'
9069 in the arrayspec and substitutes in the expressions for
9070 the parameters from 'pdt_param_list'. The descriptor
9071 fields can then be filled from the values so obtained. */
9072 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9073 for (i
= 0; i
< c
->as
->rank
; i
++)
9075 gfc_init_se (&tse
, NULL
);
9076 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9077 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9078 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9081 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9084 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9085 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9086 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9089 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9092 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9095 size
= gfc_evaluate_now (size
, &fnblock
);
9096 offset
= fold_build2_loc (input_location
,
9098 gfc_array_index_type
,
9100 offset
= gfc_evaluate_now (offset
, &fnblock
);
9101 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9102 gfc_array_index_type
,
9104 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9105 gfc_array_index_type
,
9106 tmp
, gfc_index_one_node
);
9107 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9108 gfc_array_index_type
, size
, tmp
);
9110 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9111 if (c
->ts
.type
== BT_CLASS
)
9113 tmp
= gfc_get_vptr_from_expr (comp
);
9114 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9115 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9116 tmp
= gfc_vptr_size_get (tmp
);
9119 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9120 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9121 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9122 gfc_array_index_type
, size
, tmp
);
9123 size
= gfc_evaluate_now (size
, &fnblock
);
9124 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9125 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9126 tmp
= gfc_conv_descriptor_dtype (comp
);
9127 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9129 if (c
->initializer
&& c
->initializer
->rank
)
9131 gfc_init_se (&tse
, NULL
);
9132 e
= gfc_copy_expr (c
->initializer
);
9133 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9134 gfc_conv_expr_descriptor (&tse
, e
);
9135 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9137 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9138 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9139 gfc_conv_descriptor_data_get (comp
),
9140 gfc_conv_descriptor_data_get (tse
.expr
),
9141 fold_convert (size_type_node
, size
));
9142 gfc_add_expr_to_block (&fnblock
, tmp
);
9143 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9147 /* Recurse in to PDT components. */
9148 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9149 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9150 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9152 bool is_deferred
= false;
9153 gfc_actual_arglist
*tail
= c
->param_list
;
9155 for (; tail
; tail
= tail
->next
)
9159 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9160 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9161 c
->as
? c
->as
->rank
: 0,
9163 gfc_add_expr_to_block (&fnblock
, tmp
);
9168 case DEALLOCATE_PDT_COMP
:
9169 /* Deallocate array or parameterized string length components
9170 of parameterized derived types. */
9171 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9172 && !c
->attr
.pdt_string
9173 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9174 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9177 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9178 decl
, cdecl, NULL_TREE
);
9179 if (c
->ts
.type
== BT_CLASS
)
9180 comp
= gfc_class_data_get (comp
);
9182 /* Recurse in to PDT components. */
9183 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9184 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9185 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9187 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9188 c
->as
? c
->as
->rank
: 0);
9189 gfc_add_expr_to_block (&fnblock
, tmp
);
9192 if (c
->attr
.pdt_array
)
9194 tmp
= gfc_conv_descriptor_data_get (comp
);
9195 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9196 logical_type_node
, tmp
,
9197 build_int_cst (TREE_TYPE (tmp
), 0));
9198 tmp
= gfc_call_free (tmp
);
9199 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9200 build_empty_stmt (input_location
));
9201 gfc_add_expr_to_block (&fnblock
, tmp
);
9202 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9204 else if (c
->attr
.pdt_string
)
9206 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9207 logical_type_node
, comp
,
9208 build_int_cst (TREE_TYPE (comp
), 0));
9209 tmp
= gfc_call_free (comp
);
9210 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9211 build_empty_stmt (input_location
));
9212 gfc_add_expr_to_block (&fnblock
, tmp
);
9213 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9214 gfc_add_modify (&fnblock
, comp
, tmp
);
9219 case CHECK_PDT_DUMMY
:
9221 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9222 decl
, cdecl, NULL_TREE
);
9223 if (c
->ts
.type
== BT_CLASS
)
9224 comp
= gfc_class_data_get (comp
);
9226 /* Recurse in to PDT components. */
9227 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9228 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9230 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9231 c
->as
? c
->as
->rank
: 0,
9233 gfc_add_expr_to_block (&fnblock
, tmp
);
9236 if (!c
->attr
.pdt_len
)
9241 gfc_expr
*c_expr
= NULL
;
9242 gfc_actual_arglist
*param
= pdt_param_list
;
9244 gfc_init_se (&tse
, NULL
);
9245 for (; param
; param
= param
->next
)
9246 if (!strcmp (c
->name
, param
->name
)
9247 && param
->spec_type
== SPEC_EXPLICIT
)
9248 c_expr
= param
->expr
;
9252 tree error
, cond
, cname
;
9253 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9254 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9257 cname
= gfc_build_cstring_const (c
->name
);
9258 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9259 error
= gfc_trans_runtime_error (true, NULL
,
9260 "The value of the PDT LEN "
9261 "parameter '%s' does not "
9262 "agree with that in the "
9263 "dummy declaration",
9265 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9266 void_type_node
, cond
, error
,
9267 build_empty_stmt (input_location
));
9268 gfc_add_expr_to_block (&fnblock
, tmp
);
9279 return gfc_finish_block (&fnblock
);
9282 /* Recursively traverse an object of derived type, generating code to
9283 nullify allocatable components. */
9286 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9289 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9291 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9295 /* Recursively traverse an object of derived type, generating code to
9296 deallocate allocatable components. */
9299 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9302 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9303 DEALLOCATE_ALLOC_COMP
,
9304 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9308 /* Recursively traverse an object of derived type, generating code to
9309 deallocate allocatable components. But do not deallocate coarrays.
9310 To be used for intrinsic assignment, which may not change the allocation
9311 status of coarrays. */
9314 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9316 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9317 DEALLOCATE_ALLOC_COMP
, 0);
9322 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9324 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9325 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9329 /* Recursively traverse an object of derived type, generating code to
9330 copy it and its allocatable components. */
9333 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9336 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9341 /* Recursively traverse an object of derived type, generating code to
9342 copy only its allocatable components. */
9345 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9347 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9348 COPY_ONLY_ALLOC_COMP
, 0);
9352 /* Recursively traverse an object of paramterized derived type, generating
9353 code to allocate parameterized components. */
9356 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9357 gfc_actual_arglist
*param_list
)
9360 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9361 pdt_param_list
= param_list
;
9362 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9363 ALLOCATE_PDT_COMP
, 0);
9364 pdt_param_list
= old_param_list
;
9368 /* Recursively traverse an object of paramterized derived type, generating
9369 code to deallocate parameterized components. */
9372 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9374 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9375 DEALLOCATE_PDT_COMP
, 0);
9379 /* Recursively traverse a dummy of paramterized derived type to check the
9380 values of LEN parameters. */
9383 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9384 gfc_actual_arglist
*param_list
)
9387 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9388 pdt_param_list
= param_list
;
9389 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9390 CHECK_PDT_DUMMY
, 0);
9391 pdt_param_list
= old_param_list
;
9396 /* Returns the value of LBOUND for an expression. This could be broken out
9397 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9398 called by gfc_alloc_allocatable_for_assignment. */
9400 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9405 tree cond
, cond1
, cond3
, cond4
;
9409 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9411 tmp
= gfc_rank_cst
[dim
];
9412 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9413 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9414 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9415 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9417 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9418 stride
, gfc_index_zero_node
);
9419 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9420 logical_type_node
, cond3
, cond1
);
9421 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9422 stride
, gfc_index_zero_node
);
9424 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9425 tmp
, build_int_cst (gfc_array_index_type
,
9428 cond
= logical_false_node
;
9430 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9431 logical_type_node
, cond3
, cond4
);
9432 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9433 logical_type_node
, cond
, cond1
);
9435 return fold_build3_loc (input_location
, COND_EXPR
,
9436 gfc_array_index_type
, cond
,
9437 lbound
, gfc_index_one_node
);
9440 if (expr
->expr_type
== EXPR_FUNCTION
)
9442 /* A conversion function, so use the argument. */
9443 gcc_assert (expr
->value
.function
.isym
9444 && expr
->value
.function
.isym
->conversion
);
9445 expr
= expr
->value
.function
.actual
->expr
;
9448 if (expr
->expr_type
== EXPR_VARIABLE
)
9450 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9451 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9453 if (ref
->type
== REF_COMPONENT
9454 && ref
->u
.c
.component
->as
9456 && ref
->next
->u
.ar
.type
== AR_FULL
)
9457 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9459 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9462 return gfc_index_one_node
;
9466 /* Returns true if an expression represents an lhs that can be reallocated
9470 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9478 sym
= expr
->symtree
->n
.sym
;
9480 /* An allocatable class variable with no reference. */
9481 if (sym
->ts
.type
== BT_CLASS
9482 && CLASS_DATA (sym
)->attr
.allocatable
9483 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
9484 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9485 && expr
->ref
->next
== NULL
)
9488 /* An allocatable variable. */
9489 if (sym
->attr
.allocatable
9491 && expr
->ref
->type
== REF_ARRAY
9492 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9495 /* All that can be left are allocatable components. */
9496 if ((sym
->ts
.type
!= BT_DERIVED
9497 && sym
->ts
.type
!= BT_CLASS
)
9498 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9501 /* Find a component ref followed by an array reference. */
9502 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9504 && ref
->type
== REF_COMPONENT
9505 && ref
->next
->type
== REF_ARRAY
9506 && !ref
->next
->next
)
9512 /* Return true if valid reallocatable lhs. */
9513 if (ref
->u
.c
.component
->attr
.allocatable
9514 && ref
->next
->u
.ar
.type
== AR_FULL
)
9522 concat_str_length (gfc_expr
* expr
)
9529 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9530 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9531 if (len1
== NULL_TREE
)
9533 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9534 len1
= concat_str_length (expr
->value
.op
.op1
);
9535 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9536 len1
= build_int_cst (gfc_charlen_type_node
,
9537 expr
->value
.op
.op1
->value
.character
.length
);
9538 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9540 gfc_init_se (&se
, NULL
);
9541 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9547 gfc_init_se (&se
, NULL
);
9548 se
.want_pointer
= 1;
9549 se
.descriptor_only
= 1;
9550 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9551 len1
= se
.string_length
;
9555 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9556 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9557 if (len2
== NULL_TREE
)
9559 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9560 len2
= concat_str_length (expr
->value
.op
.op2
);
9561 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9562 len2
= build_int_cst (gfc_charlen_type_node
,
9563 expr
->value
.op
.op2
->value
.character
.length
);
9564 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9566 gfc_init_se (&se
, NULL
);
9567 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9573 gfc_init_se (&se
, NULL
);
9574 se
.want_pointer
= 1;
9575 se
.descriptor_only
= 1;
9576 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9577 len2
= se
.string_length
;
9581 gcc_assert(len1
&& len2
);
9582 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9583 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9585 return fold_build2_loc (input_location
, PLUS_EXPR
,
9586 gfc_charlen_type_node
, len1
, len2
);
9590 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9594 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9598 stmtblock_t realloc_block
;
9599 stmtblock_t alloc_block
;
9603 gfc_array_info
*linfo
;
9625 gfc_array_spec
* as
;
9626 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9627 && gfc_caf_attr (expr1
, true).codimension
);
9631 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9632 Find the lhs expression in the loop chain and set expr1 and
9633 expr2 accordingly. */
9634 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9637 /* Find the ss for the lhs. */
9639 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9640 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9642 if (lss
== gfc_ss_terminator
)
9644 expr1
= lss
->info
->expr
;
9647 /* Bail out if this is not a valid allocate on assignment. */
9648 if (!gfc_is_reallocatable_lhs (expr1
)
9649 || (expr2
&& !expr2
->rank
))
9652 /* Find the ss for the lhs. */
9654 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9655 if (lss
->info
->expr
== expr1
)
9658 if (lss
== gfc_ss_terminator
)
9661 linfo
= &lss
->info
->data
.array
;
9663 /* Find an ss for the rhs. For operator expressions, we see the
9664 ss's for the operands. Any one of these will do. */
9666 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9667 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9670 if (expr2
&& rss
== gfc_ss_terminator
)
9673 gfc_start_block (&fblock
);
9675 /* Since the lhs is allocatable, this must be a descriptor type.
9676 Get the data and array size. */
9677 desc
= linfo
->descriptor
;
9678 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9679 array1
= gfc_conv_descriptor_data_get (desc
);
9681 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9682 deallocated if expr is an array of different shape or any of the
9683 corresponding length type parameter values of variable and expr
9684 differ." This assures F95 compatibility. */
9685 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9686 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9688 /* Allocate if data is NULL. */
9689 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9690 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9692 if (expr1
->ts
.deferred
)
9693 cond_null
= gfc_evaluate_now (logical_true_node
, &fblock
);
9695 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9697 tmp
= build3_v (COND_EXPR
, cond_null
,
9698 build1_v (GOTO_EXPR
, jump_label1
),
9699 build_empty_stmt (input_location
));
9700 gfc_add_expr_to_block (&fblock
, tmp
);
9702 /* Get arrayspec if expr is a full array. */
9703 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9704 && expr2
->value
.function
.isym
9705 && expr2
->value
.function
.isym
->conversion
)
9707 /* For conversion functions, take the arg. */
9708 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9709 as
= gfc_get_full_arrayspec_from_expr (arg
);
9712 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9716 /* If the lhs shape is not the same as the rhs jump to setting the
9717 bounds and doing the reallocation....... */
9718 for (n
= 0; n
< expr1
->rank
; n
++)
9720 /* Check the shape. */
9721 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9722 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9723 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9724 gfc_array_index_type
,
9725 loop
->to
[n
], loop
->from
[n
]);
9726 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9727 gfc_array_index_type
,
9729 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9730 gfc_array_index_type
,
9732 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9734 tmp
, gfc_index_zero_node
);
9735 tmp
= build3_v (COND_EXPR
, cond
,
9736 build1_v (GOTO_EXPR
, jump_label1
),
9737 build_empty_stmt (input_location
));
9738 gfc_add_expr_to_block (&fblock
, tmp
);
9741 /* ....else jump past the (re)alloc code. */
9742 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9743 gfc_add_expr_to_block (&fblock
, tmp
);
9745 /* Add the label to start automatic (re)allocation. */
9746 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9747 gfc_add_expr_to_block (&fblock
, tmp
);
9749 /* If the lhs has not been allocated, its bounds will not have been
9750 initialized and so its size is set to zero. */
9751 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9752 gfc_init_block (&alloc_block
);
9753 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9754 gfc_init_block (&realloc_block
);
9755 gfc_add_modify (&realloc_block
, size1
,
9756 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9757 tmp
= build3_v (COND_EXPR
, cond_null
,
9758 gfc_finish_block (&alloc_block
),
9759 gfc_finish_block (&realloc_block
));
9760 gfc_add_expr_to_block (&fblock
, tmp
);
9762 /* Get the rhs size and fix it. */
9764 desc2
= rss
->info
->data
.array
.descriptor
;
9768 size2
= gfc_index_one_node
;
9769 for (n
= 0; n
< expr2
->rank
; n
++)
9771 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9772 gfc_array_index_type
,
9773 loop
->to
[n
], loop
->from
[n
]);
9774 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9775 gfc_array_index_type
,
9776 tmp
, gfc_index_one_node
);
9777 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9778 gfc_array_index_type
,
9781 size2
= gfc_evaluate_now (size2
, &fblock
);
9783 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9786 /* If the lhs is deferred length, assume that the element size
9787 changes and force a reallocation. */
9788 if (expr1
->ts
.deferred
)
9789 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
9791 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9793 /* Deallocation of allocatable components will have to occur on
9794 reallocation. Fix the old descriptor now. */
9795 if ((expr1
->ts
.type
== BT_DERIVED
)
9796 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9797 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9799 old_desc
= NULL_TREE
;
9801 /* Now modify the lhs descriptor and the associated scalarizer
9802 variables. F2003 7.4.1.3: "If variable is or becomes an
9803 unallocated allocatable variable, then it is allocated with each
9804 deferred type parameter equal to the corresponding type parameters
9805 of expr , with the shape of expr , and with each lower bound equal
9806 to the corresponding element of LBOUND(expr)."
9807 Reuse size1 to keep a dimension-by-dimension track of the
9808 stride of the new array. */
9809 size1
= gfc_index_one_node
;
9810 offset
= gfc_index_zero_node
;
9812 for (n
= 0; n
< expr2
->rank
; n
++)
9814 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9815 gfc_array_index_type
,
9816 loop
->to
[n
], loop
->from
[n
]);
9817 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9818 gfc_array_index_type
,
9819 tmp
, gfc_index_one_node
);
9821 lbound
= gfc_index_one_node
;
9826 lbd
= get_std_lbound (expr2
, desc2
, n
,
9827 as
->type
== AS_ASSUMED_SIZE
);
9828 ubound
= fold_build2_loc (input_location
,
9830 gfc_array_index_type
,
9832 ubound
= fold_build2_loc (input_location
,
9834 gfc_array_index_type
,
9839 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9842 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9845 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9848 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9850 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9851 gfc_array_index_type
,
9853 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9854 gfc_array_index_type
,
9856 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9857 gfc_array_index_type
,
9861 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9862 the array offset is saved and the info.offset is used for a
9863 running offset. Use the saved_offset instead. */
9864 tmp
= gfc_conv_descriptor_offset (desc
);
9865 gfc_add_modify (&fblock
, tmp
, offset
);
9866 if (linfo
->saved_offset
9867 && VAR_P (linfo
->saved_offset
))
9868 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9870 /* Now set the deltas for the lhs. */
9871 for (n
= 0; n
< expr1
->rank
; n
++)
9873 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9875 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9876 gfc_array_index_type
, tmp
,
9878 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9879 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9882 /* Get the new lhs size in bytes. */
9883 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9885 if (expr2
->ts
.deferred
)
9887 if (VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9888 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9890 tmp
= rss
->info
->string_length
;
9894 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9895 if (!tmp
&& expr2
->expr_type
== EXPR_OP
9896 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
9898 tmp
= concat_str_length (expr2
);
9899 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
9901 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
9904 if (expr1
->ts
.u
.cl
->backend_decl
9905 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
9906 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
9908 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
9910 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
9912 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
9913 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9914 gfc_array_index_type
, tmp
,
9915 expr1
->ts
.u
.cl
->backend_decl
);
9918 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9919 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9920 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9921 gfc_array_index_type
,
9923 size2
= fold_convert (size_type_node
, size2
);
9924 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9925 size2
, size_one_node
);
9926 size2
= gfc_evaluate_now (size2
, &fblock
);
9928 /* For deferred character length, the 'size' field of the dtype might
9929 have changed so set the dtype. */
9930 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9931 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9934 tmp
= gfc_conv_descriptor_dtype (desc
);
9935 if (expr2
->ts
.u
.cl
->backend_decl
)
9936 type
= gfc_typenode_for_spec (&expr2
->ts
);
9938 type
= gfc_typenode_for_spec (&expr1
->ts
);
9940 gfc_add_modify (&fblock
, tmp
,
9941 gfc_get_dtype_rank_type (expr1
->rank
,type
));
9943 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9945 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
9946 gfc_get_dtype (TREE_TYPE (desc
)));
9949 /* Realloc expression. Note that the scalarizer uses desc.data
9950 in the array reference - (*desc.data)[<element>]. */
9951 gfc_init_block (&realloc_block
);
9952 gfc_init_se (&caf_se
, NULL
);
9956 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
9957 if (token
== NULL_TREE
)
9959 tmp
= gfc_get_tree_for_caf_expr (expr1
);
9960 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9961 tmp
= build_fold_indirect_ref (tmp
);
9962 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
9964 token
= gfc_build_addr_expr (NULL_TREE
, token
);
9967 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
9969 if ((expr1
->ts
.type
== BT_DERIVED
)
9970 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9972 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
9974 gfc_add_expr_to_block (&realloc_block
, tmp
);
9979 tmp
= build_call_expr_loc (input_location
,
9980 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
9981 fold_convert (pvoid_type_node
, array1
),
9983 gfc_conv_descriptor_data_set (&realloc_block
,
9988 tmp
= build_call_expr_loc (input_location
,
9989 gfor_fndecl_caf_deregister
, 5, token
,
9990 build_int_cst (integer_type_node
,
9991 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
9992 null_pointer_node
, null_pointer_node
,
9994 gfc_add_expr_to_block (&realloc_block
, tmp
);
9995 tmp
= build_call_expr_loc (input_location
,
9996 gfor_fndecl_caf_register
,
9998 build_int_cst (integer_type_node
,
9999 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10000 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10001 null_pointer_node
, null_pointer_node
,
10002 integer_zero_node
);
10003 gfc_add_expr_to_block (&realloc_block
, tmp
);
10006 if ((expr1
->ts
.type
== BT_DERIVED
)
10007 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10009 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10011 gfc_add_expr_to_block (&realloc_block
, tmp
);
10014 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10015 realloc_expr
= gfc_finish_block (&realloc_block
);
10017 /* Only reallocate if sizes are different. */
10018 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10019 build_empty_stmt (input_location
));
10020 realloc_expr
= tmp
;
10023 /* Malloc expression. */
10024 gfc_init_block (&alloc_block
);
10027 tmp
= build_call_expr_loc (input_location
,
10028 builtin_decl_explicit (BUILT_IN_MALLOC
),
10030 gfc_conv_descriptor_data_set (&alloc_block
,
10035 tmp
= build_call_expr_loc (input_location
,
10036 gfor_fndecl_caf_register
,
10038 build_int_cst (integer_type_node
,
10039 GFC_CAF_COARRAY_ALLOC
),
10040 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10041 null_pointer_node
, null_pointer_node
,
10042 integer_zero_node
);
10043 gfc_add_expr_to_block (&alloc_block
, tmp
);
10047 /* We already set the dtype in the case of deferred character
10049 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10050 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10053 tmp
= gfc_conv_descriptor_dtype (desc
);
10054 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10057 if ((expr1
->ts
.type
== BT_DERIVED
)
10058 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10060 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10062 gfc_add_expr_to_block (&alloc_block
, tmp
);
10064 alloc_expr
= gfc_finish_block (&alloc_block
);
10066 /* Malloc if not allocated; realloc otherwise. */
10067 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10068 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10071 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10072 gfc_add_expr_to_block (&fblock
, tmp
);
10074 /* Make sure that the scalarizer data pointer is updated. */
10075 if (linfo
->data
&& VAR_P (linfo
->data
))
10077 tmp
= gfc_conv_descriptor_data_get (desc
);
10078 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10081 /* Add the exit label. */
10082 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10083 gfc_add_expr_to_block (&fblock
, tmp
);
10085 return gfc_finish_block (&fblock
);
10089 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10090 Do likewise, recursively if necessary, with the allocatable components of
10094 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10100 stmtblock_t cleanup
;
10103 bool sym_has_alloc_comp
, has_finalizer
;
10105 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10106 || sym
->ts
.type
== BT_CLASS
)
10107 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10108 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10109 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10111 /* Make sure the frontend gets these right. */
10112 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10115 gfc_save_backend_locus (&loc
);
10116 gfc_set_backend_locus (&sym
->declared_at
);
10117 gfc_init_block (&init
);
10119 gcc_assert (VAR_P (sym
->backend_decl
)
10120 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10122 if (sym
->ts
.type
== BT_CHARACTER
10123 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10125 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10126 gfc_trans_vla_type_sizes (sym
, &init
);
10129 /* Dummy, use associated and result variables don't need anything special. */
10130 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10132 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10133 gfc_restore_backend_locus (&loc
);
10137 descriptor
= sym
->backend_decl
;
10139 /* Although static, derived types with default initializers and
10140 allocatable components must not be nulled wholesale; instead they
10141 are treated component by component. */
10142 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10144 /* SAVEd variables are not freed on exit. */
10145 gfc_trans_static_array_pointer (sym
);
10147 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10148 gfc_restore_backend_locus (&loc
);
10152 /* Get the descriptor type. */
10153 type
= TREE_TYPE (sym
->backend_decl
);
10155 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10156 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10158 if (!sym
->attr
.save
10159 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10161 if (sym
->value
== NULL
10162 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10164 rank
= sym
->as
? sym
->as
->rank
: 0;
10165 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10167 gfc_add_expr_to_block (&init
, tmp
);
10170 gfc_init_default_dt (sym
, &init
, false);
10173 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10175 /* If the backend_decl is not a descriptor, we must have a pointer
10177 descriptor
= build_fold_indirect_ref_loc (input_location
,
10178 sym
->backend_decl
);
10179 type
= TREE_TYPE (descriptor
);
10182 /* NULLIFY the data pointer, for non-saved allocatables. */
10183 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10185 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10186 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10188 /* Declare the variable static so its array descriptor stays present
10189 after leaving the scope. It may still be accessed through another
10190 image. This may happen, for example, with the caf_mpi
10192 TREE_STATIC (descriptor
) = 1;
10193 tmp
= gfc_conv_descriptor_token (descriptor
);
10194 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10195 null_pointer_node
));
10199 gfc_restore_backend_locus (&loc
);
10200 gfc_init_block (&cleanup
);
10202 /* Allocatable arrays need to be freed when they go out of scope.
10203 The allocatable components of pointers must not be touched. */
10204 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10205 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10206 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10209 sym
->attr
.referenced
= 1;
10210 e
= gfc_lval_expr_from_sym (sym
);
10211 gfc_add_finalizer_call (&cleanup
, e
);
10214 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10215 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10216 && !sym
->attr
.pointer
&& !sym
->attr
.save
10217 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10220 rank
= sym
->as
? sym
->as
->rank
: 0;
10221 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10222 gfc_add_expr_to_block (&cleanup
, tmp
);
10225 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10226 && !sym
->attr
.save
&& !sym
->attr
.result
10227 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10230 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10231 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10232 NULL_TREE
, NULL_TREE
, true, e
,
10233 sym
->attr
.codimension
10234 ? GFC_CAF_COARRAY_DEREGISTER
10235 : GFC_CAF_COARRAY_NOCOARRAY
);
10238 gfc_add_expr_to_block (&cleanup
, tmp
);
10241 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10242 gfc_finish_block (&cleanup
));
10245 /************ Expression Walking Functions ******************/
10247 /* Walk a variable reference.
10249 Possible extension - multiple component subscripts.
10250 x(:,:) = foo%a(:)%b(:)
10252 forall (i=..., j=...)
10253 x(i,j) = foo%a(j)%b(i)
10255 This adds a fair amount of complexity because you need to deal with more
10256 than one ref. Maybe handle in a similar manner to vector subscripts.
10257 Maybe not worth the effort. */
10261 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10265 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10266 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10269 return gfc_walk_array_ref (ss
, expr
, ref
);
10274 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10280 for (; ref
; ref
= ref
->next
)
10282 if (ref
->type
== REF_SUBSTRING
)
10284 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10285 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10288 /* We're only interested in array sections from now on. */
10289 if (ref
->type
!= REF_ARRAY
)
10297 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10298 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10302 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10303 newss
->info
->data
.array
.ref
= ref
;
10305 /* Make sure array is the same as array(:,:), this way
10306 we don't need to special case all the time. */
10307 ar
->dimen
= ar
->as
->rank
;
10308 for (n
= 0; n
< ar
->dimen
; n
++)
10310 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10312 gcc_assert (ar
->start
[n
] == NULL
);
10313 gcc_assert (ar
->end
[n
] == NULL
);
10314 gcc_assert (ar
->stride
[n
] == NULL
);
10320 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10321 newss
->info
->data
.array
.ref
= ref
;
10323 /* We add SS chains for all the subscripts in the section. */
10324 for (n
= 0; n
< ar
->dimen
; n
++)
10328 switch (ar
->dimen_type
[n
])
10330 case DIMEN_ELEMENT
:
10331 /* Add SS for elemental (scalar) subscripts. */
10332 gcc_assert (ar
->start
[n
]);
10333 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10334 indexss
->loop_chain
= gfc_ss_terminator
;
10335 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10339 /* We don't add anything for sections, just remember this
10340 dimension for later. */
10341 newss
->dim
[newss
->dimen
] = n
;
10346 /* Create a GFC_SS_VECTOR index in which we can store
10347 the vector's descriptor. */
10348 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10350 indexss
->loop_chain
= gfc_ss_terminator
;
10351 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10352 newss
->dim
[newss
->dimen
] = n
;
10357 /* We should know what sort of section it is by now. */
10358 gcc_unreachable ();
10361 /* We should have at least one non-elemental dimension,
10362 unless we are creating a descriptor for a (scalar) coarray. */
10363 gcc_assert (newss
->dimen
> 0
10364 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10369 /* We should know what sort of section it is by now. */
10370 gcc_unreachable ();
10378 /* Walk an expression operator. If only one operand of a binary expression is
10379 scalar, we must also add the scalar term to the SS chain. */
10382 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10387 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10388 if (expr
->value
.op
.op2
== NULL
)
10391 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10393 /* All operands are scalar. Pass back and let the caller deal with it. */
10397 /* All operands require scalarization. */
10398 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10401 /* One of the operands needs scalarization, the other is scalar.
10402 Create a gfc_ss for the scalar expression. */
10405 /* First operand is scalar. We build the chain in reverse order, so
10406 add the scalar SS after the second operand. */
10408 while (head
&& head
->next
!= ss
)
10410 /* Check we haven't somehow broken the chain. */
10412 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10414 else /* head2 == head */
10416 gcc_assert (head2
== head
);
10417 /* Second operand is scalar. */
10418 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10425 /* Reverse a SS chain. */
10428 gfc_reverse_ss (gfc_ss
* ss
)
10433 gcc_assert (ss
!= NULL
);
10435 head
= gfc_ss_terminator
;
10436 while (ss
!= gfc_ss_terminator
)
10439 /* Check we didn't somehow break the chain. */
10440 gcc_assert (next
!= NULL
);
10450 /* Given an expression referring to a procedure, return the symbol of its
10451 interface. We can't get the procedure symbol directly as we have to handle
10452 the case of (deferred) type-bound procedures. */
10455 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10460 if (procedure_ref
== NULL
)
10463 /* Normal procedure case. */
10464 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10465 && procedure_ref
->value
.function
.esym
)
10466 sym
= procedure_ref
->value
.function
.esym
;
10468 sym
= procedure_ref
->symtree
->n
.sym
;
10470 /* Typebound procedure case. */
10471 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10473 if (ref
->type
== REF_COMPONENT
10474 && ref
->u
.c
.component
->attr
.proc_pointer
)
10475 sym
= ref
->u
.c
.component
->ts
.interface
;
10484 /* Walk the arguments of an elemental function.
10485 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10486 it is NULL, we don't do the check and the argument is assumed to be present.
10490 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10491 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10493 gfc_formal_arglist
*dummy_arg
;
10499 head
= gfc_ss_terminator
;
10503 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10508 for (; arg
; arg
= arg
->next
)
10510 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10511 goto loop_continue
;
10513 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10516 /* Scalar argument. */
10517 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10518 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10519 newss
->info
->type
= type
;
10521 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10526 if (dummy_arg
!= NULL
10527 && dummy_arg
->sym
->attr
.optional
10528 && arg
->expr
->expr_type
== EXPR_VARIABLE
10529 && (gfc_expr_attr (arg
->expr
).optional
10530 || gfc_expr_attr (arg
->expr
).allocatable
10531 || gfc_expr_attr (arg
->expr
).pointer
))
10532 newss
->info
->can_be_null_ref
= true;
10538 while (tail
->next
!= gfc_ss_terminator
)
10543 if (dummy_arg
!= NULL
)
10544 dummy_arg
= dummy_arg
->next
;
10549 /* If all the arguments are scalar we don't need the argument SS. */
10550 gfc_free_ss_chain (head
);
10551 /* Pass it back. */
10555 /* Add it onto the existing chain. */
10561 /* Walk a function call. Scalar functions are passed back, and taken out of
10562 scalarization loops. For elemental functions we walk their arguments.
10563 The result of functions returning arrays is stored in a temporary outside
10564 the loop, so that the function is only called once. Hence we do not need
10565 to walk their arguments. */
10568 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10570 gfc_intrinsic_sym
*isym
;
10572 gfc_component
*comp
= NULL
;
10574 isym
= expr
->value
.function
.isym
;
10576 /* Handle intrinsic functions separately. */
10578 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10580 sym
= expr
->value
.function
.esym
;
10582 sym
= expr
->symtree
->n
.sym
;
10584 if (gfc_is_class_array_function (expr
))
10585 return gfc_get_array_ss (ss
, expr
,
10586 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10589 /* A function that returns arrays. */
10590 comp
= gfc_get_proc_ptr_comp (expr
);
10591 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10592 || (comp
&& comp
->attr
.dimension
))
10593 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10595 /* Walk the parameters of an elemental function. For now we always pass
10597 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10599 gfc_ss
*old_ss
= ss
;
10601 ss
= gfc_walk_elemental_function_args (old_ss
,
10602 expr
->value
.function
.actual
,
10603 gfc_get_proc_ifc_for_expr (expr
),
10607 || sym
->attr
.proc_pointer
10608 || sym
->attr
.if_source
!= IFSRC_DECL
10609 || sym
->attr
.array_outer_dependency
))
10610 ss
->info
->array_outer_dependency
= 1;
10613 /* Scalar functions are OK as these are evaluated outside the scalarization
10614 loop. Pass back and let the caller deal with it. */
10619 /* An array temporary is constructed for array constructors. */
10622 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10624 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10628 /* Walk an expression. Add walked expressions to the head of the SS chain.
10629 A wholly scalar expression will not be added. */
10632 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10636 switch (expr
->expr_type
)
10638 case EXPR_VARIABLE
:
10639 head
= gfc_walk_variable_expr (ss
, expr
);
10643 head
= gfc_walk_op_expr (ss
, expr
);
10646 case EXPR_FUNCTION
:
10647 head
= gfc_walk_function_expr (ss
, expr
);
10650 case EXPR_CONSTANT
:
10652 case EXPR_STRUCTURE
:
10653 /* Pass back and let the caller deal with it. */
10657 head
= gfc_walk_array_constructor (ss
, expr
);
10660 case EXPR_SUBSTRING
:
10661 /* Pass back and let the caller deal with it. */
10665 gfc_internal_error ("bad expression type during walk (%d)",
10672 /* Entry point for expression walking.
10673 A return value equal to the passed chain means this is
10674 a scalar expression. It is up to the caller to take whatever action is
10675 necessary to translate these. */
10678 gfc_walk_expr (gfc_expr
* expr
)
10682 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10683 return gfc_reverse_ss (res
);