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 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
7345 parmtype
= gfc_typenode_for_spec (&expr
->ts
);
7347 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7349 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7350 loop
.from
, loop
.to
, 0,
7351 GFC_ARRAY_UNKNOWN
, false);
7352 parm
= gfc_create_var (parmtype
, "parm");
7354 /* When expression is a class object, then add the class' handle to
7356 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7358 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7361 /* class_expr can be NULL, when no _class ref is in expr.
7362 We must not fix this here with a gfc_fix_class_ref (). */
7365 gfc_init_se (&classse
, NULL
);
7366 gfc_conv_expr (&classse
, class_expr
);
7367 gfc_free_expr (class_expr
);
7369 gcc_assert (classse
.pre
.head
== NULL_TREE
7370 && classse
.post
.head
== NULL_TREE
);
7371 gfc_allocate_lang_decl (parm
);
7372 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7377 offset
= gfc_index_zero_node
;
7379 /* The following can be somewhat confusing. We have two
7380 descriptors, a new one and the original array.
7381 {parm, parmtype, dim} refer to the new one.
7382 {desc, type, n, loop} refer to the original, which maybe
7383 a descriptorless array.
7384 The bounds of the scalarization are the bounds of the section.
7385 We don't have to worry about numeric overflows when calculating
7386 the offsets because all elements are within the array data. */
7388 /* Set the dtype. */
7389 tmp
= gfc_conv_descriptor_dtype (parm
);
7390 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7392 /* Set offset for assignments to pointer only to zero if it is not
7394 if ((se
->direct_byref
|| se
->use_offset
)
7395 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7396 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7397 base
= gfc_index_zero_node
;
7398 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7399 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7403 for (n
= 0; n
< ndim
; n
++)
7405 stride
= gfc_conv_array_stride (desc
, n
);
7407 /* Work out the offset. */
7409 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7411 gcc_assert (info
->subscript
[n
]
7412 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7413 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7417 /* Evaluate and remember the start of the section. */
7418 start
= info
->start
[n
];
7419 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7422 tmp
= gfc_conv_array_lbound (desc
, n
);
7423 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7425 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7427 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7431 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7433 /* For elemental dimensions, we only need the offset. */
7437 /* Vector subscripts need copying and are handled elsewhere. */
7439 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7441 /* look for the corresponding scalarizer dimension: dim. */
7442 for (dim
= 0; dim
< ndim
; dim
++)
7443 if (ss
->dim
[dim
] == n
)
7446 /* loop exited early: the DIM being looked for has been found. */
7447 gcc_assert (dim
< ndim
);
7449 /* Set the new lower bound. */
7450 from
= loop
.from
[dim
];
7453 onebased
= integer_onep (from
);
7454 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7455 gfc_rank_cst
[dim
], from
);
7457 /* Set the new upper bound. */
7458 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7459 gfc_rank_cst
[dim
], to
);
7461 /* Multiply the stride by the section stride to get the
7463 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7464 gfc_array_index_type
,
7465 stride
, info
->stride
[n
]);
7467 if ((se
->direct_byref
|| se
->use_offset
)
7468 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7469 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7471 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7472 TREE_TYPE (base
), base
, stride
);
7474 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7477 tmp
= gfc_conv_array_lbound (desc
, n
);
7478 toonebased
= integer_onep (tmp
);
7479 // lb(arr) - from (- start + 1)
7480 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7481 TREE_TYPE (base
), tmp
, from
);
7482 if (onebased
&& toonebased
)
7484 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7485 TREE_TYPE (base
), tmp
, start
);
7486 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7487 TREE_TYPE (base
), tmp
,
7488 gfc_index_one_node
);
7490 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7491 TREE_TYPE (base
), tmp
,
7492 gfc_conv_array_stride (desc
, n
));
7493 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7494 TREE_TYPE (base
), tmp
, base
);
7497 /* Store the new stride. */
7498 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7499 gfc_rank_cst
[dim
], stride
);
7502 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7504 from
= loop
.from
[n
];
7506 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7507 gfc_rank_cst
[n
], from
);
7508 if (n
< loop
.dimen
+ codim
- 1)
7509 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7510 gfc_rank_cst
[n
], to
);
7513 if (se
->data_not_needed
)
7514 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7515 gfc_index_zero_node
);
7517 /* Point the data pointer at the 1st element in the section. */
7518 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7519 subref_array_target
, expr
);
7521 /* Force the offset to be -1, when the lower bound of the highest
7522 dimension is one and the symbol is present and is not a
7523 pointer/allocatable or associated. */
7524 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7525 && !se
->data_not_needed
)
7526 || (se
->use_offset
&& base
!= NULL_TREE
))
7528 /* Set the offset depending on base. */
7529 tmp
= rank_remap
&& !se
->direct_byref
?
7530 fold_build2_loc (input_location
, PLUS_EXPR
,
7531 gfc_array_index_type
, base
,
7534 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7536 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
7537 && !se
->data_not_needed
7538 && (!rank_remap
|| se
->use_offset
))
7540 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7541 gfc_conv_descriptor_offset_get (desc
));
7543 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7545 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7546 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7547 && !expr
->symtree
->n
.sym
->attr
.allocatable
7548 && !expr
->symtree
->n
.sym
->attr
.pointer
7549 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7550 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7552 /* Set the offset to -1. */
7554 mpz_init_set_si (minus_one
, -1);
7555 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7556 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7560 /* Only the callee knows what the correct offset it, so just set
7562 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7567 /* For class arrays add the class tree into the saved descriptor to
7568 enable getting of _vptr and the like. */
7569 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7570 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7572 gfc_allocate_lang_decl (desc
);
7573 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7574 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7575 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7576 : expr
->symtree
->n
.sym
->backend_decl
;
7578 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7579 && IS_CLASS_ARRAY (expr
))
7582 gfc_allocate_lang_decl (desc
);
7583 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7584 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7585 vtype
= gfc_class_vptr_get (tmp
);
7586 gfc_add_modify (&se
->pre
, vtype
,
7587 gfc_build_addr_expr (TREE_TYPE (vtype
),
7588 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7590 if (!se
->direct_byref
|| se
->byref_noassign
)
7592 /* Get a pointer to the new descriptor. */
7593 if (se
->want_pointer
)
7594 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7599 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7600 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7602 /* Cleanup the scalarizer. */
7603 gfc_cleanup_loop (&loop
);
7606 /* Helper function for gfc_conv_array_parameter if array size needs to be
7610 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7613 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7614 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7615 else if (expr
->rank
> 1)
7616 *size
= build_call_expr_loc (input_location
,
7617 gfor_fndecl_size0
, 1,
7618 gfc_build_addr_expr (NULL
, desc
));
7621 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7622 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7624 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7625 gfc_array_index_type
, ubound
, lbound
);
7626 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7627 *size
, gfc_index_one_node
);
7628 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7629 *size
, gfc_index_zero_node
);
7631 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7632 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7633 *size
, fold_convert (gfc_array_index_type
, elem
));
7636 /* Convert an array for passing as an actual parameter. */
7637 /* TODO: Optimize passing g77 arrays. */
7640 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7641 const gfc_symbol
*fsym
, const char *proc_name
,
7646 tree tmp
= NULL_TREE
;
7648 tree parent
= DECL_CONTEXT (current_function_decl
);
7649 bool full_array_var
;
7650 bool this_array_result
;
7653 bool array_constructor
;
7654 bool good_allocatable
;
7655 bool ultimate_ptr_comp
;
7656 bool ultimate_alloc_comp
;
7661 ultimate_ptr_comp
= false;
7662 ultimate_alloc_comp
= false;
7664 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7666 if (ref
->next
== NULL
)
7669 if (ref
->type
== REF_COMPONENT
)
7671 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7672 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7676 full_array_var
= false;
7679 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7680 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7682 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7684 /* The symbol should have an array specification. */
7685 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7687 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7689 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7690 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7691 se
->string_length
= tmp
;
7694 /* Is this the result of the enclosing procedure? */
7695 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7696 if (this_array_result
7697 && (sym
->backend_decl
!= current_function_decl
)
7698 && (sym
->backend_decl
!= parent
))
7699 this_array_result
= false;
7701 /* Passing address of the array if it is not pointer or assumed-shape. */
7702 if (full_array_var
&& g77
&& !this_array_result
7703 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7705 tmp
= gfc_get_symbol_decl (sym
);
7707 if (sym
->ts
.type
== BT_CHARACTER
)
7708 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7710 if (!sym
->attr
.pointer
7712 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7713 && sym
->as
->type
!= AS_DEFERRED
7714 && sym
->as
->type
!= AS_ASSUMED_RANK
7715 && !sym
->attr
.allocatable
)
7717 /* Some variables are declared directly, others are declared as
7718 pointers and allocated on the heap. */
7719 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7722 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7724 array_parameter_size (tmp
, expr
, size
);
7728 if (sym
->attr
.allocatable
)
7730 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7732 gfc_conv_expr_descriptor (se
, expr
);
7736 array_parameter_size (tmp
, expr
, size
);
7737 se
->expr
= gfc_conv_array_data (tmp
);
7742 /* A convenient reduction in scope. */
7743 contiguous
= g77
&& !this_array_result
&& contiguous
;
7745 /* There is no need to pack and unpack the array, if it is contiguous
7746 and not a deferred- or assumed-shape array, or if it is simply
7748 no_pack
= ((sym
&& sym
->as
7749 && !sym
->attr
.pointer
7750 && sym
->as
->type
!= AS_DEFERRED
7751 && sym
->as
->type
!= AS_ASSUMED_RANK
7752 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7754 (ref
&& ref
->u
.ar
.as
7755 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7756 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7757 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7759 gfc_is_simply_contiguous (expr
, false, true));
7761 no_pack
= contiguous
&& no_pack
;
7763 /* Array constructors are always contiguous and do not need packing. */
7764 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7766 /* Same is true of contiguous sections from allocatable variables. */
7767 good_allocatable
= contiguous
7769 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7771 /* Or ultimate allocatable components. */
7772 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7774 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7776 gfc_conv_expr_descriptor (se
, expr
);
7777 /* Deallocate the allocatable components of structures that are
7779 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7780 && expr
->ts
.u
.derived
->attr
.alloc_comp
7781 && expr
->expr_type
!= EXPR_VARIABLE
)
7783 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7785 /* The components shall be deallocated before their containing entity. */
7786 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7788 if (expr
->ts
.type
== BT_CHARACTER
)
7789 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7791 array_parameter_size (se
->expr
, expr
, size
);
7792 se
->expr
= gfc_conv_array_data (se
->expr
);
7796 if (this_array_result
)
7798 /* Result of the enclosing function. */
7799 gfc_conv_expr_descriptor (se
, expr
);
7801 array_parameter_size (se
->expr
, expr
, size
);
7802 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7804 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7805 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7806 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7813 /* Every other type of array. */
7814 se
->want_pointer
= 1;
7815 gfc_conv_expr_descriptor (se
, expr
);
7818 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7823 /* Deallocate the allocatable components of structures that are
7824 not variable, for descriptorless arguments.
7825 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7826 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7827 && expr
->ts
.u
.derived
->attr
.alloc_comp
7828 && expr
->expr_type
!= EXPR_VARIABLE
)
7830 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7831 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7833 /* The components shall be deallocated before their containing entity. */
7834 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7837 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7838 && !gfc_is_simply_contiguous (expr
, false, true)))
7840 tree origptr
= NULL_TREE
;
7844 /* For contiguous arrays, save the original value of the descriptor. */
7847 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7848 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7849 tmp
= gfc_conv_array_data (tmp
);
7850 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7851 TREE_TYPE (origptr
), origptr
,
7852 fold_convert (TREE_TYPE (origptr
), tmp
));
7853 gfc_add_expr_to_block (&se
->pre
, tmp
);
7856 /* Repack the array. */
7857 if (warn_array_temporaries
)
7860 gfc_warning (OPT_Warray_temporaries
,
7861 "Creating array temporary at %L for argument %qs",
7862 &expr
->where
, fsym
->name
);
7864 gfc_warning (OPT_Warray_temporaries
,
7865 "Creating array temporary at %L", &expr
->where
);
7868 ptr
= build_call_expr_loc (input_location
,
7869 gfor_fndecl_in_pack
, 1, desc
);
7871 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7873 tmp
= gfc_conv_expr_present (sym
);
7874 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7875 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7876 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7879 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7881 /* Use the packed data for the actual argument, except for contiguous arrays,
7882 where the descriptor's data component is set. */
7887 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7889 gfc_ss
* ss
= gfc_walk_expr (expr
);
7890 if (!transposed_dims (ss
))
7891 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7894 tree old_field
, new_field
;
7896 /* The original descriptor has transposed dims so we can't reuse
7897 it directly; we have to create a new one. */
7898 tree old_desc
= tmp
;
7899 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7901 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7902 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7903 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7905 old_field
= gfc_conv_descriptor_offset (old_desc
);
7906 new_field
= gfc_conv_descriptor_offset (new_desc
);
7907 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7909 for (int i
= 0; i
< expr
->rank
; i
++)
7911 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7912 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7913 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7915 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7918 if (flag_coarray
== GFC_FCOARRAY_LIB
7919 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7920 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7921 == GFC_ARRAY_ALLOCATABLE
)
7923 old_field
= gfc_conv_descriptor_token (old_desc
);
7924 new_field
= gfc_conv_descriptor_token (new_desc
);
7925 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7928 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7929 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7934 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7938 if (fsym
&& proc_name
)
7939 msg
= xasprintf ("An array temporary was created for argument "
7940 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7942 msg
= xasprintf ("An array temporary was created");
7944 tmp
= build_fold_indirect_ref_loc (input_location
,
7946 tmp
= gfc_conv_array_data (tmp
);
7947 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7948 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7950 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7951 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7953 gfc_conv_expr_present (sym
), tmp
);
7955 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7960 gfc_start_block (&block
);
7962 /* Copy the data back. */
7963 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7965 tmp
= build_call_expr_loc (input_location
,
7966 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7967 gfc_add_expr_to_block (&block
, tmp
);
7970 /* Free the temporary. */
7971 tmp
= gfc_call_free (ptr
);
7972 gfc_add_expr_to_block (&block
, tmp
);
7974 stmt
= gfc_finish_block (&block
);
7976 gfc_init_block (&block
);
7977 /* Only if it was repacked. This code needs to be executed before the
7978 loop cleanup code. */
7979 tmp
= build_fold_indirect_ref_loc (input_location
,
7981 tmp
= gfc_conv_array_data (tmp
);
7982 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7983 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7985 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7986 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7988 gfc_conv_expr_present (sym
), tmp
);
7990 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7992 gfc_add_expr_to_block (&block
, tmp
);
7993 gfc_add_block_to_block (&block
, &se
->post
);
7995 gfc_init_block (&se
->post
);
7997 /* Reset the descriptor pointer. */
8000 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
8001 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
8004 gfc_add_block_to_block (&se
->post
, &block
);
8009 /* This helper function calculates the size in words of a full array. */
8012 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
8017 idx
= gfc_rank_cst
[rank
- 1];
8018 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8019 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8020 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8022 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8023 tmp
, gfc_index_one_node
);
8024 tmp
= gfc_evaluate_now (tmp
, block
);
8026 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8027 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8029 return gfc_evaluate_now (tmp
, block
);
8033 /* Allocate dest to the same size as src, and copy src -> dest.
8034 If no_malloc is set, only the copy is done. */
8037 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8038 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8039 tree add_when_allocated
)
8048 /* If the source is null, set the destination to null. Then,
8049 allocate memory to the destination. */
8050 gfc_init_block (&block
);
8052 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8054 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8055 null_data
= gfc_finish_block (&block
);
8057 gfc_init_block (&block
);
8058 if (str_sz
!= NULL_TREE
)
8061 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8065 tmp
= gfc_call_malloc (&block
, type
, size
);
8066 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8071 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8072 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8073 fold_convert (size_type_node
, size
));
8074 gfc_add_expr_to_block (&block
, tmp
);
8079 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8080 null_data
= gfc_finish_block (&block
);
8082 gfc_init_block (&block
);
8084 nelems
= gfc_full_array_size (&block
, src
, rank
);
8086 nelems
= gfc_index_one_node
;
8088 if (str_sz
!= NULL_TREE
)
8089 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8091 tmp
= fold_convert (gfc_array_index_type
,
8092 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8093 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8097 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8098 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8099 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8102 /* We know the temporary and the value will be the same length,
8103 so can use memcpy. */
8106 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8107 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8108 gfc_conv_descriptor_data_get (dest
),
8109 gfc_conv_descriptor_data_get (src
),
8110 fold_convert (size_type_node
, size
));
8111 gfc_add_expr_to_block (&block
, tmp
);
8115 gfc_add_expr_to_block (&block
, add_when_allocated
);
8116 tmp
= gfc_finish_block (&block
);
8118 /* Null the destination if the source is null; otherwise do
8119 the allocate and copy. */
8120 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8123 null_cond
= gfc_conv_descriptor_data_get (src
);
8125 null_cond
= convert (pvoid_type_node
, null_cond
);
8126 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8127 null_cond
, null_pointer_node
);
8128 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8132 /* Allocate dest to the same size as src, and copy data src -> dest. */
8135 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8136 tree add_when_allocated
)
8138 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8139 NULL_TREE
, add_when_allocated
);
8143 /* Copy data src -> dest. */
8146 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8148 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8149 NULL_TREE
, NULL_TREE
);
8152 /* Allocate dest to the same size as src, but don't copy anything. */
8155 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8157 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8158 NULL_TREE
, NULL_TREE
);
8163 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8164 tree type
, int rank
)
8171 stmtblock_t block
, globalblock
;
8173 /* If the source is null, set the destination to null. Then,
8174 allocate memory to the destination. */
8175 gfc_init_block (&block
);
8176 gfc_init_block (&globalblock
);
8178 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8181 symbol_attribute attr
;
8184 gfc_init_se (&se
, NULL
);
8185 gfc_clear_attr (&attr
);
8186 attr
.allocatable
= 1;
8187 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8188 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8189 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8191 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8192 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8193 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8194 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8195 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8196 null_data
= gfc_finish_block (&block
);
8198 gfc_init_block (&block
);
8200 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8201 fold_convert (size_type_node
, size
),
8202 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8203 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8204 GFC_CAF_COARRAY_ALLOC
);
8206 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8207 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8208 fold_convert (size_type_node
, size
));
8209 gfc_add_expr_to_block (&block
, tmp
);
8213 /* Set the rank or unitialized memory access may be reported. */
8214 tmp
= gfc_conv_descriptor_rank (dest
);
8215 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8218 nelems
= gfc_full_array_size (&block
, src
, rank
);
8220 nelems
= integer_one_node
;
8222 tmp
= fold_convert (size_type_node
,
8223 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8224 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8225 fold_convert (size_type_node
, nelems
), tmp
);
8227 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8228 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8230 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8231 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8232 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8233 null_data
= gfc_finish_block (&block
);
8235 gfc_init_block (&block
);
8236 gfc_allocate_using_caf_lib (&block
, dest
,
8237 fold_convert (size_type_node
, size
),
8238 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8239 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8240 GFC_CAF_COARRAY_ALLOC
);
8242 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8243 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8244 gfc_conv_descriptor_data_get (dest
),
8245 gfc_conv_descriptor_data_get (src
),
8246 fold_convert (size_type_node
, size
));
8247 gfc_add_expr_to_block (&block
, tmp
);
8250 tmp
= gfc_finish_block (&block
);
8252 /* Null the destination if the source is null; otherwise do
8253 the register and copy. */
8254 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8257 null_cond
= gfc_conv_descriptor_data_get (src
);
8259 null_cond
= convert (pvoid_type_node
, null_cond
);
8260 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8261 null_cond
, null_pointer_node
);
8262 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8264 return gfc_finish_block (&globalblock
);
8268 /* Helper function to abstract whether coarray processing is enabled. */
8271 caf_enabled (int caf_mode
)
8273 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8274 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8278 /* Helper function to abstract whether coarray processing is enabled
8279 and we are in a derived type coarray. */
8282 caf_in_coarray (int caf_mode
)
8284 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8285 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8286 return (caf_mode
& pat
) == pat
;
8290 /* Helper function to abstract whether coarray is to deallocate only. */
8293 gfc_caf_is_dealloc_only (int caf_mode
)
8295 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8296 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8300 /* Recursively traverse an object of derived type, generating code to
8301 deallocate, nullify or copy allocatable components. This is the work horse
8302 function for the functions named in this enum. */
8304 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8305 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8306 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8308 static gfc_actual_arglist
*pdt_param_list
;
8311 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8312 tree dest
, int rank
, int purpose
, int caf_mode
)
8316 stmtblock_t fnblock
;
8317 stmtblock_t loopbody
;
8318 stmtblock_t tmpblock
;
8329 tree null_cond
= NULL_TREE
;
8330 tree add_when_allocated
;
8331 tree dealloc_fndecl
;
8335 symbol_attribute
*attr
;
8336 bool deallocate_called
;
8338 gfc_init_block (&fnblock
);
8340 decl_type
= TREE_TYPE (decl
);
8342 if ((POINTER_TYPE_P (decl_type
))
8343 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8345 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8346 /* Deref dest in sync with decl, but only when it is not NULL. */
8348 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8350 /* Update the decl_type because it got dereferenced. */
8351 decl_type
= TREE_TYPE (decl
);
8354 /* If this is an array of derived types with allocatable components
8355 build a loop and recursively call this function. */
8356 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8357 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8359 tmp
= gfc_conv_array_data (decl
);
8360 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8362 /* Get the number of elements - 1 and set the counter. */
8363 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8365 /* Use the descriptor for an allocatable array. Since this
8366 is a full array reference, we only need the descriptor
8367 information from dimension = rank. */
8368 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8369 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8370 gfc_array_index_type
, tmp
,
8371 gfc_index_one_node
);
8373 null_cond
= gfc_conv_descriptor_data_get (decl
);
8374 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8375 logical_type_node
, null_cond
,
8376 build_int_cst (TREE_TYPE (null_cond
), 0));
8380 /* Otherwise use the TYPE_DOMAIN information. */
8381 tmp
= array_type_nelts (decl_type
);
8382 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8385 /* Remember that this is, in fact, the no. of elements - 1. */
8386 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8387 index
= gfc_create_var (gfc_array_index_type
, "S");
8389 /* Build the body of the loop. */
8390 gfc_init_block (&loopbody
);
8392 vref
= gfc_build_array_ref (var
, index
, NULL
);
8394 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8395 && !caf_enabled (caf_mode
))
8397 tmp
= build_fold_indirect_ref_loc (input_location
,
8398 gfc_conv_array_data (dest
));
8399 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8400 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8401 COPY_ALLOC_COMP
, 0);
8404 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8407 gfc_add_expr_to_block (&loopbody
, tmp
);
8409 /* Build the loop and return. */
8410 gfc_init_loopinfo (&loop
);
8412 loop
.from
[0] = gfc_index_zero_node
;
8413 loop
.loopvar
[0] = index
;
8414 loop
.to
[0] = nelems
;
8415 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8416 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8418 tmp
= gfc_finish_block (&fnblock
);
8419 /* When copying allocateable components, the above implements the
8420 deep copy. Nevertheless is a deep copy only allowed, when the current
8421 component is allocated, for which code will be generated in
8422 gfc_duplicate_allocatable (), where the deep copy code is just added
8423 into the if's body, by adding tmp (the deep copy code) as last
8424 argument to gfc_duplicate_allocatable (). */
8425 if (purpose
== COPY_ALLOC_COMP
8426 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8427 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8429 else if (null_cond
!= NULL_TREE
)
8430 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8431 build_empty_stmt (input_location
));
8436 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8438 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8439 DEALLOCATE_PDT_COMP
, 0);
8440 gfc_add_expr_to_block (&fnblock
, tmp
);
8442 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8444 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8445 NULLIFY_ALLOC_COMP
, 0);
8446 gfc_add_expr_to_block (&fnblock
, tmp
);
8449 /* Otherwise, act on the components or recursively call self to
8450 act on a chain of components. */
8451 for (c
= der_type
->components
; c
; c
= c
->next
)
8453 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8454 || c
->ts
.type
== BT_CLASS
)
8455 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8456 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8457 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8459 bool is_pdt_type
= c
->ts
.type
== BT_DERIVED
8460 && c
->ts
.u
.derived
->attr
.pdt_type
;
8462 cdecl = c
->backend_decl
;
8463 ctype
= TREE_TYPE (cdecl);
8467 case DEALLOCATE_ALLOC_COMP
:
8469 gfc_init_block (&tmpblock
);
8471 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8472 decl
, cdecl, NULL_TREE
);
8474 /* Shortcut to get the attributes of the component. */
8475 if (c
->ts
.type
== BT_CLASS
)
8477 attr
= &CLASS_DATA (c
)->attr
;
8478 if (attr
->class_pointer
)
8488 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8489 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8490 /* Call the finalizer, which will free the memory and nullify the
8491 pointer of an array. */
8492 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8493 caf_enabled (caf_mode
))
8496 deallocate_called
= false;
8498 /* Add the _class ref for classes. */
8499 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8500 comp
= gfc_class_data_get (comp
);
8502 add_when_allocated
= NULL_TREE
;
8503 if (cmp_has_alloc_comps
8504 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8506 && !deallocate_called
)
8508 /* Add checked deallocation of the components. This code is
8509 obviously added because the finalizer is not trusted to free
8511 if (c
->ts
.type
== BT_CLASS
)
8513 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8515 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8516 comp
, NULL_TREE
, rank
, purpose
,
8521 rank
= c
->as
? c
->as
->rank
: 0;
8522 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8529 if (attr
->allocatable
&& !same_type
8530 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8532 /* Handle all types of components besides components of the
8533 same_type as the current one, because those would create an
8536 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8537 ? (gfc_caf_is_dealloc_only (caf_mode
)
8538 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8539 : GFC_CAF_COARRAY_DEREGISTER
)
8540 : GFC_CAF_COARRAY_NOCOARRAY
;
8542 caf_token
= NULL_TREE
;
8543 /* Coarray components are handled directly by
8544 deallocate_with_status. */
8545 if (!attr
->codimension
8546 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8549 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8550 TREE_TYPE (c
->caf_token
),
8551 decl
, c
->caf_token
, NULL_TREE
);
8552 else if (attr
->dimension
&& !attr
->proc_pointer
)
8553 caf_token
= gfc_conv_descriptor_token (comp
);
8555 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8556 /* When this is an array but not in conjunction with a coarray
8557 then add the data-ref. For coarray'ed arrays the data-ref
8558 is added by deallocate_with_status. */
8559 comp
= gfc_conv_descriptor_data_get (comp
);
8561 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8562 NULL_TREE
, NULL_TREE
, true,
8563 NULL
, caf_dereg_mode
,
8564 add_when_allocated
, caf_token
);
8566 gfc_add_expr_to_block (&tmpblock
, tmp
);
8568 else if (attr
->allocatable
&& !attr
->codimension
8569 && !deallocate_called
)
8571 /* Case of recursive allocatable derived types. */
8575 stmtblock_t dealloc_block
;
8577 gfc_init_block (&dealloc_block
);
8578 if (add_when_allocated
)
8579 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8581 /* Convert the component into a rank 1 descriptor type. */
8582 if (attr
->dimension
)
8584 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8585 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8586 c
->ts
.type
== BT_CLASS
8587 ? CLASS_DATA (c
)->as
->rank
8592 tmp
= TREE_TYPE (comp
);
8593 ubound
= build_int_cst (gfc_array_index_type
, 1);
8596 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8598 GFC_ARRAY_ALLOCATABLE
, false);
8600 cdesc
= gfc_create_var (cdesc
, "cdesc");
8601 DECL_ARTIFICIAL (cdesc
) = 1;
8603 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8604 gfc_get_dtype_rank_type (1, tmp
));
8605 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8606 gfc_index_zero_node
,
8607 gfc_index_one_node
);
8608 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8609 gfc_index_zero_node
,
8610 gfc_index_one_node
);
8611 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8612 gfc_index_zero_node
, ubound
);
8614 if (attr
->dimension
)
8615 comp
= gfc_conv_descriptor_data_get (comp
);
8617 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8619 /* Now call the deallocator. */
8620 vtab
= gfc_find_vtab (&c
->ts
);
8621 if (vtab
->backend_decl
== NULL
)
8622 gfc_get_symbol_decl (vtab
);
8623 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8624 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8625 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8627 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8628 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8629 logical_type_node
, tmp
,
8631 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8633 tmp
= build_call_expr_loc (input_location
,
8636 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8638 tmp
= gfc_finish_block (&dealloc_block
);
8640 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8641 void_type_node
, is_allocated
, tmp
,
8642 build_empty_stmt (input_location
));
8644 gfc_add_expr_to_block (&tmpblock
, tmp
);
8646 else if (add_when_allocated
)
8647 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8649 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8650 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8652 /* Finally, reset the vptr to the declared type vtable and, if
8653 necessary reset the _len field.
8655 First recover the reference to the component and obtain
8657 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8658 decl
, cdecl, NULL_TREE
);
8659 tmp
= gfc_class_vptr_get (comp
);
8661 if (UNLIMITED_POLY (c
))
8663 /* Both vptr and _len field should be nulled. */
8664 gfc_add_modify (&tmpblock
, tmp
,
8665 build_int_cst (TREE_TYPE (tmp
), 0));
8666 tmp
= gfc_class_len_get (comp
);
8667 gfc_add_modify (&tmpblock
, tmp
,
8668 build_int_cst (TREE_TYPE (tmp
), 0));
8672 /* Build the vtable address and set the vptr with it. */
8675 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8676 vtab
= vtable
->backend_decl
;
8677 if (vtab
== NULL_TREE
)
8678 vtab
= gfc_get_symbol_decl (vtable
);
8679 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8680 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8681 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8685 /* Now add the deallocation of this component. */
8686 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8689 case NULLIFY_ALLOC_COMP
:
8691 - allocatable components (regular or in class)
8692 - components that have allocatable components
8693 - pointer components when in a coarray.
8694 Skip everything else especially proc_pointers, which may come
8695 coupled with the regular pointer attribute. */
8696 if (c
->attr
.proc_pointer
8697 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8698 && CLASS_DATA (c
)->attr
.allocatable
)
8699 || (cmp_has_alloc_comps
8700 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8701 || (c
->ts
.type
== BT_CLASS
8702 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8703 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8706 /* Process class components first, because they always have the
8707 pointer-attribute set which would be caught wrong else. */
8708 if (c
->ts
.type
== BT_CLASS
8709 && (CLASS_DATA (c
)->attr
.allocatable
8710 || CLASS_DATA (c
)->attr
.class_pointer
))
8712 /* Allocatable CLASS components. */
8713 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8714 decl
, cdecl, NULL_TREE
);
8716 comp
= gfc_class_data_get (comp
);
8717 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8718 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8722 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8723 void_type_node
, comp
,
8724 build_int_cst (TREE_TYPE (comp
), 0));
8725 gfc_add_expr_to_block (&fnblock
, tmp
);
8727 cmp_has_alloc_comps
= false;
8729 /* Coarrays need the component to be nulled before the api-call
8731 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8733 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8734 decl
, cdecl, NULL_TREE
);
8735 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8736 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8739 gfc_add_modify (&fnblock
, comp
,
8740 build_int_cst (TREE_TYPE (comp
), 0));
8741 if (gfc_deferred_strlen (c
, &comp
))
8743 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8745 decl
, comp
, NULL_TREE
);
8746 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8747 TREE_TYPE (comp
), comp
,
8748 build_int_cst (TREE_TYPE (comp
), 0));
8749 gfc_add_expr_to_block (&fnblock
, tmp
);
8751 cmp_has_alloc_comps
= false;
8754 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode
))
8756 /* Register a component of a derived type coarray with the
8757 coarray library. Do not register ultimate component
8758 coarrays here. They are treated like regular coarrays and
8759 are either allocated on all images or on none. */
8762 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8763 decl
, cdecl, NULL_TREE
);
8764 if (c
->attr
.dimension
)
8766 /* Set the dtype, because caf_register needs it. */
8767 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8768 gfc_get_dtype (TREE_TYPE (comp
)));
8769 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8770 decl
, cdecl, NULL_TREE
);
8771 token
= gfc_conv_descriptor_token (tmp
);
8777 gfc_init_se (&se
, NULL
);
8778 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8779 pvoid_type_node
, decl
, c
->caf_token
,
8781 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8782 c
->ts
.type
== BT_CLASS
8783 ? CLASS_DATA (c
)->attr
8785 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8788 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8789 gfc_build_addr_expr (NULL_TREE
,
8791 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8792 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8795 if (cmp_has_alloc_comps
)
8797 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8798 decl
, cdecl, NULL_TREE
);
8799 rank
= c
->as
? c
->as
->rank
: 0;
8800 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8801 rank
, purpose
, caf_mode
);
8802 gfc_add_expr_to_block (&fnblock
, tmp
);
8806 case REASSIGN_CAF_COMP
:
8807 if (caf_enabled (caf_mode
)
8808 && (c
->attr
.codimension
8809 || (c
->ts
.type
== BT_CLASS
8810 && (CLASS_DATA (c
)->attr
.coarray_comp
8811 || caf_in_coarray (caf_mode
)))
8812 || (c
->ts
.type
== BT_DERIVED
8813 && (c
->ts
.u
.derived
->attr
.coarray_comp
8814 || caf_in_coarray (caf_mode
))))
8817 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8818 decl
, cdecl, NULL_TREE
);
8819 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8820 dest
, cdecl, NULL_TREE
);
8822 if (c
->attr
.codimension
)
8824 if (c
->ts
.type
== BT_CLASS
)
8826 comp
= gfc_class_data_get (comp
);
8827 dcmp
= gfc_class_data_get (dcmp
);
8829 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8830 gfc_conv_descriptor_data_get (comp
));
8834 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8835 rank
, purpose
, caf_mode
8836 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8837 gfc_add_expr_to_block (&fnblock
, tmp
);
8842 case COPY_ALLOC_COMP
:
8843 if (c
->attr
.pointer
)
8846 /* We need source and destination components. */
8847 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8849 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8851 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8853 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8861 dst_data
= gfc_class_data_get (dcmp
);
8862 src_data
= gfc_class_data_get (comp
);
8863 size
= fold_convert (size_type_node
,
8864 gfc_class_vtab_size_get (comp
));
8866 if (CLASS_DATA (c
)->attr
.dimension
)
8868 nelems
= gfc_conv_descriptor_size (src_data
,
8869 CLASS_DATA (c
)->as
->rank
);
8870 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8871 size_type_node
, size
,
8872 fold_convert (size_type_node
,
8876 nelems
= build_int_cst (size_type_node
, 1);
8878 if (CLASS_DATA (c
)->attr
.dimension
8879 || CLASS_DATA (c
)->attr
.codimension
)
8881 src_data
= gfc_conv_descriptor_data_get (src_data
);
8882 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8885 gfc_init_block (&tmpblock
);
8887 /* Coarray component have to have the same allocation status and
8888 shape/type-parameter/effective-type on the LHS and RHS of an
8889 intrinsic assignment. Hence, we did not deallocated them - and
8890 do not allocate them here. */
8891 if (!CLASS_DATA (c
)->attr
.codimension
)
8893 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8894 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8895 gfc_add_modify (&tmpblock
, dst_data
,
8896 fold_convert (TREE_TYPE (dst_data
), tmp
));
8899 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8900 UNLIMITED_POLY (c
));
8901 gfc_add_expr_to_block (&tmpblock
, tmp
);
8902 tmp
= gfc_finish_block (&tmpblock
);
8904 gfc_init_block (&tmpblock
);
8905 gfc_add_modify (&tmpblock
, dst_data
,
8906 fold_convert (TREE_TYPE (dst_data
),
8907 null_pointer_node
));
8908 null_data
= gfc_finish_block (&tmpblock
);
8910 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8911 logical_type_node
, src_data
,
8914 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8919 /* To implement guarded deep copy, i.e., deep copy only allocatable
8920 components that are really allocated, the deep copy code has to
8921 be generated first and then added to the if-block in
8922 gfc_duplicate_allocatable (). */
8923 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
&& !same_type
)
8925 rank
= c
->as
? c
->as
->rank
: 0;
8926 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8927 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8928 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8934 add_when_allocated
= NULL_TREE
;
8936 if (gfc_deferred_strlen (c
, &tmp
))
8940 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8942 decl
, len
, NULL_TREE
);
8943 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8945 dest
, len
, NULL_TREE
);
8946 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8947 TREE_TYPE (len
), len
, tmp
);
8948 gfc_add_expr_to_block (&fnblock
, tmp
);
8949 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8950 /* This component can not have allocatable components,
8951 therefore add_when_allocated of duplicate_allocatable ()
8953 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8954 false, false, size
, NULL_TREE
);
8955 gfc_add_expr_to_block (&fnblock
, tmp
);
8957 else if (c
->attr
.pdt_array
)
8959 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
,
8960 c
->as
? c
->as
->rank
: 0,
8961 false, false, NULL_TREE
, NULL_TREE
);
8962 gfc_add_expr_to_block (&fnblock
, tmp
);
8964 else if ((c
->attr
.allocatable
)
8965 && !c
->attr
.proc_pointer
&& !same_type
8966 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
8967 || caf_in_coarray (caf_mode
)))
8969 rank
= c
->as
? c
->as
->rank
: 0;
8970 if (c
->attr
.codimension
)
8971 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8972 else if (flag_coarray
== GFC_FCOARRAY_LIB
8973 && caf_in_coarray (caf_mode
))
8975 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
8976 : fold_build3_loc (input_location
,
8978 pvoid_type_node
, dest
,
8981 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
8985 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8986 add_when_allocated
);
8987 gfc_add_expr_to_block (&fnblock
, tmp
);
8990 if (cmp_has_alloc_comps
|| is_pdt_type
)
8991 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8995 case ALLOCATE_PDT_COMP
:
8997 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8998 decl
, cdecl, NULL_TREE
);
9000 /* Set the PDT KIND and LEN fields. */
9001 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
9004 gfc_expr
*c_expr
= NULL
;
9005 gfc_actual_arglist
*param
= pdt_param_list
;
9006 gfc_init_se (&tse
, NULL
);
9007 for (; param
; param
= param
->next
)
9008 if (param
->name
&& !strcmp (c
->name
, param
->name
))
9009 c_expr
= param
->expr
;
9012 c_expr
= c
->initializer
;
9016 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9017 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
9021 if (c
->attr
.pdt_string
)
9024 gfc_init_se (&tse
, NULL
);
9025 tree strlen
= NULL_TREE
;
9026 gfc_expr
*e
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
9027 /* Convert the parameterized string length to its value. The
9028 string length is stored in a hidden field in the same way as
9029 deferred string lengths. */
9030 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9031 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9033 gfc_conv_expr_type (&tse
, e
,
9034 TREE_TYPE (strlen
));
9035 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9037 decl
, strlen
, NULL_TREE
);
9038 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9039 c
->ts
.u
.cl
->backend_decl
= strlen
;
9043 /* Scalar parameterized strings can be allocated now. */
9046 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9047 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9048 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9049 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9050 gfc_add_modify (&fnblock
, comp
, tmp
);
9054 /* Allocate parameterized arrays of parameterized derived types. */
9055 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9056 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9057 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9060 if (c
->ts
.type
== BT_CLASS
)
9061 comp
= gfc_class_data_get (comp
);
9063 if (c
->attr
.pdt_array
)
9067 tree size
= gfc_index_one_node
;
9068 tree offset
= gfc_index_zero_node
;
9072 /* This chunk takes the expressions for 'lower' and 'upper'
9073 in the arrayspec and substitutes in the expressions for
9074 the parameters from 'pdt_param_list'. The descriptor
9075 fields can then be filled from the values so obtained. */
9076 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9077 for (i
= 0; i
< c
->as
->rank
; i
++)
9079 gfc_init_se (&tse
, NULL
);
9080 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9081 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9082 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9085 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9088 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9089 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9090 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9093 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9096 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9099 size
= gfc_evaluate_now (size
, &fnblock
);
9100 offset
= fold_build2_loc (input_location
,
9102 gfc_array_index_type
,
9104 offset
= gfc_evaluate_now (offset
, &fnblock
);
9105 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9106 gfc_array_index_type
,
9108 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9109 gfc_array_index_type
,
9110 tmp
, gfc_index_one_node
);
9111 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9112 gfc_array_index_type
, size
, tmp
);
9114 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9115 if (c
->ts
.type
== BT_CLASS
)
9117 tmp
= gfc_get_vptr_from_expr (comp
);
9118 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9119 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9120 tmp
= gfc_vptr_size_get (tmp
);
9123 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9124 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9125 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9126 gfc_array_index_type
, size
, tmp
);
9127 size
= gfc_evaluate_now (size
, &fnblock
);
9128 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9129 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9130 tmp
= gfc_conv_descriptor_dtype (comp
);
9131 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9133 if (c
->initializer
&& c
->initializer
->rank
)
9135 gfc_init_se (&tse
, NULL
);
9136 e
= gfc_copy_expr (c
->initializer
);
9137 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9138 gfc_conv_expr_descriptor (&tse
, e
);
9139 gfc_add_block_to_block (&fnblock
, &tse
.pre
);
9141 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
9142 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
9143 gfc_conv_descriptor_data_get (comp
),
9144 gfc_conv_descriptor_data_get (tse
.expr
),
9145 fold_convert (size_type_node
, size
));
9146 gfc_add_expr_to_block (&fnblock
, tmp
);
9147 gfc_add_block_to_block (&fnblock
, &tse
.post
);
9151 /* Recurse in to PDT components. */
9152 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9153 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9154 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9156 bool is_deferred
= false;
9157 gfc_actual_arglist
*tail
= c
->param_list
;
9159 for (; tail
; tail
= tail
->next
)
9163 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9164 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9165 c
->as
? c
->as
->rank
: 0,
9167 gfc_add_expr_to_block (&fnblock
, tmp
);
9172 case DEALLOCATE_PDT_COMP
:
9173 /* Deallocate array or parameterized string length components
9174 of parameterized derived types. */
9175 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9176 && !c
->attr
.pdt_string
9177 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9178 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9181 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9182 decl
, cdecl, NULL_TREE
);
9183 if (c
->ts
.type
== BT_CLASS
)
9184 comp
= gfc_class_data_get (comp
);
9186 /* Recurse in to PDT components. */
9187 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9188 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9189 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9191 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9192 c
->as
? c
->as
->rank
: 0);
9193 gfc_add_expr_to_block (&fnblock
, tmp
);
9196 if (c
->attr
.pdt_array
)
9198 tmp
= gfc_conv_descriptor_data_get (comp
);
9199 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9200 logical_type_node
, tmp
,
9201 build_int_cst (TREE_TYPE (tmp
), 0));
9202 tmp
= gfc_call_free (tmp
);
9203 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9204 build_empty_stmt (input_location
));
9205 gfc_add_expr_to_block (&fnblock
, tmp
);
9206 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9208 else if (c
->attr
.pdt_string
)
9210 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9211 logical_type_node
, comp
,
9212 build_int_cst (TREE_TYPE (comp
), 0));
9213 tmp
= gfc_call_free (comp
);
9214 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9215 build_empty_stmt (input_location
));
9216 gfc_add_expr_to_block (&fnblock
, tmp
);
9217 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9218 gfc_add_modify (&fnblock
, comp
, tmp
);
9223 case CHECK_PDT_DUMMY
:
9225 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9226 decl
, cdecl, NULL_TREE
);
9227 if (c
->ts
.type
== BT_CLASS
)
9228 comp
= gfc_class_data_get (comp
);
9230 /* Recurse in to PDT components. */
9231 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9232 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9234 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9235 c
->as
? c
->as
->rank
: 0,
9237 gfc_add_expr_to_block (&fnblock
, tmp
);
9240 if (!c
->attr
.pdt_len
)
9245 gfc_expr
*c_expr
= NULL
;
9246 gfc_actual_arglist
*param
= pdt_param_list
;
9248 gfc_init_se (&tse
, NULL
);
9249 for (; param
; param
= param
->next
)
9250 if (!strcmp (c
->name
, param
->name
)
9251 && param
->spec_type
== SPEC_EXPLICIT
)
9252 c_expr
= param
->expr
;
9256 tree error
, cond
, cname
;
9257 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9258 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9261 cname
= gfc_build_cstring_const (c
->name
);
9262 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9263 error
= gfc_trans_runtime_error (true, NULL
,
9264 "The value of the PDT LEN "
9265 "parameter '%s' does not "
9266 "agree with that in the "
9267 "dummy declaration",
9269 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9270 void_type_node
, cond
, error
,
9271 build_empty_stmt (input_location
));
9272 gfc_add_expr_to_block (&fnblock
, tmp
);
9283 return gfc_finish_block (&fnblock
);
9286 /* Recursively traverse an object of derived type, generating code to
9287 nullify allocatable components. */
9290 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9293 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9295 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9299 /* Recursively traverse an object of derived type, generating code to
9300 deallocate allocatable components. */
9303 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9306 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9307 DEALLOCATE_ALLOC_COMP
,
9308 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9312 /* Recursively traverse an object of derived type, generating code to
9313 deallocate allocatable components. But do not deallocate coarrays.
9314 To be used for intrinsic assignment, which may not change the allocation
9315 status of coarrays. */
9318 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9320 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9321 DEALLOCATE_ALLOC_COMP
, 0);
9326 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9328 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9329 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9333 /* Recursively traverse an object of derived type, generating code to
9334 copy it and its allocatable components. */
9337 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9340 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9345 /* Recursively traverse an object of derived type, generating code to
9346 copy only its allocatable components. */
9349 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9351 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9352 COPY_ONLY_ALLOC_COMP
, 0);
9356 /* Recursively traverse an object of paramterized derived type, generating
9357 code to allocate parameterized components. */
9360 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9361 gfc_actual_arglist
*param_list
)
9364 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9365 pdt_param_list
= param_list
;
9366 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9367 ALLOCATE_PDT_COMP
, 0);
9368 pdt_param_list
= old_param_list
;
9372 /* Recursively traverse an object of paramterized derived type, generating
9373 code to deallocate parameterized components. */
9376 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9378 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9379 DEALLOCATE_PDT_COMP
, 0);
9383 /* Recursively traverse a dummy of paramterized derived type to check the
9384 values of LEN parameters. */
9387 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9388 gfc_actual_arglist
*param_list
)
9391 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9392 pdt_param_list
= param_list
;
9393 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9394 CHECK_PDT_DUMMY
, 0);
9395 pdt_param_list
= old_param_list
;
9400 /* Returns the value of LBOUND for an expression. This could be broken out
9401 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9402 called by gfc_alloc_allocatable_for_assignment. */
9404 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9409 tree cond
, cond1
, cond3
, cond4
;
9413 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9415 tmp
= gfc_rank_cst
[dim
];
9416 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9417 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9418 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9419 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9421 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9422 stride
, gfc_index_zero_node
);
9423 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9424 logical_type_node
, cond3
, cond1
);
9425 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9426 stride
, gfc_index_zero_node
);
9428 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9429 tmp
, build_int_cst (gfc_array_index_type
,
9432 cond
= logical_false_node
;
9434 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9435 logical_type_node
, cond3
, cond4
);
9436 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9437 logical_type_node
, cond
, cond1
);
9439 return fold_build3_loc (input_location
, COND_EXPR
,
9440 gfc_array_index_type
, cond
,
9441 lbound
, gfc_index_one_node
);
9444 if (expr
->expr_type
== EXPR_FUNCTION
)
9446 /* A conversion function, so use the argument. */
9447 gcc_assert (expr
->value
.function
.isym
9448 && expr
->value
.function
.isym
->conversion
);
9449 expr
= expr
->value
.function
.actual
->expr
;
9452 if (expr
->expr_type
== EXPR_VARIABLE
)
9454 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9455 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9457 if (ref
->type
== REF_COMPONENT
9458 && ref
->u
.c
.component
->as
9460 && ref
->next
->u
.ar
.type
== AR_FULL
)
9461 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9463 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9466 return gfc_index_one_node
;
9470 /* Returns true if an expression represents an lhs that can be reallocated
9474 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9482 sym
= expr
->symtree
->n
.sym
;
9484 /* An allocatable class variable with no reference. */
9485 if (sym
->ts
.type
== BT_CLASS
9486 && CLASS_DATA (sym
)->attr
.allocatable
9487 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
9488 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9489 && expr
->ref
->next
== NULL
)
9492 /* An allocatable variable. */
9493 if (sym
->attr
.allocatable
9495 && expr
->ref
->type
== REF_ARRAY
9496 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9499 /* All that can be left are allocatable components. */
9500 if ((sym
->ts
.type
!= BT_DERIVED
9501 && sym
->ts
.type
!= BT_CLASS
)
9502 || !sym
->ts
.u
.derived
->attr
.alloc_comp
)
9505 /* Find a component ref followed by an array reference. */
9506 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9508 && ref
->type
== REF_COMPONENT
9509 && ref
->next
->type
== REF_ARRAY
9510 && !ref
->next
->next
)
9516 /* Return true if valid reallocatable lhs. */
9517 if (ref
->u
.c
.component
->attr
.allocatable
9518 && ref
->next
->u
.ar
.type
== AR_FULL
)
9526 concat_str_length (gfc_expr
* expr
)
9533 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9534 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9535 if (len1
== NULL_TREE
)
9537 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9538 len1
= concat_str_length (expr
->value
.op
.op1
);
9539 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9540 len1
= build_int_cst (gfc_charlen_type_node
,
9541 expr
->value
.op
.op1
->value
.character
.length
);
9542 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9544 gfc_init_se (&se
, NULL
);
9545 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9551 gfc_init_se (&se
, NULL
);
9552 se
.want_pointer
= 1;
9553 se
.descriptor_only
= 1;
9554 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9555 len1
= se
.string_length
;
9559 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9560 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9561 if (len2
== NULL_TREE
)
9563 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9564 len2
= concat_str_length (expr
->value
.op
.op2
);
9565 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9566 len2
= build_int_cst (gfc_charlen_type_node
,
9567 expr
->value
.op
.op2
->value
.character
.length
);
9568 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9570 gfc_init_se (&se
, NULL
);
9571 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9577 gfc_init_se (&se
, NULL
);
9578 se
.want_pointer
= 1;
9579 se
.descriptor_only
= 1;
9580 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9581 len2
= se
.string_length
;
9585 gcc_assert(len1
&& len2
);
9586 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9587 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9589 return fold_build2_loc (input_location
, PLUS_EXPR
,
9590 gfc_charlen_type_node
, len1
, len2
);
9594 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9598 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9602 stmtblock_t realloc_block
;
9603 stmtblock_t alloc_block
;
9607 gfc_array_info
*linfo
;
9629 gfc_array_spec
* as
;
9630 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9631 && gfc_caf_attr (expr1
, true).codimension
);
9635 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9636 Find the lhs expression in the loop chain and set expr1 and
9637 expr2 accordingly. */
9638 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9641 /* Find the ss for the lhs. */
9643 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9644 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9646 if (lss
== gfc_ss_terminator
)
9648 expr1
= lss
->info
->expr
;
9651 /* Bail out if this is not a valid allocate on assignment. */
9652 if (!gfc_is_reallocatable_lhs (expr1
)
9653 || (expr2
&& !expr2
->rank
))
9656 /* Find the ss for the lhs. */
9658 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9659 if (lss
->info
->expr
== expr1
)
9662 if (lss
== gfc_ss_terminator
)
9665 linfo
= &lss
->info
->data
.array
;
9667 /* Find an ss for the rhs. For operator expressions, we see the
9668 ss's for the operands. Any one of these will do. */
9670 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9671 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9674 if (expr2
&& rss
== gfc_ss_terminator
)
9677 gfc_start_block (&fblock
);
9679 /* Since the lhs is allocatable, this must be a descriptor type.
9680 Get the data and array size. */
9681 desc
= linfo
->descriptor
;
9682 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9683 array1
= gfc_conv_descriptor_data_get (desc
);
9685 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9686 deallocated if expr is an array of different shape or any of the
9687 corresponding length type parameter values of variable and expr
9688 differ." This assures F95 compatibility. */
9689 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9690 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9692 /* Allocate if data is NULL. */
9693 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9694 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9696 if (expr1
->ts
.deferred
)
9697 cond_null
= gfc_evaluate_now (logical_true_node
, &fblock
);
9699 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9701 tmp
= build3_v (COND_EXPR
, cond_null
,
9702 build1_v (GOTO_EXPR
, jump_label1
),
9703 build_empty_stmt (input_location
));
9704 gfc_add_expr_to_block (&fblock
, tmp
);
9706 /* Get arrayspec if expr is a full array. */
9707 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9708 && expr2
->value
.function
.isym
9709 && expr2
->value
.function
.isym
->conversion
)
9711 /* For conversion functions, take the arg. */
9712 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9713 as
= gfc_get_full_arrayspec_from_expr (arg
);
9716 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9720 /* If the lhs shape is not the same as the rhs jump to setting the
9721 bounds and doing the reallocation....... */
9722 for (n
= 0; n
< expr1
->rank
; n
++)
9724 /* Check the shape. */
9725 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9726 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9727 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9728 gfc_array_index_type
,
9729 loop
->to
[n
], loop
->from
[n
]);
9730 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9731 gfc_array_index_type
,
9733 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9734 gfc_array_index_type
,
9736 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9738 tmp
, gfc_index_zero_node
);
9739 tmp
= build3_v (COND_EXPR
, cond
,
9740 build1_v (GOTO_EXPR
, jump_label1
),
9741 build_empty_stmt (input_location
));
9742 gfc_add_expr_to_block (&fblock
, tmp
);
9745 /* ....else jump past the (re)alloc code. */
9746 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9747 gfc_add_expr_to_block (&fblock
, tmp
);
9749 /* Add the label to start automatic (re)allocation. */
9750 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9751 gfc_add_expr_to_block (&fblock
, tmp
);
9753 /* If the lhs has not been allocated, its bounds will not have been
9754 initialized and so its size is set to zero. */
9755 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9756 gfc_init_block (&alloc_block
);
9757 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9758 gfc_init_block (&realloc_block
);
9759 gfc_add_modify (&realloc_block
, size1
,
9760 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9761 tmp
= build3_v (COND_EXPR
, cond_null
,
9762 gfc_finish_block (&alloc_block
),
9763 gfc_finish_block (&realloc_block
));
9764 gfc_add_expr_to_block (&fblock
, tmp
);
9766 /* Get the rhs size and fix it. */
9768 desc2
= rss
->info
->data
.array
.descriptor
;
9772 size2
= gfc_index_one_node
;
9773 for (n
= 0; n
< expr2
->rank
; n
++)
9775 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9776 gfc_array_index_type
,
9777 loop
->to
[n
], loop
->from
[n
]);
9778 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9779 gfc_array_index_type
,
9780 tmp
, gfc_index_one_node
);
9781 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9782 gfc_array_index_type
,
9785 size2
= gfc_evaluate_now (size2
, &fblock
);
9787 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9790 /* If the lhs is deferred length, assume that the element size
9791 changes and force a reallocation. */
9792 if (expr1
->ts
.deferred
)
9793 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
9795 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9797 /* Deallocation of allocatable components will have to occur on
9798 reallocation. Fix the old descriptor now. */
9799 if ((expr1
->ts
.type
== BT_DERIVED
)
9800 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9801 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9803 old_desc
= NULL_TREE
;
9805 /* Now modify the lhs descriptor and the associated scalarizer
9806 variables. F2003 7.4.1.3: "If variable is or becomes an
9807 unallocated allocatable variable, then it is allocated with each
9808 deferred type parameter equal to the corresponding type parameters
9809 of expr , with the shape of expr , and with each lower bound equal
9810 to the corresponding element of LBOUND(expr)."
9811 Reuse size1 to keep a dimension-by-dimension track of the
9812 stride of the new array. */
9813 size1
= gfc_index_one_node
;
9814 offset
= gfc_index_zero_node
;
9816 for (n
= 0; n
< expr2
->rank
; n
++)
9818 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9819 gfc_array_index_type
,
9820 loop
->to
[n
], loop
->from
[n
]);
9821 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9822 gfc_array_index_type
,
9823 tmp
, gfc_index_one_node
);
9825 lbound
= gfc_index_one_node
;
9830 lbd
= get_std_lbound (expr2
, desc2
, n
,
9831 as
->type
== AS_ASSUMED_SIZE
);
9832 ubound
= fold_build2_loc (input_location
,
9834 gfc_array_index_type
,
9836 ubound
= fold_build2_loc (input_location
,
9838 gfc_array_index_type
,
9843 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9846 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9849 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9852 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9854 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9855 gfc_array_index_type
,
9857 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9858 gfc_array_index_type
,
9860 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9861 gfc_array_index_type
,
9865 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9866 the array offset is saved and the info.offset is used for a
9867 running offset. Use the saved_offset instead. */
9868 tmp
= gfc_conv_descriptor_offset (desc
);
9869 gfc_add_modify (&fblock
, tmp
, offset
);
9870 if (linfo
->saved_offset
9871 && VAR_P (linfo
->saved_offset
))
9872 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9874 /* Now set the deltas for the lhs. */
9875 for (n
= 0; n
< expr1
->rank
; n
++)
9877 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9879 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9880 gfc_array_index_type
, tmp
,
9882 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9883 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9886 /* Get the new lhs size in bytes. */
9887 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9889 if (expr2
->ts
.deferred
)
9891 if (VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9892 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9894 tmp
= rss
->info
->string_length
;
9898 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9899 if (!tmp
&& expr2
->expr_type
== EXPR_OP
9900 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
9902 tmp
= concat_str_length (expr2
);
9903 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
9905 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
9908 if (expr1
->ts
.u
.cl
->backend_decl
9909 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
9910 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
9912 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
9914 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
9916 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
9917 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9918 gfc_array_index_type
, tmp
,
9919 expr1
->ts
.u
.cl
->backend_decl
);
9922 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9923 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9924 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9925 gfc_array_index_type
,
9927 size2
= fold_convert (size_type_node
, size2
);
9928 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9929 size2
, size_one_node
);
9930 size2
= gfc_evaluate_now (size2
, &fblock
);
9932 /* For deferred character length, the 'size' field of the dtype might
9933 have changed so set the dtype. */
9934 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9935 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9938 tmp
= gfc_conv_descriptor_dtype (desc
);
9939 if (expr2
->ts
.u
.cl
->backend_decl
)
9940 type
= gfc_typenode_for_spec (&expr2
->ts
);
9942 type
= gfc_typenode_for_spec (&expr1
->ts
);
9944 gfc_add_modify (&fblock
, tmp
,
9945 gfc_get_dtype_rank_type (expr1
->rank
,type
));
9947 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9949 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
9950 gfc_get_dtype (TREE_TYPE (desc
)));
9953 /* Realloc expression. Note that the scalarizer uses desc.data
9954 in the array reference - (*desc.data)[<element>]. */
9955 gfc_init_block (&realloc_block
);
9956 gfc_init_se (&caf_se
, NULL
);
9960 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
9961 if (token
== NULL_TREE
)
9963 tmp
= gfc_get_tree_for_caf_expr (expr1
);
9964 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9965 tmp
= build_fold_indirect_ref (tmp
);
9966 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
9968 token
= gfc_build_addr_expr (NULL_TREE
, token
);
9971 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
9973 if ((expr1
->ts
.type
== BT_DERIVED
)
9974 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9976 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
9978 gfc_add_expr_to_block (&realloc_block
, tmp
);
9983 tmp
= build_call_expr_loc (input_location
,
9984 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
9985 fold_convert (pvoid_type_node
, array1
),
9987 gfc_conv_descriptor_data_set (&realloc_block
,
9992 tmp
= build_call_expr_loc (input_location
,
9993 gfor_fndecl_caf_deregister
, 5, token
,
9994 build_int_cst (integer_type_node
,
9995 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
9996 null_pointer_node
, null_pointer_node
,
9998 gfc_add_expr_to_block (&realloc_block
, tmp
);
9999 tmp
= build_call_expr_loc (input_location
,
10000 gfor_fndecl_caf_register
,
10002 build_int_cst (integer_type_node
,
10003 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
10004 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10005 null_pointer_node
, null_pointer_node
,
10006 integer_zero_node
);
10007 gfc_add_expr_to_block (&realloc_block
, tmp
);
10010 if ((expr1
->ts
.type
== BT_DERIVED
)
10011 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10013 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10015 gfc_add_expr_to_block (&realloc_block
, tmp
);
10018 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
10019 realloc_expr
= gfc_finish_block (&realloc_block
);
10021 /* Only reallocate if sizes are different. */
10022 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
10023 build_empty_stmt (input_location
));
10024 realloc_expr
= tmp
;
10027 /* Malloc expression. */
10028 gfc_init_block (&alloc_block
);
10031 tmp
= build_call_expr_loc (input_location
,
10032 builtin_decl_explicit (BUILT_IN_MALLOC
),
10034 gfc_conv_descriptor_data_set (&alloc_block
,
10039 tmp
= build_call_expr_loc (input_location
,
10040 gfor_fndecl_caf_register
,
10042 build_int_cst (integer_type_node
,
10043 GFC_CAF_COARRAY_ALLOC
),
10044 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
10045 null_pointer_node
, null_pointer_node
,
10046 integer_zero_node
);
10047 gfc_add_expr_to_block (&alloc_block
, tmp
);
10051 /* We already set the dtype in the case of deferred character
10053 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10054 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10057 tmp
= gfc_conv_descriptor_dtype (desc
);
10058 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10061 if ((expr1
->ts
.type
== BT_DERIVED
)
10062 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10064 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10066 gfc_add_expr_to_block (&alloc_block
, tmp
);
10068 alloc_expr
= gfc_finish_block (&alloc_block
);
10070 /* Malloc if not allocated; realloc otherwise. */
10071 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10072 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10075 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10076 gfc_add_expr_to_block (&fblock
, tmp
);
10078 /* Make sure that the scalarizer data pointer is updated. */
10079 if (linfo
->data
&& VAR_P (linfo
->data
))
10081 tmp
= gfc_conv_descriptor_data_get (desc
);
10082 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10085 /* Add the exit label. */
10086 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10087 gfc_add_expr_to_block (&fblock
, tmp
);
10089 return gfc_finish_block (&fblock
);
10093 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10094 Do likewise, recursively if necessary, with the allocatable components of
10098 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10104 stmtblock_t cleanup
;
10107 bool sym_has_alloc_comp
, has_finalizer
;
10109 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10110 || sym
->ts
.type
== BT_CLASS
)
10111 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10112 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10113 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10115 /* Make sure the frontend gets these right. */
10116 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10119 gfc_save_backend_locus (&loc
);
10120 gfc_set_backend_locus (&sym
->declared_at
);
10121 gfc_init_block (&init
);
10123 gcc_assert (VAR_P (sym
->backend_decl
)
10124 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10126 if (sym
->ts
.type
== BT_CHARACTER
10127 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10129 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10130 gfc_trans_vla_type_sizes (sym
, &init
);
10133 /* Dummy, use associated and result variables don't need anything special. */
10134 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10136 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10137 gfc_restore_backend_locus (&loc
);
10141 descriptor
= sym
->backend_decl
;
10143 /* Although static, derived types with default initializers and
10144 allocatable components must not be nulled wholesale; instead they
10145 are treated component by component. */
10146 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10148 /* SAVEd variables are not freed on exit. */
10149 gfc_trans_static_array_pointer (sym
);
10151 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10152 gfc_restore_backend_locus (&loc
);
10156 /* Get the descriptor type. */
10157 type
= TREE_TYPE (sym
->backend_decl
);
10159 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10160 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10162 if (!sym
->attr
.save
10163 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10165 if (sym
->value
== NULL
10166 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10168 rank
= sym
->as
? sym
->as
->rank
: 0;
10169 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10171 gfc_add_expr_to_block (&init
, tmp
);
10174 gfc_init_default_dt (sym
, &init
, false);
10177 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10179 /* If the backend_decl is not a descriptor, we must have a pointer
10181 descriptor
= build_fold_indirect_ref_loc (input_location
,
10182 sym
->backend_decl
);
10183 type
= TREE_TYPE (descriptor
);
10186 /* NULLIFY the data pointer, for non-saved allocatables. */
10187 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10189 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10190 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10192 /* Declare the variable static so its array descriptor stays present
10193 after leaving the scope. It may still be accessed through another
10194 image. This may happen, for example, with the caf_mpi
10196 TREE_STATIC (descriptor
) = 1;
10197 tmp
= gfc_conv_descriptor_token (descriptor
);
10198 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10199 null_pointer_node
));
10203 gfc_restore_backend_locus (&loc
);
10204 gfc_init_block (&cleanup
);
10206 /* Allocatable arrays need to be freed when they go out of scope.
10207 The allocatable components of pointers must not be touched. */
10208 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10209 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10210 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10213 sym
->attr
.referenced
= 1;
10214 e
= gfc_lval_expr_from_sym (sym
);
10215 gfc_add_finalizer_call (&cleanup
, e
);
10218 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10219 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10220 && !sym
->attr
.pointer
&& !sym
->attr
.save
10221 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10224 rank
= sym
->as
? sym
->as
->rank
: 0;
10225 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10226 gfc_add_expr_to_block (&cleanup
, tmp
);
10229 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10230 && !sym
->attr
.save
&& !sym
->attr
.result
10231 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10234 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10235 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10236 NULL_TREE
, NULL_TREE
, true, e
,
10237 sym
->attr
.codimension
10238 ? GFC_CAF_COARRAY_DEREGISTER
10239 : GFC_CAF_COARRAY_NOCOARRAY
);
10242 gfc_add_expr_to_block (&cleanup
, tmp
);
10245 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10246 gfc_finish_block (&cleanup
));
10249 /************ Expression Walking Functions ******************/
10251 /* Walk a variable reference.
10253 Possible extension - multiple component subscripts.
10254 x(:,:) = foo%a(:)%b(:)
10256 forall (i=..., j=...)
10257 x(i,j) = foo%a(j)%b(i)
10259 This adds a fair amount of complexity because you need to deal with more
10260 than one ref. Maybe handle in a similar manner to vector subscripts.
10261 Maybe not worth the effort. */
10265 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10269 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10270 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10273 return gfc_walk_array_ref (ss
, expr
, ref
);
10278 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10284 for (; ref
; ref
= ref
->next
)
10286 if (ref
->type
== REF_SUBSTRING
)
10288 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10289 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10292 /* We're only interested in array sections from now on. */
10293 if (ref
->type
!= REF_ARRAY
)
10301 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10302 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10306 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10307 newss
->info
->data
.array
.ref
= ref
;
10309 /* Make sure array is the same as array(:,:), this way
10310 we don't need to special case all the time. */
10311 ar
->dimen
= ar
->as
->rank
;
10312 for (n
= 0; n
< ar
->dimen
; n
++)
10314 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10316 gcc_assert (ar
->start
[n
] == NULL
);
10317 gcc_assert (ar
->end
[n
] == NULL
);
10318 gcc_assert (ar
->stride
[n
] == NULL
);
10324 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10325 newss
->info
->data
.array
.ref
= ref
;
10327 /* We add SS chains for all the subscripts in the section. */
10328 for (n
= 0; n
< ar
->dimen
; n
++)
10332 switch (ar
->dimen_type
[n
])
10334 case DIMEN_ELEMENT
:
10335 /* Add SS for elemental (scalar) subscripts. */
10336 gcc_assert (ar
->start
[n
]);
10337 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10338 indexss
->loop_chain
= gfc_ss_terminator
;
10339 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10343 /* We don't add anything for sections, just remember this
10344 dimension for later. */
10345 newss
->dim
[newss
->dimen
] = n
;
10350 /* Create a GFC_SS_VECTOR index in which we can store
10351 the vector's descriptor. */
10352 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10354 indexss
->loop_chain
= gfc_ss_terminator
;
10355 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10356 newss
->dim
[newss
->dimen
] = n
;
10361 /* We should know what sort of section it is by now. */
10362 gcc_unreachable ();
10365 /* We should have at least one non-elemental dimension,
10366 unless we are creating a descriptor for a (scalar) coarray. */
10367 gcc_assert (newss
->dimen
> 0
10368 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10373 /* We should know what sort of section it is by now. */
10374 gcc_unreachable ();
10382 /* Walk an expression operator. If only one operand of a binary expression is
10383 scalar, we must also add the scalar term to the SS chain. */
10386 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10391 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10392 if (expr
->value
.op
.op2
== NULL
)
10395 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10397 /* All operands are scalar. Pass back and let the caller deal with it. */
10401 /* All operands require scalarization. */
10402 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10405 /* One of the operands needs scalarization, the other is scalar.
10406 Create a gfc_ss for the scalar expression. */
10409 /* First operand is scalar. We build the chain in reverse order, so
10410 add the scalar SS after the second operand. */
10412 while (head
&& head
->next
!= ss
)
10414 /* Check we haven't somehow broken the chain. */
10416 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10418 else /* head2 == head */
10420 gcc_assert (head2
== head
);
10421 /* Second operand is scalar. */
10422 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10429 /* Reverse a SS chain. */
10432 gfc_reverse_ss (gfc_ss
* ss
)
10437 gcc_assert (ss
!= NULL
);
10439 head
= gfc_ss_terminator
;
10440 while (ss
!= gfc_ss_terminator
)
10443 /* Check we didn't somehow break the chain. */
10444 gcc_assert (next
!= NULL
);
10454 /* Given an expression referring to a procedure, return the symbol of its
10455 interface. We can't get the procedure symbol directly as we have to handle
10456 the case of (deferred) type-bound procedures. */
10459 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10464 if (procedure_ref
== NULL
)
10467 /* Normal procedure case. */
10468 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10469 && procedure_ref
->value
.function
.esym
)
10470 sym
= procedure_ref
->value
.function
.esym
;
10472 sym
= procedure_ref
->symtree
->n
.sym
;
10474 /* Typebound procedure case. */
10475 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10477 if (ref
->type
== REF_COMPONENT
10478 && ref
->u
.c
.component
->attr
.proc_pointer
)
10479 sym
= ref
->u
.c
.component
->ts
.interface
;
10488 /* Walk the arguments of an elemental function.
10489 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10490 it is NULL, we don't do the check and the argument is assumed to be present.
10494 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10495 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10497 gfc_formal_arglist
*dummy_arg
;
10503 head
= gfc_ss_terminator
;
10507 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10512 for (; arg
; arg
= arg
->next
)
10514 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10515 goto loop_continue
;
10517 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10520 /* Scalar argument. */
10521 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10522 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10523 newss
->info
->type
= type
;
10525 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10530 if (dummy_arg
!= NULL
10531 && dummy_arg
->sym
->attr
.optional
10532 && arg
->expr
->expr_type
== EXPR_VARIABLE
10533 && (gfc_expr_attr (arg
->expr
).optional
10534 || gfc_expr_attr (arg
->expr
).allocatable
10535 || gfc_expr_attr (arg
->expr
).pointer
))
10536 newss
->info
->can_be_null_ref
= true;
10542 while (tail
->next
!= gfc_ss_terminator
)
10547 if (dummy_arg
!= NULL
)
10548 dummy_arg
= dummy_arg
->next
;
10553 /* If all the arguments are scalar we don't need the argument SS. */
10554 gfc_free_ss_chain (head
);
10555 /* Pass it back. */
10559 /* Add it onto the existing chain. */
10565 /* Walk a function call. Scalar functions are passed back, and taken out of
10566 scalarization loops. For elemental functions we walk their arguments.
10567 The result of functions returning arrays is stored in a temporary outside
10568 the loop, so that the function is only called once. Hence we do not need
10569 to walk their arguments. */
10572 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10574 gfc_intrinsic_sym
*isym
;
10576 gfc_component
*comp
= NULL
;
10578 isym
= expr
->value
.function
.isym
;
10580 /* Handle intrinsic functions separately. */
10582 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10584 sym
= expr
->value
.function
.esym
;
10586 sym
= expr
->symtree
->n
.sym
;
10588 if (gfc_is_class_array_function (expr
))
10589 return gfc_get_array_ss (ss
, expr
,
10590 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10593 /* A function that returns arrays. */
10594 comp
= gfc_get_proc_ptr_comp (expr
);
10595 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10596 || (comp
&& comp
->attr
.dimension
))
10597 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10599 /* Walk the parameters of an elemental function. For now we always pass
10601 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10603 gfc_ss
*old_ss
= ss
;
10605 ss
= gfc_walk_elemental_function_args (old_ss
,
10606 expr
->value
.function
.actual
,
10607 gfc_get_proc_ifc_for_expr (expr
),
10611 || sym
->attr
.proc_pointer
10612 || sym
->attr
.if_source
!= IFSRC_DECL
10613 || sym
->attr
.array_outer_dependency
))
10614 ss
->info
->array_outer_dependency
= 1;
10617 /* Scalar functions are OK as these are evaluated outside the scalarization
10618 loop. Pass back and let the caller deal with it. */
10623 /* An array temporary is constructed for array constructors. */
10626 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10628 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10632 /* Walk an expression. Add walked expressions to the head of the SS chain.
10633 A wholly scalar expression will not be added. */
10636 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10640 switch (expr
->expr_type
)
10642 case EXPR_VARIABLE
:
10643 head
= gfc_walk_variable_expr (ss
, expr
);
10647 head
= gfc_walk_op_expr (ss
, expr
);
10650 case EXPR_FUNCTION
:
10651 head
= gfc_walk_function_expr (ss
, expr
);
10654 case EXPR_CONSTANT
:
10656 case EXPR_STRUCTURE
:
10657 /* Pass back and let the caller deal with it. */
10661 head
= gfc_walk_array_constructor (ss
, expr
);
10664 case EXPR_SUBSTRING
:
10665 /* Pass back and let the caller deal with it. */
10669 gfc_internal_error ("bad expression type during walk (%d)",
10676 /* Entry point for expression walking.
10677 A return value equal to the passed chain means this is
10678 a scalar expression. It is up to the caller to take whatever action is
10679 necessary to translate these. */
10682 gfc_walk_expr (gfc_expr
* expr
)
10686 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10687 return gfc_reverse_ss (res
);