1 /* Array translation routines
2 Copyright (C) 2002-2017 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
&& TREE_TYPE (field
) == gfc_array_index_type
);
244 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
245 desc
, field
, NULL_TREE
);
249 gfc_conv_descriptor_span (tree desc
)
254 type
= TREE_TYPE (desc
);
255 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
257 field
= gfc_advance_chain (TYPE_FIELDS (type
), SPAN_FIELD
);
258 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
260 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
261 desc
, field
, NULL_TREE
);
265 gfc_conv_descriptor_span_get (tree desc
)
267 return gfc_conv_descriptor_span (desc
);
271 gfc_conv_descriptor_span_set (stmtblock_t
*block
, tree desc
,
274 tree t
= gfc_conv_descriptor_span (desc
);
275 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
280 gfc_conv_descriptor_rank (tree desc
)
285 dtype
= gfc_conv_descriptor_dtype (desc
);
286 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
287 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
289 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
294 gfc_get_descriptor_dimension (tree desc
)
298 type
= TREE_TYPE (desc
);
299 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
301 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
302 gcc_assert (field
!= NULL_TREE
303 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
304 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
306 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
307 desc
, field
, NULL_TREE
);
312 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
316 tmp
= gfc_get_descriptor_dimension (desc
);
318 return gfc_build_array_ref (tmp
, dim
, NULL
);
323 gfc_conv_descriptor_token (tree desc
)
328 type
= TREE_TYPE (desc
);
329 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
330 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
331 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
333 /* Should be a restricted pointer - except in the finalization wrapper. */
334 gcc_assert (field
!= NULL_TREE
335 && (TREE_TYPE (field
) == prvoid_type_node
336 || TREE_TYPE (field
) == pvoid_type_node
));
338 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
339 desc
, field
, NULL_TREE
);
344 gfc_conv_descriptor_stride (tree desc
, tree dim
)
349 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
350 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
351 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
352 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
354 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
355 tmp
, field
, NULL_TREE
);
360 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
362 tree type
= TREE_TYPE (desc
);
363 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
364 if (integer_zerop (dim
)
365 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
366 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
367 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
368 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
369 return gfc_index_one_node
;
371 return gfc_conv_descriptor_stride (desc
, dim
);
375 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
376 tree dim
, tree value
)
378 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
379 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
383 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
388 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
389 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
390 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
391 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
393 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
394 tmp
, field
, NULL_TREE
);
399 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
401 return gfc_conv_descriptor_lbound (desc
, dim
);
405 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
406 tree dim
, tree value
)
408 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
409 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
413 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
418 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
419 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
420 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
421 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
423 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
424 tmp
, field
, NULL_TREE
);
429 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
431 return gfc_conv_descriptor_ubound (desc
, dim
);
435 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
436 tree dim
, tree value
)
438 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
439 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
442 /* Build a null array descriptor constructor. */
445 gfc_build_null_descriptor (tree type
)
450 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
451 gcc_assert (DATA_FIELD
== 0);
452 field
= TYPE_FIELDS (type
);
454 /* Set a NULL data pointer. */
455 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
456 TREE_CONSTANT (tmp
) = 1;
457 /* All other fields are ignored. */
463 /* Modify a descriptor such that the lbound of a given dimension is the value
464 specified. This also updates ubound and offset accordingly. */
467 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
468 int dim
, tree new_lbound
)
470 tree offs
, ubound
, lbound
, stride
;
471 tree diff
, offs_diff
;
473 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
475 offs
= gfc_conv_descriptor_offset_get (desc
);
476 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
477 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
478 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
480 /* Get difference (new - old) by which to shift stuff. */
481 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
484 /* Shift ubound and offset accordingly. This has to be done before
485 updating the lbound, as they depend on the lbound expression! */
486 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
488 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
489 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
491 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
493 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
495 /* Finally set lbound to value we want. */
496 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
500 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
503 gfc_get_descriptor_offsets_for_info (const_tree desc_type
, tree
*data_off
,
504 tree
*dtype_off
, tree
*dim_off
,
505 tree
*dim_size
, tree
*stride_suboff
,
506 tree
*lower_suboff
, tree
*upper_suboff
)
511 type
= TYPE_MAIN_VARIANT (desc_type
);
512 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
513 *data_off
= byte_position (field
);
514 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
515 *dtype_off
= byte_position (field
);
516 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
517 *dim_off
= byte_position (field
);
518 type
= TREE_TYPE (TREE_TYPE (field
));
519 *dim_size
= TYPE_SIZE_UNIT (type
);
520 field
= gfc_advance_chain (TYPE_FIELDS (type
), STRIDE_SUBFIELD
);
521 *stride_suboff
= byte_position (field
);
522 field
= gfc_advance_chain (TYPE_FIELDS (type
), LBOUND_SUBFIELD
);
523 *lower_suboff
= byte_position (field
);
524 field
= gfc_advance_chain (TYPE_FIELDS (type
), UBOUND_SUBFIELD
);
525 *upper_suboff
= byte_position (field
);
529 /* Cleanup those #defines. */
535 #undef DIMENSION_FIELD
536 #undef CAF_TOKEN_FIELD
537 #undef STRIDE_SUBFIELD
538 #undef LBOUND_SUBFIELD
539 #undef UBOUND_SUBFIELD
542 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
543 flags & 1 = Main loop body.
544 flags & 2 = temp copy loop. */
547 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
549 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
550 ss
->info
->useflags
= flags
;
554 /* Free a gfc_ss chain. */
557 gfc_free_ss_chain (gfc_ss
* ss
)
561 while (ss
!= gfc_ss_terminator
)
563 gcc_assert (ss
!= NULL
);
572 free_ss_info (gfc_ss_info
*ss_info
)
577 if (ss_info
->refcount
> 0)
580 gcc_assert (ss_info
->refcount
== 0);
582 switch (ss_info
->type
)
585 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
586 if (ss_info
->data
.array
.subscript
[n
])
587 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[n
]);
601 gfc_free_ss (gfc_ss
* ss
)
603 free_ss_info (ss
->info
);
608 /* Creates and initializes an array type gfc_ss struct. */
611 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
614 gfc_ss_info
*ss_info
;
617 ss_info
= gfc_get_ss_info ();
619 ss_info
->type
= type
;
620 ss_info
->expr
= expr
;
626 for (i
= 0; i
< ss
->dimen
; i
++)
633 /* Creates and initializes a temporary type gfc_ss struct. */
636 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
639 gfc_ss_info
*ss_info
;
642 ss_info
= gfc_get_ss_info ();
644 ss_info
->type
= GFC_SS_TEMP
;
645 ss_info
->string_length
= string_length
;
646 ss_info
->data
.temp
.type
= type
;
650 ss
->next
= gfc_ss_terminator
;
652 for (i
= 0; i
< ss
->dimen
; i
++)
659 /* Creates and initializes a scalar type gfc_ss struct. */
662 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
665 gfc_ss_info
*ss_info
;
667 ss_info
= gfc_get_ss_info ();
669 ss_info
->type
= GFC_SS_SCALAR
;
670 ss_info
->expr
= expr
;
680 /* Free all the SS associated with a loop. */
683 gfc_cleanup_loop (gfc_loopinfo
* loop
)
685 gfc_loopinfo
*loop_next
, **ploop
;
690 while (ss
!= gfc_ss_terminator
)
692 gcc_assert (ss
!= NULL
);
693 next
= ss
->loop_chain
;
698 /* Remove reference to self in the parent loop. */
700 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
707 /* Free non-freed nested loops. */
708 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
710 loop_next
= loop
->next
;
711 gfc_cleanup_loop (loop
);
718 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
722 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
726 if (ss
->info
->type
== GFC_SS_SCALAR
727 || ss
->info
->type
== GFC_SS_REFERENCE
728 || ss
->info
->type
== GFC_SS_TEMP
)
731 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
732 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
733 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
738 /* Associate a SS chain with a loop. */
741 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
744 gfc_loopinfo
*nested_loop
;
746 if (head
== gfc_ss_terminator
)
749 set_ss_loop (head
, loop
);
752 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
756 nested_loop
= ss
->nested_ss
->loop
;
758 /* More than one ss can belong to the same loop. Hence, we add the
759 loop to the chain only if it is different from the previously
760 added one, to avoid duplicate nested loops. */
761 if (nested_loop
!= loop
->nested
)
763 gcc_assert (nested_loop
->parent
== NULL
);
764 nested_loop
->parent
= loop
;
766 gcc_assert (nested_loop
->next
== NULL
);
767 nested_loop
->next
= loop
->nested
;
768 loop
->nested
= nested_loop
;
771 gcc_assert (nested_loop
->parent
== loop
);
774 if (ss
->next
== gfc_ss_terminator
)
775 ss
->loop_chain
= loop
->ss
;
777 ss
->loop_chain
= ss
->next
;
779 gcc_assert (ss
== gfc_ss_terminator
);
784 /* Returns true if the expression is an array pointer. */
787 is_pointer_array (tree expr
)
792 if (expr
== NULL_TREE
793 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr
))
794 || GFC_CLASS_TYPE_P (TREE_TYPE (expr
)))
797 if (TREE_CODE (expr
) == VAR_DECL
798 && GFC_DECL_PTR_ARRAY_P (expr
))
801 if (TREE_CODE (expr
) == PARM_DECL
802 && GFC_DECL_PTR_ARRAY_P (expr
))
805 if (TREE_CODE (expr
) == INDIRECT_REF
806 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 0)))
809 /* The field declaration is marked as an pointer array. */
810 if (TREE_CODE (expr
) == COMPONENT_REF
811 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr
, 1))
812 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr
, 1))))
819 /* Return the span of an array. */
822 get_array_span (tree desc
, gfc_expr
*expr
)
826 if (is_pointer_array (desc
))
827 /* This will have the span field set. */
828 tmp
= gfc_conv_descriptor_span_get (desc
);
829 else if (TREE_CODE (desc
) == COMPONENT_REF
830 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
831 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
833 /* The descriptor is a class _data field and so use the vtable
834 size for the receiving span field. */
835 tmp
= gfc_get_vptr_from_expr (desc
);
836 tmp
= gfc_vptr_size_get (tmp
);
838 else if (expr
&& expr
->expr_type
== EXPR_VARIABLE
839 && expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
840 && expr
->ref
->type
== REF_COMPONENT
841 && expr
->ref
->next
->type
== REF_ARRAY
842 && expr
->ref
->next
->next
== NULL
843 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.dimension
)
845 /* Dummys come in sometimes with the descriptor detached from
846 the class field or declaration. */
847 tmp
= gfc_class_vptr_get (expr
->symtree
->n
.sym
->backend_decl
);
848 tmp
= gfc_vptr_size_get (tmp
);
852 /* If none of the fancy stuff works, the span is the element
853 size of the array. */
854 tmp
= gfc_get_element_type (TREE_TYPE (desc
));
855 tmp
= fold_convert (gfc_array_index_type
,
856 size_in_bytes (tmp
));
862 /* Generate an initializer for a static pointer or allocatable array. */
865 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
869 gcc_assert (TREE_STATIC (sym
->backend_decl
));
870 /* Just zero the data member. */
871 type
= TREE_TYPE (sym
->backend_decl
);
872 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
876 /* If the bounds of SE's loop have not yet been set, see if they can be
877 determined from array spec AS, which is the array spec of a called
878 function. MAPPING maps the callee's dummy arguments to the values
879 that the caller is passing. Add any initialization and finalization
883 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
884 gfc_se
* se
, gfc_array_spec
* as
)
886 int n
, dim
, total_dim
;
895 if (!as
|| as
->type
!= AS_EXPLICIT
)
898 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
900 total_dim
+= ss
->loop
->dimen
;
901 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
903 /* The bound is known, nothing to do. */
904 if (ss
->loop
->to
[n
] != NULL_TREE
)
908 gcc_assert (dim
< as
->rank
);
909 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
911 /* Evaluate the lower bound. */
912 gfc_init_se (&tmpse
, NULL
);
913 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
914 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
915 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
916 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
918 /* ...and the upper bound. */
919 gfc_init_se (&tmpse
, NULL
);
920 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
921 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
922 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
923 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
925 /* Set the upper bound of the loop to UPPER - LOWER. */
926 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
927 gfc_array_index_type
, upper
, lower
);
928 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
929 ss
->loop
->to
[n
] = tmp
;
933 gcc_assert (total_dim
== as
->rank
);
937 /* Generate code to allocate an array temporary, or create a variable to
938 hold the data. If size is NULL, zero the descriptor so that the
939 callee will allocate the array. If DEALLOC is true, also generate code to
940 free the array afterwards.
942 If INITIAL is not NULL, it is packed using internal_pack and the result used
943 as data instead of allocating a fresh, unitialized area of memory.
945 Initialization code is added to PRE and finalization code to POST.
946 DYNAMIC is true if the caller may want to extend the array later
947 using realloc. This prevents us from putting the array on the stack. */
950 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
951 gfc_array_info
* info
, tree size
, tree nelem
,
952 tree initial
, bool dynamic
, bool dealloc
)
958 desc
= info
->descriptor
;
959 info
->offset
= gfc_index_zero_node
;
960 if (size
== NULL_TREE
|| integer_zerop (size
))
962 /* A callee allocated array. */
963 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
968 /* Allocate the temporary. */
969 onstack
= !dynamic
&& initial
== NULL_TREE
970 && (flag_stack_arrays
971 || gfc_can_put_var_on_stack (size
));
975 /* Make a temporary variable to hold the data. */
976 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
977 nelem
, gfc_index_one_node
);
978 tmp
= gfc_evaluate_now (tmp
, pre
);
979 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
981 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
983 tmp
= gfc_create_var (tmp
, "A");
984 /* If we're here only because of -fstack-arrays we have to
985 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
986 if (!gfc_can_put_var_on_stack (size
))
987 gfc_add_expr_to_block (pre
,
988 fold_build1_loc (input_location
,
989 DECL_EXPR
, TREE_TYPE (tmp
),
991 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
992 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
996 /* Allocate memory to hold the data or call internal_pack. */
997 if (initial
== NULL_TREE
)
999 tmp
= gfc_call_malloc (pre
, NULL
, size
);
1000 tmp
= gfc_evaluate_now (tmp
, pre
);
1007 stmtblock_t do_copying
;
1009 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
1010 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
1011 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
1012 tmp
= gfc_get_element_type (tmp
);
1013 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
1014 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
1016 tmp
= build_call_expr_loc (input_location
,
1017 gfor_fndecl_in_pack
, 1, initial
);
1018 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1019 gfc_add_modify (pre
, packed
, tmp
);
1021 tmp
= build_fold_indirect_ref_loc (input_location
,
1023 source_data
= gfc_conv_descriptor_data_get (tmp
);
1025 /* internal_pack may return source->data without any allocation
1026 or copying if it is already packed. If that's the case, we
1027 need to allocate and copy manually. */
1029 gfc_start_block (&do_copying
);
1030 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
1031 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
1032 gfc_add_modify (&do_copying
, packed
, tmp
);
1033 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
1034 gfc_add_expr_to_block (&do_copying
, tmp
);
1036 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
1037 boolean_type_node
, packed
,
1039 tmp
= gfc_finish_block (&do_copying
);
1040 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
1041 build_empty_stmt (input_location
));
1042 gfc_add_expr_to_block (pre
, tmp
);
1044 tmp
= fold_convert (pvoid_type_node
, packed
);
1047 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
1050 info
->data
= gfc_conv_descriptor_data_get (desc
);
1052 /* The offset is zero because we create temporaries with a zero
1054 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
1056 if (dealloc
&& !onstack
)
1058 /* Free the temporary. */
1059 tmp
= gfc_conv_descriptor_data_get (desc
);
1060 tmp
= gfc_call_free (tmp
);
1061 gfc_add_expr_to_block (post
, tmp
);
1066 /* Get the scalarizer array dimension corresponding to actual array dimension
1069 For example, if SS represents the array ref a(1,:,:,1), it is a
1070 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1071 and 1 for ARRAY_DIM=2.
1072 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1073 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1075 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1076 array. If called on the inner ss, the result would be respectively 0,1,2 for
1077 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1078 for ARRAY_DIM=1,2. */
1081 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
1088 for (; ss
; ss
= ss
->parent
)
1089 for (n
= 0; n
< ss
->dimen
; n
++)
1090 if (ss
->dim
[n
] < array_dim
)
1093 return array_ref_dim
;
1098 innermost_ss (gfc_ss
*ss
)
1100 while (ss
->nested_ss
!= NULL
)
1108 /* Get the array reference dimension corresponding to the given loop dimension.
1109 It is different from the true array dimension given by the dim array in
1110 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1111 It is different from the loop dimension in the case of a transposed array.
1115 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
1117 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
1122 /* Generate code to create and initialize the descriptor for a temporary
1123 array. This is used for both temporaries needed by the scalarizer, and
1124 functions returning arrays. Adjusts the loop variables to be
1125 zero-based, and calculates the loop bounds for callee allocated arrays.
1126 Allocate the array unless it's callee allocated (we have a callee
1127 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1128 NULL_TREE for any n). Also fills in the descriptor, data and offset
1129 fields of info if known. Returns the size of the array, or NULL for a
1130 callee allocated array.
1132 'eltype' == NULL signals that the temporary should be a class object.
1133 The 'initial' expression is used to obtain the size of the dynamic
1134 type; otherwise the allocation and initialization proceeds as for any
1137 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1138 gfc_trans_allocate_array_storage. */
1141 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1142 tree eltype
, tree initial
, bool dynamic
,
1143 bool dealloc
, bool callee_alloc
, locus
* where
)
1147 gfc_array_info
*info
;
1148 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1156 tree class_expr
= NULL_TREE
;
1157 int n
, dim
, tmp_dim
;
1160 /* This signals a class array for which we need the size of the
1161 dynamic type. Generate an eltype and then the class expression. */
1162 if (eltype
== NULL_TREE
&& initial
)
1164 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial
)));
1165 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1166 eltype
= TREE_TYPE (class_expr
);
1167 eltype
= gfc_get_element_type (eltype
);
1168 /* Obtain the structure (class) expression. */
1169 class_expr
= TREE_OPERAND (class_expr
, 0);
1170 gcc_assert (class_expr
);
1173 memset (from
, 0, sizeof (from
));
1174 memset (to
, 0, sizeof (to
));
1176 info
= &ss
->info
->data
.array
;
1178 gcc_assert (ss
->dimen
> 0);
1179 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1181 if (warn_array_temporaries
&& where
)
1182 gfc_warning (OPT_Warray_temporaries
,
1183 "Creating array temporary at %L", where
);
1185 /* Set the lower bound to zero. */
1186 for (s
= ss
; s
; s
= s
->parent
)
1190 total_dim
+= loop
->dimen
;
1191 for (n
= 0; n
< loop
->dimen
; n
++)
1195 /* Callee allocated arrays may not have a known bound yet. */
1197 loop
->to
[n
] = gfc_evaluate_now (
1198 fold_build2_loc (input_location
, MINUS_EXPR
,
1199 gfc_array_index_type
,
1200 loop
->to
[n
], loop
->from
[n
]),
1202 loop
->from
[n
] = gfc_index_zero_node
;
1204 /* We have just changed the loop bounds, we must clear the
1205 corresponding specloop, so that delta calculation is not skipped
1206 later in gfc_set_delta. */
1207 loop
->specloop
[n
] = NULL
;
1209 /* We are constructing the temporary's descriptor based on the loop
1210 dimensions. As the dimensions may be accessed in arbitrary order
1211 (think of transpose) the size taken from the n'th loop may not map
1212 to the n'th dimension of the array. We need to reconstruct loop
1213 infos in the right order before using it to set the descriptor
1215 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1216 from
[tmp_dim
] = loop
->from
[n
];
1217 to
[tmp_dim
] = loop
->to
[n
];
1219 info
->delta
[dim
] = gfc_index_zero_node
;
1220 info
->start
[dim
] = gfc_index_zero_node
;
1221 info
->end
[dim
] = gfc_index_zero_node
;
1222 info
->stride
[dim
] = gfc_index_one_node
;
1226 /* Initialize the descriptor. */
1228 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1229 GFC_ARRAY_UNKNOWN
, true);
1230 desc
= gfc_create_var (type
, "atmp");
1231 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1233 info
->descriptor
= desc
;
1234 size
= gfc_index_one_node
;
1236 /* Emit a DECL_EXPR for the variable sized array type in
1237 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1238 sizes works correctly. */
1239 tree arraytype
= TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
));
1240 if (! TYPE_NAME (arraytype
))
1241 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
1242 NULL_TREE
, arraytype
);
1243 gfc_add_expr_to_block (pre
, build1 (DECL_EXPR
,
1244 arraytype
, TYPE_NAME (arraytype
)));
1246 /* Fill in the array dtype. */
1247 tmp
= gfc_conv_descriptor_dtype (desc
);
1248 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1251 Fill in the bounds and stride. This is a packed array, so:
1254 for (n = 0; n < rank; n++)
1257 delta = ubound[n] + 1 - lbound[n];
1258 size = size * delta;
1260 size = size * sizeof(element);
1263 or_expr
= NULL_TREE
;
1265 /* If there is at least one null loop->to[n], it is a callee allocated
1267 for (n
= 0; n
< total_dim
; n
++)
1268 if (to
[n
] == NULL_TREE
)
1274 if (size
== NULL_TREE
)
1275 for (s
= ss
; s
; s
= s
->parent
)
1276 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1278 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1280 /* For a callee allocated array express the loop bounds in terms
1281 of the descriptor fields. */
1282 tmp
= fold_build2_loc (input_location
,
1283 MINUS_EXPR
, gfc_array_index_type
,
1284 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1285 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1286 s
->loop
->to
[n
] = tmp
;
1290 for (n
= 0; n
< total_dim
; n
++)
1292 /* Store the stride and bound components in the descriptor. */
1293 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1295 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1296 gfc_index_zero_node
);
1298 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1300 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1301 gfc_array_index_type
,
1302 to
[n
], gfc_index_one_node
);
1304 /* Check whether the size for this dimension is negative. */
1305 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1306 tmp
, gfc_index_zero_node
);
1307 cond
= gfc_evaluate_now (cond
, pre
);
1312 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1313 boolean_type_node
, or_expr
, cond
);
1315 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1316 gfc_array_index_type
, size
, tmp
);
1317 size
= gfc_evaluate_now (size
, pre
);
1321 /* Get the size of the array. */
1322 if (size
&& !callee_alloc
)
1325 /* If or_expr is true, then the extent in at least one
1326 dimension is zero and the size is set to zero. */
1327 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1328 or_expr
, gfc_index_zero_node
, size
);
1331 if (class_expr
== NULL_TREE
)
1332 elemsize
= fold_convert (gfc_array_index_type
,
1333 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1335 elemsize
= gfc_class_vtab_size_get (class_expr
);
1337 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1346 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1352 if (ss
->dimen
> ss
->loop
->temp_dim
)
1353 ss
->loop
->temp_dim
= ss
->dimen
;
1359 /* Return the number of iterations in a loop that starts at START,
1360 ends at END, and has step STEP. */
1363 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1368 type
= TREE_TYPE (step
);
1369 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1370 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1371 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1372 build_int_cst (type
, 1));
1373 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1374 build_int_cst (type
, 0));
1375 return fold_convert (gfc_array_index_type
, tmp
);
1379 /* Extend the data in array DESC by EXTRA elements. */
1382 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1389 if (integer_zerop (extra
))
1392 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1394 /* Add EXTRA to the upper bound. */
1395 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1397 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1399 /* Get the value of the current data pointer. */
1400 arg0
= gfc_conv_descriptor_data_get (desc
);
1402 /* Calculate the new array size. */
1403 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1404 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1405 ubound
, gfc_index_one_node
);
1406 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1407 fold_convert (size_type_node
, tmp
),
1408 fold_convert (size_type_node
, size
));
1410 /* Call the realloc() function. */
1411 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1412 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1416 /* Return true if the bounds of iterator I can only be determined
1420 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1422 return (i
->start
->expr_type
!= EXPR_CONSTANT
1423 || i
->end
->expr_type
!= EXPR_CONSTANT
1424 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1428 /* Split the size of constructor element EXPR into the sum of two terms,
1429 one of which can be determined at compile time and one of which must
1430 be calculated at run time. Set *SIZE to the former and return true
1431 if the latter might be nonzero. */
1434 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1436 if (expr
->expr_type
== EXPR_ARRAY
)
1437 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1438 else if (expr
->rank
> 0)
1440 /* Calculate everything at run time. */
1441 mpz_set_ui (*size
, 0);
1446 /* A single element. */
1447 mpz_set_ui (*size
, 1);
1453 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1454 of array constructor C. */
1457 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1465 mpz_set_ui (*size
, 0);
1470 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1473 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1477 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1480 /* Multiply the static part of the element size by the
1481 number of iterations. */
1482 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1483 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1484 mpz_add_ui (val
, val
, 1);
1485 if (mpz_sgn (val
) > 0)
1486 mpz_mul (len
, len
, val
);
1488 mpz_set_ui (len
, 0);
1490 mpz_add (*size
, *size
, len
);
1499 /* Make sure offset is a variable. */
1502 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1505 /* We should have already created the offset variable. We cannot
1506 create it here because we may be in an inner scope. */
1507 gcc_assert (*offsetvar
!= NULL_TREE
);
1508 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1509 *poffset
= *offsetvar
;
1510 TREE_USED (*offsetvar
) = 1;
1514 /* Variables needed for bounds-checking. */
1515 static bool first_len
;
1516 static tree first_len_val
;
1517 static bool typespec_chararray_ctor
;
1520 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1521 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1525 gfc_conv_expr (se
, expr
);
1527 /* Store the value. */
1528 tmp
= build_fold_indirect_ref_loc (input_location
,
1529 gfc_conv_descriptor_data_get (desc
));
1530 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1532 if (expr
->ts
.type
== BT_CHARACTER
)
1534 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1537 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1538 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1539 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1540 gfc_charlen_type_node
, esize
,
1541 build_int_cst (gfc_charlen_type_node
,
1542 gfc_character_kinds
[i
].bit_size
/ 8));
1544 gfc_conv_string_parameter (se
);
1545 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1547 /* The temporary is an array of pointers. */
1548 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1549 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1553 /* The temporary is an array of string values. */
1554 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1555 /* We know the temporary and the value will be the same length,
1556 so can use memcpy. */
1557 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1558 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1560 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1564 gfc_add_modify (&se
->pre
, first_len_val
,
1570 /* Verify that all constructor elements are of the same
1572 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1573 boolean_type_node
, first_len_val
,
1575 gfc_trans_runtime_check
1576 (true, false, cond
, &se
->pre
, &expr
->where
,
1577 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1578 fold_convert (long_integer_type_node
, first_len_val
),
1579 fold_convert (long_integer_type_node
, se
->string_length
));
1585 /* TODO: Should the frontend already have done this conversion? */
1586 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1587 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1590 gfc_add_block_to_block (pblock
, &se
->pre
);
1591 gfc_add_block_to_block (pblock
, &se
->post
);
1595 /* Add the contents of an array to the constructor. DYNAMIC is as for
1596 gfc_trans_array_constructor_value. */
1599 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1600 tree type ATTRIBUTE_UNUSED
,
1601 tree desc
, gfc_expr
* expr
,
1602 tree
* poffset
, tree
* offsetvar
,
1613 /* We need this to be a variable so we can increment it. */
1614 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1616 gfc_init_se (&se
, NULL
);
1618 /* Walk the array expression. */
1619 ss
= gfc_walk_expr (expr
);
1620 gcc_assert (ss
!= gfc_ss_terminator
);
1622 /* Initialize the scalarizer. */
1623 gfc_init_loopinfo (&loop
);
1624 gfc_add_ss_to_loop (&loop
, ss
);
1626 /* Initialize the loop. */
1627 gfc_conv_ss_startstride (&loop
);
1628 gfc_conv_loop_setup (&loop
, &expr
->where
);
1630 /* Make sure the constructed array has room for the new data. */
1633 /* Set SIZE to the total number of elements in the subarray. */
1634 size
= gfc_index_one_node
;
1635 for (n
= 0; n
< loop
.dimen
; n
++)
1637 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1638 gfc_index_one_node
);
1639 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1640 gfc_array_index_type
, size
, tmp
);
1643 /* Grow the constructed array by SIZE elements. */
1644 gfc_grow_array (&loop
.pre
, desc
, size
);
1647 /* Make the loop body. */
1648 gfc_mark_ss_chain_used (ss
, 1);
1649 gfc_start_scalarized_body (&loop
, &body
);
1650 gfc_copy_loopinfo_to_se (&se
, &loop
);
1653 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1654 gcc_assert (se
.ss
== gfc_ss_terminator
);
1656 /* Increment the offset. */
1657 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1658 *poffset
, gfc_index_one_node
);
1659 gfc_add_modify (&body
, *poffset
, tmp
);
1661 /* Finish the loop. */
1662 gfc_trans_scalarizing_loops (&loop
, &body
);
1663 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1664 tmp
= gfc_finish_block (&loop
.pre
);
1665 gfc_add_expr_to_block (pblock
, tmp
);
1667 gfc_cleanup_loop (&loop
);
1671 /* Assign the values to the elements of an array constructor. DYNAMIC
1672 is true if descriptor DESC only contains enough data for the static
1673 size calculated by gfc_get_array_constructor_size. When true, memory
1674 for the dynamic parts must be allocated using realloc. */
1677 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1678 tree desc
, gfc_constructor_base base
,
1679 tree
* poffset
, tree
* offsetvar
,
1683 tree start
= NULL_TREE
;
1684 tree end
= NULL_TREE
;
1685 tree step
= NULL_TREE
;
1691 tree shadow_loopvar
= NULL_TREE
;
1692 gfc_saved_var saved_loopvar
;
1695 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1697 /* If this is an iterator or an array, the offset must be a variable. */
1698 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1699 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1701 /* Shadowing the iterator avoids changing its value and saves us from
1702 keeping track of it. Further, it makes sure that there's always a
1703 backend-decl for the symbol, even if there wasn't one before,
1704 e.g. in the case of an iterator that appears in a specification
1705 expression in an interface mapping. */
1711 /* Evaluate loop bounds before substituting the loop variable
1712 in case they depend on it. Such a case is invalid, but it is
1713 not more expensive to do the right thing here.
1715 gfc_init_se (&se
, NULL
);
1716 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1717 gfc_add_block_to_block (pblock
, &se
.pre
);
1718 start
= gfc_evaluate_now (se
.expr
, pblock
);
1720 gfc_init_se (&se
, NULL
);
1721 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1722 gfc_add_block_to_block (pblock
, &se
.pre
);
1723 end
= gfc_evaluate_now (se
.expr
, pblock
);
1725 gfc_init_se (&se
, NULL
);
1726 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1727 gfc_add_block_to_block (pblock
, &se
.pre
);
1728 step
= gfc_evaluate_now (se
.expr
, pblock
);
1730 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1731 type
= gfc_typenode_for_spec (&sym
->ts
);
1733 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1734 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1737 gfc_start_block (&body
);
1739 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1741 /* Array constructors can be nested. */
1742 gfc_trans_array_constructor_value (&body
, type
, desc
,
1743 c
->expr
->value
.constructor
,
1744 poffset
, offsetvar
, dynamic
);
1746 else if (c
->expr
->rank
> 0)
1748 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1749 poffset
, offsetvar
, dynamic
);
1753 /* This code really upsets the gimplifier so don't bother for now. */
1760 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1762 p
= gfc_constructor_next (p
);
1767 /* Scalar values. */
1768 gfc_init_se (&se
, NULL
);
1769 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1772 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1773 gfc_array_index_type
,
1774 *poffset
, gfc_index_one_node
);
1778 /* Collect multiple scalar constants into a constructor. */
1779 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1783 HOST_WIDE_INT idx
= 0;
1786 /* Count the number of consecutive scalar constants. */
1787 while (p
&& !(p
->iterator
1788 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1790 gfc_init_se (&se
, NULL
);
1791 gfc_conv_constant (&se
, p
->expr
);
1793 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1794 se
.expr
= fold_convert (type
, se
.expr
);
1795 /* For constant character array constructors we build
1796 an array of pointers. */
1797 else if (POINTER_TYPE_P (type
))
1798 se
.expr
= gfc_build_addr_expr
1799 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1802 CONSTRUCTOR_APPEND_ELT (v
,
1803 build_int_cst (gfc_array_index_type
,
1807 p
= gfc_constructor_next (p
);
1810 bound
= size_int (n
- 1);
1811 /* Create an array type to hold them. */
1812 tmptype
= build_range_type (gfc_array_index_type
,
1813 gfc_index_zero_node
, bound
);
1814 tmptype
= build_array_type (type
, tmptype
);
1816 init
= build_constructor (tmptype
, v
);
1817 TREE_CONSTANT (init
) = 1;
1818 TREE_STATIC (init
) = 1;
1819 /* Create a static variable to hold the data. */
1820 tmp
= gfc_create_var (tmptype
, "data");
1821 TREE_STATIC (tmp
) = 1;
1822 TREE_CONSTANT (tmp
) = 1;
1823 TREE_READONLY (tmp
) = 1;
1824 DECL_INITIAL (tmp
) = init
;
1827 /* Use BUILTIN_MEMCPY to assign the values. */
1828 tmp
= gfc_conv_descriptor_data_get (desc
);
1829 tmp
= build_fold_indirect_ref_loc (input_location
,
1831 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1832 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1833 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1835 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1836 bound
= build_int_cst (size_type_node
, n
* size
);
1837 tmp
= build_call_expr_loc (input_location
,
1838 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1839 3, tmp
, init
, bound
);
1840 gfc_add_expr_to_block (&body
, tmp
);
1842 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1843 gfc_array_index_type
, *poffset
,
1844 build_int_cst (gfc_array_index_type
, n
));
1846 if (!INTEGER_CST_P (*poffset
))
1848 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1849 *poffset
= *offsetvar
;
1853 /* The frontend should already have done any expansions
1857 /* Pass the code as is. */
1858 tmp
= gfc_finish_block (&body
);
1859 gfc_add_expr_to_block (pblock
, tmp
);
1863 /* Build the implied do-loop. */
1864 stmtblock_t implied_do_block
;
1870 loopbody
= gfc_finish_block (&body
);
1872 /* Create a new block that holds the implied-do loop. A temporary
1873 loop-variable is used. */
1874 gfc_start_block(&implied_do_block
);
1876 /* Initialize the loop. */
1877 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1879 /* If this array expands dynamically, and the number of iterations
1880 is not constant, we won't have allocated space for the static
1881 part of C->EXPR's size. Do that now. */
1882 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1884 /* Get the number of iterations. */
1885 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1887 /* Get the static part of C->EXPR's size. */
1888 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1889 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1891 /* Grow the array by TMP * TMP2 elements. */
1892 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1893 gfc_array_index_type
, tmp
, tmp2
);
1894 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1897 /* Generate the loop body. */
1898 exit_label
= gfc_build_label_decl (NULL_TREE
);
1899 gfc_start_block (&body
);
1901 /* Generate the exit condition. Depending on the sign of
1902 the step variable we have to generate the correct
1904 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1905 step
, build_int_cst (TREE_TYPE (step
), 0));
1906 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1907 boolean_type_node
, tmp
,
1908 fold_build2_loc (input_location
, GT_EXPR
,
1909 boolean_type_node
, shadow_loopvar
, end
),
1910 fold_build2_loc (input_location
, LT_EXPR
,
1911 boolean_type_node
, shadow_loopvar
, end
));
1912 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1913 TREE_USED (exit_label
) = 1;
1914 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1915 build_empty_stmt (input_location
));
1916 gfc_add_expr_to_block (&body
, tmp
);
1918 /* The main loop body. */
1919 gfc_add_expr_to_block (&body
, loopbody
);
1921 /* Increase loop variable by step. */
1922 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1923 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1925 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1927 /* Finish the loop. */
1928 tmp
= gfc_finish_block (&body
);
1929 tmp
= build1_v (LOOP_EXPR
, tmp
);
1930 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1932 /* Add the exit label. */
1933 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1934 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1936 /* Finish the implied-do loop. */
1937 tmp
= gfc_finish_block(&implied_do_block
);
1938 gfc_add_expr_to_block(pblock
, tmp
);
1940 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1947 /* The array constructor code can create a string length with an operand
1948 in the form of a temporary variable. This variable will retain its
1949 context (current_function_decl). If we store this length tree in a
1950 gfc_charlen structure which is shared by a variable in another
1951 context, the resulting gfc_charlen structure with a variable in a
1952 different context, we could trip the assertion in expand_expr_real_1
1953 when it sees that a variable has been created in one context and
1954 referenced in another.
1956 If this might be the case, we create a new gfc_charlen structure and
1957 link it into the current namespace. */
1960 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1964 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1967 (*clp
)->backend_decl
= len
;
1970 /* A catch-all to obtain the string length for anything that is not
1971 a substring of non-constant length, a constant, array or variable. */
1974 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1978 /* Don't bother if we already know the length is a constant. */
1979 if (*len
&& INTEGER_CST_P (*len
))
1982 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1983 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1986 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1987 *len
= e
->ts
.u
.cl
->backend_decl
;
1991 /* Otherwise, be brutal even if inefficient. */
1992 gfc_init_se (&se
, NULL
);
1994 /* No function call, in case of side effects. */
1995 se
.no_function_call
= 1;
1997 gfc_conv_expr (&se
, e
);
1999 gfc_conv_expr_descriptor (&se
, e
);
2001 /* Fix the value. */
2002 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2004 gfc_add_block_to_block (block
, &se
.pre
);
2005 gfc_add_block_to_block (block
, &se
.post
);
2007 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2012 /* Figure out the string length of a variable reference expression.
2013 Used by get_array_ctor_strlen. */
2016 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2022 /* Don't bother if we already know the length is a constant. */
2023 if (*len
&& INTEGER_CST_P (*len
))
2026 ts
= &expr
->symtree
->n
.sym
->ts
;
2027 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2032 /* Array references don't change the string length. */
2036 /* Use the length of the component. */
2037 ts
= &ref
->u
.c
.component
->ts
;
2041 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2042 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2044 /* Note that this might evaluate expr. */
2045 get_array_ctor_all_strlen (block
, expr
, len
);
2048 mpz_init_set_ui (char_len
, 1);
2049 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2050 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2051 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
2052 *len
= convert (gfc_charlen_type_node
, *len
);
2053 mpz_clear (char_len
);
2061 *len
= ts
->u
.cl
->backend_decl
;
2065 /* Figure out the string length of a character array constructor.
2066 If len is NULL, don't calculate the length; this happens for recursive calls
2067 when a sub-array-constructor is an element but not at the first position,
2068 so when we're not interested in the length.
2069 Returns TRUE if all elements are character constants. */
2072 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2079 if (gfc_constructor_first (base
) == NULL
)
2082 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2086 /* Loop over all constructor elements to find out is_const, but in len we
2087 want to store the length of the first, not the last, element. We can
2088 of course exit the loop as soon as is_const is found to be false. */
2089 for (c
= gfc_constructor_first (base
);
2090 c
&& is_const
; c
= gfc_constructor_next (c
))
2092 switch (c
->expr
->expr_type
)
2095 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2096 *len
= build_int_cstu (gfc_charlen_type_node
,
2097 c
->expr
->value
.character
.length
);
2101 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2108 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2114 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2118 /* After the first iteration, we don't want the length modified. */
2125 /* Check whether the array constructor C consists entirely of constant
2126 elements, and if so returns the number of those elements, otherwise
2127 return zero. Note, an empty or NULL array constructor returns zero. */
2129 unsigned HOST_WIDE_INT
2130 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2132 unsigned HOST_WIDE_INT nelem
= 0;
2134 gfc_constructor
*c
= gfc_constructor_first (base
);
2138 || c
->expr
->rank
> 0
2139 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2141 c
= gfc_constructor_next (c
);
2148 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2149 and the tree type of it's elements, TYPE, return a static constant
2150 variable that is compile-time initialized. */
2153 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2155 tree tmptype
, init
, tmp
;
2156 HOST_WIDE_INT nelem
;
2161 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2163 /* First traverse the constructor list, converting the constants
2164 to tree to build an initializer. */
2166 c
= gfc_constructor_first (expr
->value
.constructor
);
2169 gfc_init_se (&se
, NULL
);
2170 gfc_conv_constant (&se
, c
->expr
);
2171 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2172 se
.expr
= fold_convert (type
, se
.expr
);
2173 else if (POINTER_TYPE_P (type
))
2174 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2176 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2178 c
= gfc_constructor_next (c
);
2182 /* Next determine the tree type for the array. We use the gfortran
2183 front-end's gfc_get_nodesc_array_type in order to create a suitable
2184 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2186 memset (&as
, 0, sizeof (gfc_array_spec
));
2188 as
.rank
= expr
->rank
;
2189 as
.type
= AS_EXPLICIT
;
2192 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2193 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2197 for (i
= 0; i
< expr
->rank
; i
++)
2199 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2200 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2201 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2205 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2207 /* as is not needed anymore. */
2208 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2210 gfc_free_expr (as
.lower
[i
]);
2211 gfc_free_expr (as
.upper
[i
]);
2214 init
= build_constructor (tmptype
, v
);
2216 TREE_CONSTANT (init
) = 1;
2217 TREE_STATIC (init
) = 1;
2219 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2221 DECL_ARTIFICIAL (tmp
) = 1;
2222 DECL_IGNORED_P (tmp
) = 1;
2223 TREE_STATIC (tmp
) = 1;
2224 TREE_CONSTANT (tmp
) = 1;
2225 TREE_READONLY (tmp
) = 1;
2226 DECL_INITIAL (tmp
) = init
;
2233 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2234 This mostly initializes the scalarizer state info structure with the
2235 appropriate values to directly use the array created by the function
2236 gfc_build_constant_array_constructor. */
2239 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2241 gfc_array_info
*info
;
2245 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2247 info
= &ss
->info
->data
.array
;
2249 info
->descriptor
= tmp
;
2250 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2251 info
->offset
= gfc_index_zero_node
;
2253 for (i
= 0; i
< ss
->dimen
; i
++)
2255 info
->delta
[i
] = gfc_index_zero_node
;
2256 info
->start
[i
] = gfc_index_zero_node
;
2257 info
->end
[i
] = gfc_index_zero_node
;
2258 info
->stride
[i
] = gfc_index_one_node
;
2264 get_rank (gfc_loopinfo
*loop
)
2269 for (; loop
; loop
= loop
->parent
)
2270 rank
+= loop
->dimen
;
2276 /* Helper routine of gfc_trans_array_constructor to determine if the
2277 bounds of the loop specified by LOOP are constant and simple enough
2278 to use with trans_constant_array_constructor. Returns the
2279 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2282 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2285 tree size
= gfc_index_one_node
;
2289 total_dim
= get_rank (l
);
2291 for (loop
= l
; loop
; loop
= loop
->parent
)
2293 for (i
= 0; i
< loop
->dimen
; i
++)
2295 /* If the bounds aren't constant, return NULL_TREE. */
2296 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2298 if (!integer_zerop (loop
->from
[i
]))
2300 /* Only allow nonzero "from" in one-dimensional arrays. */
2303 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2304 gfc_array_index_type
,
2305 loop
->to
[i
], loop
->from
[i
]);
2309 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2310 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2311 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2312 gfc_array_index_type
, size
, tmp
);
2321 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2326 gcc_assert (array
->nested_ss
== NULL
);
2328 for (ss
= array
; ss
; ss
= ss
->parent
)
2329 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2330 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2331 return &(ss
->loop
->to
[n
]);
2337 static gfc_loopinfo
*
2338 outermost_loop (gfc_loopinfo
* loop
)
2340 while (loop
->parent
!= NULL
)
2341 loop
= loop
->parent
;
2347 /* Array constructors are handled by constructing a temporary, then using that
2348 within the scalarization loop. This is not optimal, but seems by far the
2352 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2354 gfc_constructor_base c
;
2362 bool old_first_len
, old_typespec_chararray_ctor
;
2363 tree old_first_len_val
;
2364 gfc_loopinfo
*loop
, *outer_loop
;
2365 gfc_ss_info
*ss_info
;
2371 /* Save the old values for nested checking. */
2372 old_first_len
= first_len
;
2373 old_first_len_val
= first_len_val
;
2374 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2377 outer_loop
= outermost_loop (loop
);
2379 expr
= ss_info
->expr
;
2381 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2382 typespec was given for the array constructor. */
2383 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2385 && expr
->ts
.u
.cl
->length_from_typespec
);
2387 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2388 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2390 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2394 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2396 c
= expr
->value
.constructor
;
2397 if (expr
->ts
.type
== BT_CHARACTER
)
2400 bool force_new_cl
= false;
2402 /* get_array_ctor_strlen walks the elements of the constructor, if a
2403 typespec was given, we already know the string length and want the one
2405 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2406 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2410 const_string
= false;
2411 gfc_init_se (&length_se
, NULL
);
2412 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2413 gfc_charlen_type_node
);
2414 ss_info
->string_length
= length_se
.expr
;
2416 /* Check if the character length is negative. If it is, then
2418 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2419 boolean_type_node
, ss_info
->string_length
,
2420 build_int_cst (gfc_charlen_type_node
, 0));
2421 /* Print a warning if bounds checking is enabled. */
2422 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2424 msg
= xasprintf ("Negative character length treated as LEN = 0");
2425 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2430 ss_info
->string_length
2431 = fold_build3_loc (input_location
, COND_EXPR
,
2432 gfc_charlen_type_node
, neg_len
,
2433 build_int_cst (gfc_charlen_type_node
, 0),
2434 ss_info
->string_length
);
2435 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2438 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2439 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2443 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2444 &ss_info
->string_length
);
2445 force_new_cl
= true;
2448 /* Complex character array constructors should have been taken care of
2449 and not end up here. */
2450 gcc_assert (ss_info
->string_length
);
2452 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2454 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2456 type
= build_pointer_type (type
);
2459 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2460 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2462 /* See if the constructor determines the loop bounds. */
2465 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2467 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2469 /* We have a multidimensional parameter. */
2470 for (s
= ss
; s
; s
= s
->parent
)
2473 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2475 s
->loop
->from
[n
] = gfc_index_zero_node
;
2476 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2477 gfc_index_integer_kind
);
2478 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2479 gfc_array_index_type
,
2481 gfc_index_one_node
);
2486 if (*loop_ubound0
== NULL_TREE
)
2490 /* We should have a 1-dimensional, zero-based loop. */
2491 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2492 gcc_assert (loop
->dimen
== 1);
2493 gcc_assert (integer_zerop (loop
->from
[0]));
2495 /* Split the constructor size into a static part and a dynamic part.
2496 Allocate the static size up-front and record whether the dynamic
2497 size might be nonzero. */
2499 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2500 mpz_sub_ui (size
, size
, 1);
2501 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2505 /* Special case constant array constructors. */
2508 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2511 tree size
= constant_array_constructor_loop_size (loop
);
2512 if (size
&& compare_tree_int (size
, nelem
) == 0)
2514 trans_constant_array_constructor (ss
, type
);
2520 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2521 NULL_TREE
, dynamic
, true, false, where
);
2523 desc
= ss_info
->data
.array
.descriptor
;
2524 offset
= gfc_index_zero_node
;
2525 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2526 TREE_NO_WARNING (offsetvar
) = 1;
2527 TREE_USED (offsetvar
) = 0;
2528 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2529 &offset
, &offsetvar
, dynamic
);
2531 /* If the array grows dynamically, the upper bound of the loop variable
2532 is determined by the array's final upper bound. */
2535 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2536 gfc_array_index_type
,
2537 offsetvar
, gfc_index_one_node
);
2538 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2539 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2540 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2541 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2543 *loop_ubound0
= tmp
;
2546 if (TREE_USED (offsetvar
))
2547 pushdecl (offsetvar
);
2549 gcc_assert (INTEGER_CST_P (offset
));
2552 /* Disable bound checking for now because it's probably broken. */
2553 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2560 /* Restore old values of globals. */
2561 first_len
= old_first_len
;
2562 first_len_val
= old_first_len_val
;
2563 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2567 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2568 called after evaluating all of INFO's vector dimensions. Go through
2569 each such vector dimension and see if we can now fill in any missing
2573 set_vector_loop_bounds (gfc_ss
* ss
)
2575 gfc_loopinfo
*loop
, *outer_loop
;
2576 gfc_array_info
*info
;
2584 outer_loop
= outermost_loop (ss
->loop
);
2586 info
= &ss
->info
->data
.array
;
2588 for (; ss
; ss
= ss
->parent
)
2592 for (n
= 0; n
< loop
->dimen
; n
++)
2595 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2596 || loop
->to
[n
] != NULL
)
2599 /* Loop variable N indexes vector dimension DIM, and we don't
2600 yet know the upper bound of loop variable N. Set it to the
2601 difference between the vector's upper and lower bounds. */
2602 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2603 gcc_assert (info
->subscript
[dim
]
2604 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2606 gfc_init_se (&se
, NULL
);
2607 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2608 zero
= gfc_rank_cst
[0];
2609 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2610 gfc_array_index_type
,
2611 gfc_conv_descriptor_ubound_get (desc
, zero
),
2612 gfc_conv_descriptor_lbound_get (desc
, zero
));
2613 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2620 /* Tells whether a scalar argument to an elemental procedure is saved out
2621 of a scalarization loop as a value or as a reference. */
2624 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2626 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2629 /* If the actual argument can be absent (in other words, it can
2630 be a NULL reference), don't try to evaluate it; pass instead
2631 the reference directly. */
2632 if (ss_info
->can_be_null_ref
)
2635 /* If the expression is of polymorphic type, it's actual size is not known,
2636 so we avoid copying it anywhere. */
2637 if (ss_info
->data
.scalar
.dummy_arg
2638 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2639 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2642 /* If the expression is a data reference of aggregate type,
2643 and the data reference is not used on the left hand side,
2644 avoid a copy by saving a reference to the content. */
2645 if (!ss_info
->data
.scalar
.needs_temporary
2646 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2647 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2648 && gfc_expr_is_variable (ss_info
->expr
))
2651 /* Otherwise the expression is evaluated to a temporary variable before the
2652 scalarization loop. */
2657 /* Add the pre and post chains for all the scalar expressions in a SS chain
2658 to loop. This is called after the loop parameters have been calculated,
2659 but before the actual scalarizing loops. */
2662 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2665 gfc_loopinfo
*nested_loop
, *outer_loop
;
2667 gfc_ss_info
*ss_info
;
2668 gfc_array_info
*info
;
2672 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2673 arguments could get evaluated multiple times. */
2674 if (ss
->is_alloc_lhs
)
2677 outer_loop
= outermost_loop (loop
);
2679 /* TODO: This can generate bad code if there are ordering dependencies,
2680 e.g., a callee allocated function and an unknown size constructor. */
2681 gcc_assert (ss
!= NULL
);
2683 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2687 /* Cross loop arrays are handled from within the most nested loop. */
2688 if (ss
->nested_ss
!= NULL
)
2692 expr
= ss_info
->expr
;
2693 info
= &ss_info
->data
.array
;
2695 switch (ss_info
->type
)
2698 /* Scalar expression. Evaluate this now. This includes elemental
2699 dimension indices, but not array section bounds. */
2700 gfc_init_se (&se
, NULL
);
2701 gfc_conv_expr (&se
, expr
);
2702 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2704 if (expr
->ts
.type
!= BT_CHARACTER
2705 && !gfc_is_alloc_class_scalar_function (expr
))
2707 /* Move the evaluation of scalar expressions outside the
2708 scalarization loop, except for WHERE assignments. */
2710 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2711 if (!ss_info
->where
)
2712 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2713 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2716 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2718 ss_info
->data
.scalar
.value
= se
.expr
;
2719 ss_info
->string_length
= se
.string_length
;
2722 case GFC_SS_REFERENCE
:
2723 /* Scalar argument to elemental procedure. */
2724 gfc_init_se (&se
, NULL
);
2725 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2726 gfc_conv_expr_reference (&se
, expr
);
2729 /* Evaluate the argument outside the loop and pass
2730 a reference to the value. */
2731 gfc_conv_expr (&se
, expr
);
2734 /* Ensure that a pointer to the string is stored. */
2735 if (expr
->ts
.type
== BT_CHARACTER
)
2736 gfc_conv_string_parameter (&se
);
2738 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2739 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2740 if (gfc_is_class_scalar_expr (expr
))
2741 /* This is necessary because the dynamic type will always be
2742 large than the declared type. In consequence, assigning
2743 the value to a temporary could segfault.
2744 OOP-TODO: see if this is generally correct or is the value
2745 has to be written to an allocated temporary, whose address
2746 is passed via ss_info. */
2747 ss_info
->data
.scalar
.value
= se
.expr
;
2749 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2752 ss_info
->string_length
= se
.string_length
;
2755 case GFC_SS_SECTION
:
2756 /* Add the expressions for scalar and vector subscripts. */
2757 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2758 if (info
->subscript
[n
])
2759 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2761 set_vector_loop_bounds (ss
);
2765 /* Get the vector's descriptor and store it in SS. */
2766 gfc_init_se (&se
, NULL
);
2767 gfc_conv_expr_descriptor (&se
, expr
);
2768 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2769 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2770 info
->descriptor
= se
.expr
;
2773 case GFC_SS_INTRINSIC
:
2774 gfc_add_intrinsic_ss_code (loop
, ss
);
2777 case GFC_SS_FUNCTION
:
2778 /* Array function return value. We call the function and save its
2779 result in a temporary for use inside the loop. */
2780 gfc_init_se (&se
, NULL
);
2783 gfc_conv_expr (&se
, expr
);
2784 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2785 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2786 ss_info
->string_length
= se
.string_length
;
2789 case GFC_SS_CONSTRUCTOR
:
2790 if (expr
->ts
.type
== BT_CHARACTER
2791 && ss_info
->string_length
== NULL
2793 && expr
->ts
.u
.cl
->length
2794 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2796 gfc_init_se (&se
, NULL
);
2797 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2798 gfc_charlen_type_node
);
2799 ss_info
->string_length
= se
.expr
;
2800 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2801 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2803 trans_array_constructor (ss
, where
);
2807 case GFC_SS_COMPONENT
:
2808 /* Do nothing. These are handled elsewhere. */
2817 for (nested_loop
= loop
->nested
; nested_loop
;
2818 nested_loop
= nested_loop
->next
)
2819 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2823 /* Translate expressions for the descriptor and data pointer of a SS. */
2827 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2830 gfc_ss_info
*ss_info
;
2831 gfc_array_info
*info
;
2835 info
= &ss_info
->data
.array
;
2837 /* Get the descriptor for the array to be scalarized. */
2838 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2839 gfc_init_se (&se
, NULL
);
2840 se
.descriptor_only
= 1;
2841 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2842 gfc_add_block_to_block (block
, &se
.pre
);
2843 info
->descriptor
= se
.expr
;
2844 ss_info
->string_length
= se
.string_length
;
2848 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2849 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2851 /* Emit a DECL_EXPR for the variable sized array type in
2852 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2853 sizes works correctly. */
2854 tree arraytype
= TREE_TYPE (
2855 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2856 if (! TYPE_NAME (arraytype
))
2857 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2858 NULL_TREE
, arraytype
);
2859 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2860 TYPE_NAME (arraytype
)));
2862 /* Also the data pointer. */
2863 tmp
= gfc_conv_array_data (se
.expr
);
2864 /* If this is a variable or address of a variable we use it directly.
2865 Otherwise we must evaluate it now to avoid breaking dependency
2866 analysis by pulling the expressions for elemental array indices
2869 || (TREE_CODE (tmp
) == ADDR_EXPR
2870 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2871 tmp
= gfc_evaluate_now (tmp
, block
);
2874 tmp
= gfc_conv_array_offset (se
.expr
);
2875 info
->offset
= gfc_evaluate_now (tmp
, block
);
2877 /* Make absolutely sure that the saved_offset is indeed saved
2878 so that the variable is still accessible after the loops
2880 info
->saved_offset
= info
->offset
;
2885 /* Initialize a gfc_loopinfo structure. */
2888 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2892 memset (loop
, 0, sizeof (gfc_loopinfo
));
2893 gfc_init_block (&loop
->pre
);
2894 gfc_init_block (&loop
->post
);
2896 /* Initially scalarize in order and default to no loop reversal. */
2897 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2900 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2903 loop
->ss
= gfc_ss_terminator
;
2907 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2911 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2917 /* Return an expression for the data pointer of an array. */
2920 gfc_conv_array_data (tree descriptor
)
2924 type
= TREE_TYPE (descriptor
);
2925 if (GFC_ARRAY_TYPE_P (type
))
2927 if (TREE_CODE (type
) == POINTER_TYPE
)
2931 /* Descriptorless arrays. */
2932 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2936 return gfc_conv_descriptor_data_get (descriptor
);
2940 /* Return an expression for the base offset of an array. */
2943 gfc_conv_array_offset (tree descriptor
)
2947 type
= TREE_TYPE (descriptor
);
2948 if (GFC_ARRAY_TYPE_P (type
))
2949 return GFC_TYPE_ARRAY_OFFSET (type
);
2951 return gfc_conv_descriptor_offset_get (descriptor
);
2955 /* Get an expression for the array stride. */
2958 gfc_conv_array_stride (tree descriptor
, int dim
)
2963 type
= TREE_TYPE (descriptor
);
2965 /* For descriptorless arrays use the array size. */
2966 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2967 if (tmp
!= NULL_TREE
)
2970 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2975 /* Like gfc_conv_array_stride, but for the lower bound. */
2978 gfc_conv_array_lbound (tree descriptor
, int dim
)
2983 type
= TREE_TYPE (descriptor
);
2985 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2986 if (tmp
!= NULL_TREE
)
2989 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2994 /* Like gfc_conv_array_stride, but for the upper bound. */
2997 gfc_conv_array_ubound (tree descriptor
, int dim
)
3002 type
= TREE_TYPE (descriptor
);
3004 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3005 if (tmp
!= NULL_TREE
)
3008 /* This should only ever happen when passing an assumed shape array
3009 as an actual parameter. The value will never be used. */
3010 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3011 return gfc_index_zero_node
;
3013 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3018 /* Generate code to perform an array index bound check. */
3021 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3022 locus
* where
, bool check_upper
)
3025 tree tmp_lo
, tmp_up
;
3028 const char * name
= NULL
;
3030 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3033 descriptor
= ss
->info
->data
.array
.descriptor
;
3035 index
= gfc_evaluate_now (index
, &se
->pre
);
3037 /* We find a name for the error message. */
3038 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3039 gcc_assert (name
!= NULL
);
3041 if (VAR_P (descriptor
))
3042 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3044 /* If upper bound is present, include both bounds in the error message. */
3047 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3048 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3051 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3052 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3054 msg
= xasprintf ("Index '%%ld' of dimension %d "
3055 "outside of expected range (%%ld:%%ld)", n
+1);
3057 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3059 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3060 fold_convert (long_integer_type_node
, index
),
3061 fold_convert (long_integer_type_node
, tmp_lo
),
3062 fold_convert (long_integer_type_node
, tmp_up
));
3063 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3065 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3066 fold_convert (long_integer_type_node
, index
),
3067 fold_convert (long_integer_type_node
, tmp_lo
),
3068 fold_convert (long_integer_type_node
, tmp_up
));
3073 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3076 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3077 "below lower bound of %%ld", n
+1, name
);
3079 msg
= xasprintf ("Index '%%ld' of dimension %d "
3080 "below lower bound of %%ld", n
+1);
3082 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3084 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3085 fold_convert (long_integer_type_node
, index
),
3086 fold_convert (long_integer_type_node
, tmp_lo
));
3094 /* Return the offset for an index. Performs bound checking for elemental
3095 dimensions. Single element references are processed separately.
3096 DIM is the array dimension, I is the loop dimension. */
3099 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3100 gfc_array_ref
* ar
, tree stride
)
3102 gfc_array_info
*info
;
3107 info
= &ss
->info
->data
.array
;
3109 /* Get the index into the array for this dimension. */
3112 gcc_assert (ar
->type
!= AR_ELEMENT
);
3113 switch (ar
->dimen_type
[dim
])
3115 case DIMEN_THIS_IMAGE
:
3119 /* Elemental dimension. */
3120 gcc_assert (info
->subscript
[dim
]
3121 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3122 /* We've already translated this value outside the loop. */
3123 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3125 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3126 ar
->as
->type
!= AS_ASSUMED_SIZE
3127 || dim
< ar
->dimen
- 1);
3131 gcc_assert (info
&& se
->loop
);
3132 gcc_assert (info
->subscript
[dim
]
3133 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3134 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3136 /* Get a zero-based index into the vector. */
3137 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3138 gfc_array_index_type
,
3139 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3141 /* Multiply the index by the stride. */
3142 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3143 gfc_array_index_type
,
3144 index
, gfc_conv_array_stride (desc
, 0));
3146 /* Read the vector to get an index into info->descriptor. */
3147 data
= build_fold_indirect_ref_loc (input_location
,
3148 gfc_conv_array_data (desc
));
3149 index
= gfc_build_array_ref (data
, index
, NULL
);
3150 index
= gfc_evaluate_now (index
, &se
->pre
);
3151 index
= fold_convert (gfc_array_index_type
, index
);
3153 /* Do any bounds checking on the final info->descriptor index. */
3154 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3155 ar
->as
->type
!= AS_ASSUMED_SIZE
3156 || dim
< ar
->dimen
- 1);
3160 /* Scalarized dimension. */
3161 gcc_assert (info
&& se
->loop
);
3163 /* Multiply the loop variable by the stride and delta. */
3164 index
= se
->loop
->loopvar
[i
];
3165 if (!integer_onep (info
->stride
[dim
]))
3166 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3167 gfc_array_index_type
, index
,
3169 if (!integer_zerop (info
->delta
[dim
]))
3170 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3171 gfc_array_index_type
, index
,
3181 /* Temporary array or derived type component. */
3182 gcc_assert (se
->loop
);
3183 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3185 /* Pointer functions can have stride[0] different from unity.
3186 Use the stride returned by the function call and stored in
3187 the descriptor for the temporary. */
3188 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3189 && se
->ss
->info
->expr
3190 && se
->ss
->info
->expr
->symtree
3191 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3192 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3193 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3196 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3197 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3198 gfc_array_index_type
, index
, info
->delta
[dim
]);
3201 /* Multiply by the stride. */
3202 if (!integer_onep (stride
))
3203 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3210 /* Build a scalarized array reference using the vptr 'size'. */
3213 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3218 tree decl
= NULL_TREE
;
3220 gfc_expr
*expr
= se
->ss
->info
->expr
;
3222 gfc_ref
*class_ref
= NULL
;
3225 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3226 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3227 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3232 || (expr
->ts
.type
!= BT_CLASS
3233 && !gfc_is_alloc_class_array_function (expr
)
3234 && !gfc_is_class_array_ref (expr
, NULL
)))
3237 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3238 ts
= &expr
->symtree
->n
.sym
->ts
;
3242 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3244 if (ref
->type
== REF_COMPONENT
3245 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3246 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3247 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3249 && ref
->next
->next
->type
== REF_ARRAY
3250 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3252 ts
= &ref
->u
.c
.component
->ts
;
3262 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3263 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3265 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3266 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3268 else if (expr
&& gfc_is_alloc_class_array_function (expr
))
3272 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3275 type
= TREE_TYPE (tmp
);
3278 if (GFC_CLASS_TYPE_P (type
))
3280 if (type
!= TYPE_CANONICAL (type
))
3281 type
= TYPE_CANONICAL (type
);
3289 if (decl
== NULL_TREE
)
3292 else if (class_ref
== NULL
)
3294 if (decl
== NULL_TREE
)
3295 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3296 /* For class arrays the tree containing the class is stored in
3297 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3298 For all others it's sym's backend_decl directly. */
3299 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3300 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3304 /* Remove everything after the last class reference, convert the
3305 expression and then recover its tailend once more. */
3307 ref
= class_ref
->next
;
3308 class_ref
->next
= NULL
;
3309 gfc_init_se (&tmpse
, NULL
);
3310 gfc_conv_expr (&tmpse
, expr
);
3311 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3313 class_ref
->next
= ref
;
3316 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3317 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3319 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3322 size
= gfc_class_vtab_size_get (decl
);
3324 /* For unlimited polymorphic entities then _len component needs to be
3325 multiplied with the size. If no _len component is present, then
3326 gfc_class_len_or_zero_get () return a zero_node. */
3327 tmp
= gfc_class_len_or_zero_get (decl
);
3328 if (!integer_zerop (tmp
))
3329 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3330 fold_convert (TREE_TYPE (index
), size
),
3331 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3332 fold_convert (TREE_TYPE (index
), tmp
),
3333 fold_convert (TREE_TYPE (index
),
3334 integer_one_node
)));
3336 size
= fold_convert (TREE_TYPE (index
), size
);
3338 /* Build the address of the element. */
3339 type
= TREE_TYPE (TREE_TYPE (base
));
3340 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3341 gfc_array_index_type
,
3343 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3344 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3345 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3347 /* Return the element in the se expression. */
3348 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3353 /* Build a scalarized reference to an array. */
3356 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3358 gfc_array_info
*info
;
3359 tree decl
= NULL_TREE
;
3367 expr
= ss
->info
->expr
;
3368 info
= &ss
->info
->data
.array
;
3370 n
= se
->loop
->order
[0];
3374 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3375 /* Add the offset for this dimension to the stored offset for all other
3377 if (info
->offset
&& !integer_zerop (info
->offset
))
3378 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3379 index
, info
->offset
);
3381 if (expr
&& ((is_subref_array (expr
)
3382 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
)))
3383 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3384 || expr
->expr_type
== EXPR_FUNCTION
))))
3385 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3387 /* A pointer array component can be detected from its field decl. Fix
3388 the descriptor, mark the resulting variable decl and pass it to
3389 gfc_build_array_ref. */
3390 if (is_pointer_array (info
->descriptor
))
3392 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3394 decl
= gfc_evaluate_now (info
->descriptor
, &se
->pre
);
3395 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
3396 TREE_USED (decl
) = 1;
3398 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3399 decl
= TREE_OPERAND (info
->descriptor
, 0);
3401 if (decl
== NULL_TREE
)
3402 decl
= info
->descriptor
;
3405 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3407 /* Use the vptr 'size' field to access a class the element of a class
3409 if (build_class_array_ref (se
, tmp
, index
))
3412 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3416 /* Translate access of temporary array. */
3419 gfc_conv_tmp_array_ref (gfc_se
* se
)
3421 se
->string_length
= se
->ss
->info
->string_length
;
3422 gfc_conv_scalarized_array_ref (se
, NULL
);
3423 gfc_advance_se_ss_chain (se
);
3426 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3429 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3431 if (TREE_CODE (t
) == INTEGER_CST
)
3432 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3435 if (!integer_zerop (*offset
))
3436 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3437 gfc_array_index_type
, *offset
, t
);
3445 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3451 /* For class arrays the class declaration is stored in the saved
3453 if (INDIRECT_REF_P (desc
)
3454 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3455 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3456 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3457 TREE_OPERAND (desc
, 0)));
3461 /* Class container types do not always have the GFC_CLASS_TYPE_P
3462 but the canonical type does. */
3463 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3464 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3466 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3467 if (TYPE_CANONICAL (type
)
3468 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3469 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3472 tmp
= gfc_conv_array_data (desc
);
3473 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3474 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3479 /* Build an array reference. se->expr already holds the array descriptor.
3480 This should be either a variable, indirect variable reference or component
3481 reference. For arrays which do not have a descriptor, se->expr will be
3483 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3486 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3490 tree offset
, cst_offset
;
3493 tree decl
= NULL_TREE
;
3496 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3497 char *var_name
= NULL
;
3501 gcc_assert (ar
->codimen
);
3503 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3504 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3507 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3508 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3509 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3511 /* Use the actual tree type and not the wrapped coarray. */
3512 if (!se
->want_pointer
)
3513 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3520 /* Handle scalarized references separately. */
3521 if (ar
->type
!= AR_ELEMENT
)
3523 gfc_conv_scalarized_array_ref (se
, ar
);
3524 gfc_advance_se_ss_chain (se
);
3528 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3533 len
= strlen (sym
->name
) + 1;
3534 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3536 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3538 if (ref
->type
== REF_COMPONENT
)
3539 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3542 var_name
= XALLOCAVEC (char, len
);
3543 strcpy (var_name
, sym
->name
);
3545 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3547 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3549 if (ref
->type
== REF_COMPONENT
)
3551 strcat (var_name
, "%%");
3552 strcat (var_name
, ref
->u
.c
.component
->name
);
3557 cst_offset
= offset
= gfc_index_zero_node
;
3558 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3560 /* Calculate the offsets from all the dimensions. Make sure to associate
3561 the final offset so that we form a chain of loop invariant summands. */
3562 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3564 /* Calculate the index for this dimension. */
3565 gfc_init_se (&indexse
, se
);
3566 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3567 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3569 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3571 /* Check array bounds. */
3575 /* Evaluate the indexse.expr only once. */
3576 indexse
.expr
= save_expr (indexse
.expr
);
3579 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3580 if (sym
->attr
.temporary
)
3582 gfc_init_se (&tmpse
, se
);
3583 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3584 gfc_array_index_type
);
3585 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3589 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3591 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3592 "below lower bound of %%ld", n
+1, var_name
);
3593 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3594 fold_convert (long_integer_type_node
,
3596 fold_convert (long_integer_type_node
, tmp
));
3599 /* Upper bound, but not for the last dimension of assumed-size
3601 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3603 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3604 if (sym
->attr
.temporary
)
3606 gfc_init_se (&tmpse
, se
);
3607 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3608 gfc_array_index_type
);
3609 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3613 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3614 boolean_type_node
, indexse
.expr
, tmp
);
3615 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3616 "above upper bound of %%ld", n
+1, var_name
);
3617 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3618 fold_convert (long_integer_type_node
,
3620 fold_convert (long_integer_type_node
, tmp
));
3625 /* Multiply the index by the stride. */
3626 stride
= gfc_conv_array_stride (se
->expr
, n
);
3627 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3628 indexse
.expr
, stride
);
3630 /* And add it to the total. */
3631 add_to_offset (&cst_offset
, &offset
, tmp
);
3634 if (!integer_zerop (cst_offset
))
3635 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3636 gfc_array_index_type
, offset
, cst_offset
);
3638 /* A pointer array component can be detected from its field decl. Fix
3639 the descriptor, mark the resulting variable decl and pass it to
3641 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3642 && is_pointer_array (se
->expr
))
3644 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3646 decl
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3647 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
3648 TREE_USED (decl
) = 1;
3650 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3651 decl
= TREE_OPERAND (se
->expr
, 0);
3655 else if (expr
->ts
.deferred
3656 || (sym
->ts
.type
== BT_CHARACTER
3657 && sym
->attr
.select_type_temporary
))
3658 decl
= sym
->backend_decl
;
3659 else if (sym
->ts
.type
== BT_CLASS
)
3662 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3666 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3667 LOOP_DIM dimension (if any) to array's offset. */
3670 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3671 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3674 gfc_array_info
*info
;
3677 info
= &ss
->info
->data
.array
;
3679 gfc_init_se (&se
, NULL
);
3681 se
.expr
= info
->descriptor
;
3682 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3683 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3684 gfc_add_block_to_block (pblock
, &se
.pre
);
3686 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3687 gfc_array_index_type
,
3688 info
->offset
, index
);
3689 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3693 /* Generate the code to be executed immediately before entering a
3694 scalarization loop. */
3697 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3698 stmtblock_t
* pblock
)
3701 gfc_ss_info
*ss_info
;
3702 gfc_array_info
*info
;
3703 gfc_ss_type ss_type
;
3705 gfc_loopinfo
*ploop
;
3709 /* This code will be executed before entering the scalarization loop
3710 for this dimension. */
3711 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3715 if ((ss_info
->useflags
& flag
) == 0)
3718 ss_type
= ss_info
->type
;
3719 if (ss_type
!= GFC_SS_SECTION
3720 && ss_type
!= GFC_SS_FUNCTION
3721 && ss_type
!= GFC_SS_CONSTRUCTOR
3722 && ss_type
!= GFC_SS_COMPONENT
)
3725 info
= &ss_info
->data
.array
;
3727 gcc_assert (dim
< ss
->dimen
);
3728 gcc_assert (ss
->dimen
== loop
->dimen
);
3731 ar
= &info
->ref
->u
.ar
;
3735 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3737 /* If we are in the outermost dimension of this loop, the previous
3738 dimension shall be in the parent loop. */
3739 gcc_assert (ss
->parent
!= NULL
);
3742 ploop
= loop
->parent
;
3744 /* ss and ss->parent are about the same array. */
3745 gcc_assert (ss_info
== pss
->info
);
3753 if (dim
== loop
->dimen
- 1)
3758 /* For the time being, there is no loop reordering. */
3759 gcc_assert (i
== ploop
->order
[i
]);
3760 i
= ploop
->order
[i
];
3762 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3764 stride
= gfc_conv_array_stride (info
->descriptor
,
3765 innermost_ss (ss
)->dim
[i
]);
3767 /* Calculate the stride of the innermost loop. Hopefully this will
3768 allow the backend optimizers to do their stuff more effectively.
3770 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3772 /* For the outermost loop calculate the offset due to any
3773 elemental dimensions. It will have been initialized with the
3774 base offset of the array. */
3777 for (i
= 0; i
< ar
->dimen
; i
++)
3779 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3782 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3787 /* Add the offset for the previous loop dimension. */
3788 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3790 /* Remember this offset for the second loop. */
3791 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3792 info
->saved_offset
= info
->offset
;
3797 /* Start a scalarized expression. Creates a scope and declares loop
3801 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3807 gcc_assert (!loop
->array_parameter
);
3809 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3811 n
= loop
->order
[dim
];
3813 gfc_start_block (&loop
->code
[n
]);
3815 /* Create the loop variable. */
3816 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3818 if (dim
< loop
->temp_dim
)
3822 /* Calculate values that will be constant within this loop. */
3823 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3825 gfc_start_block (pbody
);
3829 /* Generates the actual loop code for a scalarization loop. */
3832 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3833 stmtblock_t
* pbody
)
3844 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3845 | OMPWS_SCALARIZER_BODY
))
3846 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3847 && n
== loop
->dimen
- 1)
3849 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3850 init
= make_tree_vec (1);
3851 cond
= make_tree_vec (1);
3852 incr
= make_tree_vec (1);
3854 /* Cycle statement is implemented with a goto. Exit statement must not
3855 be present for this loop. */
3856 exit_label
= gfc_build_label_decl (NULL_TREE
);
3857 TREE_USED (exit_label
) = 1;
3859 /* Label for cycle statements (if needed). */
3860 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3861 gfc_add_expr_to_block (pbody
, tmp
);
3863 stmt
= make_node (OMP_FOR
);
3865 TREE_TYPE (stmt
) = void_type_node
;
3866 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3868 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3869 OMP_CLAUSE_SCHEDULE
);
3870 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3871 = OMP_CLAUSE_SCHEDULE_STATIC
;
3872 if (ompws_flags
& OMPWS_NOWAIT
)
3873 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3874 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3876 /* Initialize the loopvar. */
3877 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3879 OMP_FOR_INIT (stmt
) = init
;
3880 /* The exit condition. */
3881 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3883 loop
->loopvar
[n
], loop
->to
[n
]);
3884 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3885 OMP_FOR_COND (stmt
) = cond
;
3886 /* Increment the loopvar. */
3887 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3888 loop
->loopvar
[n
], gfc_index_one_node
);
3889 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3890 void_type_node
, loop
->loopvar
[n
], tmp
);
3891 OMP_FOR_INCR (stmt
) = incr
;
3893 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3894 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3898 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3899 && (loop
->temp_ss
== NULL
);
3901 loopbody
= gfc_finish_block (pbody
);
3904 std::swap (loop
->from
[n
], loop
->to
[n
]);
3906 /* Initialize the loopvar. */
3907 if (loop
->loopvar
[n
] != loop
->from
[n
])
3908 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3910 exit_label
= gfc_build_label_decl (NULL_TREE
);
3912 /* Generate the loop body. */
3913 gfc_init_block (&block
);
3915 /* The exit condition. */
3916 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3917 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3918 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3919 TREE_USED (exit_label
) = 1;
3920 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3921 gfc_add_expr_to_block (&block
, tmp
);
3923 /* The main body. */
3924 gfc_add_expr_to_block (&block
, loopbody
);
3926 /* Increment the loopvar. */
3927 tmp
= fold_build2_loc (input_location
,
3928 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3929 gfc_array_index_type
, loop
->loopvar
[n
],
3930 gfc_index_one_node
);
3932 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3934 /* Build the loop. */
3935 tmp
= gfc_finish_block (&block
);
3936 tmp
= build1_v (LOOP_EXPR
, tmp
);
3937 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3939 /* Add the exit label. */
3940 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3941 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3947 /* Finishes and generates the loops for a scalarized expression. */
3950 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3955 stmtblock_t
*pblock
;
3959 /* Generate the loops. */
3960 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3962 n
= loop
->order
[dim
];
3963 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3964 loop
->loopvar
[n
] = NULL_TREE
;
3965 pblock
= &loop
->code
[n
];
3968 tmp
= gfc_finish_block (pblock
);
3969 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3971 /* Clear all the used flags. */
3972 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3973 if (ss
->parent
== NULL
)
3974 ss
->info
->useflags
= 0;
3978 /* Finish the main body of a scalarized expression, and start the secondary
3982 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3986 stmtblock_t
*pblock
;
3990 /* We finish as many loops as are used by the temporary. */
3991 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3993 n
= loop
->order
[dim
];
3994 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3995 loop
->loopvar
[n
] = NULL_TREE
;
3996 pblock
= &loop
->code
[n
];
3999 /* We don't want to finish the outermost loop entirely. */
4000 n
= loop
->order
[loop
->temp_dim
- 1];
4001 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4003 /* Restore the initial offsets. */
4004 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4006 gfc_ss_type ss_type
;
4007 gfc_ss_info
*ss_info
;
4011 if ((ss_info
->useflags
& 2) == 0)
4014 ss_type
= ss_info
->type
;
4015 if (ss_type
!= GFC_SS_SECTION
4016 && ss_type
!= GFC_SS_FUNCTION
4017 && ss_type
!= GFC_SS_CONSTRUCTOR
4018 && ss_type
!= GFC_SS_COMPONENT
)
4021 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4024 /* Restart all the inner loops we just finished. */
4025 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4027 n
= loop
->order
[dim
];
4029 gfc_start_block (&loop
->code
[n
]);
4031 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4033 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4036 /* Start a block for the secondary copying code. */
4037 gfc_start_block (body
);
4041 /* Precalculate (either lower or upper) bound of an array section.
4042 BLOCK: Block in which the (pre)calculation code will go.
4043 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4044 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4045 DESC: Array descriptor from which the bound will be picked if unspecified
4046 (either lower or upper bound according to LBOUND). */
4049 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4050 tree desc
, int dim
, bool lbound
, bool deferred
)
4053 gfc_expr
* input_val
= values
[dim
];
4054 tree
*output
= &bounds
[dim
];
4059 /* Specified section bound. */
4060 gfc_init_se (&se
, NULL
);
4061 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4062 gfc_add_block_to_block (block
, &se
.pre
);
4065 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4067 /* The gfc_conv_array_lbound () routine returns a constant zero for
4068 deferred length arrays, which in the scalarizer wreaks havoc, when
4069 copying to a (newly allocated) one-based array.
4070 Keep returning the actual result in sync for both bounds. */
4071 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4073 gfc_conv_descriptor_ubound_get (desc
,
4078 /* No specific bound specified so use the bound of the array. */
4079 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4080 gfc_conv_array_ubound (desc
, dim
);
4082 *output
= gfc_evaluate_now (*output
, block
);
4086 /* Calculate the lower bound of an array section. */
4089 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4091 gfc_expr
*stride
= NULL
;
4094 gfc_array_info
*info
;
4097 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4099 info
= &ss
->info
->data
.array
;
4100 ar
= &info
->ref
->u
.ar
;
4102 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4104 /* We use a zero-based index to access the vector. */
4105 info
->start
[dim
] = gfc_index_zero_node
;
4106 info
->end
[dim
] = NULL
;
4107 info
->stride
[dim
] = gfc_index_one_node
;
4111 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4112 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4113 desc
= info
->descriptor
;
4114 stride
= ar
->stride
[dim
];
4117 /* Calculate the start of the range. For vector subscripts this will
4118 be the range of the vector. */
4119 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4120 ar
->as
->type
== AS_DEFERRED
);
4122 /* Similarly calculate the end. Although this is not used in the
4123 scalarizer, it is needed when checking bounds and where the end
4124 is an expression with side-effects. */
4125 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4126 ar
->as
->type
== AS_DEFERRED
);
4129 /* Calculate the stride. */
4131 info
->stride
[dim
] = gfc_index_one_node
;
4134 gfc_init_se (&se
, NULL
);
4135 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4136 gfc_add_block_to_block (block
, &se
.pre
);
4137 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4142 /* Calculates the range start and stride for a SS chain. Also gets the
4143 descriptor and data pointer. The range of vector subscripts is the size
4144 of the vector. Array bounds are also checked. */
4147 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4154 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4157 /* Determine the rank of the loop. */
4158 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4160 switch (ss
->info
->type
)
4162 case GFC_SS_SECTION
:
4163 case GFC_SS_CONSTRUCTOR
:
4164 case GFC_SS_FUNCTION
:
4165 case GFC_SS_COMPONENT
:
4166 loop
->dimen
= ss
->dimen
;
4169 /* As usual, lbound and ubound are exceptions!. */
4170 case GFC_SS_INTRINSIC
:
4171 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4173 case GFC_ISYM_LBOUND
:
4174 case GFC_ISYM_UBOUND
:
4175 case GFC_ISYM_LCOBOUND
:
4176 case GFC_ISYM_UCOBOUND
:
4177 case GFC_ISYM_THIS_IMAGE
:
4178 loop
->dimen
= ss
->dimen
;
4190 /* We should have determined the rank of the expression by now. If
4191 not, that's bad news. */
4195 /* Loop over all the SS in the chain. */
4196 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4198 gfc_ss_info
*ss_info
;
4199 gfc_array_info
*info
;
4203 expr
= ss_info
->expr
;
4204 info
= &ss_info
->data
.array
;
4206 if (expr
&& expr
->shape
&& !info
->shape
)
4207 info
->shape
= expr
->shape
;
4209 switch (ss_info
->type
)
4211 case GFC_SS_SECTION
:
4212 /* Get the descriptor for the array. If it is a cross loops array,
4213 we got the descriptor already in the outermost loop. */
4214 if (ss
->parent
== NULL
)
4215 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4216 !loop
->array_parameter
);
4218 for (n
= 0; n
< ss
->dimen
; n
++)
4219 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4222 case GFC_SS_INTRINSIC
:
4223 switch (expr
->value
.function
.isym
->id
)
4225 /* Fall through to supply start and stride. */
4226 case GFC_ISYM_LBOUND
:
4227 case GFC_ISYM_UBOUND
:
4231 /* This is the variant without DIM=... */
4232 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4234 arg
= expr
->value
.function
.actual
->expr
;
4235 if (arg
->rank
== -1)
4240 /* The rank (hence the return value's shape) is unknown,
4241 we have to retrieve it. */
4242 gfc_init_se (&se
, NULL
);
4243 se
.descriptor_only
= 1;
4244 gfc_conv_expr (&se
, arg
);
4245 /* This is a bare variable, so there is no preliminary
4247 gcc_assert (se
.pre
.head
== NULL_TREE
4248 && se
.post
.head
== NULL_TREE
);
4249 rank
= gfc_conv_descriptor_rank (se
.expr
);
4250 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4251 gfc_array_index_type
,
4252 fold_convert (gfc_array_index_type
,
4254 gfc_index_one_node
);
4255 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4256 info
->start
[0] = gfc_index_zero_node
;
4257 info
->stride
[0] = gfc_index_one_node
;
4260 /* Otherwise fall through GFC_SS_FUNCTION. */
4263 case GFC_ISYM_LCOBOUND
:
4264 case GFC_ISYM_UCOBOUND
:
4265 case GFC_ISYM_THIS_IMAGE
:
4273 case GFC_SS_CONSTRUCTOR
:
4274 case GFC_SS_FUNCTION
:
4275 for (n
= 0; n
< ss
->dimen
; n
++)
4277 int dim
= ss
->dim
[n
];
4279 info
->start
[dim
] = gfc_index_zero_node
;
4280 info
->end
[dim
] = gfc_index_zero_node
;
4281 info
->stride
[dim
] = gfc_index_one_node
;
4290 /* The rest is just runtime bound checking. */
4291 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4294 tree lbound
, ubound
;
4296 tree size
[GFC_MAX_DIMENSIONS
];
4297 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4298 gfc_array_info
*info
;
4302 gfc_start_block (&block
);
4304 for (n
= 0; n
< loop
->dimen
; n
++)
4305 size
[n
] = NULL_TREE
;
4307 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4310 gfc_ss_info
*ss_info
;
4313 const char *expr_name
;
4316 if (ss_info
->type
!= GFC_SS_SECTION
)
4319 /* Catch allocatable lhs in f2003. */
4320 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
4323 expr
= ss_info
->expr
;
4324 expr_loc
= &expr
->where
;
4325 expr_name
= expr
->symtree
->name
;
4327 gfc_start_block (&inner
);
4329 /* TODO: range checking for mapped dimensions. */
4330 info
= &ss_info
->data
.array
;
4332 /* This code only checks ranges. Elemental and vector
4333 dimensions are checked later. */
4334 for (n
= 0; n
< loop
->dimen
; n
++)
4339 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4342 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4343 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4344 check_upper
= false;
4348 /* Zero stride is not allowed. */
4349 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4350 info
->stride
[dim
], gfc_index_zero_node
);
4351 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4352 "of array '%s'", dim
+ 1, expr_name
);
4353 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4357 desc
= info
->descriptor
;
4359 /* This is the run-time equivalent of resolve.c's
4360 check_dimension(). The logical is more readable there
4361 than it is here, with all the trees. */
4362 lbound
= gfc_conv_array_lbound (desc
, dim
);
4363 end
= info
->end
[dim
];
4365 ubound
= gfc_conv_array_ubound (desc
, dim
);
4369 /* non_zerosized is true when the selected range is not
4371 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4372 boolean_type_node
, info
->stride
[dim
],
4373 gfc_index_zero_node
);
4374 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4375 info
->start
[dim
], end
);
4376 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4377 boolean_type_node
, stride_pos
, tmp
);
4379 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4381 info
->stride
[dim
], gfc_index_zero_node
);
4382 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4383 info
->start
[dim
], end
);
4384 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4387 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4389 stride_pos
, stride_neg
);
4391 /* Check the start of the range against the lower and upper
4392 bounds of the array, if the range is not empty.
4393 If upper bound is present, include both bounds in the
4397 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4399 info
->start
[dim
], lbound
);
4400 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4402 non_zerosized
, tmp
);
4403 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4405 info
->start
[dim
], ubound
);
4406 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4408 non_zerosized
, tmp2
);
4409 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4410 "outside of expected range (%%ld:%%ld)",
4411 dim
+ 1, expr_name
);
4412 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4414 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4415 fold_convert (long_integer_type_node
, lbound
),
4416 fold_convert (long_integer_type_node
, ubound
));
4417 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4419 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4420 fold_convert (long_integer_type_node
, lbound
),
4421 fold_convert (long_integer_type_node
, ubound
));
4426 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4428 info
->start
[dim
], lbound
);
4429 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4430 boolean_type_node
, non_zerosized
, tmp
);
4431 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4432 "below lower bound of %%ld",
4433 dim
+ 1, expr_name
);
4434 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4436 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4437 fold_convert (long_integer_type_node
, lbound
));
4441 /* Compute the last element of the range, which is not
4442 necessarily "end" (think 0:5:3, which doesn't contain 5)
4443 and check it against both lower and upper bounds. */
4445 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4446 gfc_array_index_type
, end
,
4448 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4449 gfc_array_index_type
, tmp
,
4451 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4452 gfc_array_index_type
, end
, tmp
);
4453 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4454 boolean_type_node
, tmp
, lbound
);
4455 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4456 boolean_type_node
, non_zerosized
, tmp2
);
4459 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4460 boolean_type_node
, tmp
, ubound
);
4461 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4462 boolean_type_node
, non_zerosized
, tmp3
);
4463 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4464 "outside of expected range (%%ld:%%ld)",
4465 dim
+ 1, expr_name
);
4466 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4468 fold_convert (long_integer_type_node
, tmp
),
4469 fold_convert (long_integer_type_node
, ubound
),
4470 fold_convert (long_integer_type_node
, lbound
));
4471 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4473 fold_convert (long_integer_type_node
, tmp
),
4474 fold_convert (long_integer_type_node
, ubound
),
4475 fold_convert (long_integer_type_node
, lbound
));
4480 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4481 "below lower bound of %%ld",
4482 dim
+ 1, expr_name
);
4483 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4485 fold_convert (long_integer_type_node
, tmp
),
4486 fold_convert (long_integer_type_node
, lbound
));
4490 /* Check the section sizes match. */
4491 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4492 gfc_array_index_type
, end
,
4494 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4495 gfc_array_index_type
, tmp
,
4497 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4498 gfc_array_index_type
,
4499 gfc_index_one_node
, tmp
);
4500 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4501 gfc_array_index_type
, tmp
,
4502 build_int_cst (gfc_array_index_type
, 0));
4503 /* We remember the size of the first section, and check all the
4504 others against this. */
4507 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4508 boolean_type_node
, tmp
, size
[n
]);
4509 msg
= xasprintf ("Array bound mismatch for dimension %d "
4510 "of array '%s' (%%ld/%%ld)",
4511 dim
+ 1, expr_name
);
4513 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4515 fold_convert (long_integer_type_node
, tmp
),
4516 fold_convert (long_integer_type_node
, size
[n
]));
4521 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4524 tmp
= gfc_finish_block (&inner
);
4526 /* For optional arguments, only check bounds if the argument is
4528 if (expr
->symtree
->n
.sym
->attr
.optional
4529 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4530 tmp
= build3_v (COND_EXPR
,
4531 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4532 tmp
, build_empty_stmt (input_location
));
4534 gfc_add_expr_to_block (&block
, tmp
);
4538 tmp
= gfc_finish_block (&block
);
4539 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4542 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4543 gfc_conv_ss_startstride (loop
);
4546 /* Return true if both symbols could refer to the same data object. Does
4547 not take account of aliasing due to equivalence statements. */
4550 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4551 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4553 /* Aliasing isn't possible if the symbols have different base types. */
4554 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4557 /* Pointers can point to other pointers and target objects. */
4559 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4560 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4563 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4564 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4566 if (lsym_target
&& rsym_target
4567 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4568 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4569 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4570 && (!rsym
->attr
.dimension
4571 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4578 /* Return true if the two SS could be aliased, i.e. both point to the same data
4580 /* TODO: resolve aliases based on frontend expressions. */
4583 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4587 gfc_expr
*lexpr
, *rexpr
;
4590 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4592 lexpr
= lss
->info
->expr
;
4593 rexpr
= rss
->info
->expr
;
4595 lsym
= lexpr
->symtree
->n
.sym
;
4596 rsym
= rexpr
->symtree
->n
.sym
;
4598 lsym_pointer
= lsym
->attr
.pointer
;
4599 lsym_target
= lsym
->attr
.target
;
4600 rsym_pointer
= rsym
->attr
.pointer
;
4601 rsym_target
= rsym
->attr
.target
;
4603 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4604 rsym_pointer
, rsym_target
))
4607 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4608 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4611 /* For derived types we must check all the component types. We can ignore
4612 array references as these will have the same base type as the previous
4614 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4616 if (lref
->type
!= REF_COMPONENT
)
4619 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4620 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4622 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4623 rsym_pointer
, rsym_target
))
4626 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4627 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4629 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4634 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4637 if (rref
->type
!= REF_COMPONENT
)
4640 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4641 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4643 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4644 lsym_pointer
, lsym_target
,
4645 rsym_pointer
, rsym_target
))
4648 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4649 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4651 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4652 &rref
->u
.c
.sym
->ts
))
4654 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4655 &rref
->u
.c
.component
->ts
))
4657 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4658 &rref
->u
.c
.component
->ts
))
4664 lsym_pointer
= lsym
->attr
.pointer
;
4665 lsym_target
= lsym
->attr
.target
;
4666 lsym_pointer
= lsym
->attr
.pointer
;
4667 lsym_target
= lsym
->attr
.target
;
4669 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4671 if (rref
->type
!= REF_COMPONENT
)
4674 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4675 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4677 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4678 lsym_pointer
, lsym_target
,
4679 rsym_pointer
, rsym_target
))
4682 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4683 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4685 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4694 /* Resolve array data dependencies. Creates a temporary if required. */
4695 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4699 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4705 gfc_ss_info
*ss_info
;
4706 gfc_expr
*dest_expr
;
4711 loop
->temp_ss
= NULL
;
4712 dest_expr
= dest
->info
->expr
;
4714 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4717 ss_expr
= ss_info
->expr
;
4719 if (ss_info
->array_outer_dependency
)
4725 if (ss_info
->type
!= GFC_SS_SECTION
)
4727 if (flag_realloc_lhs
4728 && dest_expr
!= ss_expr
4729 && gfc_is_reallocatable_lhs (dest_expr
)
4731 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4733 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4734 if (!nDepend
&& dest_expr
->rank
> 0
4735 && dest_expr
->ts
.type
== BT_CHARACTER
4736 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4738 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4740 if (ss_info
->type
== GFC_SS_REFERENCE
4741 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4742 ss_info
->data
.scalar
.needs_temporary
= 1;
4750 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4752 if (gfc_could_be_alias (dest
, ss
)
4753 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4761 lref
= dest_expr
->ref
;
4762 rref
= ss_expr
->ref
;
4764 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4769 for (i
= 0; i
< dest
->dimen
; i
++)
4770 for (j
= 0; j
< ss
->dimen
; j
++)
4772 && dest
->dim
[i
] == ss
->dim
[j
])
4774 /* If we don't access array elements in the same order,
4775 there is a dependency. */
4780 /* TODO : loop shifting. */
4783 /* Mark the dimensions for LOOP SHIFTING */
4784 for (n
= 0; n
< loop
->dimen
; n
++)
4786 int dim
= dest
->data
.info
.dim
[n
];
4788 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4790 else if (! gfc_is_same_range (&lref
->u
.ar
,
4791 &rref
->u
.ar
, dim
, 0))
4795 /* Put all the dimensions with dependencies in the
4798 for (n
= 0; n
< loop
->dimen
; n
++)
4800 gcc_assert (loop
->order
[n
] == n
);
4802 loop
->order
[dim
++] = n
;
4804 for (n
= 0; n
< loop
->dimen
; n
++)
4807 loop
->order
[dim
++] = n
;
4810 gcc_assert (dim
== loop
->dimen
);
4821 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4822 if (GFC_ARRAY_TYPE_P (base_type
)
4823 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4824 base_type
= gfc_get_element_type (base_type
);
4825 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4827 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4830 loop
->temp_ss
= NULL
;
4834 /* Browse through each array's information from the scalarizer and set the loop
4835 bounds according to the "best" one (per dimension), i.e. the one which
4836 provides the most information (constant bounds, shape, etc.). */
4839 set_loop_bounds (gfc_loopinfo
*loop
)
4841 int n
, dim
, spec_dim
;
4842 gfc_array_info
*info
;
4843 gfc_array_info
*specinfo
;
4847 bool dynamic
[GFC_MAX_DIMENSIONS
];
4850 bool nonoptional_arr
;
4852 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4854 loopspec
= loop
->specloop
;
4857 for (n
= 0; n
< loop
->dimen
; n
++)
4862 /* If there are both optional and nonoptional array arguments, scalarize
4863 over the nonoptional; otherwise, it does not matter as then all
4864 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4866 nonoptional_arr
= false;
4868 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4869 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4870 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4872 nonoptional_arr
= true;
4876 /* We use one SS term, and use that to determine the bounds of the
4877 loop for this dimension. We try to pick the simplest term. */
4878 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4880 gfc_ss_type ss_type
;
4882 ss_type
= ss
->info
->type
;
4883 if (ss_type
== GFC_SS_SCALAR
4884 || ss_type
== GFC_SS_TEMP
4885 || ss_type
== GFC_SS_REFERENCE
4886 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4889 info
= &ss
->info
->data
.array
;
4892 if (loopspec
[n
] != NULL
)
4894 specinfo
= &loopspec
[n
]->info
->data
.array
;
4895 spec_dim
= loopspec
[n
]->dim
[n
];
4899 /* Silence uninitialized warnings. */
4906 gcc_assert (info
->shape
[dim
]);
4907 /* The frontend has worked out the size for us. */
4910 || !integer_zerop (specinfo
->start
[spec_dim
]))
4911 /* Prefer zero-based descriptors if possible. */
4916 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4918 gfc_constructor_base base
;
4919 /* An unknown size constructor will always be rank one.
4920 Higher rank constructors will either have known shape,
4921 or still be wrapped in a call to reshape. */
4922 gcc_assert (loop
->dimen
== 1);
4924 /* Always prefer to use the constructor bounds if the size
4925 can be determined at compile time. Prefer not to otherwise,
4926 since the general case involves realloc, and it's better to
4927 avoid that overhead if possible. */
4928 base
= ss
->info
->expr
->value
.constructor
;
4929 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4930 if (!dynamic
[n
] || !loopspec
[n
])
4935 /* Avoid using an allocatable lhs in an assignment, since
4936 there might be a reallocation coming. */
4937 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4942 /* Criteria for choosing a loop specifier (most important first):
4943 doesn't need realloc
4949 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4951 else if (integer_onep (info
->stride
[dim
])
4952 && !integer_onep (specinfo
->stride
[spec_dim
]))
4954 else if (INTEGER_CST_P (info
->stride
[dim
])
4955 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4957 else if (INTEGER_CST_P (info
->start
[dim
])
4958 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4959 && integer_onep (info
->stride
[dim
])
4960 == integer_onep (specinfo
->stride
[spec_dim
])
4961 && INTEGER_CST_P (info
->stride
[dim
])
4962 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4964 /* We don't work out the upper bound.
4965 else if (INTEGER_CST_P (info->finish[n])
4966 && ! INTEGER_CST_P (specinfo->finish[n]))
4967 loopspec[n] = ss; */
4970 /* We should have found the scalarization loop specifier. If not,
4972 gcc_assert (loopspec
[n
]);
4974 info
= &loopspec
[n
]->info
->data
.array
;
4975 dim
= loopspec
[n
]->dim
[n
];
4977 /* Set the extents of this range. */
4978 cshape
= info
->shape
;
4979 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4980 && INTEGER_CST_P (info
->stride
[dim
]))
4982 loop
->from
[n
] = info
->start
[dim
];
4983 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4984 mpz_sub_ui (i
, i
, 1);
4985 /* To = from + (size - 1) * stride. */
4986 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4987 if (!integer_onep (info
->stride
[dim
]))
4988 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4989 gfc_array_index_type
, tmp
,
4991 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4992 gfc_array_index_type
,
4993 loop
->from
[n
], tmp
);
4997 loop
->from
[n
] = info
->start
[dim
];
4998 switch (loopspec
[n
]->info
->type
)
5000 case GFC_SS_CONSTRUCTOR
:
5001 /* The upper bound is calculated when we expand the
5003 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5006 case GFC_SS_SECTION
:
5007 /* Use the end expression if it exists and is not constant,
5008 so that it is only evaluated once. */
5009 loop
->to
[n
] = info
->end
[dim
];
5012 case GFC_SS_FUNCTION
:
5013 /* The loop bound will be set when we generate the call. */
5014 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5017 case GFC_SS_INTRINSIC
:
5019 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5021 /* The {l,u}bound of an assumed rank. */
5022 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5023 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5024 && expr
->value
.function
.actual
->next
->expr
== NULL
5025 && expr
->value
.function
.actual
->expr
->rank
== -1);
5027 loop
->to
[n
] = info
->end
[dim
];
5036 /* Transform everything so we have a simple incrementing variable. */
5037 if (integer_onep (info
->stride
[dim
]))
5038 info
->delta
[dim
] = gfc_index_zero_node
;
5041 /* Set the delta for this section. */
5042 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5043 /* Number of iterations is (end - start + step) / step.
5044 with start = 0, this simplifies to
5046 for (i = 0; i<=last; i++){...}; */
5047 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5048 gfc_array_index_type
, loop
->to
[n
],
5050 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5051 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5052 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5053 tmp
, build_int_cst (gfc_array_index_type
, -1));
5054 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5055 /* Make the loop variable start at 0. */
5056 loop
->from
[n
] = gfc_index_zero_node
;
5061 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5062 set_loop_bounds (loop
);
5066 /* Initialize the scalarization loop. Creates the loop variables. Determines
5067 the range of the loop variables. Creates a temporary if required.
5068 Also generates code for scalar expressions which have been
5069 moved outside the loop. */
5072 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5077 set_loop_bounds (loop
);
5079 /* Add all the scalar code that can be taken out of the loops.
5080 This may include calculating the loop bounds, so do it before
5081 allocating the temporary. */
5082 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5084 tmp_ss
= loop
->temp_ss
;
5085 /* If we want a temporary then create it. */
5088 gfc_ss_info
*tmp_ss_info
;
5090 tmp_ss_info
= tmp_ss
->info
;
5091 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5092 gcc_assert (loop
->parent
== NULL
);
5094 /* Make absolutely sure that this is a complete type. */
5095 if (tmp_ss_info
->string_length
)
5096 tmp_ss_info
->data
.temp
.type
5097 = gfc_get_character_type_len_for_eltype
5098 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5099 tmp_ss_info
->string_length
);
5101 tmp
= tmp_ss_info
->data
.temp
.type
;
5102 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5103 tmp_ss_info
->type
= GFC_SS_SECTION
;
5105 gcc_assert (tmp_ss
->dimen
!= 0);
5107 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5108 NULL_TREE
, false, true, false, where
);
5111 /* For array parameters we don't have loop variables, so don't calculate the
5113 if (!loop
->array_parameter
)
5114 gfc_set_delta (loop
);
5118 /* Calculates how to transform from loop variables to array indices for each
5119 array: once loop bounds are chosen, sets the difference (DELTA field) between
5120 loop bounds and array reference bounds, for each array info. */
5123 gfc_set_delta (gfc_loopinfo
*loop
)
5125 gfc_ss
*ss
, **loopspec
;
5126 gfc_array_info
*info
;
5130 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5132 loopspec
= loop
->specloop
;
5134 /* Calculate the translation from loop variables to array indices. */
5135 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5137 gfc_ss_type ss_type
;
5139 ss_type
= ss
->info
->type
;
5140 if (ss_type
!= GFC_SS_SECTION
5141 && ss_type
!= GFC_SS_COMPONENT
5142 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5145 info
= &ss
->info
->data
.array
;
5147 for (n
= 0; n
< ss
->dimen
; n
++)
5149 /* If we are specifying the range the delta is already set. */
5150 if (loopspec
[n
] != ss
)
5154 /* Calculate the offset relative to the loop variable.
5155 First multiply by the stride. */
5156 tmp
= loop
->from
[n
];
5157 if (!integer_onep (info
->stride
[dim
]))
5158 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5159 gfc_array_index_type
,
5160 tmp
, info
->stride
[dim
]);
5162 /* Then subtract this from our starting value. */
5163 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5164 gfc_array_index_type
,
5165 info
->start
[dim
], tmp
);
5167 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5172 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5173 gfc_set_delta (loop
);
5177 /* Calculate the size of a given array dimension from the bounds. This
5178 is simply (ubound - lbound + 1) if this expression is positive
5179 or 0 if it is negative (pick either one if it is zero). Optionally
5180 (if or_expr is present) OR the (expression != 0) condition to it. */
5183 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5188 /* Calculate (ubound - lbound + 1). */
5189 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5191 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5192 gfc_index_one_node
);
5194 /* Check whether the size for this dimension is negative. */
5195 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
5196 gfc_index_zero_node
);
5197 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5198 gfc_index_zero_node
, res
);
5200 /* Build OR expression. */
5202 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5203 boolean_type_node
, *or_expr
, cond
);
5209 /* For an array descriptor, get the total number of elements. This is just
5210 the product of the extents along from_dim to to_dim. */
5213 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5218 res
= gfc_index_one_node
;
5220 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5226 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5227 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5229 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5230 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5238 /* Full size of an array. */
5241 gfc_conv_descriptor_size (tree desc
, int rank
)
5243 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5247 /* Size of a coarray for all dimensions but the last. */
5250 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5252 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5256 /* Fills in an array descriptor, and returns the size of the array.
5257 The size will be a simple_val, ie a variable or a constant. Also
5258 calculates the offset of the base. The pointer argument overflow,
5259 which should be of integer type, will increase in value if overflow
5260 occurs during the size calculation. Returns the size of the array.
5264 for (n = 0; n < rank; n++)
5266 a.lbound[n] = specified_lower_bound;
5267 offset = offset + a.lbond[n] * stride;
5269 a.ubound[n] = specified_upper_bound;
5270 a.stride[n] = stride;
5271 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5272 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5273 stride = stride * size;
5275 for (n = rank; n < rank+corank; n++)
5276 (Set lcobound/ucobound as above.)
5277 element_size = sizeof (array element);
5280 stride = (size_t) stride;
5281 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5282 stride = stride * element_size;
5288 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5289 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5290 stmtblock_t
* descriptor_block
, tree
* overflow
,
5291 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5292 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5305 stmtblock_t thenblock
;
5306 stmtblock_t elseblock
;
5311 type
= TREE_TYPE (descriptor
);
5313 stride
= gfc_index_one_node
;
5314 offset
= gfc_index_zero_node
;
5316 /* Set the dtype before the alloc, because registration of coarrays needs
5318 if (expr
->ts
.type
== BT_CHARACTER
5319 && expr
->ts
.deferred
5320 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5322 type
= gfc_typenode_for_spec (&expr
->ts
);
5323 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5324 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5328 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5329 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5332 or_expr
= boolean_false_node
;
5334 for (n
= 0; n
< rank
; n
++)
5339 /* We have 3 possibilities for determining the size of the array:
5340 lower == NULL => lbound = 1, ubound = upper[n]
5341 upper[n] = NULL => lbound = 1, ubound = lower[n]
5342 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5345 /* Set lower bound. */
5346 gfc_init_se (&se
, NULL
);
5347 if (expr3_desc
!= NULL_TREE
)
5349 if (e3_is_array_constr
)
5350 /* The lbound of a constant array [] starts at zero, but when
5351 allocating it, the standard expects the array to start at
5353 se
.expr
= gfc_index_one_node
;
5355 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5358 else if (lower
== NULL
)
5359 se
.expr
= gfc_index_one_node
;
5362 gcc_assert (lower
[n
]);
5365 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5366 gfc_add_block_to_block (pblock
, &se
.pre
);
5370 se
.expr
= gfc_index_one_node
;
5374 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5375 gfc_rank_cst
[n
], se
.expr
);
5376 conv_lbound
= se
.expr
;
5378 /* Work out the offset for this component. */
5379 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5381 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5382 gfc_array_index_type
, offset
, tmp
);
5384 /* Set upper bound. */
5385 gfc_init_se (&se
, NULL
);
5386 if (expr3_desc
!= NULL_TREE
)
5388 if (e3_is_array_constr
)
5390 /* The lbound of a constant array [] starts at zero, but when
5391 allocating it, the standard expects the array to start at
5392 one. Therefore fix the upper bound to be
5393 (desc.ubound - desc.lbound)+ 1. */
5394 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5395 gfc_array_index_type
,
5396 gfc_conv_descriptor_ubound_get (
5397 expr3_desc
, gfc_rank_cst
[n
]),
5398 gfc_conv_descriptor_lbound_get (
5399 expr3_desc
, gfc_rank_cst
[n
]));
5400 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5401 gfc_array_index_type
, tmp
,
5402 gfc_index_one_node
);
5403 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5406 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5411 gcc_assert (ubound
);
5412 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5413 gfc_add_block_to_block (pblock
, &se
.pre
);
5414 if (ubound
->expr_type
== EXPR_FUNCTION
)
5415 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5417 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5418 gfc_rank_cst
[n
], se
.expr
);
5419 conv_ubound
= se
.expr
;
5421 /* Store the stride. */
5422 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5423 gfc_rank_cst
[n
], stride
);
5425 /* Calculate size and check whether extent is negative. */
5426 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5427 size
= gfc_evaluate_now (size
, pblock
);
5429 /* Check whether multiplying the stride by the number of
5430 elements in this dimension would overflow. We must also check
5431 whether the current dimension has zero size in order to avoid
5434 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5435 gfc_array_index_type
,
5436 fold_convert (gfc_array_index_type
,
5437 TYPE_MAX_VALUE (gfc_array_index_type
)),
5439 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5440 boolean_type_node
, tmp
, stride
),
5441 PRED_FORTRAN_OVERFLOW
);
5442 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5443 integer_one_node
, integer_zero_node
);
5444 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5445 boolean_type_node
, size
,
5446 gfc_index_zero_node
),
5447 PRED_FORTRAN_SIZE_ZERO
);
5448 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5449 integer_zero_node
, tmp
);
5450 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5452 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5454 /* Multiply the stride by the number of elements in this dimension. */
5455 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5456 gfc_array_index_type
, stride
, size
);
5457 stride
= gfc_evaluate_now (stride
, pblock
);
5460 for (n
= rank
; n
< rank
+ corank
; n
++)
5464 /* Set lower bound. */
5465 gfc_init_se (&se
, NULL
);
5466 if (lower
== NULL
|| lower
[n
] == NULL
)
5468 gcc_assert (n
== rank
+ corank
- 1);
5469 se
.expr
= gfc_index_one_node
;
5473 if (ubound
|| n
== rank
+ corank
- 1)
5475 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5476 gfc_add_block_to_block (pblock
, &se
.pre
);
5480 se
.expr
= gfc_index_one_node
;
5484 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5485 gfc_rank_cst
[n
], se
.expr
);
5487 if (n
< rank
+ corank
- 1)
5489 gfc_init_se (&se
, NULL
);
5490 gcc_assert (ubound
);
5491 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5492 gfc_add_block_to_block (pblock
, &se
.pre
);
5493 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5494 gfc_rank_cst
[n
], se
.expr
);
5498 /* The stride is the number of elements in the array, so multiply by the
5499 size of an element to get the total size. Obviously, if there is a
5500 SOURCE expression (expr3) we must use its element size. */
5501 if (expr3_elem_size
!= NULL_TREE
)
5502 tmp
= expr3_elem_size
;
5503 else if (expr3
!= NULL
)
5505 if (expr3
->ts
.type
== BT_CLASS
)
5508 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5509 gfc_add_vptr_component (sz
);
5510 gfc_add_size_component (sz
);
5511 gfc_init_se (&se_sz
, NULL
);
5512 gfc_conv_expr (&se_sz
, sz
);
5518 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5519 tmp
= TYPE_SIZE_UNIT (tmp
);
5523 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5525 /* Convert to size_t. */
5526 element_size
= fold_convert (size_type_node
, tmp
);
5529 return element_size
;
5531 *nelems
= gfc_evaluate_now (stride
, pblock
);
5532 stride
= fold_convert (size_type_node
, stride
);
5534 /* First check for overflow. Since an array of type character can
5535 have zero element_size, we must check for that before
5537 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5539 TYPE_MAX_VALUE (size_type_node
), element_size
);
5540 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5541 boolean_type_node
, tmp
, stride
),
5542 PRED_FORTRAN_OVERFLOW
);
5543 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5544 integer_one_node
, integer_zero_node
);
5545 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5546 boolean_type_node
, element_size
,
5547 build_int_cst (size_type_node
, 0)),
5548 PRED_FORTRAN_SIZE_ZERO
);
5549 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5550 integer_zero_node
, tmp
);
5551 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5553 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5555 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5556 stride
, element_size
);
5558 if (poffset
!= NULL
)
5560 offset
= gfc_evaluate_now (offset
, pblock
);
5564 if (integer_zerop (or_expr
))
5566 if (integer_onep (or_expr
))
5567 return build_int_cst (size_type_node
, 0);
5569 var
= gfc_create_var (TREE_TYPE (size
), "size");
5570 gfc_start_block (&thenblock
);
5571 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5572 thencase
= gfc_finish_block (&thenblock
);
5574 gfc_start_block (&elseblock
);
5575 gfc_add_modify (&elseblock
, var
, size
);
5576 elsecase
= gfc_finish_block (&elseblock
);
5578 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5579 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5580 gfc_add_expr_to_block (pblock
, tmp
);
5586 /* Retrieve the last ref from the chain. This routine is specific to
5587 gfc_array_allocate ()'s needs. */
5590 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5592 gfc_ref
*ref
, *prev_ref
;
5595 /* Prevent warnings for uninitialized variables. */
5596 prev_ref
= *prev_ref_in
;
5597 while (ref
&& ref
->next
!= NULL
)
5599 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5600 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5605 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5609 *prev_ref_in
= prev_ref
;
5613 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5614 the work for an ALLOCATE statement. */
5618 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5619 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5620 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5621 bool e3_is_array_constr
)
5625 tree offset
= NULL_TREE
;
5626 tree token
= NULL_TREE
;
5629 tree error
= NULL_TREE
;
5630 tree overflow
; /* Boolean storing whether size calculation overflows. */
5631 tree var_overflow
= NULL_TREE
;
5633 tree set_descriptor
;
5634 stmtblock_t set_descriptor_block
;
5635 stmtblock_t elseblock
;
5638 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5639 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5640 non_ulimate_coarray_ptr_comp
;
5644 /* Find the last reference in the chain. */
5645 if (!retrieve_last_ref (&ref
, &prev_ref
))
5648 /* Take the allocatable and coarray properties solely from the expr-ref's
5649 attributes and not from source=-expression. */
5652 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5653 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5654 non_ulimate_coarray_ptr_comp
= false;
5658 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5659 /* Pointer components in coarrayed derived types must be treated
5660 specially in that they are registered without a check if the are
5661 already associated. This does not hold for ultimate coarray
5663 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5664 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5665 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5668 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5669 a coarray. In this case it does not matter whether we are on this_image
5672 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5673 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5680 gcc_assert (coarray
);
5682 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5684 gfc_ref
*old_ref
= ref
;
5685 /* F08:C633: Array shape from expr3. */
5688 /* Find the last reference in the chain. */
5689 if (!retrieve_last_ref (&ref
, &prev_ref
))
5691 if (expr3
->expr_type
== EXPR_FUNCTION
5692 && gfc_expr_attr (expr3
).dimension
)
5697 alloc_w_e3_arr_spec
= true;
5700 /* Figure out the size of the array. */
5701 switch (ref
->u
.ar
.type
)
5707 upper
= ref
->u
.ar
.start
;
5713 lower
= ref
->u
.ar
.start
;
5714 upper
= ref
->u
.ar
.end
;
5718 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5719 || alloc_w_e3_arr_spec
);
5721 lower
= ref
->u
.ar
.as
->lower
;
5722 upper
= ref
->u
.ar
.as
->upper
;
5730 overflow
= integer_zero_node
;
5732 gfc_init_block (&set_descriptor_block
);
5733 /* Take the corank only from the actual ref and not from the coref. The
5734 later will mislead the generation of the array dimensions for allocatable/
5735 pointer components in derived types. */
5736 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5737 : ref
->u
.ar
.as
->rank
,
5738 coarray
? ref
->u
.ar
.as
->corank
: 0,
5739 &offset
, lower
, upper
,
5740 &se
->pre
, &set_descriptor_block
, &overflow
,
5741 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5742 e3_is_array_constr
, expr
);
5746 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5747 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5749 if (status
== NULL_TREE
)
5751 /* Generate the block of code handling overflow. */
5752 msg
= gfc_build_addr_expr (pchar_type_node
,
5753 gfc_build_localized_cstring_const
5754 ("Integer overflow when calculating the amount of "
5755 "memory to allocate"));
5756 error
= build_call_expr_loc (input_location
,
5757 gfor_fndecl_runtime_error
, 1, msg
);
5761 tree status_type
= TREE_TYPE (status
);
5762 stmtblock_t set_status_block
;
5764 gfc_start_block (&set_status_block
);
5765 gfc_add_modify (&set_status_block
, status
,
5766 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5767 error
= gfc_finish_block (&set_status_block
);
5771 gfc_start_block (&elseblock
);
5773 /* Allocate memory to store the data. */
5774 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5775 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5777 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5779 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5780 : gfc_conv_descriptor_data_get (se
->expr
);
5781 token
= gfc_conv_descriptor_token (se
->expr
);
5782 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5785 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5786 STRIP_NOPS (pointer
);
5788 /* The allocatable variant takes the old pointer as first argument. */
5790 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5791 status
, errmsg
, errlen
, label_finish
, expr
,
5792 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5793 else if (non_ulimate_coarray_ptr_comp
&& token
)
5794 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5795 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5797 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5799 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5803 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5804 boolean_type_node
, var_overflow
, integer_zero_node
),
5805 PRED_FORTRAN_OVERFLOW
);
5806 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5807 error
, gfc_finish_block (&elseblock
));
5810 tmp
= gfc_finish_block (&elseblock
);
5812 gfc_add_expr_to_block (&se
->pre
, tmp
);
5814 /* Update the array descriptors. */
5816 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5818 /* Pointer arrays need the span field to be set. */
5819 if (is_pointer_array (se
->expr
)
5820 || (expr
->ts
.type
== BT_CLASS
5821 && CLASS_DATA (expr
)->attr
.class_pointer
))
5823 if (expr3
&& expr3_elem_size
!= NULL_TREE
)
5824 tmp
= expr3_elem_size
;
5826 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se
->expr
)));
5827 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5828 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5831 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5832 if (status
!= NULL_TREE
)
5834 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5835 boolean_type_node
, status
,
5836 build_int_cst (TREE_TYPE (status
), 0));
5837 gfc_add_expr_to_block (&se
->pre
,
5838 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5841 build_empty_stmt (input_location
)));
5844 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5850 /* Create an array constructor from an initialization expression.
5851 We assume the frontend already did any expansions and conversions. */
5854 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5861 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5863 if (expr
->expr_type
== EXPR_VARIABLE
5864 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5865 && expr
->symtree
->n
.sym
->value
)
5866 expr
= expr
->symtree
->n
.sym
->value
;
5868 switch (expr
->expr_type
)
5871 case EXPR_STRUCTURE
:
5872 /* A single scalar or derived type value. Create an array with all
5873 elements equal to that value. */
5874 gfc_init_se (&se
, NULL
);
5876 if (expr
->expr_type
== EXPR_CONSTANT
)
5877 gfc_conv_constant (&se
, expr
);
5879 gfc_conv_structure (&se
, expr
, 1);
5881 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5882 /* This will probably eat buckets of memory for large arrays. */
5885 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5891 /* Create a vector of all the elements. */
5892 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5893 c
; c
= gfc_constructor_next (c
))
5897 /* Problems occur when we get something like
5898 integer :: a(lots) = (/(i, i=1, lots)/) */
5899 gfc_fatal_error ("The number of elements in the array "
5900 "constructor at %L requires an increase of "
5901 "the allowed %d upper limit. See "
5902 "%<-fmax-array-constructor%> option",
5903 &expr
->where
, flag_max_array_constructor
);
5906 if (mpz_cmp_si (c
->offset
, 0) != 0)
5907 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5911 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5917 mpz_add (maxval
, c
->offset
, c
->repeat
);
5918 mpz_sub_ui (maxval
, maxval
, 1);
5919 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5920 if (mpz_cmp_si (c
->offset
, 0) != 0)
5922 mpz_add_ui (maxval
, c
->offset
, 1);
5923 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5926 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5928 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5934 gfc_init_se (&se
, NULL
);
5935 switch (c
->expr
->expr_type
)
5938 gfc_conv_constant (&se
, c
->expr
);
5941 case EXPR_STRUCTURE
:
5942 gfc_conv_structure (&se
, c
->expr
, 1);
5946 /* Catch those occasional beasts that do not simplify
5947 for one reason or another, assuming that if they are
5948 standard defying the frontend will catch them. */
5949 gfc_conv_expr (&se
, c
->expr
);
5953 if (range
== NULL_TREE
)
5954 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5957 if (index
!= NULL_TREE
)
5958 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5959 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5965 return gfc_build_null_descriptor (type
);
5971 /* Create a constructor from the list of elements. */
5972 tmp
= build_constructor (type
, v
);
5973 TREE_CONSTANT (tmp
) = 1;
5978 /* Generate code to evaluate non-constant coarray cobounds. */
5981 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5982 const gfc_symbol
*sym
)
5990 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5992 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5994 /* Evaluate non-constant array bound expressions. */
5995 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5996 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5998 gfc_init_se (&se
, NULL
);
5999 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6000 gfc_add_block_to_block (pblock
, &se
.pre
);
6001 gfc_add_modify (pblock
, lbound
, se
.expr
);
6003 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6004 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6006 gfc_init_se (&se
, NULL
);
6007 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6008 gfc_add_block_to_block (pblock
, &se
.pre
);
6009 gfc_add_modify (pblock
, ubound
, se
.expr
);
6015 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6016 returns the size (in elements) of the array. */
6019 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6020 stmtblock_t
* pblock
)
6033 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6035 size
= gfc_index_one_node
;
6036 offset
= gfc_index_zero_node
;
6037 for (dim
= 0; dim
< as
->rank
; dim
++)
6039 /* Evaluate non-constant array bound expressions. */
6040 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6041 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6043 gfc_init_se (&se
, NULL
);
6044 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6045 gfc_add_block_to_block (pblock
, &se
.pre
);
6046 gfc_add_modify (pblock
, lbound
, se
.expr
);
6048 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6049 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6051 gfc_init_se (&se
, NULL
);
6052 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6053 gfc_add_block_to_block (pblock
, &se
.pre
);
6054 gfc_add_modify (pblock
, ubound
, se
.expr
);
6056 /* The offset of this dimension. offset = offset - lbound * stride. */
6057 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6059 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6062 /* The size of this dimension, and the stride of the next. */
6063 if (dim
+ 1 < as
->rank
)
6064 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6066 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6068 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6070 /* Calculate stride = size * (ubound + 1 - lbound). */
6071 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6072 gfc_array_index_type
,
6073 gfc_index_one_node
, lbound
);
6074 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6075 gfc_array_index_type
, ubound
, tmp
);
6076 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6077 gfc_array_index_type
, size
, tmp
);
6079 gfc_add_modify (pblock
, stride
, tmp
);
6081 stride
= gfc_evaluate_now (tmp
, pblock
);
6083 /* Make sure that negative size arrays are translated
6084 to being zero size. */
6085 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6086 stride
, gfc_index_zero_node
);
6087 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6088 gfc_array_index_type
, tmp
,
6089 stride
, gfc_index_zero_node
);
6090 gfc_add_modify (pblock
, stride
, tmp
);
6096 gfc_trans_array_cobounds (type
, pblock
, sym
);
6097 gfc_trans_vla_type_sizes (sym
, pblock
);
6104 /* Generate code to initialize/allocate an array variable. */
6107 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6108 gfc_wrapped_block
* block
)
6112 tree tmp
= NULL_TREE
;
6119 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6121 /* Do nothing for USEd variables. */
6122 if (sym
->attr
.use_assoc
)
6125 type
= TREE_TYPE (decl
);
6126 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6127 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6129 gfc_init_block (&init
);
6131 /* Evaluate character string length. */
6132 if (sym
->ts
.type
== BT_CHARACTER
6133 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6135 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6137 gfc_trans_vla_type_sizes (sym
, &init
);
6139 /* Emit a DECL_EXPR for this variable, which will cause the
6140 gimplifier to allocate storage, and all that good stuff. */
6141 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6142 gfc_add_expr_to_block (&init
, tmp
);
6147 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6151 type
= TREE_TYPE (type
);
6153 gcc_assert (!sym
->attr
.use_assoc
);
6154 gcc_assert (!TREE_STATIC (decl
));
6155 gcc_assert (!sym
->module
);
6157 if (sym
->ts
.type
== BT_CHARACTER
6158 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6159 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6161 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6163 /* Don't actually allocate space for Cray Pointees. */
6164 if (sym
->attr
.cray_pointee
)
6166 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6167 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6169 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6173 if (flag_stack_arrays
)
6175 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6176 space
= build_decl (sym
->declared_at
.lb
->location
,
6177 VAR_DECL
, create_tmp_var_name ("A"),
6178 TREE_TYPE (TREE_TYPE (decl
)));
6179 gfc_trans_vla_type_sizes (sym
, &init
);
6183 /* The size is the number of elements in the array, so multiply by the
6184 size of an element to get the total size. */
6185 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6186 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6187 size
, fold_convert (gfc_array_index_type
, tmp
));
6189 /* Allocate memory to hold the data. */
6190 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6191 gfc_add_modify (&init
, decl
, tmp
);
6193 /* Free the temporary. */
6194 tmp
= gfc_call_free (decl
);
6198 /* Set offset of the array. */
6199 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6200 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6202 /* Automatic arrays should not have initializers. */
6203 gcc_assert (!sym
->value
);
6205 inittree
= gfc_finish_block (&init
);
6212 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6213 where also space is located. */
6214 gfc_init_block (&init
);
6215 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6216 TREE_TYPE (space
), space
);
6217 gfc_add_expr_to_block (&init
, tmp
);
6218 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6219 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6220 gfc_add_modify (&init
, decl
, addr
);
6221 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6224 gfc_add_init_cleanup (block
, inittree
, tmp
);
6228 /* Generate entry and exit code for g77 calling convention arrays. */
6231 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6241 gfc_save_backend_locus (&loc
);
6242 gfc_set_backend_locus (&sym
->declared_at
);
6244 /* Descriptor type. */
6245 parm
= sym
->backend_decl
;
6246 type
= TREE_TYPE (parm
);
6247 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6249 gfc_start_block (&init
);
6251 if (sym
->ts
.type
== BT_CHARACTER
6252 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6253 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6255 /* Evaluate the bounds of the array. */
6256 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6258 /* Set the offset. */
6259 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6260 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6262 /* Set the pointer itself if we aren't using the parameter directly. */
6263 if (TREE_CODE (parm
) != PARM_DECL
)
6265 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6266 gfc_add_modify (&init
, parm
, tmp
);
6268 stmt
= gfc_finish_block (&init
);
6270 gfc_restore_backend_locus (&loc
);
6272 /* Add the initialization code to the start of the function. */
6274 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6276 tmp
= gfc_conv_expr_present (sym
);
6277 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6280 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6284 /* Modify the descriptor of an array parameter so that it has the
6285 correct lower bound. Also move the upper bound accordingly.
6286 If the array is not packed, it will be copied into a temporary.
6287 For each dimension we set the new lower and upper bounds. Then we copy the
6288 stride and calculate the offset for this dimension. We also work out
6289 what the stride of a packed array would be, and see it the two match.
6290 If the array need repacking, we set the stride to the values we just
6291 calculated, recalculate the offset and copy the array data.
6292 Code is also added to copy the data back at the end of the function.
6296 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6297 gfc_wrapped_block
* block
)
6304 tree stmtInit
, stmtCleanup
;
6311 tree stride
, stride2
;
6321 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6323 /* Do nothing for pointer and allocatable arrays. */
6324 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6325 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6326 || sym
->attr
.allocatable
6327 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6330 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6332 gfc_trans_g77_array (sym
, block
);
6337 gfc_save_backend_locus (&loc
);
6338 /* loc.nextc is not set by save_backend_locus but the location routines
6340 if (loc
.nextc
== NULL
)
6341 loc
.nextc
= loc
.lb
->line
;
6342 gfc_set_backend_locus (&sym
->declared_at
);
6344 /* Descriptor type. */
6345 type
= TREE_TYPE (tmpdesc
);
6346 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6347 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6349 /* For a class array the dummy array descriptor is in the _class
6351 dumdesc
= gfc_class_data_get (dumdesc
);
6353 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6354 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6355 gfc_start_block (&init
);
6357 if (sym
->ts
.type
== BT_CHARACTER
6358 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6359 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6361 checkparm
= (as
->type
== AS_EXPLICIT
6362 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6364 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6365 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6367 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6369 /* For non-constant shape arrays we only check if the first dimension
6370 is contiguous. Repacking higher dimensions wouldn't gain us
6371 anything as we still don't know the array stride. */
6372 partial
= gfc_create_var (boolean_type_node
, "partial");
6373 TREE_USED (partial
) = 1;
6374 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6375 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6376 gfc_index_one_node
);
6377 gfc_add_modify (&init
, partial
, tmp
);
6380 partial
= NULL_TREE
;
6382 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6383 here, however I think it does the right thing. */
6386 /* Set the first stride. */
6387 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6388 stride
= gfc_evaluate_now (stride
, &init
);
6390 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6391 stride
, gfc_index_zero_node
);
6392 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6393 tmp
, gfc_index_one_node
, stride
);
6394 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6395 gfc_add_modify (&init
, stride
, tmp
);
6397 /* Allow the user to disable array repacking. */
6398 stmt_unpacked
= NULL_TREE
;
6402 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6403 /* A library call to repack the array if necessary. */
6404 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6405 stmt_unpacked
= build_call_expr_loc (input_location
,
6406 gfor_fndecl_in_pack
, 1, tmp
);
6408 stride
= gfc_index_one_node
;
6410 if (warn_array_temporaries
)
6411 gfc_warning (OPT_Warray_temporaries
,
6412 "Creating array temporary at %L", &loc
);
6415 /* This is for the case where the array data is used directly without
6416 calling the repack function. */
6417 if (no_repack
|| partial
!= NULL_TREE
)
6418 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6420 stmt_packed
= NULL_TREE
;
6422 /* Assign the data pointer. */
6423 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6425 /* Don't repack unknown shape arrays when the first stride is 1. */
6426 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6427 partial
, stmt_packed
, stmt_unpacked
);
6430 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6431 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6433 offset
= gfc_index_zero_node
;
6434 size
= gfc_index_one_node
;
6436 /* Evaluate the bounds of the array. */
6437 for (n
= 0; n
< as
->rank
; n
++)
6439 if (checkparm
|| !as
->upper
[n
])
6441 /* Get the bounds of the actual parameter. */
6442 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6443 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6447 dubound
= NULL_TREE
;
6448 dlbound
= NULL_TREE
;
6451 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6452 if (!INTEGER_CST_P (lbound
))
6454 gfc_init_se (&se
, NULL
);
6455 gfc_conv_expr_type (&se
, as
->lower
[n
],
6456 gfc_array_index_type
);
6457 gfc_add_block_to_block (&init
, &se
.pre
);
6458 gfc_add_modify (&init
, lbound
, se
.expr
);
6461 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6462 /* Set the desired upper bound. */
6465 /* We know what we want the upper bound to be. */
6466 if (!INTEGER_CST_P (ubound
))
6468 gfc_init_se (&se
, NULL
);
6469 gfc_conv_expr_type (&se
, as
->upper
[n
],
6470 gfc_array_index_type
);
6471 gfc_add_block_to_block (&init
, &se
.pre
);
6472 gfc_add_modify (&init
, ubound
, se
.expr
);
6475 /* Check the sizes match. */
6478 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6482 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6483 gfc_array_index_type
, ubound
, lbound
);
6484 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6485 gfc_array_index_type
,
6486 gfc_index_one_node
, temp
);
6487 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6488 gfc_array_index_type
, dubound
,
6490 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6491 gfc_array_index_type
,
6492 gfc_index_one_node
, stride2
);
6493 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6494 gfc_array_index_type
, temp
, stride2
);
6495 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6496 "%%ld instead of %%ld", n
+1, sym
->name
);
6498 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6499 fold_convert (long_integer_type_node
, temp
),
6500 fold_convert (long_integer_type_node
, stride2
));
6507 /* For assumed shape arrays move the upper bound by the same amount
6508 as the lower bound. */
6509 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6510 gfc_array_index_type
, dubound
, dlbound
);
6511 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6512 gfc_array_index_type
, tmp
, lbound
);
6513 gfc_add_modify (&init
, ubound
, tmp
);
6515 /* The offset of this dimension. offset = offset - lbound * stride. */
6516 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6518 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6519 gfc_array_index_type
, offset
, tmp
);
6521 /* The size of this dimension, and the stride of the next. */
6522 if (n
+ 1 < as
->rank
)
6524 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6526 if (no_repack
|| partial
!= NULL_TREE
)
6528 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6530 /* Figure out the stride if not a known constant. */
6531 if (!INTEGER_CST_P (stride
))
6534 stmt_packed
= NULL_TREE
;
6537 /* Calculate stride = size * (ubound + 1 - lbound). */
6538 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6539 gfc_array_index_type
,
6540 gfc_index_one_node
, lbound
);
6541 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6542 gfc_array_index_type
, ubound
, tmp
);
6543 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6544 gfc_array_index_type
, size
, tmp
);
6548 /* Assign the stride. */
6549 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6550 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6551 gfc_array_index_type
, partial
,
6552 stmt_unpacked
, stmt_packed
);
6554 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6555 gfc_add_modify (&init
, stride
, tmp
);
6560 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6562 if (stride
&& !INTEGER_CST_P (stride
))
6564 /* Calculate size = stride * (ubound + 1 - lbound). */
6565 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6566 gfc_array_index_type
,
6567 gfc_index_one_node
, lbound
);
6568 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6569 gfc_array_index_type
,
6571 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6572 gfc_array_index_type
,
6573 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6574 gfc_add_modify (&init
, stride
, tmp
);
6579 gfc_trans_array_cobounds (type
, &init
, sym
);
6581 /* Set the offset. */
6582 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6583 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6585 gfc_trans_vla_type_sizes (sym
, &init
);
6587 stmtInit
= gfc_finish_block (&init
);
6589 /* Only do the entry/initialization code if the arg is present. */
6590 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6591 optional_arg
= (sym
->attr
.optional
6592 || (sym
->ns
->proc_name
->attr
.entry_master
6593 && sym
->attr
.dummy
));
6596 tmp
= gfc_conv_expr_present (sym
);
6597 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6598 build_empty_stmt (input_location
));
6603 stmtCleanup
= NULL_TREE
;
6606 stmtblock_t cleanup
;
6607 gfc_start_block (&cleanup
);
6609 if (sym
->attr
.intent
!= INTENT_IN
)
6611 /* Copy the data back. */
6612 tmp
= build_call_expr_loc (input_location
,
6613 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6614 gfc_add_expr_to_block (&cleanup
, tmp
);
6617 /* Free the temporary. */
6618 tmp
= gfc_call_free (tmpdesc
);
6619 gfc_add_expr_to_block (&cleanup
, tmp
);
6621 stmtCleanup
= gfc_finish_block (&cleanup
);
6623 /* Only do the cleanup if the array was repacked. */
6625 /* For a class array the dummy array descriptor is in the _class
6627 tmp
= gfc_class_data_get (dumdesc
);
6629 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6630 tmp
= gfc_conv_descriptor_data_get (tmp
);
6631 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6633 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6634 build_empty_stmt (input_location
));
6638 tmp
= gfc_conv_expr_present (sym
);
6639 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6640 build_empty_stmt (input_location
));
6644 /* We don't need to free any memory allocated by internal_pack as it will
6645 be freed at the end of the function by pop_context. */
6646 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6648 gfc_restore_backend_locus (&loc
);
6652 /* Calculate the overall offset, including subreferences. */
6654 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6655 bool subref
, gfc_expr
*expr
)
6665 /* If offset is NULL and this is not a subreferenced array, there is
6667 if (offset
== NULL_TREE
)
6670 offset
= gfc_index_zero_node
;
6675 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6677 /* Offset the data pointer for pointer assignments from arrays with
6678 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6681 /* Go past the array reference. */
6682 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6683 if (ref
->type
== REF_ARRAY
&&
6684 ref
->u
.ar
.type
!= AR_ELEMENT
)
6690 /* Calculate the offset for each subsequent subreference. */
6691 for (; ref
; ref
= ref
->next
)
6696 field
= ref
->u
.c
.component
->backend_decl
;
6697 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6698 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6700 tmp
, field
, NULL_TREE
);
6704 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6705 gfc_init_se (&start
, NULL
);
6706 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6707 gfc_add_block_to_block (block
, &start
.pre
);
6708 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6712 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6713 && ref
->u
.ar
.type
== AR_ELEMENT
);
6715 /* TODO - Add bounds checking. */
6716 stride
= gfc_index_one_node
;
6717 index
= gfc_index_zero_node
;
6718 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6723 /* Update the index. */
6724 gfc_init_se (&start
, NULL
);
6725 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6726 itmp
= gfc_evaluate_now (start
.expr
, block
);
6727 gfc_init_se (&start
, NULL
);
6728 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6729 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6730 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6731 gfc_array_index_type
, itmp
, jtmp
);
6732 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6733 gfc_array_index_type
, itmp
, stride
);
6734 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6735 gfc_array_index_type
, itmp
, index
);
6736 index
= gfc_evaluate_now (index
, block
);
6738 /* Update the stride. */
6739 gfc_init_se (&start
, NULL
);
6740 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6741 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6742 gfc_array_index_type
, start
.expr
,
6744 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6745 gfc_array_index_type
,
6746 gfc_index_one_node
, itmp
);
6747 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6748 gfc_array_index_type
, stride
, itmp
);
6749 stride
= gfc_evaluate_now (stride
, block
);
6752 /* Apply the index to obtain the array element. */
6753 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6763 /* Set the target data pointer. */
6764 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6765 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6769 /* gfc_conv_expr_descriptor needs the string length an expression
6770 so that the size of the temporary can be obtained. This is done
6771 by adding up the string lengths of all the elements in the
6772 expression. Function with non-constant expressions have their
6773 string lengths mapped onto the actual arguments using the
6774 interface mapping machinery in trans-expr.c. */
6776 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6778 gfc_interface_mapping mapping
;
6779 gfc_formal_arglist
*formal
;
6780 gfc_actual_arglist
*arg
;
6783 if (expr
->ts
.u
.cl
->length
6784 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6786 if (!expr
->ts
.u
.cl
->backend_decl
)
6787 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6791 switch (expr
->expr_type
)
6794 get_array_charlen (expr
->value
.op
.op1
, se
);
6796 /* For parentheses the expression ts.u.cl is identical. */
6797 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6800 expr
->ts
.u
.cl
->backend_decl
=
6801 gfc_create_var (gfc_charlen_type_node
, "sln");
6803 if (expr
->value
.op
.op2
)
6805 get_array_charlen (expr
->value
.op
.op2
, se
);
6807 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6809 /* Add the string lengths and assign them to the expression
6810 string length backend declaration. */
6811 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6812 fold_build2_loc (input_location
, PLUS_EXPR
,
6813 gfc_charlen_type_node
,
6814 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6815 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6818 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6819 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6823 if (expr
->value
.function
.esym
== NULL
6824 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6826 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6830 /* Map expressions involving the dummy arguments onto the actual
6831 argument expressions. */
6832 gfc_init_interface_mapping (&mapping
);
6833 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6834 arg
= expr
->value
.function
.actual
;
6836 /* Set se = NULL in the calls to the interface mapping, to suppress any
6838 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6843 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6846 gfc_init_se (&tse
, NULL
);
6848 /* Build the expression for the character length and convert it. */
6849 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6851 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6852 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6853 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6854 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6855 gfc_charlen_type_node
, tse
.expr
,
6856 build_int_cst (gfc_charlen_type_node
, 0));
6857 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6858 gfc_free_interface_mapping (&mapping
);
6862 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6868 /* Helper function to check dimensions. */
6870 transposed_dims (gfc_ss
*ss
)
6874 for (n
= 0; n
< ss
->dimen
; n
++)
6875 if (ss
->dim
[n
] != n
)
6881 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6882 AR_FULL, suitable for the scalarizer. */
6885 walk_coarray (gfc_expr
*e
)
6889 gcc_assert (gfc_get_corank (e
) > 0);
6891 ss
= gfc_walk_expr (e
);
6893 /* Fix scalar coarray. */
6894 if (ss
== gfc_ss_terminator
)
6901 if (ref
->type
== REF_ARRAY
6902 && ref
->u
.ar
.codimen
> 0)
6908 gcc_assert (ref
!= NULL
);
6909 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6910 ref
->u
.ar
.type
= AR_SECTION
;
6911 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6918 /* Convert an array for passing as an actual argument. Expressions and
6919 vector subscripts are evaluated and stored in a temporary, which is then
6920 passed. For whole arrays the descriptor is passed. For array sections
6921 a modified copy of the descriptor is passed, but using the original data.
6923 This function is also used for array pointer assignments, and there
6926 - se->want_pointer && !se->direct_byref
6927 EXPR is an actual argument. On exit, se->expr contains a
6928 pointer to the array descriptor.
6930 - !se->want_pointer && !se->direct_byref
6931 EXPR is an actual argument to an intrinsic function or the
6932 left-hand side of a pointer assignment. On exit, se->expr
6933 contains the descriptor for EXPR.
6935 - !se->want_pointer && se->direct_byref
6936 EXPR is the right-hand side of a pointer assignment and
6937 se->expr is the descriptor for the previously-evaluated
6938 left-hand side. The function creates an assignment from
6942 The se->force_tmp flag disables the non-copying descriptor optimization
6943 that is used for transpose. It may be used in cases where there is an
6944 alias between the transpose argument and another argument in the same
6948 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6951 gfc_ss_type ss_type
;
6952 gfc_ss_info
*ss_info
;
6954 gfc_array_info
*info
;
6963 bool subref_array_target
= false;
6964 gfc_expr
*arg
, *ss_expr
;
6966 if (se
->want_coarray
)
6967 ss
= walk_coarray (expr
);
6969 ss
= gfc_walk_expr (expr
);
6971 gcc_assert (ss
!= NULL
);
6972 gcc_assert (ss
!= gfc_ss_terminator
);
6975 ss_type
= ss_info
->type
;
6976 ss_expr
= ss_info
->expr
;
6978 /* Special case: TRANSPOSE which needs no temporary. */
6979 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6980 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6982 /* This is a call to transpose which has already been handled by the
6983 scalarizer, so that we just need to get its argument's descriptor. */
6984 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6985 expr
= expr
->value
.function
.actual
->expr
;
6988 /* Special case things we know we can pass easily. */
6989 switch (expr
->expr_type
)
6992 /* If we have a linear array section, we can pass it directly.
6993 Otherwise we need to copy it into a temporary. */
6995 gcc_assert (ss_type
== GFC_SS_SECTION
);
6996 gcc_assert (ss_expr
== expr
);
6997 info
= &ss_info
->data
.array
;
6999 /* Get the descriptor for the array. */
7000 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7001 desc
= info
->descriptor
;
7003 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7004 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7005 && !subref_array_target
;
7012 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7014 /* Create a new descriptor if the array doesn't have one. */
7017 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7019 else if (se
->direct_byref
)
7022 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7024 if (full
&& !transposed_dims (ss
))
7026 if (se
->direct_byref
&& !se
->byref_noassign
)
7028 /* Copy the descriptor for pointer assignments. */
7029 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7031 /* Add any offsets from subreferences. */
7032 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7033 subref_array_target
, expr
);
7035 /* ....and set the span field. */
7036 tmp
= get_array_span (desc
, expr
);
7037 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7039 else if (se
->want_pointer
)
7041 /* We pass full arrays directly. This means that pointers and
7042 allocatable arrays should also work. */
7043 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7050 if (expr
->ts
.type
== BT_CHARACTER
)
7051 se
->string_length
= gfc_get_expr_charlen (expr
);
7053 gfc_free_ss_chain (ss
);
7059 /* A transformational function return value will be a temporary
7060 array descriptor. We still need to go through the scalarizer
7061 to create the descriptor. Elemental functions are handled as
7062 arbitrary expressions, i.e. copy to a temporary. */
7064 if (se
->direct_byref
)
7066 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7068 /* For pointer assignments pass the descriptor directly. */
7072 gcc_assert (se
->ss
== ss
);
7074 if (!is_pointer_array (se
->expr
))
7076 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7077 tmp
= fold_convert (gfc_array_index_type
,
7078 size_in_bytes (tmp
));
7079 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7082 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7083 gfc_conv_expr (se
, expr
);
7085 gfc_free_ss_chain (ss
);
7089 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7091 if (ss_expr
!= expr
)
7092 /* Elemental function. */
7093 gcc_assert ((expr
->value
.function
.esym
!= NULL
7094 && expr
->value
.function
.esym
->attr
.elemental
)
7095 || (expr
->value
.function
.isym
!= NULL
7096 && expr
->value
.function
.isym
->elemental
)
7097 || gfc_inline_intrinsic_function_p (expr
));
7099 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7102 if (expr
->ts
.type
== BT_CHARACTER
7103 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7104 get_array_charlen (expr
, se
);
7110 /* Transformational function. */
7111 info
= &ss_info
->data
.array
;
7117 /* Constant array constructors don't need a temporary. */
7118 if (ss_type
== GFC_SS_CONSTRUCTOR
7119 && expr
->ts
.type
!= BT_CHARACTER
7120 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7123 info
= &ss_info
->data
.array
;
7133 /* Something complicated. Copy it into a temporary. */
7139 /* If we are creating a temporary, we don't need to bother about aliases
7144 gfc_init_loopinfo (&loop
);
7146 /* Associate the SS with the loop. */
7147 gfc_add_ss_to_loop (&loop
, ss
);
7149 /* Tell the scalarizer not to bother creating loop variables, etc. */
7151 loop
.array_parameter
= 1;
7153 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7154 gcc_assert (!se
->direct_byref
);
7156 /* Setup the scalarizing loops and bounds. */
7157 gfc_conv_ss_startstride (&loop
);
7161 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
7162 get_array_charlen (expr
, se
);
7164 /* Tell the scalarizer to make a temporary. */
7165 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7166 ((expr
->ts
.type
== BT_CHARACTER
)
7167 ? expr
->ts
.u
.cl
->backend_decl
7171 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7172 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7173 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7176 gfc_conv_loop_setup (&loop
, & expr
->where
);
7180 /* Copy into a temporary and pass that. We don't need to copy the data
7181 back because expressions and vector subscripts must be INTENT_IN. */
7182 /* TODO: Optimize passing function return values. */
7187 /* Start the copying loops. */
7188 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7189 gfc_mark_ss_chain_used (ss
, 1);
7190 gfc_start_scalarized_body (&loop
, &block
);
7192 /* Copy each data element. */
7193 gfc_init_se (&lse
, NULL
);
7194 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7195 gfc_init_se (&rse
, NULL
);
7196 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7198 lse
.ss
= loop
.temp_ss
;
7201 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7202 if (expr
->ts
.type
== BT_CHARACTER
)
7204 gfc_conv_expr (&rse
, expr
);
7205 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7206 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7210 gfc_conv_expr_val (&rse
, expr
);
7212 gfc_add_block_to_block (&block
, &rse
.pre
);
7213 gfc_add_block_to_block (&block
, &lse
.pre
);
7215 lse
.string_length
= rse
.string_length
;
7217 deep_copy
= !se
->data_not_needed
7218 && (expr
->expr_type
== EXPR_VARIABLE
7219 || expr
->expr_type
== EXPR_ARRAY
);
7220 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7222 gfc_add_expr_to_block (&block
, tmp
);
7224 /* Finish the copying loops. */
7225 gfc_trans_scalarizing_loops (&loop
, &block
);
7227 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7229 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7231 desc
= info
->descriptor
;
7232 se
->string_length
= ss_info
->string_length
;
7236 /* We pass sections without copying to a temporary. Make a new
7237 descriptor and point it at the section we want. The loop variable
7238 limits will be the limits of the section.
7239 A function may decide to repack the array to speed up access, but
7240 we're not bothered about that here. */
7241 int dim
, ndim
, codim
;
7248 bool onebased
= false, rank_remap
;
7250 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7251 rank_remap
= ss
->dimen
< ndim
;
7253 if (se
->want_coarray
)
7255 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7257 codim
= gfc_get_corank (expr
);
7258 for (n
= 0; n
< codim
- 1; n
++)
7260 /* Make sure we are not lost somehow. */
7261 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7263 /* Make sure the call to gfc_conv_section_startstride won't
7264 generate unnecessary code to calculate stride. */
7265 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7267 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7268 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7269 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7272 gcc_assert (n
== codim
- 1);
7273 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7274 info
->descriptor
, n
+ ndim
, true,
7275 ar
->as
->type
== AS_DEFERRED
);
7276 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7281 /* Set the string_length for a character array. */
7282 if (expr
->ts
.type
== BT_CHARACTER
)
7283 se
->string_length
= gfc_get_expr_charlen (expr
);
7285 /* If we have an array section or are assigning make sure that
7286 the lower bound is 1. References to the full
7287 array should otherwise keep the original bounds. */
7288 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7289 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7290 if (!integer_onep (loop
.from
[dim
]))
7292 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7293 gfc_array_index_type
, gfc_index_one_node
,
7295 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7296 gfc_array_index_type
,
7298 loop
.from
[dim
] = gfc_index_one_node
;
7301 desc
= info
->descriptor
;
7302 if (se
->direct_byref
&& !se
->byref_noassign
)
7304 /* For pointer assignments we fill in the destination.... */
7306 parmtype
= TREE_TYPE (parm
);
7308 /* ....and set the span field. */
7309 tmp
= get_array_span (desc
, expr
);
7310 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7314 /* Otherwise make a new one. */
7315 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7316 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7317 loop
.from
, loop
.to
, 0,
7318 GFC_ARRAY_UNKNOWN
, false);
7319 parm
= gfc_create_var (parmtype
, "parm");
7321 /* When expression is a class object, then add the class' handle to
7323 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7325 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7328 /* class_expr can be NULL, when no _class ref is in expr.
7329 We must not fix this here with a gfc_fix_class_ref (). */
7332 gfc_init_se (&classse
, NULL
);
7333 gfc_conv_expr (&classse
, class_expr
);
7334 gfc_free_expr (class_expr
);
7336 gcc_assert (classse
.pre
.head
== NULL_TREE
7337 && classse
.post
.head
== NULL_TREE
);
7338 gfc_allocate_lang_decl (parm
);
7339 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7344 offset
= gfc_index_zero_node
;
7346 /* The following can be somewhat confusing. We have two
7347 descriptors, a new one and the original array.
7348 {parm, parmtype, dim} refer to the new one.
7349 {desc, type, n, loop} refer to the original, which maybe
7350 a descriptorless array.
7351 The bounds of the scalarization are the bounds of the section.
7352 We don't have to worry about numeric overflows when calculating
7353 the offsets because all elements are within the array data. */
7355 /* Set the dtype. */
7356 tmp
= gfc_conv_descriptor_dtype (parm
);
7357 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7359 /* Set offset for assignments to pointer only to zero if it is not
7361 if ((se
->direct_byref
|| se
->use_offset
)
7362 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7363 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7364 base
= gfc_index_zero_node
;
7365 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7366 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7370 for (n
= 0; n
< ndim
; n
++)
7372 stride
= gfc_conv_array_stride (desc
, n
);
7374 /* Work out the offset. */
7376 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7378 gcc_assert (info
->subscript
[n
]
7379 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7380 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7384 /* Evaluate and remember the start of the section. */
7385 start
= info
->start
[n
];
7386 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7389 tmp
= gfc_conv_array_lbound (desc
, n
);
7390 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7392 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7394 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7398 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7400 /* For elemental dimensions, we only need the offset. */
7404 /* Vector subscripts need copying and are handled elsewhere. */
7406 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7408 /* look for the corresponding scalarizer dimension: dim. */
7409 for (dim
= 0; dim
< ndim
; dim
++)
7410 if (ss
->dim
[dim
] == n
)
7413 /* loop exited early: the DIM being looked for has been found. */
7414 gcc_assert (dim
< ndim
);
7416 /* Set the new lower bound. */
7417 from
= loop
.from
[dim
];
7420 onebased
= integer_onep (from
);
7421 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7422 gfc_rank_cst
[dim
], from
);
7424 /* Set the new upper bound. */
7425 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7426 gfc_rank_cst
[dim
], to
);
7428 /* Multiply the stride by the section stride to get the
7430 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7431 gfc_array_index_type
,
7432 stride
, info
->stride
[n
]);
7434 if ((se
->direct_byref
|| se
->use_offset
)
7435 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7436 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7438 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7439 TREE_TYPE (base
), base
, stride
);
7441 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7444 tmp
= gfc_conv_array_lbound (desc
, n
);
7445 toonebased
= integer_onep (tmp
);
7446 // lb(arr) - from (- start + 1)
7447 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7448 TREE_TYPE (base
), tmp
, from
);
7449 if (onebased
&& toonebased
)
7451 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7452 TREE_TYPE (base
), tmp
, start
);
7453 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7454 TREE_TYPE (base
), tmp
,
7455 gfc_index_one_node
);
7457 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7458 TREE_TYPE (base
), tmp
,
7459 gfc_conv_array_stride (desc
, n
));
7460 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7461 TREE_TYPE (base
), tmp
, base
);
7464 /* Store the new stride. */
7465 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7466 gfc_rank_cst
[dim
], stride
);
7469 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7471 from
= loop
.from
[n
];
7473 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7474 gfc_rank_cst
[n
], from
);
7475 if (n
< loop
.dimen
+ codim
- 1)
7476 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7477 gfc_rank_cst
[n
], to
);
7480 if (se
->data_not_needed
)
7481 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7482 gfc_index_zero_node
);
7484 /* Point the data pointer at the 1st element in the section. */
7485 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7486 subref_array_target
, expr
);
7488 /* Force the offset to be -1, when the lower bound of the highest
7489 dimension is one and the symbol is present and is not a
7490 pointer/allocatable or associated. */
7491 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7492 && !se
->data_not_needed
)
7493 || (se
->use_offset
&& base
!= NULL_TREE
))
7495 /* Set the offset depending on base. */
7496 tmp
= rank_remap
&& !se
->direct_byref
?
7497 fold_build2_loc (input_location
, PLUS_EXPR
,
7498 gfc_array_index_type
, base
,
7501 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7503 else if (IS_CLASS_ARRAY (expr
) && !se
->data_not_needed
7504 && (!rank_remap
|| se
->use_offset
)
7505 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7507 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7508 gfc_conv_descriptor_offset_get (desc
));
7510 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7512 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7513 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7514 && !expr
->symtree
->n
.sym
->attr
.allocatable
7515 && !expr
->symtree
->n
.sym
->attr
.pointer
7516 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7517 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7519 /* Set the offset to -1. */
7521 mpz_init_set_si (minus_one
, -1);
7522 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7523 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7527 /* Only the callee knows what the correct offset it, so just set
7529 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7534 /* For class arrays add the class tree into the saved descriptor to
7535 enable getting of _vptr and the like. */
7536 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7537 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7539 gfc_allocate_lang_decl (desc
);
7540 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7541 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7542 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7543 : expr
->symtree
->n
.sym
->backend_decl
;
7545 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7546 && IS_CLASS_ARRAY (expr
))
7549 gfc_allocate_lang_decl (desc
);
7550 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7551 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7552 vtype
= gfc_class_vptr_get (tmp
);
7553 gfc_add_modify (&se
->pre
, vtype
,
7554 gfc_build_addr_expr (TREE_TYPE (vtype
),
7555 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7557 if (!se
->direct_byref
|| se
->byref_noassign
)
7559 /* Get a pointer to the new descriptor. */
7560 if (se
->want_pointer
)
7561 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7566 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7567 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7569 /* Cleanup the scalarizer. */
7570 gfc_cleanup_loop (&loop
);
7573 /* Helper function for gfc_conv_array_parameter if array size needs to be
7577 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7580 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7581 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7582 else if (expr
->rank
> 1)
7583 *size
= build_call_expr_loc (input_location
,
7584 gfor_fndecl_size0
, 1,
7585 gfc_build_addr_expr (NULL
, desc
));
7588 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7589 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7591 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7592 gfc_array_index_type
, ubound
, lbound
);
7593 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7594 *size
, gfc_index_one_node
);
7595 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7596 *size
, gfc_index_zero_node
);
7598 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7599 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7600 *size
, fold_convert (gfc_array_index_type
, elem
));
7603 /* Convert an array for passing as an actual parameter. */
7604 /* TODO: Optimize passing g77 arrays. */
7607 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7608 const gfc_symbol
*fsym
, const char *proc_name
,
7613 tree tmp
= NULL_TREE
;
7615 tree parent
= DECL_CONTEXT (current_function_decl
);
7616 bool full_array_var
;
7617 bool this_array_result
;
7620 bool array_constructor
;
7621 bool good_allocatable
;
7622 bool ultimate_ptr_comp
;
7623 bool ultimate_alloc_comp
;
7628 ultimate_ptr_comp
= false;
7629 ultimate_alloc_comp
= false;
7631 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7633 if (ref
->next
== NULL
)
7636 if (ref
->type
== REF_COMPONENT
)
7638 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7639 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7643 full_array_var
= false;
7646 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7647 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7649 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7651 /* The symbol should have an array specification. */
7652 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7654 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7656 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7657 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7658 se
->string_length
= tmp
;
7661 /* Is this the result of the enclosing procedure? */
7662 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7663 if (this_array_result
7664 && (sym
->backend_decl
!= current_function_decl
)
7665 && (sym
->backend_decl
!= parent
))
7666 this_array_result
= false;
7668 /* Passing address of the array if it is not pointer or assumed-shape. */
7669 if (full_array_var
&& g77
&& !this_array_result
7670 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7672 tmp
= gfc_get_symbol_decl (sym
);
7674 if (sym
->ts
.type
== BT_CHARACTER
)
7675 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7677 if (!sym
->attr
.pointer
7679 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7680 && sym
->as
->type
!= AS_DEFERRED
7681 && sym
->as
->type
!= AS_ASSUMED_RANK
7682 && !sym
->attr
.allocatable
)
7684 /* Some variables are declared directly, others are declared as
7685 pointers and allocated on the heap. */
7686 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7689 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7691 array_parameter_size (tmp
, expr
, size
);
7695 if (sym
->attr
.allocatable
)
7697 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7699 gfc_conv_expr_descriptor (se
, expr
);
7703 array_parameter_size (tmp
, expr
, size
);
7704 se
->expr
= gfc_conv_array_data (tmp
);
7709 /* A convenient reduction in scope. */
7710 contiguous
= g77
&& !this_array_result
&& contiguous
;
7712 /* There is no need to pack and unpack the array, if it is contiguous
7713 and not a deferred- or assumed-shape array, or if it is simply
7715 no_pack
= ((sym
&& sym
->as
7716 && !sym
->attr
.pointer
7717 && sym
->as
->type
!= AS_DEFERRED
7718 && sym
->as
->type
!= AS_ASSUMED_RANK
7719 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7721 (ref
&& ref
->u
.ar
.as
7722 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7723 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7724 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7726 gfc_is_simply_contiguous (expr
, false, true));
7728 no_pack
= contiguous
&& no_pack
;
7730 /* Array constructors are always contiguous and do not need packing. */
7731 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7733 /* Same is true of contiguous sections from allocatable variables. */
7734 good_allocatable
= contiguous
7736 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7738 /* Or ultimate allocatable components. */
7739 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7741 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7743 gfc_conv_expr_descriptor (se
, expr
);
7744 /* Deallocate the allocatable components of structures that are
7746 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7747 && expr
->ts
.u
.derived
->attr
.alloc_comp
7748 && expr
->expr_type
!= EXPR_VARIABLE
)
7750 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7752 /* The components shall be deallocated before their containing entity. */
7753 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7755 if (expr
->ts
.type
== BT_CHARACTER
)
7756 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7758 array_parameter_size (se
->expr
, expr
, size
);
7759 se
->expr
= gfc_conv_array_data (se
->expr
);
7763 if (this_array_result
)
7765 /* Result of the enclosing function. */
7766 gfc_conv_expr_descriptor (se
, expr
);
7768 array_parameter_size (se
->expr
, expr
, size
);
7769 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7771 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7772 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7773 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7780 /* Every other type of array. */
7781 se
->want_pointer
= 1;
7782 gfc_conv_expr_descriptor (se
, expr
);
7785 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7790 /* Deallocate the allocatable components of structures that are
7791 not variable, for descriptorless arguments.
7792 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7793 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7794 && expr
->ts
.u
.derived
->attr
.alloc_comp
7795 && expr
->expr_type
!= EXPR_VARIABLE
)
7797 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7798 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7800 /* The components shall be deallocated before their containing entity. */
7801 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7804 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7805 && !gfc_is_simply_contiguous (expr
, false, true)))
7807 tree origptr
= NULL_TREE
;
7811 /* For contiguous arrays, save the original value of the descriptor. */
7814 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7815 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7816 tmp
= gfc_conv_array_data (tmp
);
7817 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7818 TREE_TYPE (origptr
), origptr
,
7819 fold_convert (TREE_TYPE (origptr
), tmp
));
7820 gfc_add_expr_to_block (&se
->pre
, tmp
);
7823 /* Repack the array. */
7824 if (warn_array_temporaries
)
7827 gfc_warning (OPT_Warray_temporaries
,
7828 "Creating array temporary at %L for argument %qs",
7829 &expr
->where
, fsym
->name
);
7831 gfc_warning (OPT_Warray_temporaries
,
7832 "Creating array temporary at %L", &expr
->where
);
7835 ptr
= build_call_expr_loc (input_location
,
7836 gfor_fndecl_in_pack
, 1, desc
);
7838 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7840 tmp
= gfc_conv_expr_present (sym
);
7841 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7842 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7843 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7846 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7848 /* Use the packed data for the actual argument, except for contiguous arrays,
7849 where the descriptor's data component is set. */
7854 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7856 gfc_ss
* ss
= gfc_walk_expr (expr
);
7857 if (!transposed_dims (ss
))
7858 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7861 tree old_field
, new_field
;
7863 /* The original descriptor has transposed dims so we can't reuse
7864 it directly; we have to create a new one. */
7865 tree old_desc
= tmp
;
7866 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7868 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7869 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7870 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7872 old_field
= gfc_conv_descriptor_offset (old_desc
);
7873 new_field
= gfc_conv_descriptor_offset (new_desc
);
7874 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7876 for (int i
= 0; i
< expr
->rank
; i
++)
7878 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7879 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7880 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7882 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7885 if (flag_coarray
== GFC_FCOARRAY_LIB
7886 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7887 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7888 == GFC_ARRAY_ALLOCATABLE
)
7890 old_field
= gfc_conv_descriptor_token (old_desc
);
7891 new_field
= gfc_conv_descriptor_token (new_desc
);
7892 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7895 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7896 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7901 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7905 if (fsym
&& proc_name
)
7906 msg
= xasprintf ("An array temporary was created for argument "
7907 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7909 msg
= xasprintf ("An array temporary was created");
7911 tmp
= build_fold_indirect_ref_loc (input_location
,
7913 tmp
= gfc_conv_array_data (tmp
);
7914 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7915 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7917 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7918 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7920 gfc_conv_expr_present (sym
), tmp
);
7922 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7927 gfc_start_block (&block
);
7929 /* Copy the data back. */
7930 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7932 tmp
= build_call_expr_loc (input_location
,
7933 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7934 gfc_add_expr_to_block (&block
, tmp
);
7937 /* Free the temporary. */
7938 tmp
= gfc_call_free (ptr
);
7939 gfc_add_expr_to_block (&block
, tmp
);
7941 stmt
= gfc_finish_block (&block
);
7943 gfc_init_block (&block
);
7944 /* Only if it was repacked. This code needs to be executed before the
7945 loop cleanup code. */
7946 tmp
= build_fold_indirect_ref_loc (input_location
,
7948 tmp
= gfc_conv_array_data (tmp
);
7949 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7950 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7952 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7953 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7955 gfc_conv_expr_present (sym
), tmp
);
7957 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7959 gfc_add_expr_to_block (&block
, tmp
);
7960 gfc_add_block_to_block (&block
, &se
->post
);
7962 gfc_init_block (&se
->post
);
7964 /* Reset the descriptor pointer. */
7967 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7968 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7971 gfc_add_block_to_block (&se
->post
, &block
);
7976 /* This helper function calculates the size in words of a full array. */
7979 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7984 idx
= gfc_rank_cst
[rank
- 1];
7985 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7986 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7987 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7989 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7990 tmp
, gfc_index_one_node
);
7991 tmp
= gfc_evaluate_now (tmp
, block
);
7993 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7994 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7996 return gfc_evaluate_now (tmp
, block
);
8000 /* Allocate dest to the same size as src, and copy src -> dest.
8001 If no_malloc is set, only the copy is done. */
8004 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8005 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8006 tree add_when_allocated
)
8015 /* If the source is null, set the destination to null. Then,
8016 allocate memory to the destination. */
8017 gfc_init_block (&block
);
8019 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8021 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8022 null_data
= gfc_finish_block (&block
);
8024 gfc_init_block (&block
);
8025 if (str_sz
!= NULL_TREE
)
8028 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8032 tmp
= gfc_call_malloc (&block
, type
, size
);
8033 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8038 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8039 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8040 fold_convert (size_type_node
, size
));
8041 gfc_add_expr_to_block (&block
, tmp
);
8046 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8047 null_data
= gfc_finish_block (&block
);
8049 gfc_init_block (&block
);
8051 nelems
= gfc_full_array_size (&block
, src
, rank
);
8053 nelems
= gfc_index_one_node
;
8055 if (str_sz
!= NULL_TREE
)
8056 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8058 tmp
= fold_convert (gfc_array_index_type
,
8059 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8060 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8064 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8065 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8066 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8069 /* We know the temporary and the value will be the same length,
8070 so can use memcpy. */
8073 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8074 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8075 gfc_conv_descriptor_data_get (dest
),
8076 gfc_conv_descriptor_data_get (src
),
8077 fold_convert (size_type_node
, size
));
8078 gfc_add_expr_to_block (&block
, tmp
);
8082 gfc_add_expr_to_block (&block
, add_when_allocated
);
8083 tmp
= gfc_finish_block (&block
);
8085 /* Null the destination if the source is null; otherwise do
8086 the allocate and copy. */
8087 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8090 null_cond
= gfc_conv_descriptor_data_get (src
);
8092 null_cond
= convert (pvoid_type_node
, null_cond
);
8093 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8094 null_cond
, null_pointer_node
);
8095 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8099 /* Allocate dest to the same size as src, and copy data src -> dest. */
8102 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8103 tree add_when_allocated
)
8105 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8106 NULL_TREE
, add_when_allocated
);
8110 /* Copy data src -> dest. */
8113 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8115 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8116 NULL_TREE
, NULL_TREE
);
8119 /* Allocate dest to the same size as src, but don't copy anything. */
8122 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8124 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8125 NULL_TREE
, NULL_TREE
);
8130 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8131 tree type
, int rank
)
8138 stmtblock_t block
, globalblock
;
8140 /* If the source is null, set the destination to null. Then,
8141 allocate memory to the destination. */
8142 gfc_init_block (&block
);
8143 gfc_init_block (&globalblock
);
8145 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8148 symbol_attribute attr
;
8151 gfc_init_se (&se
, NULL
);
8152 gfc_clear_attr (&attr
);
8153 attr
.allocatable
= 1;
8154 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8155 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8156 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8158 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8159 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8160 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8161 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8162 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8163 null_data
= gfc_finish_block (&block
);
8165 gfc_init_block (&block
);
8167 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8168 fold_convert (size_type_node
, size
),
8169 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8170 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8171 GFC_CAF_COARRAY_ALLOC
);
8173 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8174 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8175 fold_convert (size_type_node
, size
));
8176 gfc_add_expr_to_block (&block
, tmp
);
8180 /* Set the rank or unitialized memory access may be reported. */
8181 tmp
= gfc_conv_descriptor_dtype (dest
);
8182 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8185 nelems
= gfc_full_array_size (&block
, src
, rank
);
8187 nelems
= integer_one_node
;
8189 tmp
= fold_convert (size_type_node
,
8190 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8191 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8192 fold_convert (size_type_node
, nelems
), tmp
);
8194 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8195 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8197 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8198 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8199 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8200 null_data
= gfc_finish_block (&block
);
8202 gfc_init_block (&block
);
8203 gfc_allocate_using_caf_lib (&block
, dest
,
8204 fold_convert (size_type_node
, size
),
8205 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8206 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8207 GFC_CAF_COARRAY_ALLOC
);
8209 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8210 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8211 gfc_conv_descriptor_data_get (dest
),
8212 gfc_conv_descriptor_data_get (src
),
8213 fold_convert (size_type_node
, size
));
8214 gfc_add_expr_to_block (&block
, tmp
);
8217 tmp
= gfc_finish_block (&block
);
8219 /* Null the destination if the source is null; otherwise do
8220 the register and copy. */
8221 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8224 null_cond
= gfc_conv_descriptor_data_get (src
);
8226 null_cond
= convert (pvoid_type_node
, null_cond
);
8227 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8228 null_cond
, null_pointer_node
);
8229 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8231 return gfc_finish_block (&globalblock
);
8235 /* Helper function to abstract whether coarray processing is enabled. */
8238 caf_enabled (int caf_mode
)
8240 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8241 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8245 /* Helper function to abstract whether coarray processing is enabled
8246 and we are in a derived type coarray. */
8249 caf_in_coarray (int caf_mode
)
8251 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8252 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8253 return (caf_mode
& pat
) == pat
;
8257 /* Helper function to abstract whether coarray is to deallocate only. */
8260 gfc_caf_is_dealloc_only (int caf_mode
)
8262 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8263 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8267 /* Recursively traverse an object of derived type, generating code to
8268 deallocate, nullify or copy allocatable components. This is the work horse
8269 function for the functions named in this enum. */
8271 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8272 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8273 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8275 static gfc_actual_arglist
*pdt_param_list
;
8278 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8279 tree dest
, int rank
, int purpose
, int caf_mode
)
8283 stmtblock_t fnblock
;
8284 stmtblock_t loopbody
;
8285 stmtblock_t tmpblock
;
8296 tree null_cond
= NULL_TREE
;
8297 tree add_when_allocated
;
8298 tree dealloc_fndecl
;
8302 symbol_attribute
*attr
;
8303 bool deallocate_called
;
8305 gfc_init_block (&fnblock
);
8307 decl_type
= TREE_TYPE (decl
);
8309 if ((POINTER_TYPE_P (decl_type
))
8310 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8312 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8313 /* Deref dest in sync with decl, but only when it is not NULL. */
8315 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8317 /* Update the decl_type because it got dereferenced. */
8318 decl_type
= TREE_TYPE (decl
);
8321 /* If this is an array of derived types with allocatable components
8322 build a loop and recursively call this function. */
8323 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8324 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8326 tmp
= gfc_conv_array_data (decl
);
8327 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8329 /* Get the number of elements - 1 and set the counter. */
8330 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8332 /* Use the descriptor for an allocatable array. Since this
8333 is a full array reference, we only need the descriptor
8334 information from dimension = rank. */
8335 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8336 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8337 gfc_array_index_type
, tmp
,
8338 gfc_index_one_node
);
8340 null_cond
= gfc_conv_descriptor_data_get (decl
);
8341 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8342 boolean_type_node
, null_cond
,
8343 build_int_cst (TREE_TYPE (null_cond
), 0));
8347 /* Otherwise use the TYPE_DOMAIN information. */
8348 tmp
= array_type_nelts (decl_type
);
8349 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8352 /* Remember that this is, in fact, the no. of elements - 1. */
8353 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8354 index
= gfc_create_var (gfc_array_index_type
, "S");
8356 /* Build the body of the loop. */
8357 gfc_init_block (&loopbody
);
8359 vref
= gfc_build_array_ref (var
, index
, NULL
);
8361 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8362 && !caf_enabled (caf_mode
))
8364 tmp
= build_fold_indirect_ref_loc (input_location
,
8365 gfc_conv_array_data (dest
));
8366 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8367 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8368 COPY_ALLOC_COMP
, 0);
8371 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8374 gfc_add_expr_to_block (&loopbody
, tmp
);
8376 /* Build the loop and return. */
8377 gfc_init_loopinfo (&loop
);
8379 loop
.from
[0] = gfc_index_zero_node
;
8380 loop
.loopvar
[0] = index
;
8381 loop
.to
[0] = nelems
;
8382 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8383 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8385 tmp
= gfc_finish_block (&fnblock
);
8386 /* When copying allocateable components, the above implements the
8387 deep copy. Nevertheless is a deep copy only allowed, when the current
8388 component is allocated, for which code will be generated in
8389 gfc_duplicate_allocatable (), where the deep copy code is just added
8390 into the if's body, by adding tmp (the deep copy code) as last
8391 argument to gfc_duplicate_allocatable (). */
8392 if (purpose
== COPY_ALLOC_COMP
8393 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8394 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8396 else if (null_cond
!= NULL_TREE
)
8397 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8398 build_empty_stmt (input_location
));
8403 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8405 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8406 DEALLOCATE_PDT_COMP
, 0);
8407 gfc_add_expr_to_block (&fnblock
, tmp
);
8409 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8411 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8412 NULLIFY_ALLOC_COMP
, 0);
8413 gfc_add_expr_to_block (&fnblock
, tmp
);
8416 /* Otherwise, act on the components or recursively call self to
8417 act on a chain of components. */
8418 for (c
= der_type
->components
; c
; c
= c
->next
)
8420 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8421 || c
->ts
.type
== BT_CLASS
)
8422 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8423 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8424 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8426 cdecl = c
->backend_decl
;
8427 ctype
= TREE_TYPE (cdecl);
8431 case DEALLOCATE_ALLOC_COMP
:
8433 gfc_init_block (&tmpblock
);
8435 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8436 decl
, cdecl, NULL_TREE
);
8438 /* Shortcut to get the attributes of the component. */
8439 if (c
->ts
.type
== BT_CLASS
)
8441 attr
= &CLASS_DATA (c
)->attr
;
8442 if (attr
->class_pointer
)
8452 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8453 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8454 /* Call the finalizer, which will free the memory and nullify the
8455 pointer of an array. */
8456 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8457 caf_enabled (caf_mode
))
8460 deallocate_called
= false;
8462 /* Add the _class ref for classes. */
8463 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8464 comp
= gfc_class_data_get (comp
);
8466 add_when_allocated
= NULL_TREE
;
8467 if (cmp_has_alloc_comps
8468 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8470 && !deallocate_called
)
8472 /* Add checked deallocation of the components. This code is
8473 obviously added because the finalizer is not trusted to free
8475 if (c
->ts
.type
== BT_CLASS
)
8477 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8479 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8480 comp
, NULL_TREE
, rank
, purpose
,
8485 rank
= c
->as
? c
->as
->rank
: 0;
8486 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8493 if (attr
->allocatable
&& !same_type
8494 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8496 /* Handle all types of components besides components of the
8497 same_type as the current one, because those would create an
8500 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8501 ? (gfc_caf_is_dealloc_only (caf_mode
)
8502 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8503 : GFC_CAF_COARRAY_DEREGISTER
)
8504 : GFC_CAF_COARRAY_NOCOARRAY
;
8506 caf_token
= NULL_TREE
;
8507 /* Coarray components are handled directly by
8508 deallocate_with_status. */
8509 if (!attr
->codimension
8510 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8513 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8514 TREE_TYPE (c
->caf_token
),
8515 decl
, c
->caf_token
, NULL_TREE
);
8516 else if (attr
->dimension
&& !attr
->proc_pointer
)
8517 caf_token
= gfc_conv_descriptor_token (comp
);
8519 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8520 /* When this is an array but not in conjunction with a coarray
8521 then add the data-ref. For coarray'ed arrays the data-ref
8522 is added by deallocate_with_status. */
8523 comp
= gfc_conv_descriptor_data_get (comp
);
8525 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8526 NULL_TREE
, NULL_TREE
, true,
8527 NULL
, caf_dereg_mode
,
8528 add_when_allocated
, caf_token
);
8530 gfc_add_expr_to_block (&tmpblock
, tmp
);
8532 else if (attr
->allocatable
&& !attr
->codimension
8533 && !deallocate_called
)
8535 /* Case of recursive allocatable derived types. */
8539 stmtblock_t dealloc_block
;
8541 gfc_init_block (&dealloc_block
);
8542 if (add_when_allocated
)
8543 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8545 /* Convert the component into a rank 1 descriptor type. */
8546 if (attr
->dimension
)
8548 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8549 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8550 c
->ts
.type
== BT_CLASS
8551 ? CLASS_DATA (c
)->as
->rank
8556 tmp
= TREE_TYPE (comp
);
8557 ubound
= build_int_cst (gfc_array_index_type
, 1);
8560 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8562 GFC_ARRAY_ALLOCATABLE
, false);
8564 cdesc
= gfc_create_var (cdesc
, "cdesc");
8565 DECL_ARTIFICIAL (cdesc
) = 1;
8567 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8568 gfc_get_dtype_rank_type (1, tmp
));
8569 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8570 gfc_index_zero_node
,
8571 gfc_index_one_node
);
8572 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8573 gfc_index_zero_node
,
8574 gfc_index_one_node
);
8575 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8576 gfc_index_zero_node
, ubound
);
8578 if (attr
->dimension
)
8579 comp
= gfc_conv_descriptor_data_get (comp
);
8581 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8583 /* Now call the deallocator. */
8584 vtab
= gfc_find_vtab (&c
->ts
);
8585 if (vtab
->backend_decl
== NULL
)
8586 gfc_get_symbol_decl (vtab
);
8587 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8588 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8589 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8591 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8592 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8593 boolean_type_node
, tmp
,
8595 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8597 tmp
= build_call_expr_loc (input_location
,
8600 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8602 tmp
= gfc_finish_block (&dealloc_block
);
8604 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8605 void_type_node
, is_allocated
, tmp
,
8606 build_empty_stmt (input_location
));
8608 gfc_add_expr_to_block (&tmpblock
, tmp
);
8610 else if (add_when_allocated
)
8611 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8613 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8614 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8616 /* Finally, reset the vptr to the declared type vtable and, if
8617 necessary reset the _len field.
8619 First recover the reference to the component and obtain
8621 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8622 decl
, cdecl, NULL_TREE
);
8623 tmp
= gfc_class_vptr_get (comp
);
8625 if (UNLIMITED_POLY (c
))
8627 /* Both vptr and _len field should be nulled. */
8628 gfc_add_modify (&tmpblock
, tmp
,
8629 build_int_cst (TREE_TYPE (tmp
), 0));
8630 tmp
= gfc_class_len_get (comp
);
8631 gfc_add_modify (&tmpblock
, tmp
,
8632 build_int_cst (TREE_TYPE (tmp
), 0));
8636 /* Build the vtable address and set the vptr with it. */
8639 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8640 vtab
= vtable
->backend_decl
;
8641 if (vtab
== NULL_TREE
)
8642 vtab
= gfc_get_symbol_decl (vtable
);
8643 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8644 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8645 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8649 /* Now add the deallocation of this component. */
8650 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8653 case NULLIFY_ALLOC_COMP
:
8655 - allocatable components (regular or in class)
8656 - components that have allocatable components
8657 - pointer components when in a coarray.
8658 Skip everything else especially proc_pointers, which may come
8659 coupled with the regular pointer attribute. */
8660 if (c
->attr
.proc_pointer
8661 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8662 && CLASS_DATA (c
)->attr
.allocatable
)
8663 || (cmp_has_alloc_comps
8664 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8665 || (c
->ts
.type
== BT_CLASS
8666 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8667 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8670 /* Process class components first, because they always have the
8671 pointer-attribute set which would be caught wrong else. */
8672 if (c
->ts
.type
== BT_CLASS
8673 && (CLASS_DATA (c
)->attr
.allocatable
8674 || CLASS_DATA (c
)->attr
.class_pointer
))
8676 /* Allocatable CLASS components. */
8677 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8678 decl
, cdecl, NULL_TREE
);
8680 comp
= gfc_class_data_get (comp
);
8681 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8682 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8686 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8687 void_type_node
, comp
,
8688 build_int_cst (TREE_TYPE (comp
), 0));
8689 gfc_add_expr_to_block (&fnblock
, tmp
);
8691 cmp_has_alloc_comps
= false;
8693 /* Coarrays need the component to be nulled before the api-call
8695 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8697 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8698 decl
, cdecl, NULL_TREE
);
8699 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8700 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8703 gfc_add_modify (&fnblock
, comp
,
8704 build_int_cst (TREE_TYPE (comp
), 0));
8705 if (gfc_deferred_strlen (c
, &comp
))
8707 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8709 decl
, comp
, NULL_TREE
);
8710 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8711 TREE_TYPE (comp
), comp
,
8712 build_int_cst (TREE_TYPE (comp
), 0));
8713 gfc_add_expr_to_block (&fnblock
, tmp
);
8715 cmp_has_alloc_comps
= false;
8718 if (flag_coarray
== GFC_FCOARRAY_LIB
8719 && (caf_in_coarray (caf_mode
) || c
->attr
.codimension
))
8721 /* Register the component with the coarray library. */
8724 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8725 decl
, cdecl, NULL_TREE
);
8726 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8728 /* Set the dtype, because caf_register needs it. */
8729 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8730 gfc_get_dtype (TREE_TYPE (comp
)));
8731 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8732 decl
, cdecl, NULL_TREE
);
8733 token
= gfc_conv_descriptor_token (tmp
);
8739 gfc_init_se (&se
, NULL
);
8740 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8741 pvoid_type_node
, decl
, c
->caf_token
,
8743 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8744 c
->ts
.type
== BT_CLASS
8745 ? CLASS_DATA (c
)->attr
8747 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8750 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8751 gfc_build_addr_expr (NULL_TREE
,
8753 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8754 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8757 if (cmp_has_alloc_comps
)
8759 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8760 decl
, cdecl, NULL_TREE
);
8761 rank
= c
->as
? c
->as
->rank
: 0;
8762 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8763 rank
, purpose
, caf_mode
);
8764 gfc_add_expr_to_block (&fnblock
, tmp
);
8768 case REASSIGN_CAF_COMP
:
8769 if (caf_enabled (caf_mode
)
8770 && (c
->attr
.codimension
8771 || (c
->ts
.type
== BT_CLASS
8772 && (CLASS_DATA (c
)->attr
.coarray_comp
8773 || caf_in_coarray (caf_mode
)))
8774 || (c
->ts
.type
== BT_DERIVED
8775 && (c
->ts
.u
.derived
->attr
.coarray_comp
8776 || caf_in_coarray (caf_mode
))))
8779 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8780 decl
, cdecl, NULL_TREE
);
8781 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8782 dest
, cdecl, NULL_TREE
);
8784 if (c
->attr
.codimension
)
8786 if (c
->ts
.type
== BT_CLASS
)
8788 comp
= gfc_class_data_get (comp
);
8789 dcmp
= gfc_class_data_get (dcmp
);
8791 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8792 gfc_conv_descriptor_data_get (comp
));
8796 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8797 rank
, purpose
, caf_mode
8798 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8799 gfc_add_expr_to_block (&fnblock
, tmp
);
8804 case COPY_ALLOC_COMP
:
8805 if (c
->attr
.pointer
)
8808 /* We need source and destination components. */
8809 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8811 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8813 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8815 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8823 dst_data
= gfc_class_data_get (dcmp
);
8824 src_data
= gfc_class_data_get (comp
);
8825 size
= fold_convert (size_type_node
,
8826 gfc_class_vtab_size_get (comp
));
8828 if (CLASS_DATA (c
)->attr
.dimension
)
8830 nelems
= gfc_conv_descriptor_size (src_data
,
8831 CLASS_DATA (c
)->as
->rank
);
8832 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8833 size_type_node
, size
,
8834 fold_convert (size_type_node
,
8838 nelems
= build_int_cst (size_type_node
, 1);
8840 if (CLASS_DATA (c
)->attr
.dimension
8841 || CLASS_DATA (c
)->attr
.codimension
)
8843 src_data
= gfc_conv_descriptor_data_get (src_data
);
8844 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8847 gfc_init_block (&tmpblock
);
8849 /* Coarray component have to have the same allocation status and
8850 shape/type-parameter/effective-type on the LHS and RHS of an
8851 intrinsic assignment. Hence, we did not deallocated them - and
8852 do not allocate them here. */
8853 if (!CLASS_DATA (c
)->attr
.codimension
)
8855 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8856 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8857 gfc_add_modify (&tmpblock
, dst_data
,
8858 fold_convert (TREE_TYPE (dst_data
), tmp
));
8861 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8862 UNLIMITED_POLY (c
));
8863 gfc_add_expr_to_block (&tmpblock
, tmp
);
8864 tmp
= gfc_finish_block (&tmpblock
);
8866 gfc_init_block (&tmpblock
);
8867 gfc_add_modify (&tmpblock
, dst_data
,
8868 fold_convert (TREE_TYPE (dst_data
),
8869 null_pointer_node
));
8870 null_data
= gfc_finish_block (&tmpblock
);
8872 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8873 boolean_type_node
, src_data
,
8876 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8881 /* To implement guarded deep copy, i.e., deep copy only allocatable
8882 components that are really allocated, the deep copy code has to
8883 be generated first and then added to the if-block in
8884 gfc_duplicate_allocatable (). */
8885 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
8888 rank
= c
->as
? c
->as
->rank
: 0;
8889 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8890 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8891 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8897 add_when_allocated
= NULL_TREE
;
8899 if (gfc_deferred_strlen (c
, &tmp
))
8903 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8905 decl
, len
, NULL_TREE
);
8906 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8908 dest
, len
, NULL_TREE
);
8909 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8910 TREE_TYPE (len
), len
, tmp
);
8911 gfc_add_expr_to_block (&fnblock
, tmp
);
8912 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8913 /* This component can not have allocatable components,
8914 therefore add_when_allocated of duplicate_allocatable ()
8916 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8917 false, false, size
, NULL_TREE
);
8918 gfc_add_expr_to_block (&fnblock
, tmp
);
8920 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
&& !same_type
8921 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
8922 || caf_in_coarray (caf_mode
)))
8924 rank
= c
->as
? c
->as
->rank
: 0;
8925 if (c
->attr
.codimension
)
8926 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8927 else if (flag_coarray
== GFC_FCOARRAY_LIB
8928 && caf_in_coarray (caf_mode
))
8930 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
8931 : fold_build3_loc (input_location
,
8933 pvoid_type_node
, dest
,
8936 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
8940 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8941 add_when_allocated
);
8942 gfc_add_expr_to_block (&fnblock
, tmp
);
8945 if (cmp_has_alloc_comps
)
8946 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8950 case ALLOCATE_PDT_COMP
:
8952 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8953 decl
, cdecl, NULL_TREE
);
8955 /* Set the PDT KIND and LEN fields. */
8956 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
8959 gfc_expr
*c_expr
= NULL
;
8960 gfc_actual_arglist
*param
= pdt_param_list
;
8961 gfc_init_se (&tse
, NULL
);
8962 for (; param
; param
= param
->next
)
8963 if (!strcmp (c
->name
, param
->name
))
8964 c_expr
= param
->expr
;
8967 c_expr
= c
->initializer
;
8971 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
8972 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
8976 if (c
->attr
.pdt_string
)
8979 gfc_init_se (&tse
, NULL
);
8981 /* Convert the parameterized string length to its value. The
8982 string length is stored in a hidden field in the same way as
8983 deferred string lengths. */
8984 gfc_insert_parameter_exprs (c
->ts
.u
.cl
->length
, pdt_param_list
);
8985 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
8987 gfc_conv_expr_type (&tse
, c
->ts
.u
.cl
->length
,
8988 TREE_TYPE (strlen
));
8989 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
8991 decl
, strlen
, NULL_TREE
);
8992 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
8993 c
->ts
.u
.cl
->backend_decl
= strlen
;
8995 /* Scalar parameterizied strings can be allocated now. */
8998 tmp
= fold_convert (gfc_array_index_type
, strlen
);
8999 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9000 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9001 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9002 gfc_add_modify (&fnblock
, comp
, tmp
);
9006 /* Allocate paramterized arrays of parameterized derived types. */
9007 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9008 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9009 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9012 if (c
->ts
.type
== BT_CLASS
)
9013 comp
= gfc_class_data_get (comp
);
9015 if (c
->attr
.pdt_array
)
9019 tree size
= gfc_index_one_node
;
9020 tree offset
= gfc_index_zero_node
;
9024 /* This chunk takes the expressions for 'lower' and 'upper'
9025 in the arrayspec and substitutes in the expressions for
9026 the parameters from 'pdt_param_list'. The descriptor
9027 fields can then be filled from the values so obtained. */
9028 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9029 for (i
= 0; i
< c
->as
->rank
; i
++)
9031 gfc_init_se (&tse
, NULL
);
9032 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9033 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9034 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9037 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9040 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9041 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9042 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9045 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9048 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9051 size
= gfc_evaluate_now (size
, &fnblock
);
9052 offset
= fold_build2_loc (input_location
,
9054 gfc_array_index_type
,
9056 offset
= gfc_evaluate_now (offset
, &fnblock
);
9057 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9058 gfc_array_index_type
,
9060 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9061 gfc_array_index_type
,
9062 tmp
, gfc_index_one_node
);
9063 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9064 gfc_array_index_type
, size
, tmp
);
9066 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9067 if (c
->ts
.type
== BT_CLASS
)
9069 tmp
= gfc_get_vptr_from_expr (comp
);
9070 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9071 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9072 tmp
= gfc_vptr_size_get (tmp
);
9075 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9076 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9077 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9078 gfc_array_index_type
, size
, tmp
);
9079 size
= gfc_evaluate_now (size
, &fnblock
);
9080 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9081 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9082 tmp
= gfc_conv_descriptor_dtype (comp
);
9083 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9086 /* Recurse in to PDT components. */
9087 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9088 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9089 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9091 bool is_deferred
= false;
9092 gfc_actual_arglist
*tail
= c
->param_list
;
9094 for (; tail
; tail
= tail
->next
)
9098 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9099 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9100 c
->as
? c
->as
->rank
: 0,
9102 gfc_add_expr_to_block (&fnblock
, tmp
);
9107 case DEALLOCATE_PDT_COMP
:
9108 /* Deallocate array or parameterized string length components
9109 of parameterized derived types. */
9110 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9111 && !c
->attr
.pdt_string
9112 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9113 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9116 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9117 decl
, cdecl, NULL_TREE
);
9118 if (c
->ts
.type
== BT_CLASS
)
9119 comp
= gfc_class_data_get (comp
);
9121 /* Recurse in to PDT components. */
9122 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9123 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9124 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9126 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9127 c
->as
? c
->as
->rank
: 0);
9128 gfc_add_expr_to_block (&fnblock
, tmp
);
9131 if (c
->attr
.pdt_array
)
9133 tmp
= gfc_conv_descriptor_data_get (comp
);
9134 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9135 boolean_type_node
, tmp
,
9136 build_int_cst (TREE_TYPE (tmp
), 0));
9137 tmp
= gfc_call_free (tmp
);
9138 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9139 build_empty_stmt (input_location
));
9140 gfc_add_expr_to_block (&fnblock
, tmp
);
9141 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9143 else if (c
->attr
.pdt_string
)
9145 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9146 boolean_type_node
, comp
,
9147 build_int_cst (TREE_TYPE (comp
), 0));
9148 tmp
= gfc_call_free (comp
);
9149 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9150 build_empty_stmt (input_location
));
9151 gfc_add_expr_to_block (&fnblock
, tmp
);
9152 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9153 gfc_add_modify (&fnblock
, comp
, tmp
);
9158 case CHECK_PDT_DUMMY
:
9160 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9161 decl
, cdecl, NULL_TREE
);
9162 if (c
->ts
.type
== BT_CLASS
)
9163 comp
= gfc_class_data_get (comp
);
9165 /* Recurse in to PDT components. */
9166 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9167 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9169 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9170 c
->as
? c
->as
->rank
: 0,
9172 gfc_add_expr_to_block (&fnblock
, tmp
);
9175 if (!c
->attr
.pdt_len
)
9180 gfc_expr
*c_expr
= NULL
;
9181 gfc_actual_arglist
*param
= pdt_param_list
;
9183 gfc_init_se (&tse
, NULL
);
9184 for (; param
; param
= param
->next
)
9185 if (!strcmp (c
->name
, param
->name
))
9186 c_expr
= param
->expr
;
9190 tree error
, cond
, cname
;
9191 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9192 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9195 cname
= gfc_build_cstring_const (c
->name
);
9196 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9197 error
= gfc_trans_runtime_error (true, NULL
,
9198 "The value of the PDT LEN "
9199 "parameter '%s' does not "
9200 "agree with that in the "
9201 "dummy declaration",
9203 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9204 void_type_node
, cond
, error
,
9205 build_empty_stmt (input_location
));
9206 gfc_add_expr_to_block (&fnblock
, tmp
);
9217 return gfc_finish_block (&fnblock
);
9220 /* Recursively traverse an object of derived type, generating code to
9221 nullify allocatable components. */
9224 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9227 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9229 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9233 /* Recursively traverse an object of derived type, generating code to
9234 deallocate allocatable components. */
9237 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9240 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9241 DEALLOCATE_ALLOC_COMP
,
9242 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9246 /* Recursively traverse an object of derived type, generating code to
9247 deallocate allocatable components. But do not deallocate coarrays.
9248 To be used for intrinsic assignment, which may not change the allocation
9249 status of coarrays. */
9252 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9254 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9255 DEALLOCATE_ALLOC_COMP
, 0);
9260 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9262 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9263 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9267 /* Recursively traverse an object of derived type, generating code to
9268 copy it and its allocatable components. */
9271 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9274 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9279 /* Recursively traverse an object of derived type, generating code to
9280 copy only its allocatable components. */
9283 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9285 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9286 COPY_ONLY_ALLOC_COMP
, 0);
9290 /* Recursively traverse an object of paramterized derived type, generating
9291 code to allocate parameterized components. */
9294 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9295 gfc_actual_arglist
*param_list
)
9298 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9299 pdt_param_list
= param_list
;
9300 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9301 ALLOCATE_PDT_COMP
, 0);
9302 pdt_param_list
= old_param_list
;
9306 /* Recursively traverse an object of paramterized derived type, generating
9307 code to deallocate parameterized components. */
9310 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9312 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9313 DEALLOCATE_PDT_COMP
, 0);
9317 /* Recursively traverse a dummy of paramterized derived type to check the
9318 values of LEN parameters. */
9321 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9322 gfc_actual_arglist
*param_list
)
9325 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9326 pdt_param_list
= param_list
;
9327 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9328 CHECK_PDT_DUMMY
, 0);
9329 pdt_param_list
= old_param_list
;
9334 /* Returns the value of LBOUND for an expression. This could be broken out
9335 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9336 called by gfc_alloc_allocatable_for_assignment. */
9338 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9343 tree cond
, cond1
, cond3
, cond4
;
9347 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9349 tmp
= gfc_rank_cst
[dim
];
9350 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9351 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9352 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9353 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
9355 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
9356 stride
, gfc_index_zero_node
);
9357 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9358 boolean_type_node
, cond3
, cond1
);
9359 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
9360 stride
, gfc_index_zero_node
);
9362 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9363 tmp
, build_int_cst (gfc_array_index_type
,
9366 cond
= boolean_false_node
;
9368 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9369 boolean_type_node
, cond3
, cond4
);
9370 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9371 boolean_type_node
, cond
, cond1
);
9373 return fold_build3_loc (input_location
, COND_EXPR
,
9374 gfc_array_index_type
, cond
,
9375 lbound
, gfc_index_one_node
);
9378 if (expr
->expr_type
== EXPR_FUNCTION
)
9380 /* A conversion function, so use the argument. */
9381 gcc_assert (expr
->value
.function
.isym
9382 && expr
->value
.function
.isym
->conversion
);
9383 expr
= expr
->value
.function
.actual
->expr
;
9386 if (expr
->expr_type
== EXPR_VARIABLE
)
9388 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9389 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9391 if (ref
->type
== REF_COMPONENT
9392 && ref
->u
.c
.component
->as
9394 && ref
->next
->u
.ar
.type
== AR_FULL
)
9395 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9397 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9400 return gfc_index_one_node
;
9404 /* Returns true if an expression represents an lhs that can be reallocated
9408 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9415 /* An allocatable class variable with no reference. */
9416 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
9417 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.allocatable
9418 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
9419 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9420 && expr
->ref
->next
== NULL
)
9423 /* An allocatable variable. */
9424 if (expr
->symtree
->n
.sym
->attr
.allocatable
9426 && expr
->ref
->type
== REF_ARRAY
9427 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9430 /* All that can be left are allocatable components. */
9431 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9432 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9433 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
9436 /* Find a component ref followed by an array reference. */
9437 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9439 && ref
->type
== REF_COMPONENT
9440 && ref
->next
->type
== REF_ARRAY
9441 && !ref
->next
->next
)
9447 /* Return true if valid reallocatable lhs. */
9448 if (ref
->u
.c
.component
->attr
.allocatable
9449 && ref
->next
->u
.ar
.type
== AR_FULL
)
9457 concat_str_length (gfc_expr
* expr
)
9464 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9465 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9466 if (len1
== NULL_TREE
)
9468 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9469 len1
= concat_str_length (expr
->value
.op
.op1
);
9470 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9471 len1
= build_int_cst (gfc_charlen_type_node
,
9472 expr
->value
.op
.op1
->value
.character
.length
);
9473 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9475 gfc_init_se (&se
, NULL
);
9476 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9482 gfc_init_se (&se
, NULL
);
9483 se
.want_pointer
= 1;
9484 se
.descriptor_only
= 1;
9485 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9486 len1
= se
.string_length
;
9490 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9491 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9492 if (len2
== NULL_TREE
)
9494 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9495 len2
= concat_str_length (expr
->value
.op
.op2
);
9496 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9497 len2
= build_int_cst (gfc_charlen_type_node
,
9498 expr
->value
.op
.op2
->value
.character
.length
);
9499 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9501 gfc_init_se (&se
, NULL
);
9502 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9508 gfc_init_se (&se
, NULL
);
9509 se
.want_pointer
= 1;
9510 se
.descriptor_only
= 1;
9511 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9512 len2
= se
.string_length
;
9516 gcc_assert(len1
&& len2
);
9517 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9518 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9520 return fold_build2_loc (input_location
, PLUS_EXPR
,
9521 gfc_charlen_type_node
, len1
, len2
);
9525 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9529 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9533 stmtblock_t realloc_block
;
9534 stmtblock_t alloc_block
;
9538 gfc_array_info
*linfo
;
9560 gfc_array_spec
* as
;
9561 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9562 && gfc_caf_attr (expr1
, true).codimension
);
9566 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9567 Find the lhs expression in the loop chain and set expr1 and
9568 expr2 accordingly. */
9569 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9572 /* Find the ss for the lhs. */
9574 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9575 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9577 if (lss
== gfc_ss_terminator
)
9579 expr1
= lss
->info
->expr
;
9582 /* Bail out if this is not a valid allocate on assignment. */
9583 if (!gfc_is_reallocatable_lhs (expr1
)
9584 || (expr2
&& !expr2
->rank
))
9587 /* Find the ss for the lhs. */
9589 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9590 if (lss
->info
->expr
== expr1
)
9593 if (lss
== gfc_ss_terminator
)
9596 linfo
= &lss
->info
->data
.array
;
9598 /* Find an ss for the rhs. For operator expressions, we see the
9599 ss's for the operands. Any one of these will do. */
9601 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9602 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9605 if (expr2
&& rss
== gfc_ss_terminator
)
9608 gfc_start_block (&fblock
);
9610 /* Since the lhs is allocatable, this must be a descriptor type.
9611 Get the data and array size. */
9612 desc
= linfo
->descriptor
;
9613 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9614 array1
= gfc_conv_descriptor_data_get (desc
);
9616 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9617 deallocated if expr is an array of different shape or any of the
9618 corresponding length type parameter values of variable and expr
9619 differ." This assures F95 compatibility. */
9620 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9621 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9623 /* Allocate if data is NULL. */
9624 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9625 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9627 if (expr1
->ts
.deferred
)
9628 cond_null
= gfc_evaluate_now (boolean_true_node
, &fblock
);
9630 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9632 tmp
= build3_v (COND_EXPR
, cond_null
,
9633 build1_v (GOTO_EXPR
, jump_label1
),
9634 build_empty_stmt (input_location
));
9635 gfc_add_expr_to_block (&fblock
, tmp
);
9637 /* Get arrayspec if expr is a full array. */
9638 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9639 && expr2
->value
.function
.isym
9640 && expr2
->value
.function
.isym
->conversion
)
9642 /* For conversion functions, take the arg. */
9643 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9644 as
= gfc_get_full_arrayspec_from_expr (arg
);
9647 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9651 /* If the lhs shape is not the same as the rhs jump to setting the
9652 bounds and doing the reallocation....... */
9653 for (n
= 0; n
< expr1
->rank
; n
++)
9655 /* Check the shape. */
9656 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9657 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9658 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9659 gfc_array_index_type
,
9660 loop
->to
[n
], loop
->from
[n
]);
9661 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9662 gfc_array_index_type
,
9664 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9665 gfc_array_index_type
,
9667 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9669 tmp
, gfc_index_zero_node
);
9670 tmp
= build3_v (COND_EXPR
, cond
,
9671 build1_v (GOTO_EXPR
, jump_label1
),
9672 build_empty_stmt (input_location
));
9673 gfc_add_expr_to_block (&fblock
, tmp
);
9676 /* ....else jump past the (re)alloc code. */
9677 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9678 gfc_add_expr_to_block (&fblock
, tmp
);
9680 /* Add the label to start automatic (re)allocation. */
9681 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9682 gfc_add_expr_to_block (&fblock
, tmp
);
9684 /* If the lhs has not been allocated, its bounds will not have been
9685 initialized and so its size is set to zero. */
9686 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9687 gfc_init_block (&alloc_block
);
9688 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9689 gfc_init_block (&realloc_block
);
9690 gfc_add_modify (&realloc_block
, size1
,
9691 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9692 tmp
= build3_v (COND_EXPR
, cond_null
,
9693 gfc_finish_block (&alloc_block
),
9694 gfc_finish_block (&realloc_block
));
9695 gfc_add_expr_to_block (&fblock
, tmp
);
9697 /* Get the rhs size and fix it. */
9699 desc2
= rss
->info
->data
.array
.descriptor
;
9703 size2
= gfc_index_one_node
;
9704 for (n
= 0; n
< expr2
->rank
; n
++)
9706 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9707 gfc_array_index_type
,
9708 loop
->to
[n
], loop
->from
[n
]);
9709 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9710 gfc_array_index_type
,
9711 tmp
, gfc_index_one_node
);
9712 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9713 gfc_array_index_type
,
9716 size2
= gfc_evaluate_now (size2
, &fblock
);
9718 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
9721 /* If the lhs is deferred length, assume that the element size
9722 changes and force a reallocation. */
9723 if (expr1
->ts
.deferred
)
9724 neq_size
= gfc_evaluate_now (boolean_true_node
, &fblock
);
9726 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9728 /* Deallocation of allocatable components will have to occur on
9729 reallocation. Fix the old descriptor now. */
9730 if ((expr1
->ts
.type
== BT_DERIVED
)
9731 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9732 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9734 old_desc
= NULL_TREE
;
9736 /* Now modify the lhs descriptor and the associated scalarizer
9737 variables. F2003 7.4.1.3: "If variable is or becomes an
9738 unallocated allocatable variable, then it is allocated with each
9739 deferred type parameter equal to the corresponding type parameters
9740 of expr , with the shape of expr , and with each lower bound equal
9741 to the corresponding element of LBOUND(expr)."
9742 Reuse size1 to keep a dimension-by-dimension track of the
9743 stride of the new array. */
9744 size1
= gfc_index_one_node
;
9745 offset
= gfc_index_zero_node
;
9747 for (n
= 0; n
< expr2
->rank
; n
++)
9749 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9750 gfc_array_index_type
,
9751 loop
->to
[n
], loop
->from
[n
]);
9752 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9753 gfc_array_index_type
,
9754 tmp
, gfc_index_one_node
);
9756 lbound
= gfc_index_one_node
;
9761 lbd
= get_std_lbound (expr2
, desc2
, n
,
9762 as
->type
== AS_ASSUMED_SIZE
);
9763 ubound
= fold_build2_loc (input_location
,
9765 gfc_array_index_type
,
9767 ubound
= fold_build2_loc (input_location
,
9769 gfc_array_index_type
,
9774 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9777 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9780 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9783 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9785 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9786 gfc_array_index_type
,
9788 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9789 gfc_array_index_type
,
9791 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9792 gfc_array_index_type
,
9796 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9797 the array offset is saved and the info.offset is used for a
9798 running offset. Use the saved_offset instead. */
9799 tmp
= gfc_conv_descriptor_offset (desc
);
9800 gfc_add_modify (&fblock
, tmp
, offset
);
9801 if (linfo
->saved_offset
9802 && VAR_P (linfo
->saved_offset
))
9803 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9805 /* Now set the deltas for the lhs. */
9806 for (n
= 0; n
< expr1
->rank
; n
++)
9808 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9810 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9811 gfc_array_index_type
, tmp
,
9813 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9814 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9817 /* Get the new lhs size in bytes. */
9818 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9820 if (expr2
->ts
.deferred
)
9822 if (VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9823 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9825 tmp
= rss
->info
->string_length
;
9829 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9830 if (!tmp
&& expr2
->expr_type
== EXPR_OP
9831 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
9833 tmp
= concat_str_length (expr2
);
9834 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
9836 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
9839 if (expr1
->ts
.u
.cl
->backend_decl
9840 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
9841 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
9843 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
9845 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
9847 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
9848 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9849 gfc_array_index_type
, tmp
,
9850 expr1
->ts
.u
.cl
->backend_decl
);
9853 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9854 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9855 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9856 gfc_array_index_type
,
9858 size2
= fold_convert (size_type_node
, size2
);
9859 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9860 size2
, size_one_node
);
9861 size2
= gfc_evaluate_now (size2
, &fblock
);
9863 /* For deferred character length, the 'size' field of the dtype might
9864 have changed so set the dtype. */
9865 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9866 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9869 tmp
= gfc_conv_descriptor_dtype (desc
);
9870 if (expr2
->ts
.u
.cl
->backend_decl
)
9871 type
= gfc_typenode_for_spec (&expr2
->ts
);
9873 type
= gfc_typenode_for_spec (&expr1
->ts
);
9875 gfc_add_modify (&fblock
, tmp
,
9876 gfc_get_dtype_rank_type (expr1
->rank
,type
));
9878 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9880 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
9881 gfc_get_dtype (TREE_TYPE (desc
)));
9884 /* Realloc expression. Note that the scalarizer uses desc.data
9885 in the array reference - (*desc.data)[<element>]. */
9886 gfc_init_block (&realloc_block
);
9887 gfc_init_se (&caf_se
, NULL
);
9891 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
9892 if (token
== NULL_TREE
)
9894 tmp
= gfc_get_tree_for_caf_expr (expr1
);
9895 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9896 tmp
= build_fold_indirect_ref (tmp
);
9897 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
9899 token
= gfc_build_addr_expr (NULL_TREE
, token
);
9902 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
9904 if ((expr1
->ts
.type
== BT_DERIVED
)
9905 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9907 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
9909 gfc_add_expr_to_block (&realloc_block
, tmp
);
9914 tmp
= build_call_expr_loc (input_location
,
9915 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
9916 fold_convert (pvoid_type_node
, array1
),
9918 gfc_conv_descriptor_data_set (&realloc_block
,
9923 tmp
= build_call_expr_loc (input_location
,
9924 gfor_fndecl_caf_deregister
, 5, token
,
9925 build_int_cst (integer_type_node
,
9926 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
9927 null_pointer_node
, null_pointer_node
,
9929 gfc_add_expr_to_block (&realloc_block
, tmp
);
9930 tmp
= build_call_expr_loc (input_location
,
9931 gfor_fndecl_caf_register
,
9933 build_int_cst (integer_type_node
,
9934 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
9935 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9936 null_pointer_node
, null_pointer_node
,
9938 gfc_add_expr_to_block (&realloc_block
, tmp
);
9941 if ((expr1
->ts
.type
== BT_DERIVED
)
9942 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9944 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
9946 gfc_add_expr_to_block (&realloc_block
, tmp
);
9949 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
9950 realloc_expr
= gfc_finish_block (&realloc_block
);
9952 /* Only reallocate if sizes are different. */
9953 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
9954 build_empty_stmt (input_location
));
9958 /* Malloc expression. */
9959 gfc_init_block (&alloc_block
);
9962 tmp
= build_call_expr_loc (input_location
,
9963 builtin_decl_explicit (BUILT_IN_MALLOC
),
9965 gfc_conv_descriptor_data_set (&alloc_block
,
9970 tmp
= build_call_expr_loc (input_location
,
9971 gfor_fndecl_caf_register
,
9973 build_int_cst (integer_type_node
,
9974 GFC_CAF_COARRAY_ALLOC
),
9975 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9976 null_pointer_node
, null_pointer_node
,
9978 gfc_add_expr_to_block (&alloc_block
, tmp
);
9982 /* We already set the dtype in the case of deferred character
9984 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9985 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9988 tmp
= gfc_conv_descriptor_dtype (desc
);
9989 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9992 if ((expr1
->ts
.type
== BT_DERIVED
)
9993 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9995 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
9997 gfc_add_expr_to_block (&alloc_block
, tmp
);
9999 alloc_expr
= gfc_finish_block (&alloc_block
);
10001 /* Malloc if not allocated; realloc otherwise. */
10002 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10003 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10006 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10007 gfc_add_expr_to_block (&fblock
, tmp
);
10009 /* Make sure that the scalarizer data pointer is updated. */
10010 if (linfo
->data
&& VAR_P (linfo
->data
))
10012 tmp
= gfc_conv_descriptor_data_get (desc
);
10013 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10016 /* Add the exit label. */
10017 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10018 gfc_add_expr_to_block (&fblock
, tmp
);
10020 return gfc_finish_block (&fblock
);
10024 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10025 Do likewise, recursively if necessary, with the allocatable components of
10029 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10035 stmtblock_t cleanup
;
10038 bool sym_has_alloc_comp
, has_finalizer
;
10040 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10041 || sym
->ts
.type
== BT_CLASS
)
10042 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10043 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10044 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10046 /* Make sure the frontend gets these right. */
10047 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10050 gfc_save_backend_locus (&loc
);
10051 gfc_set_backend_locus (&sym
->declared_at
);
10052 gfc_init_block (&init
);
10054 gcc_assert (VAR_P (sym
->backend_decl
)
10055 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10057 if (sym
->ts
.type
== BT_CHARACTER
10058 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10060 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10061 gfc_trans_vla_type_sizes (sym
, &init
);
10064 /* Dummy, use associated and result variables don't need anything special. */
10065 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10067 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10068 gfc_restore_backend_locus (&loc
);
10072 descriptor
= sym
->backend_decl
;
10074 /* Although static, derived types with default initializers and
10075 allocatable components must not be nulled wholesale; instead they
10076 are treated component by component. */
10077 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10079 /* SAVEd variables are not freed on exit. */
10080 gfc_trans_static_array_pointer (sym
);
10082 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10083 gfc_restore_backend_locus (&loc
);
10087 /* Get the descriptor type. */
10088 type
= TREE_TYPE (sym
->backend_decl
);
10090 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10091 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10093 if (!sym
->attr
.save
10094 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10096 if (sym
->value
== NULL
10097 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10099 rank
= sym
->as
? sym
->as
->rank
: 0;
10100 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10102 gfc_add_expr_to_block (&init
, tmp
);
10105 gfc_init_default_dt (sym
, &init
, false);
10108 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10110 /* If the backend_decl is not a descriptor, we must have a pointer
10112 descriptor
= build_fold_indirect_ref_loc (input_location
,
10113 sym
->backend_decl
);
10114 type
= TREE_TYPE (descriptor
);
10117 /* NULLIFY the data pointer, for non-saved allocatables. */
10118 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10120 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10121 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10123 /* Declare the variable static so its array descriptor stays present
10124 after leaving the scope. It may still be accessed through another
10125 image. This may happen, for example, with the caf_mpi
10127 TREE_STATIC (descriptor
) = 1;
10128 tmp
= gfc_conv_descriptor_token (descriptor
);
10129 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10130 null_pointer_node
));
10134 gfc_restore_backend_locus (&loc
);
10135 gfc_init_block (&cleanup
);
10137 /* Allocatable arrays need to be freed when they go out of scope.
10138 The allocatable components of pointers must not be touched. */
10139 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10140 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10141 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10144 sym
->attr
.referenced
= 1;
10145 e
= gfc_lval_expr_from_sym (sym
);
10146 gfc_add_finalizer_call (&cleanup
, e
);
10149 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10150 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10151 && !sym
->attr
.pointer
&& !sym
->attr
.save
10152 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10155 rank
= sym
->as
? sym
->as
->rank
: 0;
10156 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10157 gfc_add_expr_to_block (&cleanup
, tmp
);
10160 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10161 && !sym
->attr
.save
&& !sym
->attr
.result
10162 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10165 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10166 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10167 NULL_TREE
, NULL_TREE
, true, e
,
10168 sym
->attr
.codimension
10169 ? GFC_CAF_COARRAY_DEREGISTER
10170 : GFC_CAF_COARRAY_NOCOARRAY
);
10173 gfc_add_expr_to_block (&cleanup
, tmp
);
10176 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10177 gfc_finish_block (&cleanup
));
10180 /************ Expression Walking Functions ******************/
10182 /* Walk a variable reference.
10184 Possible extension - multiple component subscripts.
10185 x(:,:) = foo%a(:)%b(:)
10187 forall (i=..., j=...)
10188 x(i,j) = foo%a(j)%b(i)
10190 This adds a fair amount of complexity because you need to deal with more
10191 than one ref. Maybe handle in a similar manner to vector subscripts.
10192 Maybe not worth the effort. */
10196 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10200 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10201 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10204 return gfc_walk_array_ref (ss
, expr
, ref
);
10209 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10215 for (; ref
; ref
= ref
->next
)
10217 if (ref
->type
== REF_SUBSTRING
)
10219 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10220 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10223 /* We're only interested in array sections from now on. */
10224 if (ref
->type
!= REF_ARRAY
)
10232 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10233 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10237 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10238 newss
->info
->data
.array
.ref
= ref
;
10240 /* Make sure array is the same as array(:,:), this way
10241 we don't need to special case all the time. */
10242 ar
->dimen
= ar
->as
->rank
;
10243 for (n
= 0; n
< ar
->dimen
; n
++)
10245 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10247 gcc_assert (ar
->start
[n
] == NULL
);
10248 gcc_assert (ar
->end
[n
] == NULL
);
10249 gcc_assert (ar
->stride
[n
] == NULL
);
10255 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10256 newss
->info
->data
.array
.ref
= ref
;
10258 /* We add SS chains for all the subscripts in the section. */
10259 for (n
= 0; n
< ar
->dimen
; n
++)
10263 switch (ar
->dimen_type
[n
])
10265 case DIMEN_ELEMENT
:
10266 /* Add SS for elemental (scalar) subscripts. */
10267 gcc_assert (ar
->start
[n
]);
10268 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10269 indexss
->loop_chain
= gfc_ss_terminator
;
10270 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10274 /* We don't add anything for sections, just remember this
10275 dimension for later. */
10276 newss
->dim
[newss
->dimen
] = n
;
10281 /* Create a GFC_SS_VECTOR index in which we can store
10282 the vector's descriptor. */
10283 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10285 indexss
->loop_chain
= gfc_ss_terminator
;
10286 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10287 newss
->dim
[newss
->dimen
] = n
;
10292 /* We should know what sort of section it is by now. */
10293 gcc_unreachable ();
10296 /* We should have at least one non-elemental dimension,
10297 unless we are creating a descriptor for a (scalar) coarray. */
10298 gcc_assert (newss
->dimen
> 0
10299 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10304 /* We should know what sort of section it is by now. */
10305 gcc_unreachable ();
10313 /* Walk an expression operator. If only one operand of a binary expression is
10314 scalar, we must also add the scalar term to the SS chain. */
10317 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10322 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10323 if (expr
->value
.op
.op2
== NULL
)
10326 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10328 /* All operands are scalar. Pass back and let the caller deal with it. */
10332 /* All operands require scalarization. */
10333 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10336 /* One of the operands needs scalarization, the other is scalar.
10337 Create a gfc_ss for the scalar expression. */
10340 /* First operand is scalar. We build the chain in reverse order, so
10341 add the scalar SS after the second operand. */
10343 while (head
&& head
->next
!= ss
)
10345 /* Check we haven't somehow broken the chain. */
10347 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10349 else /* head2 == head */
10351 gcc_assert (head2
== head
);
10352 /* Second operand is scalar. */
10353 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10360 /* Reverse a SS chain. */
10363 gfc_reverse_ss (gfc_ss
* ss
)
10368 gcc_assert (ss
!= NULL
);
10370 head
= gfc_ss_terminator
;
10371 while (ss
!= gfc_ss_terminator
)
10374 /* Check we didn't somehow break the chain. */
10375 gcc_assert (next
!= NULL
);
10385 /* Given an expression referring to a procedure, return the symbol of its
10386 interface. We can't get the procedure symbol directly as we have to handle
10387 the case of (deferred) type-bound procedures. */
10390 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10395 if (procedure_ref
== NULL
)
10398 /* Normal procedure case. */
10399 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10400 && procedure_ref
->value
.function
.esym
)
10401 sym
= procedure_ref
->value
.function
.esym
;
10403 sym
= procedure_ref
->symtree
->n
.sym
;
10405 /* Typebound procedure case. */
10406 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10408 if (ref
->type
== REF_COMPONENT
10409 && ref
->u
.c
.component
->attr
.proc_pointer
)
10410 sym
= ref
->u
.c
.component
->ts
.interface
;
10419 /* Walk the arguments of an elemental function.
10420 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10421 it is NULL, we don't do the check and the argument is assumed to be present.
10425 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10426 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10428 gfc_formal_arglist
*dummy_arg
;
10434 head
= gfc_ss_terminator
;
10438 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10443 for (; arg
; arg
= arg
->next
)
10445 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10446 goto loop_continue
;
10448 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10451 /* Scalar argument. */
10452 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10453 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10454 newss
->info
->type
= type
;
10456 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10461 if (dummy_arg
!= NULL
10462 && dummy_arg
->sym
->attr
.optional
10463 && arg
->expr
->expr_type
== EXPR_VARIABLE
10464 && (gfc_expr_attr (arg
->expr
).optional
10465 || gfc_expr_attr (arg
->expr
).allocatable
10466 || gfc_expr_attr (arg
->expr
).pointer
))
10467 newss
->info
->can_be_null_ref
= true;
10473 while (tail
->next
!= gfc_ss_terminator
)
10478 if (dummy_arg
!= NULL
)
10479 dummy_arg
= dummy_arg
->next
;
10484 /* If all the arguments are scalar we don't need the argument SS. */
10485 gfc_free_ss_chain (head
);
10486 /* Pass it back. */
10490 /* Add it onto the existing chain. */
10496 /* Walk a function call. Scalar functions are passed back, and taken out of
10497 scalarization loops. For elemental functions we walk their arguments.
10498 The result of functions returning arrays is stored in a temporary outside
10499 the loop, so that the function is only called once. Hence we do not need
10500 to walk their arguments. */
10503 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10505 gfc_intrinsic_sym
*isym
;
10507 gfc_component
*comp
= NULL
;
10509 isym
= expr
->value
.function
.isym
;
10511 /* Handle intrinsic functions separately. */
10513 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10515 sym
= expr
->value
.function
.esym
;
10517 sym
= expr
->symtree
->n
.sym
;
10519 if (gfc_is_alloc_class_array_function (expr
))
10520 return gfc_get_array_ss (ss
, expr
,
10521 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10524 /* A function that returns arrays. */
10525 comp
= gfc_get_proc_ptr_comp (expr
);
10526 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10527 || (comp
&& comp
->attr
.dimension
))
10528 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10530 /* Walk the parameters of an elemental function. For now we always pass
10532 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10534 gfc_ss
*old_ss
= ss
;
10536 ss
= gfc_walk_elemental_function_args (old_ss
,
10537 expr
->value
.function
.actual
,
10538 gfc_get_proc_ifc_for_expr (expr
),
10542 || sym
->attr
.proc_pointer
10543 || sym
->attr
.if_source
!= IFSRC_DECL
10544 || sym
->attr
.array_outer_dependency
))
10545 ss
->info
->array_outer_dependency
= 1;
10548 /* Scalar functions are OK as these are evaluated outside the scalarization
10549 loop. Pass back and let the caller deal with it. */
10554 /* An array temporary is constructed for array constructors. */
10557 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10559 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10563 /* Walk an expression. Add walked expressions to the head of the SS chain.
10564 A wholly scalar expression will not be added. */
10567 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10571 switch (expr
->expr_type
)
10573 case EXPR_VARIABLE
:
10574 head
= gfc_walk_variable_expr (ss
, expr
);
10578 head
= gfc_walk_op_expr (ss
, expr
);
10581 case EXPR_FUNCTION
:
10582 head
= gfc_walk_function_expr (ss
, expr
);
10585 case EXPR_CONSTANT
:
10587 case EXPR_STRUCTURE
:
10588 /* Pass back and let the caller deal with it. */
10592 head
= gfc_walk_array_constructor (ss
, expr
);
10595 case EXPR_SUBSTRING
:
10596 /* Pass back and let the caller deal with it. */
10600 gfc_internal_error ("bad expression type during walk (%d)",
10607 /* Entry point for expression walking.
10608 A return value equal to the passed chain means this is
10609 a scalar expression. It is up to the caller to take whatever action is
10610 necessary to translate these. */
10613 gfc_walk_expr (gfc_expr
* expr
)
10617 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10618 return gfc_reverse_ss (res
);