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 logical_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
, logical_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 logical_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 logical_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
));
1583 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
1584 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc
))))
1586 /* Assignment of a CLASS array constructor to a derived type array. */
1587 if (expr
->expr_type
== EXPR_FUNCTION
)
1588 se
->expr
= gfc_evaluate_now (se
->expr
, pblock
);
1589 se
->expr
= gfc_class_data_get (se
->expr
);
1590 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
1591 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1592 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1596 /* TODO: Should the frontend already have done this conversion? */
1597 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1598 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1601 gfc_add_block_to_block (pblock
, &se
->pre
);
1602 gfc_add_block_to_block (pblock
, &se
->post
);
1606 /* Add the contents of an array to the constructor. DYNAMIC is as for
1607 gfc_trans_array_constructor_value. */
1610 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1611 tree type ATTRIBUTE_UNUSED
,
1612 tree desc
, gfc_expr
* expr
,
1613 tree
* poffset
, tree
* offsetvar
,
1624 /* We need this to be a variable so we can increment it. */
1625 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1627 gfc_init_se (&se
, NULL
);
1629 /* Walk the array expression. */
1630 ss
= gfc_walk_expr (expr
);
1631 gcc_assert (ss
!= gfc_ss_terminator
);
1633 /* Initialize the scalarizer. */
1634 gfc_init_loopinfo (&loop
);
1635 gfc_add_ss_to_loop (&loop
, ss
);
1637 /* Initialize the loop. */
1638 gfc_conv_ss_startstride (&loop
);
1639 gfc_conv_loop_setup (&loop
, &expr
->where
);
1641 /* Make sure the constructed array has room for the new data. */
1644 /* Set SIZE to the total number of elements in the subarray. */
1645 size
= gfc_index_one_node
;
1646 for (n
= 0; n
< loop
.dimen
; n
++)
1648 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1649 gfc_index_one_node
);
1650 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1651 gfc_array_index_type
, size
, tmp
);
1654 /* Grow the constructed array by SIZE elements. */
1655 gfc_grow_array (&loop
.pre
, desc
, size
);
1658 /* Make the loop body. */
1659 gfc_mark_ss_chain_used (ss
, 1);
1660 gfc_start_scalarized_body (&loop
, &body
);
1661 gfc_copy_loopinfo_to_se (&se
, &loop
);
1664 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1665 gcc_assert (se
.ss
== gfc_ss_terminator
);
1667 /* Increment the offset. */
1668 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1669 *poffset
, gfc_index_one_node
);
1670 gfc_add_modify (&body
, *poffset
, tmp
);
1672 /* Finish the loop. */
1673 gfc_trans_scalarizing_loops (&loop
, &body
);
1674 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1675 tmp
= gfc_finish_block (&loop
.pre
);
1676 gfc_add_expr_to_block (pblock
, tmp
);
1678 gfc_cleanup_loop (&loop
);
1682 /* Assign the values to the elements of an array constructor. DYNAMIC
1683 is true if descriptor DESC only contains enough data for the static
1684 size calculated by gfc_get_array_constructor_size. When true, memory
1685 for the dynamic parts must be allocated using realloc. */
1688 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1689 tree desc
, gfc_constructor_base base
,
1690 tree
* poffset
, tree
* offsetvar
,
1694 tree start
= NULL_TREE
;
1695 tree end
= NULL_TREE
;
1696 tree step
= NULL_TREE
;
1702 tree shadow_loopvar
= NULL_TREE
;
1703 gfc_saved_var saved_loopvar
;
1706 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1708 /* If this is an iterator or an array, the offset must be a variable. */
1709 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1710 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1712 /* Shadowing the iterator avoids changing its value and saves us from
1713 keeping track of it. Further, it makes sure that there's always a
1714 backend-decl for the symbol, even if there wasn't one before,
1715 e.g. in the case of an iterator that appears in a specification
1716 expression in an interface mapping. */
1722 /* Evaluate loop bounds before substituting the loop variable
1723 in case they depend on it. Such a case is invalid, but it is
1724 not more expensive to do the right thing here.
1726 gfc_init_se (&se
, NULL
);
1727 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1728 gfc_add_block_to_block (pblock
, &se
.pre
);
1729 start
= gfc_evaluate_now (se
.expr
, pblock
);
1731 gfc_init_se (&se
, NULL
);
1732 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1733 gfc_add_block_to_block (pblock
, &se
.pre
);
1734 end
= gfc_evaluate_now (se
.expr
, pblock
);
1736 gfc_init_se (&se
, NULL
);
1737 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1738 gfc_add_block_to_block (pblock
, &se
.pre
);
1739 step
= gfc_evaluate_now (se
.expr
, pblock
);
1741 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1742 type
= gfc_typenode_for_spec (&sym
->ts
);
1744 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1745 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1748 gfc_start_block (&body
);
1750 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1752 /* Array constructors can be nested. */
1753 gfc_trans_array_constructor_value (&body
, type
, desc
,
1754 c
->expr
->value
.constructor
,
1755 poffset
, offsetvar
, dynamic
);
1757 else if (c
->expr
->rank
> 0)
1759 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1760 poffset
, offsetvar
, dynamic
);
1764 /* This code really upsets the gimplifier so don't bother for now. */
1771 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1773 p
= gfc_constructor_next (p
);
1778 /* Scalar values. */
1779 gfc_init_se (&se
, NULL
);
1780 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1783 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1784 gfc_array_index_type
,
1785 *poffset
, gfc_index_one_node
);
1789 /* Collect multiple scalar constants into a constructor. */
1790 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1794 HOST_WIDE_INT idx
= 0;
1797 /* Count the number of consecutive scalar constants. */
1798 while (p
&& !(p
->iterator
1799 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1801 gfc_init_se (&se
, NULL
);
1802 gfc_conv_constant (&se
, p
->expr
);
1804 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1805 se
.expr
= fold_convert (type
, se
.expr
);
1806 /* For constant character array constructors we build
1807 an array of pointers. */
1808 else if (POINTER_TYPE_P (type
))
1809 se
.expr
= gfc_build_addr_expr
1810 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1813 CONSTRUCTOR_APPEND_ELT (v
,
1814 build_int_cst (gfc_array_index_type
,
1818 p
= gfc_constructor_next (p
);
1821 bound
= size_int (n
- 1);
1822 /* Create an array type to hold them. */
1823 tmptype
= build_range_type (gfc_array_index_type
,
1824 gfc_index_zero_node
, bound
);
1825 tmptype
= build_array_type (type
, tmptype
);
1827 init
= build_constructor (tmptype
, v
);
1828 TREE_CONSTANT (init
) = 1;
1829 TREE_STATIC (init
) = 1;
1830 /* Create a static variable to hold the data. */
1831 tmp
= gfc_create_var (tmptype
, "data");
1832 TREE_STATIC (tmp
) = 1;
1833 TREE_CONSTANT (tmp
) = 1;
1834 TREE_READONLY (tmp
) = 1;
1835 DECL_INITIAL (tmp
) = init
;
1838 /* Use BUILTIN_MEMCPY to assign the values. */
1839 tmp
= gfc_conv_descriptor_data_get (desc
);
1840 tmp
= build_fold_indirect_ref_loc (input_location
,
1842 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1843 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1844 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1846 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1847 bound
= build_int_cst (size_type_node
, n
* size
);
1848 tmp
= build_call_expr_loc (input_location
,
1849 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1850 3, tmp
, init
, bound
);
1851 gfc_add_expr_to_block (&body
, tmp
);
1853 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1854 gfc_array_index_type
, *poffset
,
1855 build_int_cst (gfc_array_index_type
, n
));
1857 if (!INTEGER_CST_P (*poffset
))
1859 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1860 *poffset
= *offsetvar
;
1864 /* The frontend should already have done any expansions
1868 /* Pass the code as is. */
1869 tmp
= gfc_finish_block (&body
);
1870 gfc_add_expr_to_block (pblock
, tmp
);
1874 /* Build the implied do-loop. */
1875 stmtblock_t implied_do_block
;
1881 loopbody
= gfc_finish_block (&body
);
1883 /* Create a new block that holds the implied-do loop. A temporary
1884 loop-variable is used. */
1885 gfc_start_block(&implied_do_block
);
1887 /* Initialize the loop. */
1888 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1890 /* If this array expands dynamically, and the number of iterations
1891 is not constant, we won't have allocated space for the static
1892 part of C->EXPR's size. Do that now. */
1893 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1895 /* Get the number of iterations. */
1896 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1898 /* Get the static part of C->EXPR's size. */
1899 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1900 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1902 /* Grow the array by TMP * TMP2 elements. */
1903 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1904 gfc_array_index_type
, tmp
, tmp2
);
1905 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1908 /* Generate the loop body. */
1909 exit_label
= gfc_build_label_decl (NULL_TREE
);
1910 gfc_start_block (&body
);
1912 /* Generate the exit condition. Depending on the sign of
1913 the step variable we have to generate the correct
1915 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1916 step
, build_int_cst (TREE_TYPE (step
), 0));
1917 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1918 logical_type_node
, tmp
,
1919 fold_build2_loc (input_location
, GT_EXPR
,
1920 logical_type_node
, shadow_loopvar
, end
),
1921 fold_build2_loc (input_location
, LT_EXPR
,
1922 logical_type_node
, shadow_loopvar
, end
));
1923 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1924 TREE_USED (exit_label
) = 1;
1925 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1926 build_empty_stmt (input_location
));
1927 gfc_add_expr_to_block (&body
, tmp
);
1929 /* The main loop body. */
1930 gfc_add_expr_to_block (&body
, loopbody
);
1932 /* Increase loop variable by step. */
1933 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1934 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1936 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1938 /* Finish the loop. */
1939 tmp
= gfc_finish_block (&body
);
1940 tmp
= build1_v (LOOP_EXPR
, tmp
);
1941 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1943 /* Add the exit label. */
1944 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1945 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1947 /* Finish the implied-do loop. */
1948 tmp
= gfc_finish_block(&implied_do_block
);
1949 gfc_add_expr_to_block(pblock
, tmp
);
1951 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1958 /* The array constructor code can create a string length with an operand
1959 in the form of a temporary variable. This variable will retain its
1960 context (current_function_decl). If we store this length tree in a
1961 gfc_charlen structure which is shared by a variable in another
1962 context, the resulting gfc_charlen structure with a variable in a
1963 different context, we could trip the assertion in expand_expr_real_1
1964 when it sees that a variable has been created in one context and
1965 referenced in another.
1967 If this might be the case, we create a new gfc_charlen structure and
1968 link it into the current namespace. */
1971 store_backend_decl (gfc_charlen
**clp
, tree len
, bool force_new_cl
)
1975 gfc_charlen
*new_cl
= gfc_new_charlen (gfc_current_ns
, *clp
);
1978 (*clp
)->backend_decl
= len
;
1981 /* A catch-all to obtain the string length for anything that is not
1982 a substring of non-constant length, a constant, array or variable. */
1985 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1989 /* Don't bother if we already know the length is a constant. */
1990 if (*len
&& INTEGER_CST_P (*len
))
1993 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1994 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1997 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1998 *len
= e
->ts
.u
.cl
->backend_decl
;
2002 /* Otherwise, be brutal even if inefficient. */
2003 gfc_init_se (&se
, NULL
);
2005 /* No function call, in case of side effects. */
2006 se
.no_function_call
= 1;
2008 gfc_conv_expr (&se
, e
);
2010 gfc_conv_expr_descriptor (&se
, e
);
2012 /* Fix the value. */
2013 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
2015 gfc_add_block_to_block (block
, &se
.pre
);
2016 gfc_add_block_to_block (block
, &se
.post
);
2018 store_backend_decl (&e
->ts
.u
.cl
, *len
, true);
2023 /* Figure out the string length of a variable reference expression.
2024 Used by get_array_ctor_strlen. */
2027 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
2033 /* Don't bother if we already know the length is a constant. */
2034 if (*len
&& INTEGER_CST_P (*len
))
2037 ts
= &expr
->symtree
->n
.sym
->ts
;
2038 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2043 /* Array references don't change the string length. */
2047 /* Use the length of the component. */
2048 ts
= &ref
->u
.c
.component
->ts
;
2052 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
2053 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
2055 /* Note that this might evaluate expr. */
2056 get_array_ctor_all_strlen (block
, expr
, len
);
2059 mpz_init_set_ui (char_len
, 1);
2060 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
2061 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
2062 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
2063 *len
= convert (gfc_charlen_type_node
, *len
);
2064 mpz_clear (char_len
);
2072 *len
= ts
->u
.cl
->backend_decl
;
2076 /* Figure out the string length of a character array constructor.
2077 If len is NULL, don't calculate the length; this happens for recursive calls
2078 when a sub-array-constructor is an element but not at the first position,
2079 so when we're not interested in the length.
2080 Returns TRUE if all elements are character constants. */
2083 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
2090 if (gfc_constructor_first (base
) == NULL
)
2093 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
2097 /* Loop over all constructor elements to find out is_const, but in len we
2098 want to store the length of the first, not the last, element. We can
2099 of course exit the loop as soon as is_const is found to be false. */
2100 for (c
= gfc_constructor_first (base
);
2101 c
&& is_const
; c
= gfc_constructor_next (c
))
2103 switch (c
->expr
->expr_type
)
2106 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
2107 *len
= build_int_cstu (gfc_charlen_type_node
,
2108 c
->expr
->value
.character
.length
);
2112 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
2119 get_array_ctor_var_strlen (block
, c
->expr
, len
);
2125 get_array_ctor_all_strlen (block
, c
->expr
, len
);
2129 /* After the first iteration, we don't want the length modified. */
2136 /* Check whether the array constructor C consists entirely of constant
2137 elements, and if so returns the number of those elements, otherwise
2138 return zero. Note, an empty or NULL array constructor returns zero. */
2140 unsigned HOST_WIDE_INT
2141 gfc_constant_array_constructor_p (gfc_constructor_base base
)
2143 unsigned HOST_WIDE_INT nelem
= 0;
2145 gfc_constructor
*c
= gfc_constructor_first (base
);
2149 || c
->expr
->rank
> 0
2150 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
2152 c
= gfc_constructor_next (c
);
2159 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2160 and the tree type of it's elements, TYPE, return a static constant
2161 variable that is compile-time initialized. */
2164 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
2166 tree tmptype
, init
, tmp
;
2167 HOST_WIDE_INT nelem
;
2172 vec
<constructor_elt
, va_gc
> *v
= NULL
;
2174 /* First traverse the constructor list, converting the constants
2175 to tree to build an initializer. */
2177 c
= gfc_constructor_first (expr
->value
.constructor
);
2180 gfc_init_se (&se
, NULL
);
2181 gfc_conv_constant (&se
, c
->expr
);
2182 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2183 se
.expr
= fold_convert (type
, se
.expr
);
2184 else if (POINTER_TYPE_P (type
))
2185 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2187 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2189 c
= gfc_constructor_next (c
);
2193 /* Next determine the tree type for the array. We use the gfortran
2194 front-end's gfc_get_nodesc_array_type in order to create a suitable
2195 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2197 memset (&as
, 0, sizeof (gfc_array_spec
));
2199 as
.rank
= expr
->rank
;
2200 as
.type
= AS_EXPLICIT
;
2203 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2204 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2208 for (i
= 0; i
< expr
->rank
; i
++)
2210 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2211 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2212 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2216 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2218 /* as is not needed anymore. */
2219 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2221 gfc_free_expr (as
.lower
[i
]);
2222 gfc_free_expr (as
.upper
[i
]);
2225 init
= build_constructor (tmptype
, v
);
2227 TREE_CONSTANT (init
) = 1;
2228 TREE_STATIC (init
) = 1;
2230 tmp
= build_decl (input_location
, VAR_DECL
, create_tmp_var_name ("A"),
2232 DECL_ARTIFICIAL (tmp
) = 1;
2233 DECL_IGNORED_P (tmp
) = 1;
2234 TREE_STATIC (tmp
) = 1;
2235 TREE_CONSTANT (tmp
) = 1;
2236 TREE_READONLY (tmp
) = 1;
2237 DECL_INITIAL (tmp
) = init
;
2244 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2245 This mostly initializes the scalarizer state info structure with the
2246 appropriate values to directly use the array created by the function
2247 gfc_build_constant_array_constructor. */
2250 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2252 gfc_array_info
*info
;
2256 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2258 info
= &ss
->info
->data
.array
;
2260 info
->descriptor
= tmp
;
2261 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2262 info
->offset
= gfc_index_zero_node
;
2264 for (i
= 0; i
< ss
->dimen
; i
++)
2266 info
->delta
[i
] = gfc_index_zero_node
;
2267 info
->start
[i
] = gfc_index_zero_node
;
2268 info
->end
[i
] = gfc_index_zero_node
;
2269 info
->stride
[i
] = gfc_index_one_node
;
2275 get_rank (gfc_loopinfo
*loop
)
2280 for (; loop
; loop
= loop
->parent
)
2281 rank
+= loop
->dimen
;
2287 /* Helper routine of gfc_trans_array_constructor to determine if the
2288 bounds of the loop specified by LOOP are constant and simple enough
2289 to use with trans_constant_array_constructor. Returns the
2290 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2293 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2296 tree size
= gfc_index_one_node
;
2300 total_dim
= get_rank (l
);
2302 for (loop
= l
; loop
; loop
= loop
->parent
)
2304 for (i
= 0; i
< loop
->dimen
; i
++)
2306 /* If the bounds aren't constant, return NULL_TREE. */
2307 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2309 if (!integer_zerop (loop
->from
[i
]))
2311 /* Only allow nonzero "from" in one-dimensional arrays. */
2314 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2315 gfc_array_index_type
,
2316 loop
->to
[i
], loop
->from
[i
]);
2320 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2321 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2322 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2323 gfc_array_index_type
, size
, tmp
);
2332 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2337 gcc_assert (array
->nested_ss
== NULL
);
2339 for (ss
= array
; ss
; ss
= ss
->parent
)
2340 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2341 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2342 return &(ss
->loop
->to
[n
]);
2348 static gfc_loopinfo
*
2349 outermost_loop (gfc_loopinfo
* loop
)
2351 while (loop
->parent
!= NULL
)
2352 loop
= loop
->parent
;
2358 /* Array constructors are handled by constructing a temporary, then using that
2359 within the scalarization loop. This is not optimal, but seems by far the
2363 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2365 gfc_constructor_base c
;
2373 bool old_first_len
, old_typespec_chararray_ctor
;
2374 tree old_first_len_val
;
2375 gfc_loopinfo
*loop
, *outer_loop
;
2376 gfc_ss_info
*ss_info
;
2382 /* Save the old values for nested checking. */
2383 old_first_len
= first_len
;
2384 old_first_len_val
= first_len_val
;
2385 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2388 outer_loop
= outermost_loop (loop
);
2390 expr
= ss_info
->expr
;
2392 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2393 typespec was given for the array constructor. */
2394 typespec_chararray_ctor
= (expr
->ts
.type
== BT_CHARACTER
2396 && expr
->ts
.u
.cl
->length_from_typespec
);
2398 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2399 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2401 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2405 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2407 c
= expr
->value
.constructor
;
2408 if (expr
->ts
.type
== BT_CHARACTER
)
2411 bool force_new_cl
= false;
2413 /* get_array_ctor_strlen walks the elements of the constructor, if a
2414 typespec was given, we already know the string length and want the one
2416 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2417 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2421 const_string
= false;
2422 gfc_init_se (&length_se
, NULL
);
2423 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2424 gfc_charlen_type_node
);
2425 ss_info
->string_length
= length_se
.expr
;
2427 /* Check if the character length is negative. If it is, then
2429 neg_len
= fold_build2_loc (input_location
, LT_EXPR
,
2430 logical_type_node
, ss_info
->string_length
,
2431 build_int_cst (gfc_charlen_type_node
, 0));
2432 /* Print a warning if bounds checking is enabled. */
2433 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2435 msg
= xasprintf ("Negative character length treated as LEN = 0");
2436 gfc_trans_runtime_check (false, true, neg_len
, &length_se
.pre
,
2441 ss_info
->string_length
2442 = fold_build3_loc (input_location
, COND_EXPR
,
2443 gfc_charlen_type_node
, neg_len
,
2444 build_int_cst (gfc_charlen_type_node
, 0),
2445 ss_info
->string_length
);
2446 ss_info
->string_length
= gfc_evaluate_now (ss_info
->string_length
,
2449 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2450 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2454 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2455 &ss_info
->string_length
);
2456 force_new_cl
= true;
2459 /* Complex character array constructors should have been taken care of
2460 and not end up here. */
2461 gcc_assert (ss_info
->string_length
);
2463 store_backend_decl (&expr
->ts
.u
.cl
, ss_info
->string_length
, force_new_cl
);
2465 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2467 type
= build_pointer_type (type
);
2470 type
= gfc_typenode_for_spec (expr
->ts
.type
== BT_CLASS
2471 ? &CLASS_DATA (expr
)->ts
: &expr
->ts
);
2473 /* See if the constructor determines the loop bounds. */
2476 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2478 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2480 /* We have a multidimensional parameter. */
2481 for (s
= ss
; s
; s
= s
->parent
)
2484 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2486 s
->loop
->from
[n
] = gfc_index_zero_node
;
2487 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2488 gfc_index_integer_kind
);
2489 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2490 gfc_array_index_type
,
2492 gfc_index_one_node
);
2497 if (*loop_ubound0
== NULL_TREE
)
2501 /* We should have a 1-dimensional, zero-based loop. */
2502 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2503 gcc_assert (loop
->dimen
== 1);
2504 gcc_assert (integer_zerop (loop
->from
[0]));
2506 /* Split the constructor size into a static part and a dynamic part.
2507 Allocate the static size up-front and record whether the dynamic
2508 size might be nonzero. */
2510 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2511 mpz_sub_ui (size
, size
, 1);
2512 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2516 /* Special case constant array constructors. */
2519 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2522 tree size
= constant_array_constructor_loop_size (loop
);
2523 if (size
&& compare_tree_int (size
, nelem
) == 0)
2525 trans_constant_array_constructor (ss
, type
);
2531 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2532 NULL_TREE
, dynamic
, true, false, where
);
2534 desc
= ss_info
->data
.array
.descriptor
;
2535 offset
= gfc_index_zero_node
;
2536 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2537 TREE_NO_WARNING (offsetvar
) = 1;
2538 TREE_USED (offsetvar
) = 0;
2539 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2540 &offset
, &offsetvar
, dynamic
);
2542 /* If the array grows dynamically, the upper bound of the loop variable
2543 is determined by the array's final upper bound. */
2546 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2547 gfc_array_index_type
,
2548 offsetvar
, gfc_index_one_node
);
2549 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2550 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2551 if (*loop_ubound0
&& VAR_P (*loop_ubound0
))
2552 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2554 *loop_ubound0
= tmp
;
2557 if (TREE_USED (offsetvar
))
2558 pushdecl (offsetvar
);
2560 gcc_assert (INTEGER_CST_P (offset
));
2563 /* Disable bound checking for now because it's probably broken. */
2564 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2571 /* Restore old values of globals. */
2572 first_len
= old_first_len
;
2573 first_len_val
= old_first_len_val
;
2574 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2578 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2579 called after evaluating all of INFO's vector dimensions. Go through
2580 each such vector dimension and see if we can now fill in any missing
2584 set_vector_loop_bounds (gfc_ss
* ss
)
2586 gfc_loopinfo
*loop
, *outer_loop
;
2587 gfc_array_info
*info
;
2595 outer_loop
= outermost_loop (ss
->loop
);
2597 info
= &ss
->info
->data
.array
;
2599 for (; ss
; ss
= ss
->parent
)
2603 for (n
= 0; n
< loop
->dimen
; n
++)
2606 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2607 || loop
->to
[n
] != NULL
)
2610 /* Loop variable N indexes vector dimension DIM, and we don't
2611 yet know the upper bound of loop variable N. Set it to the
2612 difference between the vector's upper and lower bounds. */
2613 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2614 gcc_assert (info
->subscript
[dim
]
2615 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2617 gfc_init_se (&se
, NULL
);
2618 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2619 zero
= gfc_rank_cst
[0];
2620 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2621 gfc_array_index_type
,
2622 gfc_conv_descriptor_ubound_get (desc
, zero
),
2623 gfc_conv_descriptor_lbound_get (desc
, zero
));
2624 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2631 /* Tells whether a scalar argument to an elemental procedure is saved out
2632 of a scalarization loop as a value or as a reference. */
2635 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info
* ss_info
)
2637 if (ss_info
->type
!= GFC_SS_REFERENCE
)
2640 /* If the actual argument can be absent (in other words, it can
2641 be a NULL reference), don't try to evaluate it; pass instead
2642 the reference directly. */
2643 if (ss_info
->can_be_null_ref
)
2646 /* If the expression is of polymorphic type, it's actual size is not known,
2647 so we avoid copying it anywhere. */
2648 if (ss_info
->data
.scalar
.dummy_arg
2649 && ss_info
->data
.scalar
.dummy_arg
->ts
.type
== BT_CLASS
2650 && ss_info
->expr
->ts
.type
== BT_CLASS
)
2653 /* If the expression is a data reference of aggregate type,
2654 and the data reference is not used on the left hand side,
2655 avoid a copy by saving a reference to the content. */
2656 if (!ss_info
->data
.scalar
.needs_temporary
2657 && (ss_info
->expr
->ts
.type
== BT_DERIVED
2658 || ss_info
->expr
->ts
.type
== BT_CLASS
)
2659 && gfc_expr_is_variable (ss_info
->expr
))
2662 /* Otherwise the expression is evaluated to a temporary variable before the
2663 scalarization loop. */
2668 /* Add the pre and post chains for all the scalar expressions in a SS chain
2669 to loop. This is called after the loop parameters have been calculated,
2670 but before the actual scalarizing loops. */
2673 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2676 gfc_loopinfo
*nested_loop
, *outer_loop
;
2678 gfc_ss_info
*ss_info
;
2679 gfc_array_info
*info
;
2683 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2684 arguments could get evaluated multiple times. */
2685 if (ss
->is_alloc_lhs
)
2688 outer_loop
= outermost_loop (loop
);
2690 /* TODO: This can generate bad code if there are ordering dependencies,
2691 e.g., a callee allocated function and an unknown size constructor. */
2692 gcc_assert (ss
!= NULL
);
2694 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2698 /* Cross loop arrays are handled from within the most nested loop. */
2699 if (ss
->nested_ss
!= NULL
)
2703 expr
= ss_info
->expr
;
2704 info
= &ss_info
->data
.array
;
2706 switch (ss_info
->type
)
2709 /* Scalar expression. Evaluate this now. This includes elemental
2710 dimension indices, but not array section bounds. */
2711 gfc_init_se (&se
, NULL
);
2712 gfc_conv_expr (&se
, expr
);
2713 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2715 if (expr
->ts
.type
!= BT_CHARACTER
2716 && !gfc_is_alloc_class_scalar_function (expr
))
2718 /* Move the evaluation of scalar expressions outside the
2719 scalarization loop, except for WHERE assignments. */
2721 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2722 if (!ss_info
->where
)
2723 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2724 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2727 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2729 ss_info
->data
.scalar
.value
= se
.expr
;
2730 ss_info
->string_length
= se
.string_length
;
2733 case GFC_SS_REFERENCE
:
2734 /* Scalar argument to elemental procedure. */
2735 gfc_init_se (&se
, NULL
);
2736 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
2737 gfc_conv_expr_reference (&se
, expr
);
2740 /* Evaluate the argument outside the loop and pass
2741 a reference to the value. */
2742 gfc_conv_expr (&se
, expr
);
2745 /* Ensure that a pointer to the string is stored. */
2746 if (expr
->ts
.type
== BT_CHARACTER
)
2747 gfc_conv_string_parameter (&se
);
2749 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2750 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2751 if (gfc_is_class_scalar_expr (expr
))
2752 /* This is necessary because the dynamic type will always be
2753 large than the declared type. In consequence, assigning
2754 the value to a temporary could segfault.
2755 OOP-TODO: see if this is generally correct or is the value
2756 has to be written to an allocated temporary, whose address
2757 is passed via ss_info. */
2758 ss_info
->data
.scalar
.value
= se
.expr
;
2760 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2763 ss_info
->string_length
= se
.string_length
;
2766 case GFC_SS_SECTION
:
2767 /* Add the expressions for scalar and vector subscripts. */
2768 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2769 if (info
->subscript
[n
])
2770 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2772 set_vector_loop_bounds (ss
);
2776 /* Get the vector's descriptor and store it in SS. */
2777 gfc_init_se (&se
, NULL
);
2778 gfc_conv_expr_descriptor (&se
, expr
);
2779 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2780 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2781 info
->descriptor
= se
.expr
;
2784 case GFC_SS_INTRINSIC
:
2785 gfc_add_intrinsic_ss_code (loop
, ss
);
2788 case GFC_SS_FUNCTION
:
2789 /* Array function return value. We call the function and save its
2790 result in a temporary for use inside the loop. */
2791 gfc_init_se (&se
, NULL
);
2794 if (gfc_is_class_array_function (expr
))
2795 expr
->must_finalize
= 1;
2796 gfc_conv_expr (&se
, expr
);
2797 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2798 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2799 ss_info
->string_length
= se
.string_length
;
2802 case GFC_SS_CONSTRUCTOR
:
2803 if (expr
->ts
.type
== BT_CHARACTER
2804 && ss_info
->string_length
== NULL
2806 && expr
->ts
.u
.cl
->length
2807 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2809 gfc_init_se (&se
, NULL
);
2810 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2811 gfc_charlen_type_node
);
2812 ss_info
->string_length
= se
.expr
;
2813 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2814 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2816 trans_array_constructor (ss
, where
);
2820 case GFC_SS_COMPONENT
:
2821 /* Do nothing. These are handled elsewhere. */
2830 for (nested_loop
= loop
->nested
; nested_loop
;
2831 nested_loop
= nested_loop
->next
)
2832 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2836 /* Translate expressions for the descriptor and data pointer of a SS. */
2840 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2843 gfc_ss_info
*ss_info
;
2844 gfc_array_info
*info
;
2848 info
= &ss_info
->data
.array
;
2850 /* Get the descriptor for the array to be scalarized. */
2851 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2852 gfc_init_se (&se
, NULL
);
2853 se
.descriptor_only
= 1;
2854 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2855 gfc_add_block_to_block (block
, &se
.pre
);
2856 info
->descriptor
= se
.expr
;
2857 ss_info
->string_length
= se
.string_length
;
2861 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2862 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2864 /* Emit a DECL_EXPR for the variable sized array type in
2865 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2866 sizes works correctly. */
2867 tree arraytype
= TREE_TYPE (
2868 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2869 if (! TYPE_NAME (arraytype
))
2870 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2871 NULL_TREE
, arraytype
);
2872 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2873 TYPE_NAME (arraytype
)));
2875 /* Also the data pointer. */
2876 tmp
= gfc_conv_array_data (se
.expr
);
2877 /* If this is a variable or address of a variable we use it directly.
2878 Otherwise we must evaluate it now to avoid breaking dependency
2879 analysis by pulling the expressions for elemental array indices
2882 || (TREE_CODE (tmp
) == ADDR_EXPR
2883 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2884 tmp
= gfc_evaluate_now (tmp
, block
);
2887 tmp
= gfc_conv_array_offset (se
.expr
);
2888 info
->offset
= gfc_evaluate_now (tmp
, block
);
2890 /* Make absolutely sure that the saved_offset is indeed saved
2891 so that the variable is still accessible after the loops
2893 info
->saved_offset
= info
->offset
;
2898 /* Initialize a gfc_loopinfo structure. */
2901 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2905 memset (loop
, 0, sizeof (gfc_loopinfo
));
2906 gfc_init_block (&loop
->pre
);
2907 gfc_init_block (&loop
->post
);
2909 /* Initially scalarize in order and default to no loop reversal. */
2910 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2913 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2916 loop
->ss
= gfc_ss_terminator
;
2920 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2924 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2930 /* Return an expression for the data pointer of an array. */
2933 gfc_conv_array_data (tree descriptor
)
2937 type
= TREE_TYPE (descriptor
);
2938 if (GFC_ARRAY_TYPE_P (type
))
2940 if (TREE_CODE (type
) == POINTER_TYPE
)
2944 /* Descriptorless arrays. */
2945 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2949 return gfc_conv_descriptor_data_get (descriptor
);
2953 /* Return an expression for the base offset of an array. */
2956 gfc_conv_array_offset (tree descriptor
)
2960 type
= TREE_TYPE (descriptor
);
2961 if (GFC_ARRAY_TYPE_P (type
))
2962 return GFC_TYPE_ARRAY_OFFSET (type
);
2964 return gfc_conv_descriptor_offset_get (descriptor
);
2968 /* Get an expression for the array stride. */
2971 gfc_conv_array_stride (tree descriptor
, int dim
)
2976 type
= TREE_TYPE (descriptor
);
2978 /* For descriptorless arrays use the array size. */
2979 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2980 if (tmp
!= NULL_TREE
)
2983 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2988 /* Like gfc_conv_array_stride, but for the lower bound. */
2991 gfc_conv_array_lbound (tree descriptor
, int dim
)
2996 type
= TREE_TYPE (descriptor
);
2998 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2999 if (tmp
!= NULL_TREE
)
3002 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3007 /* Like gfc_conv_array_stride, but for the upper bound. */
3010 gfc_conv_array_ubound (tree descriptor
, int dim
)
3015 type
= TREE_TYPE (descriptor
);
3017 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3018 if (tmp
!= NULL_TREE
)
3021 /* This should only ever happen when passing an assumed shape array
3022 as an actual parameter. The value will never be used. */
3023 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3024 return gfc_index_zero_node
;
3026 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3031 /* Generate code to perform an array index bound check. */
3034 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3035 locus
* where
, bool check_upper
)
3038 tree tmp_lo
, tmp_up
;
3041 const char * name
= NULL
;
3043 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3046 descriptor
= ss
->info
->data
.array
.descriptor
;
3048 index
= gfc_evaluate_now (index
, &se
->pre
);
3050 /* We find a name for the error message. */
3051 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3052 gcc_assert (name
!= NULL
);
3054 if (VAR_P (descriptor
))
3055 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3057 /* If upper bound is present, include both bounds in the error message. */
3060 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3061 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3064 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3065 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3067 msg
= xasprintf ("Index '%%ld' of dimension %d "
3068 "outside of expected range (%%ld:%%ld)", n
+1);
3070 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3072 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3073 fold_convert (long_integer_type_node
, index
),
3074 fold_convert (long_integer_type_node
, tmp_lo
),
3075 fold_convert (long_integer_type_node
, tmp_up
));
3076 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3078 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3079 fold_convert (long_integer_type_node
, index
),
3080 fold_convert (long_integer_type_node
, tmp_lo
),
3081 fold_convert (long_integer_type_node
, tmp_up
));
3086 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3089 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3090 "below lower bound of %%ld", n
+1, name
);
3092 msg
= xasprintf ("Index '%%ld' of dimension %d "
3093 "below lower bound of %%ld", n
+1);
3095 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3097 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3098 fold_convert (long_integer_type_node
, index
),
3099 fold_convert (long_integer_type_node
, tmp_lo
));
3107 /* Return the offset for an index. Performs bound checking for elemental
3108 dimensions. Single element references are processed separately.
3109 DIM is the array dimension, I is the loop dimension. */
3112 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3113 gfc_array_ref
* ar
, tree stride
)
3115 gfc_array_info
*info
;
3120 info
= &ss
->info
->data
.array
;
3122 /* Get the index into the array for this dimension. */
3125 gcc_assert (ar
->type
!= AR_ELEMENT
);
3126 switch (ar
->dimen_type
[dim
])
3128 case DIMEN_THIS_IMAGE
:
3132 /* Elemental dimension. */
3133 gcc_assert (info
->subscript
[dim
]
3134 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3135 /* We've already translated this value outside the loop. */
3136 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3138 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3139 ar
->as
->type
!= AS_ASSUMED_SIZE
3140 || dim
< ar
->dimen
- 1);
3144 gcc_assert (info
&& se
->loop
);
3145 gcc_assert (info
->subscript
[dim
]
3146 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3147 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3149 /* Get a zero-based index into the vector. */
3150 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3151 gfc_array_index_type
,
3152 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3154 /* Multiply the index by the stride. */
3155 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3156 gfc_array_index_type
,
3157 index
, gfc_conv_array_stride (desc
, 0));
3159 /* Read the vector to get an index into info->descriptor. */
3160 data
= build_fold_indirect_ref_loc (input_location
,
3161 gfc_conv_array_data (desc
));
3162 index
= gfc_build_array_ref (data
, index
, NULL
);
3163 index
= gfc_evaluate_now (index
, &se
->pre
);
3164 index
= fold_convert (gfc_array_index_type
, index
);
3166 /* Do any bounds checking on the final info->descriptor index. */
3167 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3168 ar
->as
->type
!= AS_ASSUMED_SIZE
3169 || dim
< ar
->dimen
- 1);
3173 /* Scalarized dimension. */
3174 gcc_assert (info
&& se
->loop
);
3176 /* Multiply the loop variable by the stride and delta. */
3177 index
= se
->loop
->loopvar
[i
];
3178 if (!integer_onep (info
->stride
[dim
]))
3179 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3180 gfc_array_index_type
, index
,
3182 if (!integer_zerop (info
->delta
[dim
]))
3183 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3184 gfc_array_index_type
, index
,
3194 /* Temporary array or derived type component. */
3195 gcc_assert (se
->loop
);
3196 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3198 /* Pointer functions can have stride[0] different from unity.
3199 Use the stride returned by the function call and stored in
3200 the descriptor for the temporary. */
3201 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3202 && se
->ss
->info
->expr
3203 && se
->ss
->info
->expr
->symtree
3204 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3205 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3206 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3209 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3210 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3211 gfc_array_index_type
, index
, info
->delta
[dim
]);
3214 /* Multiply by the stride. */
3215 if (!integer_onep (stride
))
3216 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3223 /* Build a scalarized array reference using the vptr 'size'. */
3226 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3231 tree decl
= NULL_TREE
;
3233 gfc_expr
*expr
= se
->ss
->info
->expr
;
3235 gfc_ref
*class_ref
= NULL
;
3238 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3239 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3240 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3245 || (expr
->ts
.type
!= BT_CLASS
3246 && !gfc_is_class_array_function (expr
)
3247 && !gfc_is_class_array_ref (expr
, NULL
)))
3250 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3251 ts
= &expr
->symtree
->n
.sym
->ts
;
3255 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3257 if (ref
->type
== REF_COMPONENT
3258 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3259 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3260 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3262 && ref
->next
->next
->type
== REF_ARRAY
3263 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3265 ts
= &ref
->u
.c
.component
->ts
;
3275 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3276 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
3277 && expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
)
3279 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3281 else if (expr
&& gfc_is_class_array_function (expr
))
3285 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3288 type
= TREE_TYPE (tmp
);
3291 if (GFC_CLASS_TYPE_P (type
))
3293 if (type
!= TYPE_CANONICAL (type
))
3294 type
= TYPE_CANONICAL (type
);
3302 if (decl
== NULL_TREE
)
3305 se
->class_vptr
= gfc_evaluate_now (gfc_class_vptr_get (decl
), &se
->pre
);
3307 else if (class_ref
== NULL
)
3309 if (decl
== NULL_TREE
)
3310 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3311 /* For class arrays the tree containing the class is stored in
3312 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3313 For all others it's sym's backend_decl directly. */
3314 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3315 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3319 /* Remove everything after the last class reference, convert the
3320 expression and then recover its tailend once more. */
3322 ref
= class_ref
->next
;
3323 class_ref
->next
= NULL
;
3324 gfc_init_se (&tmpse
, NULL
);
3325 gfc_conv_expr (&tmpse
, expr
);
3326 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3328 class_ref
->next
= ref
;
3331 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3332 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3334 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3337 size
= gfc_class_vtab_size_get (decl
);
3339 /* For unlimited polymorphic entities then _len component needs to be
3340 multiplied with the size. If no _len component is present, then
3341 gfc_class_len_or_zero_get () return a zero_node. */
3342 tmp
= gfc_class_len_or_zero_get (decl
);
3343 if (!integer_zerop (tmp
))
3344 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3345 fold_convert (TREE_TYPE (index
), size
),
3346 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3347 fold_convert (TREE_TYPE (index
), tmp
),
3348 fold_convert (TREE_TYPE (index
),
3349 integer_one_node
)));
3351 size
= fold_convert (TREE_TYPE (index
), size
);
3353 /* Build the address of the element. */
3354 type
= TREE_TYPE (TREE_TYPE (base
));
3355 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3356 gfc_array_index_type
,
3358 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3359 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3360 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3362 /* Return the element in the se expression. */
3363 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3368 /* Build a scalarized reference to an array. */
3371 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3373 gfc_array_info
*info
;
3374 tree decl
= NULL_TREE
;
3382 expr
= ss
->info
->expr
;
3383 info
= &ss
->info
->data
.array
;
3385 n
= se
->loop
->order
[0];
3389 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3390 /* Add the offset for this dimension to the stored offset for all other
3392 if (info
->offset
&& !integer_zerop (info
->offset
))
3393 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3394 index
, info
->offset
);
3396 if (expr
&& ((is_subref_array (expr
)
3397 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
)))
3398 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3399 || expr
->expr_type
== EXPR_FUNCTION
))))
3400 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3402 /* A pointer array component can be detected from its field decl. Fix
3403 the descriptor, mark the resulting variable decl and pass it to
3404 gfc_build_array_ref. */
3405 if (is_pointer_array (info
->descriptor
))
3407 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3409 decl
= gfc_evaluate_now (info
->descriptor
, &se
->pre
);
3410 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
3411 TREE_USED (decl
) = 1;
3413 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3414 decl
= TREE_OPERAND (info
->descriptor
, 0);
3416 if (decl
== NULL_TREE
)
3417 decl
= info
->descriptor
;
3420 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3422 /* Use the vptr 'size' field to access a class the element of a class
3424 if (build_class_array_ref (se
, tmp
, index
))
3427 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3431 /* Translate access of temporary array. */
3434 gfc_conv_tmp_array_ref (gfc_se
* se
)
3436 se
->string_length
= se
->ss
->info
->string_length
;
3437 gfc_conv_scalarized_array_ref (se
, NULL
);
3438 gfc_advance_se_ss_chain (se
);
3441 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3444 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3446 if (TREE_CODE (t
) == INTEGER_CST
)
3447 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3450 if (!integer_zerop (*offset
))
3451 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3452 gfc_array_index_type
, *offset
, t
);
3460 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3466 /* For class arrays the class declaration is stored in the saved
3468 if (INDIRECT_REF_P (desc
)
3469 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3470 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3471 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3472 TREE_OPERAND (desc
, 0)));
3476 /* Class container types do not always have the GFC_CLASS_TYPE_P
3477 but the canonical type does. */
3478 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3479 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3481 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3482 if (TYPE_CANONICAL (type
)
3483 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3484 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3487 tmp
= gfc_conv_array_data (desc
);
3488 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3489 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3494 /* Build an array reference. se->expr already holds the array descriptor.
3495 This should be either a variable, indirect variable reference or component
3496 reference. For arrays which do not have a descriptor, se->expr will be
3498 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3501 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3505 tree offset
, cst_offset
;
3508 tree decl
= NULL_TREE
;
3511 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3512 char *var_name
= NULL
;
3516 gcc_assert (ar
->codimen
);
3518 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3519 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3522 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3523 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3524 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3526 /* Use the actual tree type and not the wrapped coarray. */
3527 if (!se
->want_pointer
)
3528 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3535 /* Handle scalarized references separately. */
3536 if (ar
->type
!= AR_ELEMENT
)
3538 gfc_conv_scalarized_array_ref (se
, ar
);
3539 gfc_advance_se_ss_chain (se
);
3543 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3548 len
= strlen (sym
->name
) + 1;
3549 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3551 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3553 if (ref
->type
== REF_COMPONENT
)
3554 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3557 var_name
= XALLOCAVEC (char, len
);
3558 strcpy (var_name
, sym
->name
);
3560 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3562 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3564 if (ref
->type
== REF_COMPONENT
)
3566 strcat (var_name
, "%%");
3567 strcat (var_name
, ref
->u
.c
.component
->name
);
3572 cst_offset
= offset
= gfc_index_zero_node
;
3573 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3575 /* Calculate the offsets from all the dimensions. Make sure to associate
3576 the final offset so that we form a chain of loop invariant summands. */
3577 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3579 /* Calculate the index for this dimension. */
3580 gfc_init_se (&indexse
, se
);
3581 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3582 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3584 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3586 /* Check array bounds. */
3590 /* Evaluate the indexse.expr only once. */
3591 indexse
.expr
= save_expr (indexse
.expr
);
3594 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3595 if (sym
->attr
.temporary
)
3597 gfc_init_se (&tmpse
, se
);
3598 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3599 gfc_array_index_type
);
3600 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3604 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3606 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3607 "below lower bound of %%ld", n
+1, var_name
);
3608 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3609 fold_convert (long_integer_type_node
,
3611 fold_convert (long_integer_type_node
, tmp
));
3614 /* Upper bound, but not for the last dimension of assumed-size
3616 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3618 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3619 if (sym
->attr
.temporary
)
3621 gfc_init_se (&tmpse
, se
);
3622 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3623 gfc_array_index_type
);
3624 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3628 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3629 logical_type_node
, indexse
.expr
, tmp
);
3630 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3631 "above upper bound of %%ld", n
+1, var_name
);
3632 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3633 fold_convert (long_integer_type_node
,
3635 fold_convert (long_integer_type_node
, tmp
));
3640 /* Multiply the index by the stride. */
3641 stride
= gfc_conv_array_stride (se
->expr
, n
);
3642 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3643 indexse
.expr
, stride
);
3645 /* And add it to the total. */
3646 add_to_offset (&cst_offset
, &offset
, tmp
);
3649 if (!integer_zerop (cst_offset
))
3650 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3651 gfc_array_index_type
, offset
, cst_offset
);
3653 /* A pointer array component can be detected from its field decl. Fix
3654 the descriptor, mark the resulting variable decl and pass it to
3656 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3657 && is_pointer_array (se
->expr
))
3659 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3661 decl
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3662 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
3663 TREE_USED (decl
) = 1;
3665 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3666 decl
= TREE_OPERAND (se
->expr
, 0);
3670 else if (expr
->ts
.deferred
3671 || (sym
->ts
.type
== BT_CHARACTER
3672 && sym
->attr
.select_type_temporary
))
3673 decl
= sym
->backend_decl
;
3674 else if (sym
->ts
.type
== BT_CLASS
)
3677 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3681 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3682 LOOP_DIM dimension (if any) to array's offset. */
3685 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3686 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3689 gfc_array_info
*info
;
3692 info
= &ss
->info
->data
.array
;
3694 gfc_init_se (&se
, NULL
);
3696 se
.expr
= info
->descriptor
;
3697 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3698 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3699 gfc_add_block_to_block (pblock
, &se
.pre
);
3701 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3702 gfc_array_index_type
,
3703 info
->offset
, index
);
3704 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3708 /* Generate the code to be executed immediately before entering a
3709 scalarization loop. */
3712 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3713 stmtblock_t
* pblock
)
3716 gfc_ss_info
*ss_info
;
3717 gfc_array_info
*info
;
3718 gfc_ss_type ss_type
;
3720 gfc_loopinfo
*ploop
;
3724 /* This code will be executed before entering the scalarization loop
3725 for this dimension. */
3726 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3730 if ((ss_info
->useflags
& flag
) == 0)
3733 ss_type
= ss_info
->type
;
3734 if (ss_type
!= GFC_SS_SECTION
3735 && ss_type
!= GFC_SS_FUNCTION
3736 && ss_type
!= GFC_SS_CONSTRUCTOR
3737 && ss_type
!= GFC_SS_COMPONENT
)
3740 info
= &ss_info
->data
.array
;
3742 gcc_assert (dim
< ss
->dimen
);
3743 gcc_assert (ss
->dimen
== loop
->dimen
);
3746 ar
= &info
->ref
->u
.ar
;
3750 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3752 /* If we are in the outermost dimension of this loop, the previous
3753 dimension shall be in the parent loop. */
3754 gcc_assert (ss
->parent
!= NULL
);
3757 ploop
= loop
->parent
;
3759 /* ss and ss->parent are about the same array. */
3760 gcc_assert (ss_info
== pss
->info
);
3768 if (dim
== loop
->dimen
- 1)
3773 /* For the time being, there is no loop reordering. */
3774 gcc_assert (i
== ploop
->order
[i
]);
3775 i
= ploop
->order
[i
];
3777 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3779 stride
= gfc_conv_array_stride (info
->descriptor
,
3780 innermost_ss (ss
)->dim
[i
]);
3782 /* Calculate the stride of the innermost loop. Hopefully this will
3783 allow the backend optimizers to do their stuff more effectively.
3785 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3787 /* For the outermost loop calculate the offset due to any
3788 elemental dimensions. It will have been initialized with the
3789 base offset of the array. */
3792 for (i
= 0; i
< ar
->dimen
; i
++)
3794 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3797 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3802 /* Add the offset for the previous loop dimension. */
3803 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3805 /* Remember this offset for the second loop. */
3806 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3807 info
->saved_offset
= info
->offset
;
3812 /* Start a scalarized expression. Creates a scope and declares loop
3816 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3822 gcc_assert (!loop
->array_parameter
);
3824 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3826 n
= loop
->order
[dim
];
3828 gfc_start_block (&loop
->code
[n
]);
3830 /* Create the loop variable. */
3831 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3833 if (dim
< loop
->temp_dim
)
3837 /* Calculate values that will be constant within this loop. */
3838 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3840 gfc_start_block (pbody
);
3844 /* Generates the actual loop code for a scalarization loop. */
3847 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3848 stmtblock_t
* pbody
)
3859 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3860 | OMPWS_SCALARIZER_BODY
))
3861 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3862 && n
== loop
->dimen
- 1)
3864 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3865 init
= make_tree_vec (1);
3866 cond
= make_tree_vec (1);
3867 incr
= make_tree_vec (1);
3869 /* Cycle statement is implemented with a goto. Exit statement must not
3870 be present for this loop. */
3871 exit_label
= gfc_build_label_decl (NULL_TREE
);
3872 TREE_USED (exit_label
) = 1;
3874 /* Label for cycle statements (if needed). */
3875 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3876 gfc_add_expr_to_block (pbody
, tmp
);
3878 stmt
= make_node (OMP_FOR
);
3880 TREE_TYPE (stmt
) = void_type_node
;
3881 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3883 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3884 OMP_CLAUSE_SCHEDULE
);
3885 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3886 = OMP_CLAUSE_SCHEDULE_STATIC
;
3887 if (ompws_flags
& OMPWS_NOWAIT
)
3888 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3889 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3891 /* Initialize the loopvar. */
3892 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3894 OMP_FOR_INIT (stmt
) = init
;
3895 /* The exit condition. */
3896 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3898 loop
->loopvar
[n
], loop
->to
[n
]);
3899 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3900 OMP_FOR_COND (stmt
) = cond
;
3901 /* Increment the loopvar. */
3902 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3903 loop
->loopvar
[n
], gfc_index_one_node
);
3904 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3905 void_type_node
, loop
->loopvar
[n
], tmp
);
3906 OMP_FOR_INCR (stmt
) = incr
;
3908 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3909 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3913 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3914 && (loop
->temp_ss
== NULL
);
3916 loopbody
= gfc_finish_block (pbody
);
3919 std::swap (loop
->from
[n
], loop
->to
[n
]);
3921 /* Initialize the loopvar. */
3922 if (loop
->loopvar
[n
] != loop
->from
[n
])
3923 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3925 exit_label
= gfc_build_label_decl (NULL_TREE
);
3927 /* Generate the loop body. */
3928 gfc_init_block (&block
);
3930 /* The exit condition. */
3931 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3932 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3933 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3934 TREE_USED (exit_label
) = 1;
3935 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3936 gfc_add_expr_to_block (&block
, tmp
);
3938 /* The main body. */
3939 gfc_add_expr_to_block (&block
, loopbody
);
3941 /* Increment the loopvar. */
3942 tmp
= fold_build2_loc (input_location
,
3943 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3944 gfc_array_index_type
, loop
->loopvar
[n
],
3945 gfc_index_one_node
);
3947 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3949 /* Build the loop. */
3950 tmp
= gfc_finish_block (&block
);
3951 tmp
= build1_v (LOOP_EXPR
, tmp
);
3952 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3954 /* Add the exit label. */
3955 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3956 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3962 /* Finishes and generates the loops for a scalarized expression. */
3965 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3970 stmtblock_t
*pblock
;
3974 /* Generate the loops. */
3975 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3977 n
= loop
->order
[dim
];
3978 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3979 loop
->loopvar
[n
] = NULL_TREE
;
3980 pblock
= &loop
->code
[n
];
3983 tmp
= gfc_finish_block (pblock
);
3984 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3986 /* Clear all the used flags. */
3987 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3988 if (ss
->parent
== NULL
)
3989 ss
->info
->useflags
= 0;
3993 /* Finish the main body of a scalarized expression, and start the secondary
3997 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
4001 stmtblock_t
*pblock
;
4005 /* We finish as many loops as are used by the temporary. */
4006 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4008 n
= loop
->order
[dim
];
4009 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4010 loop
->loopvar
[n
] = NULL_TREE
;
4011 pblock
= &loop
->code
[n
];
4014 /* We don't want to finish the outermost loop entirely. */
4015 n
= loop
->order
[loop
->temp_dim
- 1];
4016 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4018 /* Restore the initial offsets. */
4019 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4021 gfc_ss_type ss_type
;
4022 gfc_ss_info
*ss_info
;
4026 if ((ss_info
->useflags
& 2) == 0)
4029 ss_type
= ss_info
->type
;
4030 if (ss_type
!= GFC_SS_SECTION
4031 && ss_type
!= GFC_SS_FUNCTION
4032 && ss_type
!= GFC_SS_CONSTRUCTOR
4033 && ss_type
!= GFC_SS_COMPONENT
)
4036 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4039 /* Restart all the inner loops we just finished. */
4040 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4042 n
= loop
->order
[dim
];
4044 gfc_start_block (&loop
->code
[n
]);
4046 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4048 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4051 /* Start a block for the secondary copying code. */
4052 gfc_start_block (body
);
4056 /* Precalculate (either lower or upper) bound of an array section.
4057 BLOCK: Block in which the (pre)calculation code will go.
4058 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4059 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4060 DESC: Array descriptor from which the bound will be picked if unspecified
4061 (either lower or upper bound according to LBOUND). */
4064 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4065 tree desc
, int dim
, bool lbound
, bool deferred
)
4068 gfc_expr
* input_val
= values
[dim
];
4069 tree
*output
= &bounds
[dim
];
4074 /* Specified section bound. */
4075 gfc_init_se (&se
, NULL
);
4076 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4077 gfc_add_block_to_block (block
, &se
.pre
);
4080 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4082 /* The gfc_conv_array_lbound () routine returns a constant zero for
4083 deferred length arrays, which in the scalarizer wreaks havoc, when
4084 copying to a (newly allocated) one-based array.
4085 Keep returning the actual result in sync for both bounds. */
4086 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4088 gfc_conv_descriptor_ubound_get (desc
,
4093 /* No specific bound specified so use the bound of the array. */
4094 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4095 gfc_conv_array_ubound (desc
, dim
);
4097 *output
= gfc_evaluate_now (*output
, block
);
4101 /* Calculate the lower bound of an array section. */
4104 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4106 gfc_expr
*stride
= NULL
;
4109 gfc_array_info
*info
;
4112 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4114 info
= &ss
->info
->data
.array
;
4115 ar
= &info
->ref
->u
.ar
;
4117 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4119 /* We use a zero-based index to access the vector. */
4120 info
->start
[dim
] = gfc_index_zero_node
;
4121 info
->end
[dim
] = NULL
;
4122 info
->stride
[dim
] = gfc_index_one_node
;
4126 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4127 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4128 desc
= info
->descriptor
;
4129 stride
= ar
->stride
[dim
];
4132 /* Calculate the start of the range. For vector subscripts this will
4133 be the range of the vector. */
4134 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4135 ar
->as
->type
== AS_DEFERRED
);
4137 /* Similarly calculate the end. Although this is not used in the
4138 scalarizer, it is needed when checking bounds and where the end
4139 is an expression with side-effects. */
4140 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4141 ar
->as
->type
== AS_DEFERRED
);
4144 /* Calculate the stride. */
4146 info
->stride
[dim
] = gfc_index_one_node
;
4149 gfc_init_se (&se
, NULL
);
4150 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4151 gfc_add_block_to_block (block
, &se
.pre
);
4152 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4157 /* Calculates the range start and stride for a SS chain. Also gets the
4158 descriptor and data pointer. The range of vector subscripts is the size
4159 of the vector. Array bounds are also checked. */
4162 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4169 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4172 /* Determine the rank of the loop. */
4173 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4175 switch (ss
->info
->type
)
4177 case GFC_SS_SECTION
:
4178 case GFC_SS_CONSTRUCTOR
:
4179 case GFC_SS_FUNCTION
:
4180 case GFC_SS_COMPONENT
:
4181 loop
->dimen
= ss
->dimen
;
4184 /* As usual, lbound and ubound are exceptions!. */
4185 case GFC_SS_INTRINSIC
:
4186 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4188 case GFC_ISYM_LBOUND
:
4189 case GFC_ISYM_UBOUND
:
4190 case GFC_ISYM_LCOBOUND
:
4191 case GFC_ISYM_UCOBOUND
:
4192 case GFC_ISYM_THIS_IMAGE
:
4193 loop
->dimen
= ss
->dimen
;
4205 /* We should have determined the rank of the expression by now. If
4206 not, that's bad news. */
4210 /* Loop over all the SS in the chain. */
4211 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4213 gfc_ss_info
*ss_info
;
4214 gfc_array_info
*info
;
4218 expr
= ss_info
->expr
;
4219 info
= &ss_info
->data
.array
;
4221 if (expr
&& expr
->shape
&& !info
->shape
)
4222 info
->shape
= expr
->shape
;
4224 switch (ss_info
->type
)
4226 case GFC_SS_SECTION
:
4227 /* Get the descriptor for the array. If it is a cross loops array,
4228 we got the descriptor already in the outermost loop. */
4229 if (ss
->parent
== NULL
)
4230 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4231 !loop
->array_parameter
);
4233 for (n
= 0; n
< ss
->dimen
; n
++)
4234 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4237 case GFC_SS_INTRINSIC
:
4238 switch (expr
->value
.function
.isym
->id
)
4240 /* Fall through to supply start and stride. */
4241 case GFC_ISYM_LBOUND
:
4242 case GFC_ISYM_UBOUND
:
4246 /* This is the variant without DIM=... */
4247 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4249 arg
= expr
->value
.function
.actual
->expr
;
4250 if (arg
->rank
== -1)
4255 /* The rank (hence the return value's shape) is unknown,
4256 we have to retrieve it. */
4257 gfc_init_se (&se
, NULL
);
4258 se
.descriptor_only
= 1;
4259 gfc_conv_expr (&se
, arg
);
4260 /* This is a bare variable, so there is no preliminary
4262 gcc_assert (se
.pre
.head
== NULL_TREE
4263 && se
.post
.head
== NULL_TREE
);
4264 rank
= gfc_conv_descriptor_rank (se
.expr
);
4265 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4266 gfc_array_index_type
,
4267 fold_convert (gfc_array_index_type
,
4269 gfc_index_one_node
);
4270 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4271 info
->start
[0] = gfc_index_zero_node
;
4272 info
->stride
[0] = gfc_index_one_node
;
4275 /* Otherwise fall through GFC_SS_FUNCTION. */
4278 case GFC_ISYM_LCOBOUND
:
4279 case GFC_ISYM_UCOBOUND
:
4280 case GFC_ISYM_THIS_IMAGE
:
4288 case GFC_SS_CONSTRUCTOR
:
4289 case GFC_SS_FUNCTION
:
4290 for (n
= 0; n
< ss
->dimen
; n
++)
4292 int dim
= ss
->dim
[n
];
4294 info
->start
[dim
] = gfc_index_zero_node
;
4295 info
->end
[dim
] = gfc_index_zero_node
;
4296 info
->stride
[dim
] = gfc_index_one_node
;
4305 /* The rest is just runtime bound checking. */
4306 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4309 tree lbound
, ubound
;
4311 tree size
[GFC_MAX_DIMENSIONS
];
4312 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4313 gfc_array_info
*info
;
4317 gfc_start_block (&block
);
4319 for (n
= 0; n
< loop
->dimen
; n
++)
4320 size
[n
] = NULL_TREE
;
4322 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4325 gfc_ss_info
*ss_info
;
4328 const char *expr_name
;
4331 if (ss_info
->type
!= GFC_SS_SECTION
)
4334 /* Catch allocatable lhs in f2003. */
4335 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
4338 expr
= ss_info
->expr
;
4339 expr_loc
= &expr
->where
;
4340 expr_name
= expr
->symtree
->name
;
4342 gfc_start_block (&inner
);
4344 /* TODO: range checking for mapped dimensions. */
4345 info
= &ss_info
->data
.array
;
4347 /* This code only checks ranges. Elemental and vector
4348 dimensions are checked later. */
4349 for (n
= 0; n
< loop
->dimen
; n
++)
4354 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4357 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4358 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4359 check_upper
= false;
4363 /* Zero stride is not allowed. */
4364 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4365 info
->stride
[dim
], gfc_index_zero_node
);
4366 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4367 "of array '%s'", dim
+ 1, expr_name
);
4368 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4372 desc
= info
->descriptor
;
4374 /* This is the run-time equivalent of resolve.c's
4375 check_dimension(). The logical is more readable there
4376 than it is here, with all the trees. */
4377 lbound
= gfc_conv_array_lbound (desc
, dim
);
4378 end
= info
->end
[dim
];
4380 ubound
= gfc_conv_array_ubound (desc
, dim
);
4384 /* non_zerosized is true when the selected range is not
4386 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4387 logical_type_node
, info
->stride
[dim
],
4388 gfc_index_zero_node
);
4389 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4390 info
->start
[dim
], end
);
4391 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4392 logical_type_node
, stride_pos
, tmp
);
4394 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4396 info
->stride
[dim
], gfc_index_zero_node
);
4397 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4398 info
->start
[dim
], end
);
4399 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4402 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4404 stride_pos
, stride_neg
);
4406 /* Check the start of the range against the lower and upper
4407 bounds of the array, if the range is not empty.
4408 If upper bound is present, include both bounds in the
4412 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4414 info
->start
[dim
], lbound
);
4415 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4417 non_zerosized
, tmp
);
4418 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4420 info
->start
[dim
], ubound
);
4421 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4423 non_zerosized
, tmp2
);
4424 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4425 "outside of expected range (%%ld:%%ld)",
4426 dim
+ 1, expr_name
);
4427 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4429 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4430 fold_convert (long_integer_type_node
, lbound
),
4431 fold_convert (long_integer_type_node
, ubound
));
4432 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4434 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4435 fold_convert (long_integer_type_node
, lbound
),
4436 fold_convert (long_integer_type_node
, ubound
));
4441 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4443 info
->start
[dim
], lbound
);
4444 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4445 logical_type_node
, non_zerosized
, tmp
);
4446 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4447 "below lower bound of %%ld",
4448 dim
+ 1, expr_name
);
4449 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4451 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4452 fold_convert (long_integer_type_node
, lbound
));
4456 /* Compute the last element of the range, which is not
4457 necessarily "end" (think 0:5:3, which doesn't contain 5)
4458 and check it against both lower and upper bounds. */
4460 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4461 gfc_array_index_type
, end
,
4463 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4464 gfc_array_index_type
, tmp
,
4466 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4467 gfc_array_index_type
, end
, tmp
);
4468 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4469 logical_type_node
, tmp
, lbound
);
4470 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4471 logical_type_node
, non_zerosized
, tmp2
);
4474 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4475 logical_type_node
, tmp
, ubound
);
4476 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4477 logical_type_node
, non_zerosized
, tmp3
);
4478 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4479 "outside of expected range (%%ld:%%ld)",
4480 dim
+ 1, expr_name
);
4481 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4483 fold_convert (long_integer_type_node
, tmp
),
4484 fold_convert (long_integer_type_node
, ubound
),
4485 fold_convert (long_integer_type_node
, lbound
));
4486 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4488 fold_convert (long_integer_type_node
, tmp
),
4489 fold_convert (long_integer_type_node
, ubound
),
4490 fold_convert (long_integer_type_node
, lbound
));
4495 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4496 "below lower bound of %%ld",
4497 dim
+ 1, expr_name
);
4498 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4500 fold_convert (long_integer_type_node
, tmp
),
4501 fold_convert (long_integer_type_node
, lbound
));
4505 /* Check the section sizes match. */
4506 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4507 gfc_array_index_type
, end
,
4509 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4510 gfc_array_index_type
, tmp
,
4512 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4513 gfc_array_index_type
,
4514 gfc_index_one_node
, tmp
);
4515 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4516 gfc_array_index_type
, tmp
,
4517 build_int_cst (gfc_array_index_type
, 0));
4518 /* We remember the size of the first section, and check all the
4519 others against this. */
4522 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4523 logical_type_node
, tmp
, size
[n
]);
4524 msg
= xasprintf ("Array bound mismatch for dimension %d "
4525 "of array '%s' (%%ld/%%ld)",
4526 dim
+ 1, expr_name
);
4528 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4530 fold_convert (long_integer_type_node
, tmp
),
4531 fold_convert (long_integer_type_node
, size
[n
]));
4536 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4539 tmp
= gfc_finish_block (&inner
);
4541 /* For optional arguments, only check bounds if the argument is
4543 if (expr
->symtree
->n
.sym
->attr
.optional
4544 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4545 tmp
= build3_v (COND_EXPR
,
4546 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4547 tmp
, build_empty_stmt (input_location
));
4549 gfc_add_expr_to_block (&block
, tmp
);
4553 tmp
= gfc_finish_block (&block
);
4554 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4557 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4558 gfc_conv_ss_startstride (loop
);
4561 /* Return true if both symbols could refer to the same data object. Does
4562 not take account of aliasing due to equivalence statements. */
4565 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4566 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4568 /* Aliasing isn't possible if the symbols have different base types. */
4569 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4572 /* Pointers can point to other pointers and target objects. */
4574 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4575 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4578 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4579 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4581 if (lsym_target
&& rsym_target
4582 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4583 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4584 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4585 && (!rsym
->attr
.dimension
4586 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4593 /* Return true if the two SS could be aliased, i.e. both point to the same data
4595 /* TODO: resolve aliases based on frontend expressions. */
4598 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4602 gfc_expr
*lexpr
, *rexpr
;
4605 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4607 lexpr
= lss
->info
->expr
;
4608 rexpr
= rss
->info
->expr
;
4610 lsym
= lexpr
->symtree
->n
.sym
;
4611 rsym
= rexpr
->symtree
->n
.sym
;
4613 lsym_pointer
= lsym
->attr
.pointer
;
4614 lsym_target
= lsym
->attr
.target
;
4615 rsym_pointer
= rsym
->attr
.pointer
;
4616 rsym_target
= rsym
->attr
.target
;
4618 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4619 rsym_pointer
, rsym_target
))
4622 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4623 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4626 /* For derived types we must check all the component types. We can ignore
4627 array references as these will have the same base type as the previous
4629 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4631 if (lref
->type
!= REF_COMPONENT
)
4634 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4635 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4637 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4638 rsym_pointer
, rsym_target
))
4641 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4642 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4644 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4649 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4652 if (rref
->type
!= REF_COMPONENT
)
4655 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4656 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4658 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4659 lsym_pointer
, lsym_target
,
4660 rsym_pointer
, rsym_target
))
4663 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4664 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4666 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4667 &rref
->u
.c
.sym
->ts
))
4669 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4670 &rref
->u
.c
.component
->ts
))
4672 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4673 &rref
->u
.c
.component
->ts
))
4679 lsym_pointer
= lsym
->attr
.pointer
;
4680 lsym_target
= lsym
->attr
.target
;
4681 lsym_pointer
= lsym
->attr
.pointer
;
4682 lsym_target
= lsym
->attr
.target
;
4684 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4686 if (rref
->type
!= REF_COMPONENT
)
4689 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4690 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4692 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4693 lsym_pointer
, lsym_target
,
4694 rsym_pointer
, rsym_target
))
4697 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4698 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4700 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4709 /* Resolve array data dependencies. Creates a temporary if required. */
4710 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4714 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4720 gfc_ss_info
*ss_info
;
4721 gfc_expr
*dest_expr
;
4726 loop
->temp_ss
= NULL
;
4727 dest_expr
= dest
->info
->expr
;
4729 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4732 ss_expr
= ss_info
->expr
;
4734 if (ss_info
->array_outer_dependency
)
4740 if (ss_info
->type
!= GFC_SS_SECTION
)
4742 if (flag_realloc_lhs
4743 && dest_expr
!= ss_expr
4744 && gfc_is_reallocatable_lhs (dest_expr
)
4746 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4748 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4749 if (!nDepend
&& dest_expr
->rank
> 0
4750 && dest_expr
->ts
.type
== BT_CHARACTER
4751 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4753 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4755 if (ss_info
->type
== GFC_SS_REFERENCE
4756 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4757 ss_info
->data
.scalar
.needs_temporary
= 1;
4765 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4767 if (gfc_could_be_alias (dest
, ss
)
4768 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4776 lref
= dest_expr
->ref
;
4777 rref
= ss_expr
->ref
;
4779 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4784 for (i
= 0; i
< dest
->dimen
; i
++)
4785 for (j
= 0; j
< ss
->dimen
; j
++)
4787 && dest
->dim
[i
] == ss
->dim
[j
])
4789 /* If we don't access array elements in the same order,
4790 there is a dependency. */
4795 /* TODO : loop shifting. */
4798 /* Mark the dimensions for LOOP SHIFTING */
4799 for (n
= 0; n
< loop
->dimen
; n
++)
4801 int dim
= dest
->data
.info
.dim
[n
];
4803 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4805 else if (! gfc_is_same_range (&lref
->u
.ar
,
4806 &rref
->u
.ar
, dim
, 0))
4810 /* Put all the dimensions with dependencies in the
4813 for (n
= 0; n
< loop
->dimen
; n
++)
4815 gcc_assert (loop
->order
[n
] == n
);
4817 loop
->order
[dim
++] = n
;
4819 for (n
= 0; n
< loop
->dimen
; n
++)
4822 loop
->order
[dim
++] = n
;
4825 gcc_assert (dim
== loop
->dimen
);
4836 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4837 if (GFC_ARRAY_TYPE_P (base_type
)
4838 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4839 base_type
= gfc_get_element_type (base_type
);
4840 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4842 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4845 loop
->temp_ss
= NULL
;
4849 /* Browse through each array's information from the scalarizer and set the loop
4850 bounds according to the "best" one (per dimension), i.e. the one which
4851 provides the most information (constant bounds, shape, etc.). */
4854 set_loop_bounds (gfc_loopinfo
*loop
)
4856 int n
, dim
, spec_dim
;
4857 gfc_array_info
*info
;
4858 gfc_array_info
*specinfo
;
4862 bool dynamic
[GFC_MAX_DIMENSIONS
];
4865 bool nonoptional_arr
;
4867 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4869 loopspec
= loop
->specloop
;
4872 for (n
= 0; n
< loop
->dimen
; n
++)
4877 /* If there are both optional and nonoptional array arguments, scalarize
4878 over the nonoptional; otherwise, it does not matter as then all
4879 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4881 nonoptional_arr
= false;
4883 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4884 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4885 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4887 nonoptional_arr
= true;
4891 /* We use one SS term, and use that to determine the bounds of the
4892 loop for this dimension. We try to pick the simplest term. */
4893 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4895 gfc_ss_type ss_type
;
4897 ss_type
= ss
->info
->type
;
4898 if (ss_type
== GFC_SS_SCALAR
4899 || ss_type
== GFC_SS_TEMP
4900 || ss_type
== GFC_SS_REFERENCE
4901 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4904 info
= &ss
->info
->data
.array
;
4907 if (loopspec
[n
] != NULL
)
4909 specinfo
= &loopspec
[n
]->info
->data
.array
;
4910 spec_dim
= loopspec
[n
]->dim
[n
];
4914 /* Silence uninitialized warnings. */
4921 gcc_assert (info
->shape
[dim
]);
4922 /* The frontend has worked out the size for us. */
4925 || !integer_zerop (specinfo
->start
[spec_dim
]))
4926 /* Prefer zero-based descriptors if possible. */
4931 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4933 gfc_constructor_base base
;
4934 /* An unknown size constructor will always be rank one.
4935 Higher rank constructors will either have known shape,
4936 or still be wrapped in a call to reshape. */
4937 gcc_assert (loop
->dimen
== 1);
4939 /* Always prefer to use the constructor bounds if the size
4940 can be determined at compile time. Prefer not to otherwise,
4941 since the general case involves realloc, and it's better to
4942 avoid that overhead if possible. */
4943 base
= ss
->info
->expr
->value
.constructor
;
4944 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4945 if (!dynamic
[n
] || !loopspec
[n
])
4950 /* Avoid using an allocatable lhs in an assignment, since
4951 there might be a reallocation coming. */
4952 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4957 /* Criteria for choosing a loop specifier (most important first):
4958 doesn't need realloc
4964 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4966 else if (integer_onep (info
->stride
[dim
])
4967 && !integer_onep (specinfo
->stride
[spec_dim
]))
4969 else if (INTEGER_CST_P (info
->stride
[dim
])
4970 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4972 else if (INTEGER_CST_P (info
->start
[dim
])
4973 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4974 && integer_onep (info
->stride
[dim
])
4975 == integer_onep (specinfo
->stride
[spec_dim
])
4976 && INTEGER_CST_P (info
->stride
[dim
])
4977 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4979 /* We don't work out the upper bound.
4980 else if (INTEGER_CST_P (info->finish[n])
4981 && ! INTEGER_CST_P (specinfo->finish[n]))
4982 loopspec[n] = ss; */
4985 /* We should have found the scalarization loop specifier. If not,
4987 gcc_assert (loopspec
[n
]);
4989 info
= &loopspec
[n
]->info
->data
.array
;
4990 dim
= loopspec
[n
]->dim
[n
];
4992 /* Set the extents of this range. */
4993 cshape
= info
->shape
;
4994 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4995 && INTEGER_CST_P (info
->stride
[dim
]))
4997 loop
->from
[n
] = info
->start
[dim
];
4998 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4999 mpz_sub_ui (i
, i
, 1);
5000 /* To = from + (size - 1) * stride. */
5001 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
5002 if (!integer_onep (info
->stride
[dim
]))
5003 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5004 gfc_array_index_type
, tmp
,
5006 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5007 gfc_array_index_type
,
5008 loop
->from
[n
], tmp
);
5012 loop
->from
[n
] = info
->start
[dim
];
5013 switch (loopspec
[n
]->info
->type
)
5015 case GFC_SS_CONSTRUCTOR
:
5016 /* The upper bound is calculated when we expand the
5018 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5021 case GFC_SS_SECTION
:
5022 /* Use the end expression if it exists and is not constant,
5023 so that it is only evaluated once. */
5024 loop
->to
[n
] = info
->end
[dim
];
5027 case GFC_SS_FUNCTION
:
5028 /* The loop bound will be set when we generate the call. */
5029 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5032 case GFC_SS_INTRINSIC
:
5034 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5036 /* The {l,u}bound of an assumed rank. */
5037 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5038 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5039 && expr
->value
.function
.actual
->next
->expr
== NULL
5040 && expr
->value
.function
.actual
->expr
->rank
== -1);
5042 loop
->to
[n
] = info
->end
[dim
];
5051 /* Transform everything so we have a simple incrementing variable. */
5052 if (integer_onep (info
->stride
[dim
]))
5053 info
->delta
[dim
] = gfc_index_zero_node
;
5056 /* Set the delta for this section. */
5057 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5058 /* Number of iterations is (end - start + step) / step.
5059 with start = 0, this simplifies to
5061 for (i = 0; i<=last; i++){...}; */
5062 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5063 gfc_array_index_type
, loop
->to
[n
],
5065 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5066 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5067 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5068 tmp
, build_int_cst (gfc_array_index_type
, -1));
5069 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5070 /* Make the loop variable start at 0. */
5071 loop
->from
[n
] = gfc_index_zero_node
;
5076 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5077 set_loop_bounds (loop
);
5081 /* Initialize the scalarization loop. Creates the loop variables. Determines
5082 the range of the loop variables. Creates a temporary if required.
5083 Also generates code for scalar expressions which have been
5084 moved outside the loop. */
5087 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5092 set_loop_bounds (loop
);
5094 /* Add all the scalar code that can be taken out of the loops.
5095 This may include calculating the loop bounds, so do it before
5096 allocating the temporary. */
5097 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5099 tmp_ss
= loop
->temp_ss
;
5100 /* If we want a temporary then create it. */
5103 gfc_ss_info
*tmp_ss_info
;
5105 tmp_ss_info
= tmp_ss
->info
;
5106 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5107 gcc_assert (loop
->parent
== NULL
);
5109 /* Make absolutely sure that this is a complete type. */
5110 if (tmp_ss_info
->string_length
)
5111 tmp_ss_info
->data
.temp
.type
5112 = gfc_get_character_type_len_for_eltype
5113 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5114 tmp_ss_info
->string_length
);
5116 tmp
= tmp_ss_info
->data
.temp
.type
;
5117 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5118 tmp_ss_info
->type
= GFC_SS_SECTION
;
5120 gcc_assert (tmp_ss
->dimen
!= 0);
5122 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5123 NULL_TREE
, false, true, false, where
);
5126 /* For array parameters we don't have loop variables, so don't calculate the
5128 if (!loop
->array_parameter
)
5129 gfc_set_delta (loop
);
5133 /* Calculates how to transform from loop variables to array indices for each
5134 array: once loop bounds are chosen, sets the difference (DELTA field) between
5135 loop bounds and array reference bounds, for each array info. */
5138 gfc_set_delta (gfc_loopinfo
*loop
)
5140 gfc_ss
*ss
, **loopspec
;
5141 gfc_array_info
*info
;
5145 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5147 loopspec
= loop
->specloop
;
5149 /* Calculate the translation from loop variables to array indices. */
5150 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5152 gfc_ss_type ss_type
;
5154 ss_type
= ss
->info
->type
;
5155 if (ss_type
!= GFC_SS_SECTION
5156 && ss_type
!= GFC_SS_COMPONENT
5157 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5160 info
= &ss
->info
->data
.array
;
5162 for (n
= 0; n
< ss
->dimen
; n
++)
5164 /* If we are specifying the range the delta is already set. */
5165 if (loopspec
[n
] != ss
)
5169 /* Calculate the offset relative to the loop variable.
5170 First multiply by the stride. */
5171 tmp
= loop
->from
[n
];
5172 if (!integer_onep (info
->stride
[dim
]))
5173 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5174 gfc_array_index_type
,
5175 tmp
, info
->stride
[dim
]);
5177 /* Then subtract this from our starting value. */
5178 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5179 gfc_array_index_type
,
5180 info
->start
[dim
], tmp
);
5182 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5187 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5188 gfc_set_delta (loop
);
5192 /* Calculate the size of a given array dimension from the bounds. This
5193 is simply (ubound - lbound + 1) if this expression is positive
5194 or 0 if it is negative (pick either one if it is zero). Optionally
5195 (if or_expr is present) OR the (expression != 0) condition to it. */
5198 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5203 /* Calculate (ubound - lbound + 1). */
5204 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5206 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5207 gfc_index_one_node
);
5209 /* Check whether the size for this dimension is negative. */
5210 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5211 gfc_index_zero_node
);
5212 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5213 gfc_index_zero_node
, res
);
5215 /* Build OR expression. */
5217 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5218 logical_type_node
, *or_expr
, cond
);
5224 /* For an array descriptor, get the total number of elements. This is just
5225 the product of the extents along from_dim to to_dim. */
5228 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5233 res
= gfc_index_one_node
;
5235 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5241 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5242 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5244 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5245 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5253 /* Full size of an array. */
5256 gfc_conv_descriptor_size (tree desc
, int rank
)
5258 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5262 /* Size of a coarray for all dimensions but the last. */
5265 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5267 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5271 /* Fills in an array descriptor, and returns the size of the array.
5272 The size will be a simple_val, ie a variable or a constant. Also
5273 calculates the offset of the base. The pointer argument overflow,
5274 which should be of integer type, will increase in value if overflow
5275 occurs during the size calculation. Returns the size of the array.
5279 for (n = 0; n < rank; n++)
5281 a.lbound[n] = specified_lower_bound;
5282 offset = offset + a.lbond[n] * stride;
5284 a.ubound[n] = specified_upper_bound;
5285 a.stride[n] = stride;
5286 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5287 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5288 stride = stride * size;
5290 for (n = rank; n < rank+corank; n++)
5291 (Set lcobound/ucobound as above.)
5292 element_size = sizeof (array element);
5295 stride = (size_t) stride;
5296 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5297 stride = stride * element_size;
5303 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5304 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5305 stmtblock_t
* descriptor_block
, tree
* overflow
,
5306 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5307 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5320 stmtblock_t thenblock
;
5321 stmtblock_t elseblock
;
5326 type
= TREE_TYPE (descriptor
);
5328 stride
= gfc_index_one_node
;
5329 offset
= gfc_index_zero_node
;
5331 /* Set the dtype before the alloc, because registration of coarrays needs
5333 if (expr
->ts
.type
== BT_CHARACTER
5334 && expr
->ts
.deferred
5335 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5337 type
= gfc_typenode_for_spec (&expr
->ts
);
5338 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5339 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5343 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5344 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5347 or_expr
= logical_false_node
;
5349 for (n
= 0; n
< rank
; n
++)
5354 /* We have 3 possibilities for determining the size of the array:
5355 lower == NULL => lbound = 1, ubound = upper[n]
5356 upper[n] = NULL => lbound = 1, ubound = lower[n]
5357 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5360 /* Set lower bound. */
5361 gfc_init_se (&se
, NULL
);
5362 if (expr3_desc
!= NULL_TREE
)
5364 if (e3_is_array_constr
)
5365 /* The lbound of a constant array [] starts at zero, but when
5366 allocating it, the standard expects the array to start at
5368 se
.expr
= gfc_index_one_node
;
5370 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5373 else if (lower
== NULL
)
5374 se
.expr
= gfc_index_one_node
;
5377 gcc_assert (lower
[n
]);
5380 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5381 gfc_add_block_to_block (pblock
, &se
.pre
);
5385 se
.expr
= gfc_index_one_node
;
5389 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5390 gfc_rank_cst
[n
], se
.expr
);
5391 conv_lbound
= se
.expr
;
5393 /* Work out the offset for this component. */
5394 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5396 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5397 gfc_array_index_type
, offset
, tmp
);
5399 /* Set upper bound. */
5400 gfc_init_se (&se
, NULL
);
5401 if (expr3_desc
!= NULL_TREE
)
5403 if (e3_is_array_constr
)
5405 /* The lbound of a constant array [] starts at zero, but when
5406 allocating it, the standard expects the array to start at
5407 one. Therefore fix the upper bound to be
5408 (desc.ubound - desc.lbound)+ 1. */
5409 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5410 gfc_array_index_type
,
5411 gfc_conv_descriptor_ubound_get (
5412 expr3_desc
, gfc_rank_cst
[n
]),
5413 gfc_conv_descriptor_lbound_get (
5414 expr3_desc
, gfc_rank_cst
[n
]));
5415 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5416 gfc_array_index_type
, tmp
,
5417 gfc_index_one_node
);
5418 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5421 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5426 gcc_assert (ubound
);
5427 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5428 gfc_add_block_to_block (pblock
, &se
.pre
);
5429 if (ubound
->expr_type
== EXPR_FUNCTION
)
5430 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5432 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5433 gfc_rank_cst
[n
], se
.expr
);
5434 conv_ubound
= se
.expr
;
5436 /* Store the stride. */
5437 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5438 gfc_rank_cst
[n
], stride
);
5440 /* Calculate size and check whether extent is negative. */
5441 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5442 size
= gfc_evaluate_now (size
, pblock
);
5444 /* Check whether multiplying the stride by the number of
5445 elements in this dimension would overflow. We must also check
5446 whether the current dimension has zero size in order to avoid
5449 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5450 gfc_array_index_type
,
5451 fold_convert (gfc_array_index_type
,
5452 TYPE_MAX_VALUE (gfc_array_index_type
)),
5454 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5455 logical_type_node
, tmp
, stride
),
5456 PRED_FORTRAN_OVERFLOW
);
5457 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5458 integer_one_node
, integer_zero_node
);
5459 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5460 logical_type_node
, size
,
5461 gfc_index_zero_node
),
5462 PRED_FORTRAN_SIZE_ZERO
);
5463 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5464 integer_zero_node
, tmp
);
5465 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5467 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5469 /* Multiply the stride by the number of elements in this dimension. */
5470 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5471 gfc_array_index_type
, stride
, size
);
5472 stride
= gfc_evaluate_now (stride
, pblock
);
5475 for (n
= rank
; n
< rank
+ corank
; n
++)
5479 /* Set lower bound. */
5480 gfc_init_se (&se
, NULL
);
5481 if (lower
== NULL
|| lower
[n
] == NULL
)
5483 gcc_assert (n
== rank
+ corank
- 1);
5484 se
.expr
= gfc_index_one_node
;
5488 if (ubound
|| n
== rank
+ corank
- 1)
5490 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5491 gfc_add_block_to_block (pblock
, &se
.pre
);
5495 se
.expr
= gfc_index_one_node
;
5499 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5500 gfc_rank_cst
[n
], se
.expr
);
5502 if (n
< rank
+ corank
- 1)
5504 gfc_init_se (&se
, NULL
);
5505 gcc_assert (ubound
);
5506 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5507 gfc_add_block_to_block (pblock
, &se
.pre
);
5508 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5509 gfc_rank_cst
[n
], se
.expr
);
5513 /* The stride is the number of elements in the array, so multiply by the
5514 size of an element to get the total size. Obviously, if there is a
5515 SOURCE expression (expr3) we must use its element size. */
5516 if (expr3_elem_size
!= NULL_TREE
)
5517 tmp
= expr3_elem_size
;
5518 else if (expr3
!= NULL
)
5520 if (expr3
->ts
.type
== BT_CLASS
)
5523 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5524 gfc_add_vptr_component (sz
);
5525 gfc_add_size_component (sz
);
5526 gfc_init_se (&se_sz
, NULL
);
5527 gfc_conv_expr (&se_sz
, sz
);
5533 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5534 tmp
= TYPE_SIZE_UNIT (tmp
);
5538 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5540 /* Convert to size_t. */
5541 element_size
= fold_convert (size_type_node
, tmp
);
5544 return element_size
;
5546 *nelems
= gfc_evaluate_now (stride
, pblock
);
5547 stride
= fold_convert (size_type_node
, stride
);
5549 /* First check for overflow. Since an array of type character can
5550 have zero element_size, we must check for that before
5552 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5554 TYPE_MAX_VALUE (size_type_node
), element_size
);
5555 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5556 logical_type_node
, tmp
, stride
),
5557 PRED_FORTRAN_OVERFLOW
);
5558 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5559 integer_one_node
, integer_zero_node
);
5560 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5561 logical_type_node
, element_size
,
5562 build_int_cst (size_type_node
, 0)),
5563 PRED_FORTRAN_SIZE_ZERO
);
5564 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5565 integer_zero_node
, tmp
);
5566 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5568 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5570 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5571 stride
, element_size
);
5573 if (poffset
!= NULL
)
5575 offset
= gfc_evaluate_now (offset
, pblock
);
5579 if (integer_zerop (or_expr
))
5581 if (integer_onep (or_expr
))
5582 return build_int_cst (size_type_node
, 0);
5584 var
= gfc_create_var (TREE_TYPE (size
), "size");
5585 gfc_start_block (&thenblock
);
5586 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5587 thencase
= gfc_finish_block (&thenblock
);
5589 gfc_start_block (&elseblock
);
5590 gfc_add_modify (&elseblock
, var
, size
);
5591 elsecase
= gfc_finish_block (&elseblock
);
5593 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5594 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5595 gfc_add_expr_to_block (pblock
, tmp
);
5601 /* Retrieve the last ref from the chain. This routine is specific to
5602 gfc_array_allocate ()'s needs. */
5605 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5607 gfc_ref
*ref
, *prev_ref
;
5610 /* Prevent warnings for uninitialized variables. */
5611 prev_ref
= *prev_ref_in
;
5612 while (ref
&& ref
->next
!= NULL
)
5614 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5615 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5620 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5624 *prev_ref_in
= prev_ref
;
5628 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5629 the work for an ALLOCATE statement. */
5633 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5634 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5635 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5636 bool e3_is_array_constr
)
5640 tree offset
= NULL_TREE
;
5641 tree token
= NULL_TREE
;
5644 tree error
= NULL_TREE
;
5645 tree overflow
; /* Boolean storing whether size calculation overflows. */
5646 tree var_overflow
= NULL_TREE
;
5648 tree set_descriptor
;
5649 stmtblock_t set_descriptor_block
;
5650 stmtblock_t elseblock
;
5653 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5654 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5655 non_ulimate_coarray_ptr_comp
;
5659 /* Find the last reference in the chain. */
5660 if (!retrieve_last_ref (&ref
, &prev_ref
))
5663 /* Take the allocatable and coarray properties solely from the expr-ref's
5664 attributes and not from source=-expression. */
5667 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5668 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5669 non_ulimate_coarray_ptr_comp
= false;
5673 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5674 /* Pointer components in coarrayed derived types must be treated
5675 specially in that they are registered without a check if the are
5676 already associated. This does not hold for ultimate coarray
5678 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5679 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5680 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5683 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5684 a coarray. In this case it does not matter whether we are on this_image
5687 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5688 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5695 gcc_assert (coarray
);
5697 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5699 gfc_ref
*old_ref
= ref
;
5700 /* F08:C633: Array shape from expr3. */
5703 /* Find the last reference in the chain. */
5704 if (!retrieve_last_ref (&ref
, &prev_ref
))
5706 if (expr3
->expr_type
== EXPR_FUNCTION
5707 && gfc_expr_attr (expr3
).dimension
)
5712 alloc_w_e3_arr_spec
= true;
5715 /* Figure out the size of the array. */
5716 switch (ref
->u
.ar
.type
)
5722 upper
= ref
->u
.ar
.start
;
5728 lower
= ref
->u
.ar
.start
;
5729 upper
= ref
->u
.ar
.end
;
5733 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5734 || alloc_w_e3_arr_spec
);
5736 lower
= ref
->u
.ar
.as
->lower
;
5737 upper
= ref
->u
.ar
.as
->upper
;
5745 overflow
= integer_zero_node
;
5747 gfc_init_block (&set_descriptor_block
);
5748 /* Take the corank only from the actual ref and not from the coref. The
5749 later will mislead the generation of the array dimensions for allocatable/
5750 pointer components in derived types. */
5751 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5752 : ref
->u
.ar
.as
->rank
,
5753 coarray
? ref
->u
.ar
.as
->corank
: 0,
5754 &offset
, lower
, upper
,
5755 &se
->pre
, &set_descriptor_block
, &overflow
,
5756 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5757 e3_is_array_constr
, expr
);
5761 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5762 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5764 if (status
== NULL_TREE
)
5766 /* Generate the block of code handling overflow. */
5767 msg
= gfc_build_addr_expr (pchar_type_node
,
5768 gfc_build_localized_cstring_const
5769 ("Integer overflow when calculating the amount of "
5770 "memory to allocate"));
5771 error
= build_call_expr_loc (input_location
,
5772 gfor_fndecl_runtime_error
, 1, msg
);
5776 tree status_type
= TREE_TYPE (status
);
5777 stmtblock_t set_status_block
;
5779 gfc_start_block (&set_status_block
);
5780 gfc_add_modify (&set_status_block
, status
,
5781 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5782 error
= gfc_finish_block (&set_status_block
);
5786 gfc_start_block (&elseblock
);
5788 /* Allocate memory to store the data. */
5789 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5790 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5792 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5794 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5795 : gfc_conv_descriptor_data_get (se
->expr
);
5796 token
= gfc_conv_descriptor_token (se
->expr
);
5797 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5800 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5801 STRIP_NOPS (pointer
);
5803 /* The allocatable variant takes the old pointer as first argument. */
5805 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5806 status
, errmsg
, errlen
, label_finish
, expr
,
5807 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5808 else if (non_ulimate_coarray_ptr_comp
&& token
)
5809 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5810 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5812 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5814 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5818 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5819 logical_type_node
, var_overflow
, integer_zero_node
),
5820 PRED_FORTRAN_OVERFLOW
);
5821 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5822 error
, gfc_finish_block (&elseblock
));
5825 tmp
= gfc_finish_block (&elseblock
);
5827 gfc_add_expr_to_block (&se
->pre
, tmp
);
5829 /* Update the array descriptors. */
5831 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5833 /* Pointer arrays need the span field to be set. */
5834 if (is_pointer_array (se
->expr
)
5835 || (expr
->ts
.type
== BT_CLASS
5836 && CLASS_DATA (expr
)->attr
.class_pointer
))
5838 if (expr3
&& expr3_elem_size
!= NULL_TREE
)
5839 tmp
= expr3_elem_size
;
5841 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se
->expr
)));
5842 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5843 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5846 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5847 if (status
!= NULL_TREE
)
5849 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5850 logical_type_node
, status
,
5851 build_int_cst (TREE_TYPE (status
), 0));
5852 gfc_add_expr_to_block (&se
->pre
,
5853 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5856 build_empty_stmt (input_location
)));
5859 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5865 /* Create an array constructor from an initialization expression.
5866 We assume the frontend already did any expansions and conversions. */
5869 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5876 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5878 if (expr
->expr_type
== EXPR_VARIABLE
5879 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5880 && expr
->symtree
->n
.sym
->value
)
5881 expr
= expr
->symtree
->n
.sym
->value
;
5883 switch (expr
->expr_type
)
5886 case EXPR_STRUCTURE
:
5887 /* A single scalar or derived type value. Create an array with all
5888 elements equal to that value. */
5889 gfc_init_se (&se
, NULL
);
5891 if (expr
->expr_type
== EXPR_CONSTANT
)
5892 gfc_conv_constant (&se
, expr
);
5894 gfc_conv_structure (&se
, expr
, 1);
5896 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5897 /* This will probably eat buckets of memory for large arrays. */
5900 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5906 /* Create a vector of all the elements. */
5907 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5908 c
; c
= gfc_constructor_next (c
))
5912 /* Problems occur when we get something like
5913 integer :: a(lots) = (/(i, i=1, lots)/) */
5914 gfc_fatal_error ("The number of elements in the array "
5915 "constructor at %L requires an increase of "
5916 "the allowed %d upper limit. See "
5917 "%<-fmax-array-constructor%> option",
5918 &expr
->where
, flag_max_array_constructor
);
5921 if (mpz_cmp_si (c
->offset
, 0) != 0)
5922 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5926 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5932 mpz_add (maxval
, c
->offset
, c
->repeat
);
5933 mpz_sub_ui (maxval
, maxval
, 1);
5934 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5935 if (mpz_cmp_si (c
->offset
, 0) != 0)
5937 mpz_add_ui (maxval
, c
->offset
, 1);
5938 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5941 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5943 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5949 gfc_init_se (&se
, NULL
);
5950 switch (c
->expr
->expr_type
)
5953 gfc_conv_constant (&se
, c
->expr
);
5956 case EXPR_STRUCTURE
:
5957 gfc_conv_structure (&se
, c
->expr
, 1);
5961 /* Catch those occasional beasts that do not simplify
5962 for one reason or another, assuming that if they are
5963 standard defying the frontend will catch them. */
5964 gfc_conv_expr (&se
, c
->expr
);
5968 if (range
== NULL_TREE
)
5969 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5972 if (index
!= NULL_TREE
)
5973 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5974 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5980 return gfc_build_null_descriptor (type
);
5986 /* Create a constructor from the list of elements. */
5987 tmp
= build_constructor (type
, v
);
5988 TREE_CONSTANT (tmp
) = 1;
5993 /* Generate code to evaluate non-constant coarray cobounds. */
5996 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5997 const gfc_symbol
*sym
)
6005 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6007 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6009 /* Evaluate non-constant array bound expressions. */
6010 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6011 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6013 gfc_init_se (&se
, NULL
);
6014 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6015 gfc_add_block_to_block (pblock
, &se
.pre
);
6016 gfc_add_modify (pblock
, lbound
, se
.expr
);
6018 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6019 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6021 gfc_init_se (&se
, NULL
);
6022 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6023 gfc_add_block_to_block (pblock
, &se
.pre
);
6024 gfc_add_modify (pblock
, ubound
, se
.expr
);
6030 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6031 returns the size (in elements) of the array. */
6034 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6035 stmtblock_t
* pblock
)
6048 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6050 size
= gfc_index_one_node
;
6051 offset
= gfc_index_zero_node
;
6052 for (dim
= 0; dim
< as
->rank
; dim
++)
6054 /* Evaluate non-constant array bound expressions. */
6055 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6056 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6058 gfc_init_se (&se
, NULL
);
6059 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6060 gfc_add_block_to_block (pblock
, &se
.pre
);
6061 gfc_add_modify (pblock
, lbound
, se
.expr
);
6063 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6064 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6066 gfc_init_se (&se
, NULL
);
6067 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6068 gfc_add_block_to_block (pblock
, &se
.pre
);
6069 gfc_add_modify (pblock
, ubound
, se
.expr
);
6071 /* The offset of this dimension. offset = offset - lbound * stride. */
6072 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6074 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6077 /* The size of this dimension, and the stride of the next. */
6078 if (dim
+ 1 < as
->rank
)
6079 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6081 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6083 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6085 /* Calculate stride = size * (ubound + 1 - lbound). */
6086 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6087 gfc_array_index_type
,
6088 gfc_index_one_node
, lbound
);
6089 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6090 gfc_array_index_type
, ubound
, tmp
);
6091 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6092 gfc_array_index_type
, size
, tmp
);
6094 gfc_add_modify (pblock
, stride
, tmp
);
6096 stride
= gfc_evaluate_now (tmp
, pblock
);
6098 /* Make sure that negative size arrays are translated
6099 to being zero size. */
6100 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6101 stride
, gfc_index_zero_node
);
6102 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6103 gfc_array_index_type
, tmp
,
6104 stride
, gfc_index_zero_node
);
6105 gfc_add_modify (pblock
, stride
, tmp
);
6111 gfc_trans_array_cobounds (type
, pblock
, sym
);
6112 gfc_trans_vla_type_sizes (sym
, pblock
);
6119 /* Generate code to initialize/allocate an array variable. */
6122 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6123 gfc_wrapped_block
* block
)
6127 tree tmp
= NULL_TREE
;
6134 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6136 /* Do nothing for USEd variables. */
6137 if (sym
->attr
.use_assoc
)
6140 type
= TREE_TYPE (decl
);
6141 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6142 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6144 gfc_init_block (&init
);
6146 /* Evaluate character string length. */
6147 if (sym
->ts
.type
== BT_CHARACTER
6148 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6150 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6152 gfc_trans_vla_type_sizes (sym
, &init
);
6154 /* Emit a DECL_EXPR for this variable, which will cause the
6155 gimplifier to allocate storage, and all that good stuff. */
6156 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6157 gfc_add_expr_to_block (&init
, tmp
);
6162 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6166 type
= TREE_TYPE (type
);
6168 gcc_assert (!sym
->attr
.use_assoc
);
6169 gcc_assert (!TREE_STATIC (decl
));
6170 gcc_assert (!sym
->module
);
6172 if (sym
->ts
.type
== BT_CHARACTER
6173 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6174 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6176 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6178 /* Don't actually allocate space for Cray Pointees. */
6179 if (sym
->attr
.cray_pointee
)
6181 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6182 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6184 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6188 if (flag_stack_arrays
)
6190 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6191 space
= build_decl (sym
->declared_at
.lb
->location
,
6192 VAR_DECL
, create_tmp_var_name ("A"),
6193 TREE_TYPE (TREE_TYPE (decl
)));
6194 gfc_trans_vla_type_sizes (sym
, &init
);
6198 /* The size is the number of elements in the array, so multiply by the
6199 size of an element to get the total size. */
6200 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6201 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6202 size
, fold_convert (gfc_array_index_type
, tmp
));
6204 /* Allocate memory to hold the data. */
6205 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6206 gfc_add_modify (&init
, decl
, tmp
);
6208 /* Free the temporary. */
6209 tmp
= gfc_call_free (decl
);
6213 /* Set offset of the array. */
6214 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6215 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6217 /* Automatic arrays should not have initializers. */
6218 gcc_assert (!sym
->value
);
6220 inittree
= gfc_finish_block (&init
);
6227 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6228 where also space is located. */
6229 gfc_init_block (&init
);
6230 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6231 TREE_TYPE (space
), space
);
6232 gfc_add_expr_to_block (&init
, tmp
);
6233 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6234 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6235 gfc_add_modify (&init
, decl
, addr
);
6236 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6239 gfc_add_init_cleanup (block
, inittree
, tmp
);
6243 /* Generate entry and exit code for g77 calling convention arrays. */
6246 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6256 gfc_save_backend_locus (&loc
);
6257 gfc_set_backend_locus (&sym
->declared_at
);
6259 /* Descriptor type. */
6260 parm
= sym
->backend_decl
;
6261 type
= TREE_TYPE (parm
);
6262 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6264 gfc_start_block (&init
);
6266 if (sym
->ts
.type
== BT_CHARACTER
6267 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6268 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6270 /* Evaluate the bounds of the array. */
6271 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6273 /* Set the offset. */
6274 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6275 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6277 /* Set the pointer itself if we aren't using the parameter directly. */
6278 if (TREE_CODE (parm
) != PARM_DECL
)
6280 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6281 gfc_add_modify (&init
, parm
, tmp
);
6283 stmt
= gfc_finish_block (&init
);
6285 gfc_restore_backend_locus (&loc
);
6287 /* Add the initialization code to the start of the function. */
6289 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6291 tmp
= gfc_conv_expr_present (sym
);
6292 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6295 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6299 /* Modify the descriptor of an array parameter so that it has the
6300 correct lower bound. Also move the upper bound accordingly.
6301 If the array is not packed, it will be copied into a temporary.
6302 For each dimension we set the new lower and upper bounds. Then we copy the
6303 stride and calculate the offset for this dimension. We also work out
6304 what the stride of a packed array would be, and see it the two match.
6305 If the array need repacking, we set the stride to the values we just
6306 calculated, recalculate the offset and copy the array data.
6307 Code is also added to copy the data back at the end of the function.
6311 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6312 gfc_wrapped_block
* block
)
6319 tree stmtInit
, stmtCleanup
;
6326 tree stride
, stride2
;
6336 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6338 /* Do nothing for pointer and allocatable arrays. */
6339 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6340 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6341 || sym
->attr
.allocatable
6342 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6345 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6347 gfc_trans_g77_array (sym
, block
);
6352 gfc_save_backend_locus (&loc
);
6353 /* loc.nextc is not set by save_backend_locus but the location routines
6355 if (loc
.nextc
== NULL
)
6356 loc
.nextc
= loc
.lb
->line
;
6357 gfc_set_backend_locus (&sym
->declared_at
);
6359 /* Descriptor type. */
6360 type
= TREE_TYPE (tmpdesc
);
6361 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6362 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6364 /* For a class array the dummy array descriptor is in the _class
6366 dumdesc
= gfc_class_data_get (dumdesc
);
6368 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6369 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6370 gfc_start_block (&init
);
6372 if (sym
->ts
.type
== BT_CHARACTER
6373 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6374 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6376 checkparm
= (as
->type
== AS_EXPLICIT
6377 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6379 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6380 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6382 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6384 /* For non-constant shape arrays we only check if the first dimension
6385 is contiguous. Repacking higher dimensions wouldn't gain us
6386 anything as we still don't know the array stride. */
6387 partial
= gfc_create_var (logical_type_node
, "partial");
6388 TREE_USED (partial
) = 1;
6389 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6390 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6391 gfc_index_one_node
);
6392 gfc_add_modify (&init
, partial
, tmp
);
6395 partial
= NULL_TREE
;
6397 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6398 here, however I think it does the right thing. */
6401 /* Set the first stride. */
6402 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6403 stride
= gfc_evaluate_now (stride
, &init
);
6405 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6406 stride
, gfc_index_zero_node
);
6407 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6408 tmp
, gfc_index_one_node
, stride
);
6409 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6410 gfc_add_modify (&init
, stride
, tmp
);
6412 /* Allow the user to disable array repacking. */
6413 stmt_unpacked
= NULL_TREE
;
6417 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6418 /* A library call to repack the array if necessary. */
6419 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6420 stmt_unpacked
= build_call_expr_loc (input_location
,
6421 gfor_fndecl_in_pack
, 1, tmp
);
6423 stride
= gfc_index_one_node
;
6425 if (warn_array_temporaries
)
6426 gfc_warning (OPT_Warray_temporaries
,
6427 "Creating array temporary at %L", &loc
);
6430 /* This is for the case where the array data is used directly without
6431 calling the repack function. */
6432 if (no_repack
|| partial
!= NULL_TREE
)
6433 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6435 stmt_packed
= NULL_TREE
;
6437 /* Assign the data pointer. */
6438 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6440 /* Don't repack unknown shape arrays when the first stride is 1. */
6441 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6442 partial
, stmt_packed
, stmt_unpacked
);
6445 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6446 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6448 offset
= gfc_index_zero_node
;
6449 size
= gfc_index_one_node
;
6451 /* Evaluate the bounds of the array. */
6452 for (n
= 0; n
< as
->rank
; n
++)
6454 if (checkparm
|| !as
->upper
[n
])
6456 /* Get the bounds of the actual parameter. */
6457 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6458 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6462 dubound
= NULL_TREE
;
6463 dlbound
= NULL_TREE
;
6466 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6467 if (!INTEGER_CST_P (lbound
))
6469 gfc_init_se (&se
, NULL
);
6470 gfc_conv_expr_type (&se
, as
->lower
[n
],
6471 gfc_array_index_type
);
6472 gfc_add_block_to_block (&init
, &se
.pre
);
6473 gfc_add_modify (&init
, lbound
, se
.expr
);
6476 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6477 /* Set the desired upper bound. */
6480 /* We know what we want the upper bound to be. */
6481 if (!INTEGER_CST_P (ubound
))
6483 gfc_init_se (&se
, NULL
);
6484 gfc_conv_expr_type (&se
, as
->upper
[n
],
6485 gfc_array_index_type
);
6486 gfc_add_block_to_block (&init
, &se
.pre
);
6487 gfc_add_modify (&init
, ubound
, se
.expr
);
6490 /* Check the sizes match. */
6493 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6497 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6498 gfc_array_index_type
, ubound
, lbound
);
6499 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6500 gfc_array_index_type
,
6501 gfc_index_one_node
, temp
);
6502 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6503 gfc_array_index_type
, dubound
,
6505 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6506 gfc_array_index_type
,
6507 gfc_index_one_node
, stride2
);
6508 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6509 gfc_array_index_type
, temp
, stride2
);
6510 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6511 "%%ld instead of %%ld", n
+1, sym
->name
);
6513 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6514 fold_convert (long_integer_type_node
, temp
),
6515 fold_convert (long_integer_type_node
, stride2
));
6522 /* For assumed shape arrays move the upper bound by the same amount
6523 as the lower bound. */
6524 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6525 gfc_array_index_type
, dubound
, dlbound
);
6526 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6527 gfc_array_index_type
, tmp
, lbound
);
6528 gfc_add_modify (&init
, ubound
, tmp
);
6530 /* The offset of this dimension. offset = offset - lbound * stride. */
6531 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6533 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6534 gfc_array_index_type
, offset
, tmp
);
6536 /* The size of this dimension, and the stride of the next. */
6537 if (n
+ 1 < as
->rank
)
6539 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6541 if (no_repack
|| partial
!= NULL_TREE
)
6543 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6545 /* Figure out the stride if not a known constant. */
6546 if (!INTEGER_CST_P (stride
))
6549 stmt_packed
= NULL_TREE
;
6552 /* Calculate stride = size * (ubound + 1 - lbound). */
6553 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6554 gfc_array_index_type
,
6555 gfc_index_one_node
, lbound
);
6556 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6557 gfc_array_index_type
, ubound
, tmp
);
6558 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6559 gfc_array_index_type
, size
, tmp
);
6563 /* Assign the stride. */
6564 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6565 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6566 gfc_array_index_type
, partial
,
6567 stmt_unpacked
, stmt_packed
);
6569 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6570 gfc_add_modify (&init
, stride
, tmp
);
6575 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6577 if (stride
&& !INTEGER_CST_P (stride
))
6579 /* Calculate size = stride * (ubound + 1 - lbound). */
6580 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6581 gfc_array_index_type
,
6582 gfc_index_one_node
, lbound
);
6583 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6584 gfc_array_index_type
,
6586 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6587 gfc_array_index_type
,
6588 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6589 gfc_add_modify (&init
, stride
, tmp
);
6594 gfc_trans_array_cobounds (type
, &init
, sym
);
6596 /* Set the offset. */
6597 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6598 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6600 gfc_trans_vla_type_sizes (sym
, &init
);
6602 stmtInit
= gfc_finish_block (&init
);
6604 /* Only do the entry/initialization code if the arg is present. */
6605 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6606 optional_arg
= (sym
->attr
.optional
6607 || (sym
->ns
->proc_name
->attr
.entry_master
6608 && sym
->attr
.dummy
));
6611 tmp
= gfc_conv_expr_present (sym
);
6612 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6613 build_empty_stmt (input_location
));
6618 stmtCleanup
= NULL_TREE
;
6621 stmtblock_t cleanup
;
6622 gfc_start_block (&cleanup
);
6624 if (sym
->attr
.intent
!= INTENT_IN
)
6626 /* Copy the data back. */
6627 tmp
= build_call_expr_loc (input_location
,
6628 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6629 gfc_add_expr_to_block (&cleanup
, tmp
);
6632 /* Free the temporary. */
6633 tmp
= gfc_call_free (tmpdesc
);
6634 gfc_add_expr_to_block (&cleanup
, tmp
);
6636 stmtCleanup
= gfc_finish_block (&cleanup
);
6638 /* Only do the cleanup if the array was repacked. */
6640 /* For a class array the dummy array descriptor is in the _class
6642 tmp
= gfc_class_data_get (dumdesc
);
6644 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6645 tmp
= gfc_conv_descriptor_data_get (tmp
);
6646 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6648 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6649 build_empty_stmt (input_location
));
6653 tmp
= gfc_conv_expr_present (sym
);
6654 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6655 build_empty_stmt (input_location
));
6659 /* We don't need to free any memory allocated by internal_pack as it will
6660 be freed at the end of the function by pop_context. */
6661 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6663 gfc_restore_backend_locus (&loc
);
6667 /* Calculate the overall offset, including subreferences. */
6669 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6670 bool subref
, gfc_expr
*expr
)
6680 /* If offset is NULL and this is not a subreferenced array, there is
6682 if (offset
== NULL_TREE
)
6685 offset
= gfc_index_zero_node
;
6690 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6692 /* Offset the data pointer for pointer assignments from arrays with
6693 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6696 /* Go past the array reference. */
6697 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6698 if (ref
->type
== REF_ARRAY
&&
6699 ref
->u
.ar
.type
!= AR_ELEMENT
)
6705 /* Calculate the offset for each subsequent subreference. */
6706 for (; ref
; ref
= ref
->next
)
6711 field
= ref
->u
.c
.component
->backend_decl
;
6712 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6713 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6715 tmp
, field
, NULL_TREE
);
6719 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6720 gfc_init_se (&start
, NULL
);
6721 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6722 gfc_add_block_to_block (block
, &start
.pre
);
6723 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6727 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6728 && ref
->u
.ar
.type
== AR_ELEMENT
);
6730 /* TODO - Add bounds checking. */
6731 stride
= gfc_index_one_node
;
6732 index
= gfc_index_zero_node
;
6733 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6738 /* Update the index. */
6739 gfc_init_se (&start
, NULL
);
6740 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6741 itmp
= gfc_evaluate_now (start
.expr
, block
);
6742 gfc_init_se (&start
, NULL
);
6743 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6744 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6745 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6746 gfc_array_index_type
, itmp
, jtmp
);
6747 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6748 gfc_array_index_type
, itmp
, stride
);
6749 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6750 gfc_array_index_type
, itmp
, index
);
6751 index
= gfc_evaluate_now (index
, block
);
6753 /* Update the stride. */
6754 gfc_init_se (&start
, NULL
);
6755 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6756 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6757 gfc_array_index_type
, start
.expr
,
6759 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6760 gfc_array_index_type
,
6761 gfc_index_one_node
, itmp
);
6762 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6763 gfc_array_index_type
, stride
, itmp
);
6764 stride
= gfc_evaluate_now (stride
, block
);
6767 /* Apply the index to obtain the array element. */
6768 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6778 /* Set the target data pointer. */
6779 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6780 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6784 /* gfc_conv_expr_descriptor needs the string length an expression
6785 so that the size of the temporary can be obtained. This is done
6786 by adding up the string lengths of all the elements in the
6787 expression. Function with non-constant expressions have their
6788 string lengths mapped onto the actual arguments using the
6789 interface mapping machinery in trans-expr.c. */
6791 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6793 gfc_interface_mapping mapping
;
6794 gfc_formal_arglist
*formal
;
6795 gfc_actual_arglist
*arg
;
6798 if (expr
->ts
.u
.cl
->length
6799 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6801 if (!expr
->ts
.u
.cl
->backend_decl
)
6802 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6806 switch (expr
->expr_type
)
6809 get_array_charlen (expr
->value
.op
.op1
, se
);
6811 /* For parentheses the expression ts.u.cl is identical. */
6812 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6815 expr
->ts
.u
.cl
->backend_decl
=
6816 gfc_create_var (gfc_charlen_type_node
, "sln");
6818 if (expr
->value
.op
.op2
)
6820 get_array_charlen (expr
->value
.op
.op2
, se
);
6822 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6824 /* Add the string lengths and assign them to the expression
6825 string length backend declaration. */
6826 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6827 fold_build2_loc (input_location
, PLUS_EXPR
,
6828 gfc_charlen_type_node
,
6829 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6830 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6833 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6834 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6838 if (expr
->value
.function
.esym
== NULL
6839 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6841 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6845 /* Map expressions involving the dummy arguments onto the actual
6846 argument expressions. */
6847 gfc_init_interface_mapping (&mapping
);
6848 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6849 arg
= expr
->value
.function
.actual
;
6851 /* Set se = NULL in the calls to the interface mapping, to suppress any
6853 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6858 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6861 gfc_init_se (&tse
, NULL
);
6863 /* Build the expression for the character length and convert it. */
6864 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6866 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6867 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6868 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6869 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6870 gfc_charlen_type_node
, tse
.expr
,
6871 build_int_cst (gfc_charlen_type_node
, 0));
6872 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6873 gfc_free_interface_mapping (&mapping
);
6877 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6883 /* Helper function to check dimensions. */
6885 transposed_dims (gfc_ss
*ss
)
6889 for (n
= 0; n
< ss
->dimen
; n
++)
6890 if (ss
->dim
[n
] != n
)
6896 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6897 AR_FULL, suitable for the scalarizer. */
6900 walk_coarray (gfc_expr
*e
)
6904 gcc_assert (gfc_get_corank (e
) > 0);
6906 ss
= gfc_walk_expr (e
);
6908 /* Fix scalar coarray. */
6909 if (ss
== gfc_ss_terminator
)
6916 if (ref
->type
== REF_ARRAY
6917 && ref
->u
.ar
.codimen
> 0)
6923 gcc_assert (ref
!= NULL
);
6924 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6925 ref
->u
.ar
.type
= AR_SECTION
;
6926 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6933 /* Convert an array for passing as an actual argument. Expressions and
6934 vector subscripts are evaluated and stored in a temporary, which is then
6935 passed. For whole arrays the descriptor is passed. For array sections
6936 a modified copy of the descriptor is passed, but using the original data.
6938 This function is also used for array pointer assignments, and there
6941 - se->want_pointer && !se->direct_byref
6942 EXPR is an actual argument. On exit, se->expr contains a
6943 pointer to the array descriptor.
6945 - !se->want_pointer && !se->direct_byref
6946 EXPR is an actual argument to an intrinsic function or the
6947 left-hand side of a pointer assignment. On exit, se->expr
6948 contains the descriptor for EXPR.
6950 - !se->want_pointer && se->direct_byref
6951 EXPR is the right-hand side of a pointer assignment and
6952 se->expr is the descriptor for the previously-evaluated
6953 left-hand side. The function creates an assignment from
6957 The se->force_tmp flag disables the non-copying descriptor optimization
6958 that is used for transpose. It may be used in cases where there is an
6959 alias between the transpose argument and another argument in the same
6963 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6966 gfc_ss_type ss_type
;
6967 gfc_ss_info
*ss_info
;
6969 gfc_array_info
*info
;
6978 bool subref_array_target
= false;
6979 gfc_expr
*arg
, *ss_expr
;
6981 if (se
->want_coarray
)
6982 ss
= walk_coarray (expr
);
6984 ss
= gfc_walk_expr (expr
);
6986 gcc_assert (ss
!= NULL
);
6987 gcc_assert (ss
!= gfc_ss_terminator
);
6990 ss_type
= ss_info
->type
;
6991 ss_expr
= ss_info
->expr
;
6993 /* Special case: TRANSPOSE which needs no temporary. */
6994 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6995 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6997 /* This is a call to transpose which has already been handled by the
6998 scalarizer, so that we just need to get its argument's descriptor. */
6999 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7000 expr
= expr
->value
.function
.actual
->expr
;
7003 /* Special case things we know we can pass easily. */
7004 switch (expr
->expr_type
)
7007 /* If we have a linear array section, we can pass it directly.
7008 Otherwise we need to copy it into a temporary. */
7010 gcc_assert (ss_type
== GFC_SS_SECTION
);
7011 gcc_assert (ss_expr
== expr
);
7012 info
= &ss_info
->data
.array
;
7014 /* Get the descriptor for the array. */
7015 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7016 desc
= info
->descriptor
;
7018 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7019 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7020 && !subref_array_target
;
7027 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7029 /* Create a new descriptor if the array doesn't have one. */
7032 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7034 else if (se
->direct_byref
)
7037 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7039 if (full
&& !transposed_dims (ss
))
7041 if (se
->direct_byref
&& !se
->byref_noassign
)
7043 /* Copy the descriptor for pointer assignments. */
7044 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7046 /* Add any offsets from subreferences. */
7047 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7048 subref_array_target
, expr
);
7050 /* ....and set the span field. */
7051 tmp
= get_array_span (desc
, expr
);
7052 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7054 else if (se
->want_pointer
)
7056 /* We pass full arrays directly. This means that pointers and
7057 allocatable arrays should also work. */
7058 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7065 if (expr
->ts
.type
== BT_CHARACTER
)
7066 se
->string_length
= gfc_get_expr_charlen (expr
);
7068 gfc_free_ss_chain (ss
);
7074 /* A transformational function return value will be a temporary
7075 array descriptor. We still need to go through the scalarizer
7076 to create the descriptor. Elemental functions are handled as
7077 arbitrary expressions, i.e. copy to a temporary. */
7079 if (se
->direct_byref
)
7081 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7083 /* For pointer assignments pass the descriptor directly. */
7087 gcc_assert (se
->ss
== ss
);
7089 if (!is_pointer_array (se
->expr
))
7091 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7092 tmp
= fold_convert (gfc_array_index_type
,
7093 size_in_bytes (tmp
));
7094 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7097 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7098 gfc_conv_expr (se
, expr
);
7100 gfc_free_ss_chain (ss
);
7104 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7106 if (ss_expr
!= expr
)
7107 /* Elemental function. */
7108 gcc_assert ((expr
->value
.function
.esym
!= NULL
7109 && expr
->value
.function
.esym
->attr
.elemental
)
7110 || (expr
->value
.function
.isym
!= NULL
7111 && expr
->value
.function
.isym
->elemental
)
7112 || gfc_inline_intrinsic_function_p (expr
));
7114 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7117 if (expr
->ts
.type
== BT_CHARACTER
7118 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7119 get_array_charlen (expr
, se
);
7125 /* Transformational function. */
7126 info
= &ss_info
->data
.array
;
7132 /* Constant array constructors don't need a temporary. */
7133 if (ss_type
== GFC_SS_CONSTRUCTOR
7134 && expr
->ts
.type
!= BT_CHARACTER
7135 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7138 info
= &ss_info
->data
.array
;
7148 /* Something complicated. Copy it into a temporary. */
7154 /* If we are creating a temporary, we don't need to bother about aliases
7159 gfc_init_loopinfo (&loop
);
7161 /* Associate the SS with the loop. */
7162 gfc_add_ss_to_loop (&loop
, ss
);
7164 /* Tell the scalarizer not to bother creating loop variables, etc. */
7166 loop
.array_parameter
= 1;
7168 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7169 gcc_assert (!se
->direct_byref
);
7171 /* Setup the scalarizing loops and bounds. */
7172 gfc_conv_ss_startstride (&loop
);
7176 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
7177 get_array_charlen (expr
, se
);
7179 /* Tell the scalarizer to make a temporary. */
7180 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7181 ((expr
->ts
.type
== BT_CHARACTER
)
7182 ? expr
->ts
.u
.cl
->backend_decl
7186 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7187 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7188 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7191 gfc_conv_loop_setup (&loop
, & expr
->where
);
7195 /* Copy into a temporary and pass that. We don't need to copy the data
7196 back because expressions and vector subscripts must be INTENT_IN. */
7197 /* TODO: Optimize passing function return values. */
7202 /* Start the copying loops. */
7203 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7204 gfc_mark_ss_chain_used (ss
, 1);
7205 gfc_start_scalarized_body (&loop
, &block
);
7207 /* Copy each data element. */
7208 gfc_init_se (&lse
, NULL
);
7209 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7210 gfc_init_se (&rse
, NULL
);
7211 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7213 lse
.ss
= loop
.temp_ss
;
7216 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7217 if (expr
->ts
.type
== BT_CHARACTER
)
7219 gfc_conv_expr (&rse
, expr
);
7220 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7221 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7225 gfc_conv_expr_val (&rse
, expr
);
7227 gfc_add_block_to_block (&block
, &rse
.pre
);
7228 gfc_add_block_to_block (&block
, &lse
.pre
);
7230 lse
.string_length
= rse
.string_length
;
7232 deep_copy
= !se
->data_not_needed
7233 && (expr
->expr_type
== EXPR_VARIABLE
7234 || expr
->expr_type
== EXPR_ARRAY
);
7235 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7237 gfc_add_expr_to_block (&block
, tmp
);
7239 /* Finish the copying loops. */
7240 gfc_trans_scalarizing_loops (&loop
, &block
);
7242 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7244 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7246 desc
= info
->descriptor
;
7247 se
->string_length
= ss_info
->string_length
;
7251 /* We pass sections without copying to a temporary. Make a new
7252 descriptor and point it at the section we want. The loop variable
7253 limits will be the limits of the section.
7254 A function may decide to repack the array to speed up access, but
7255 we're not bothered about that here. */
7256 int dim
, ndim
, codim
;
7263 bool onebased
= false, rank_remap
;
7265 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7266 rank_remap
= ss
->dimen
< ndim
;
7268 if (se
->want_coarray
)
7270 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7272 codim
= gfc_get_corank (expr
);
7273 for (n
= 0; n
< codim
- 1; n
++)
7275 /* Make sure we are not lost somehow. */
7276 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7278 /* Make sure the call to gfc_conv_section_startstride won't
7279 generate unnecessary code to calculate stride. */
7280 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7282 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7283 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7284 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7287 gcc_assert (n
== codim
- 1);
7288 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7289 info
->descriptor
, n
+ ndim
, true,
7290 ar
->as
->type
== AS_DEFERRED
);
7291 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7296 /* Set the string_length for a character array. */
7297 if (expr
->ts
.type
== BT_CHARACTER
)
7298 se
->string_length
= gfc_get_expr_charlen (expr
);
7300 /* If we have an array section or are assigning make sure that
7301 the lower bound is 1. References to the full
7302 array should otherwise keep the original bounds. */
7303 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7304 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7305 if (!integer_onep (loop
.from
[dim
]))
7307 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7308 gfc_array_index_type
, gfc_index_one_node
,
7310 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7311 gfc_array_index_type
,
7313 loop
.from
[dim
] = gfc_index_one_node
;
7316 desc
= info
->descriptor
;
7317 if (se
->direct_byref
&& !se
->byref_noassign
)
7319 /* For pointer assignments we fill in the destination.... */
7321 parmtype
= TREE_TYPE (parm
);
7323 /* ....and set the span field. */
7324 tmp
= get_array_span (desc
, expr
);
7325 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7329 /* Otherwise make a new one. */
7330 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7331 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7332 loop
.from
, loop
.to
, 0,
7333 GFC_ARRAY_UNKNOWN
, false);
7334 parm
= gfc_create_var (parmtype
, "parm");
7336 /* When expression is a class object, then add the class' handle to
7338 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7340 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7343 /* class_expr can be NULL, when no _class ref is in expr.
7344 We must not fix this here with a gfc_fix_class_ref (). */
7347 gfc_init_se (&classse
, NULL
);
7348 gfc_conv_expr (&classse
, class_expr
);
7349 gfc_free_expr (class_expr
);
7351 gcc_assert (classse
.pre
.head
== NULL_TREE
7352 && classse
.post
.head
== NULL_TREE
);
7353 gfc_allocate_lang_decl (parm
);
7354 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7359 offset
= gfc_index_zero_node
;
7361 /* The following can be somewhat confusing. We have two
7362 descriptors, a new one and the original array.
7363 {parm, parmtype, dim} refer to the new one.
7364 {desc, type, n, loop} refer to the original, which maybe
7365 a descriptorless array.
7366 The bounds of the scalarization are the bounds of the section.
7367 We don't have to worry about numeric overflows when calculating
7368 the offsets because all elements are within the array data. */
7370 /* Set the dtype. */
7371 tmp
= gfc_conv_descriptor_dtype (parm
);
7372 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7374 /* Set offset for assignments to pointer only to zero if it is not
7376 if ((se
->direct_byref
|| se
->use_offset
)
7377 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7378 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7379 base
= gfc_index_zero_node
;
7380 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7381 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7385 for (n
= 0; n
< ndim
; n
++)
7387 stride
= gfc_conv_array_stride (desc
, n
);
7389 /* Work out the offset. */
7391 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7393 gcc_assert (info
->subscript
[n
]
7394 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7395 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7399 /* Evaluate and remember the start of the section. */
7400 start
= info
->start
[n
];
7401 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7404 tmp
= gfc_conv_array_lbound (desc
, n
);
7405 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7407 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7409 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7413 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7415 /* For elemental dimensions, we only need the offset. */
7419 /* Vector subscripts need copying and are handled elsewhere. */
7421 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7423 /* look for the corresponding scalarizer dimension: dim. */
7424 for (dim
= 0; dim
< ndim
; dim
++)
7425 if (ss
->dim
[dim
] == n
)
7428 /* loop exited early: the DIM being looked for has been found. */
7429 gcc_assert (dim
< ndim
);
7431 /* Set the new lower bound. */
7432 from
= loop
.from
[dim
];
7435 onebased
= integer_onep (from
);
7436 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7437 gfc_rank_cst
[dim
], from
);
7439 /* Set the new upper bound. */
7440 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7441 gfc_rank_cst
[dim
], to
);
7443 /* Multiply the stride by the section stride to get the
7445 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7446 gfc_array_index_type
,
7447 stride
, info
->stride
[n
]);
7449 if ((se
->direct_byref
|| se
->use_offset
)
7450 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7451 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7453 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7454 TREE_TYPE (base
), base
, stride
);
7456 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7459 tmp
= gfc_conv_array_lbound (desc
, n
);
7460 toonebased
= integer_onep (tmp
);
7461 // lb(arr) - from (- start + 1)
7462 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7463 TREE_TYPE (base
), tmp
, from
);
7464 if (onebased
&& toonebased
)
7466 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7467 TREE_TYPE (base
), tmp
, start
);
7468 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7469 TREE_TYPE (base
), tmp
,
7470 gfc_index_one_node
);
7472 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7473 TREE_TYPE (base
), tmp
,
7474 gfc_conv_array_stride (desc
, n
));
7475 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7476 TREE_TYPE (base
), tmp
, base
);
7479 /* Store the new stride. */
7480 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7481 gfc_rank_cst
[dim
], stride
);
7484 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7486 from
= loop
.from
[n
];
7488 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7489 gfc_rank_cst
[n
], from
);
7490 if (n
< loop
.dimen
+ codim
- 1)
7491 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7492 gfc_rank_cst
[n
], to
);
7495 if (se
->data_not_needed
)
7496 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7497 gfc_index_zero_node
);
7499 /* Point the data pointer at the 1st element in the section. */
7500 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7501 subref_array_target
, expr
);
7503 /* Force the offset to be -1, when the lower bound of the highest
7504 dimension is one and the symbol is present and is not a
7505 pointer/allocatable or associated. */
7506 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7507 && !se
->data_not_needed
)
7508 || (se
->use_offset
&& base
!= NULL_TREE
))
7510 /* Set the offset depending on base. */
7511 tmp
= rank_remap
&& !se
->direct_byref
?
7512 fold_build2_loc (input_location
, PLUS_EXPR
,
7513 gfc_array_index_type
, base
,
7516 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7518 else if (IS_CLASS_ARRAY (expr
) && !se
->data_not_needed
7519 && (!rank_remap
|| se
->use_offset
)
7520 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7522 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7523 gfc_conv_descriptor_offset_get (desc
));
7525 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7527 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7528 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7529 && !expr
->symtree
->n
.sym
->attr
.allocatable
7530 && !expr
->symtree
->n
.sym
->attr
.pointer
7531 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7532 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7534 /* Set the offset to -1. */
7536 mpz_init_set_si (minus_one
, -1);
7537 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7538 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7542 /* Only the callee knows what the correct offset it, so just set
7544 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7549 /* For class arrays add the class tree into the saved descriptor to
7550 enable getting of _vptr and the like. */
7551 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7552 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7554 gfc_allocate_lang_decl (desc
);
7555 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7556 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7557 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7558 : expr
->symtree
->n
.sym
->backend_decl
;
7560 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7561 && IS_CLASS_ARRAY (expr
))
7564 gfc_allocate_lang_decl (desc
);
7565 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7566 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7567 vtype
= gfc_class_vptr_get (tmp
);
7568 gfc_add_modify (&se
->pre
, vtype
,
7569 gfc_build_addr_expr (TREE_TYPE (vtype
),
7570 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7572 if (!se
->direct_byref
|| se
->byref_noassign
)
7574 /* Get a pointer to the new descriptor. */
7575 if (se
->want_pointer
)
7576 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7581 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7582 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7584 /* Cleanup the scalarizer. */
7585 gfc_cleanup_loop (&loop
);
7588 /* Helper function for gfc_conv_array_parameter if array size needs to be
7592 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7595 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7596 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7597 else if (expr
->rank
> 1)
7598 *size
= build_call_expr_loc (input_location
,
7599 gfor_fndecl_size0
, 1,
7600 gfc_build_addr_expr (NULL
, desc
));
7603 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7604 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7606 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7607 gfc_array_index_type
, ubound
, lbound
);
7608 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7609 *size
, gfc_index_one_node
);
7610 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7611 *size
, gfc_index_zero_node
);
7613 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7614 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7615 *size
, fold_convert (gfc_array_index_type
, elem
));
7618 /* Convert an array for passing as an actual parameter. */
7619 /* TODO: Optimize passing g77 arrays. */
7622 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7623 const gfc_symbol
*fsym
, const char *proc_name
,
7628 tree tmp
= NULL_TREE
;
7630 tree parent
= DECL_CONTEXT (current_function_decl
);
7631 bool full_array_var
;
7632 bool this_array_result
;
7635 bool array_constructor
;
7636 bool good_allocatable
;
7637 bool ultimate_ptr_comp
;
7638 bool ultimate_alloc_comp
;
7643 ultimate_ptr_comp
= false;
7644 ultimate_alloc_comp
= false;
7646 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7648 if (ref
->next
== NULL
)
7651 if (ref
->type
== REF_COMPONENT
)
7653 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7654 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7658 full_array_var
= false;
7661 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7662 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7664 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7666 /* The symbol should have an array specification. */
7667 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7669 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7671 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7672 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7673 se
->string_length
= tmp
;
7676 /* Is this the result of the enclosing procedure? */
7677 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7678 if (this_array_result
7679 && (sym
->backend_decl
!= current_function_decl
)
7680 && (sym
->backend_decl
!= parent
))
7681 this_array_result
= false;
7683 /* Passing address of the array if it is not pointer or assumed-shape. */
7684 if (full_array_var
&& g77
&& !this_array_result
7685 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7687 tmp
= gfc_get_symbol_decl (sym
);
7689 if (sym
->ts
.type
== BT_CHARACTER
)
7690 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7692 if (!sym
->attr
.pointer
7694 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7695 && sym
->as
->type
!= AS_DEFERRED
7696 && sym
->as
->type
!= AS_ASSUMED_RANK
7697 && !sym
->attr
.allocatable
)
7699 /* Some variables are declared directly, others are declared as
7700 pointers and allocated on the heap. */
7701 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7704 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7706 array_parameter_size (tmp
, expr
, size
);
7710 if (sym
->attr
.allocatable
)
7712 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7714 gfc_conv_expr_descriptor (se
, expr
);
7718 array_parameter_size (tmp
, expr
, size
);
7719 se
->expr
= gfc_conv_array_data (tmp
);
7724 /* A convenient reduction in scope. */
7725 contiguous
= g77
&& !this_array_result
&& contiguous
;
7727 /* There is no need to pack and unpack the array, if it is contiguous
7728 and not a deferred- or assumed-shape array, or if it is simply
7730 no_pack
= ((sym
&& sym
->as
7731 && !sym
->attr
.pointer
7732 && sym
->as
->type
!= AS_DEFERRED
7733 && sym
->as
->type
!= AS_ASSUMED_RANK
7734 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7736 (ref
&& ref
->u
.ar
.as
7737 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7738 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7739 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7741 gfc_is_simply_contiguous (expr
, false, true));
7743 no_pack
= contiguous
&& no_pack
;
7745 /* Array constructors are always contiguous and do not need packing. */
7746 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7748 /* Same is true of contiguous sections from allocatable variables. */
7749 good_allocatable
= contiguous
7751 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7753 /* Or ultimate allocatable components. */
7754 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7756 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7758 gfc_conv_expr_descriptor (se
, expr
);
7759 /* Deallocate the allocatable components of structures that are
7761 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7762 && expr
->ts
.u
.derived
->attr
.alloc_comp
7763 && expr
->expr_type
!= EXPR_VARIABLE
)
7765 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7767 /* The components shall be deallocated before their containing entity. */
7768 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7770 if (expr
->ts
.type
== BT_CHARACTER
)
7771 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7773 array_parameter_size (se
->expr
, expr
, size
);
7774 se
->expr
= gfc_conv_array_data (se
->expr
);
7778 if (this_array_result
)
7780 /* Result of the enclosing function. */
7781 gfc_conv_expr_descriptor (se
, expr
);
7783 array_parameter_size (se
->expr
, expr
, size
);
7784 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7786 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7787 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7788 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7795 /* Every other type of array. */
7796 se
->want_pointer
= 1;
7797 gfc_conv_expr_descriptor (se
, expr
);
7800 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7805 /* Deallocate the allocatable components of structures that are
7806 not variable, for descriptorless arguments.
7807 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7808 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7809 && expr
->ts
.u
.derived
->attr
.alloc_comp
7810 && expr
->expr_type
!= EXPR_VARIABLE
)
7812 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7813 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7815 /* The components shall be deallocated before their containing entity. */
7816 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7819 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7820 && !gfc_is_simply_contiguous (expr
, false, true)))
7822 tree origptr
= NULL_TREE
;
7826 /* For contiguous arrays, save the original value of the descriptor. */
7829 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7830 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7831 tmp
= gfc_conv_array_data (tmp
);
7832 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7833 TREE_TYPE (origptr
), origptr
,
7834 fold_convert (TREE_TYPE (origptr
), tmp
));
7835 gfc_add_expr_to_block (&se
->pre
, tmp
);
7838 /* Repack the array. */
7839 if (warn_array_temporaries
)
7842 gfc_warning (OPT_Warray_temporaries
,
7843 "Creating array temporary at %L for argument %qs",
7844 &expr
->where
, fsym
->name
);
7846 gfc_warning (OPT_Warray_temporaries
,
7847 "Creating array temporary at %L", &expr
->where
);
7850 ptr
= build_call_expr_loc (input_location
,
7851 gfor_fndecl_in_pack
, 1, desc
);
7853 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7855 tmp
= gfc_conv_expr_present (sym
);
7856 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7857 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7858 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7861 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7863 /* Use the packed data for the actual argument, except for contiguous arrays,
7864 where the descriptor's data component is set. */
7869 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7871 gfc_ss
* ss
= gfc_walk_expr (expr
);
7872 if (!transposed_dims (ss
))
7873 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7876 tree old_field
, new_field
;
7878 /* The original descriptor has transposed dims so we can't reuse
7879 it directly; we have to create a new one. */
7880 tree old_desc
= tmp
;
7881 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7883 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7884 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7885 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7887 old_field
= gfc_conv_descriptor_offset (old_desc
);
7888 new_field
= gfc_conv_descriptor_offset (new_desc
);
7889 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7891 for (int i
= 0; i
< expr
->rank
; i
++)
7893 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7894 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7895 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7897 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7900 if (flag_coarray
== GFC_FCOARRAY_LIB
7901 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7902 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7903 == GFC_ARRAY_ALLOCATABLE
)
7905 old_field
= gfc_conv_descriptor_token (old_desc
);
7906 new_field
= gfc_conv_descriptor_token (new_desc
);
7907 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7910 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7911 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7916 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7920 if (fsym
&& proc_name
)
7921 msg
= xasprintf ("An array temporary was created for argument "
7922 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7924 msg
= xasprintf ("An array temporary was created");
7926 tmp
= build_fold_indirect_ref_loc (input_location
,
7928 tmp
= gfc_conv_array_data (tmp
);
7929 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7930 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7932 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7933 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7935 gfc_conv_expr_present (sym
), tmp
);
7937 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7942 gfc_start_block (&block
);
7944 /* Copy the data back. */
7945 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7947 tmp
= build_call_expr_loc (input_location
,
7948 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7949 gfc_add_expr_to_block (&block
, tmp
);
7952 /* Free the temporary. */
7953 tmp
= gfc_call_free (ptr
);
7954 gfc_add_expr_to_block (&block
, tmp
);
7956 stmt
= gfc_finish_block (&block
);
7958 gfc_init_block (&block
);
7959 /* Only if it was repacked. This code needs to be executed before the
7960 loop cleanup code. */
7961 tmp
= build_fold_indirect_ref_loc (input_location
,
7963 tmp
= gfc_conv_array_data (tmp
);
7964 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7965 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7967 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7968 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7970 gfc_conv_expr_present (sym
), tmp
);
7972 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7974 gfc_add_expr_to_block (&block
, tmp
);
7975 gfc_add_block_to_block (&block
, &se
->post
);
7977 gfc_init_block (&se
->post
);
7979 /* Reset the descriptor pointer. */
7982 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7983 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7986 gfc_add_block_to_block (&se
->post
, &block
);
7991 /* This helper function calculates the size in words of a full array. */
7994 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7999 idx
= gfc_rank_cst
[rank
- 1];
8000 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
8001 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
8002 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8004 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8005 tmp
, gfc_index_one_node
);
8006 tmp
= gfc_evaluate_now (tmp
, block
);
8008 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8009 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8011 return gfc_evaluate_now (tmp
, block
);
8015 /* Allocate dest to the same size as src, and copy src -> dest.
8016 If no_malloc is set, only the copy is done. */
8019 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8020 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8021 tree add_when_allocated
)
8030 /* If the source is null, set the destination to null. Then,
8031 allocate memory to the destination. */
8032 gfc_init_block (&block
);
8034 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8036 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8037 null_data
= gfc_finish_block (&block
);
8039 gfc_init_block (&block
);
8040 if (str_sz
!= NULL_TREE
)
8043 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8047 tmp
= gfc_call_malloc (&block
, type
, size
);
8048 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8053 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8054 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8055 fold_convert (size_type_node
, size
));
8056 gfc_add_expr_to_block (&block
, tmp
);
8061 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8062 null_data
= gfc_finish_block (&block
);
8064 gfc_init_block (&block
);
8066 nelems
= gfc_full_array_size (&block
, src
, rank
);
8068 nelems
= gfc_index_one_node
;
8070 if (str_sz
!= NULL_TREE
)
8071 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8073 tmp
= fold_convert (gfc_array_index_type
,
8074 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8075 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8079 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8080 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8081 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8084 /* We know the temporary and the value will be the same length,
8085 so can use memcpy. */
8088 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8089 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8090 gfc_conv_descriptor_data_get (dest
),
8091 gfc_conv_descriptor_data_get (src
),
8092 fold_convert (size_type_node
, size
));
8093 gfc_add_expr_to_block (&block
, tmp
);
8097 gfc_add_expr_to_block (&block
, add_when_allocated
);
8098 tmp
= gfc_finish_block (&block
);
8100 /* Null the destination if the source is null; otherwise do
8101 the allocate and copy. */
8102 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8105 null_cond
= gfc_conv_descriptor_data_get (src
);
8107 null_cond
= convert (pvoid_type_node
, null_cond
);
8108 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8109 null_cond
, null_pointer_node
);
8110 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8114 /* Allocate dest to the same size as src, and copy data src -> dest. */
8117 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8118 tree add_when_allocated
)
8120 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8121 NULL_TREE
, add_when_allocated
);
8125 /* Copy data src -> dest. */
8128 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8130 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8131 NULL_TREE
, NULL_TREE
);
8134 /* Allocate dest to the same size as src, but don't copy anything. */
8137 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8139 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8140 NULL_TREE
, NULL_TREE
);
8145 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8146 tree type
, int rank
)
8153 stmtblock_t block
, globalblock
;
8155 /* If the source is null, set the destination to null. Then,
8156 allocate memory to the destination. */
8157 gfc_init_block (&block
);
8158 gfc_init_block (&globalblock
);
8160 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8163 symbol_attribute attr
;
8166 gfc_init_se (&se
, NULL
);
8167 gfc_clear_attr (&attr
);
8168 attr
.allocatable
= 1;
8169 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8170 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8171 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8173 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8174 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8175 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8176 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8177 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8178 null_data
= gfc_finish_block (&block
);
8180 gfc_init_block (&block
);
8182 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8183 fold_convert (size_type_node
, size
),
8184 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8185 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8186 GFC_CAF_COARRAY_ALLOC
);
8188 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8189 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8190 fold_convert (size_type_node
, size
));
8191 gfc_add_expr_to_block (&block
, tmp
);
8195 /* Set the rank or unitialized memory access may be reported. */
8196 tmp
= gfc_conv_descriptor_dtype (dest
);
8197 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8200 nelems
= gfc_full_array_size (&block
, src
, rank
);
8202 nelems
= integer_one_node
;
8204 tmp
= fold_convert (size_type_node
,
8205 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8206 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8207 fold_convert (size_type_node
, nelems
), tmp
);
8209 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8210 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8212 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8213 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8214 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8215 null_data
= gfc_finish_block (&block
);
8217 gfc_init_block (&block
);
8218 gfc_allocate_using_caf_lib (&block
, dest
,
8219 fold_convert (size_type_node
, size
),
8220 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8221 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8222 GFC_CAF_COARRAY_ALLOC
);
8224 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8225 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8226 gfc_conv_descriptor_data_get (dest
),
8227 gfc_conv_descriptor_data_get (src
),
8228 fold_convert (size_type_node
, size
));
8229 gfc_add_expr_to_block (&block
, tmp
);
8232 tmp
= gfc_finish_block (&block
);
8234 /* Null the destination if the source is null; otherwise do
8235 the register and copy. */
8236 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8239 null_cond
= gfc_conv_descriptor_data_get (src
);
8241 null_cond
= convert (pvoid_type_node
, null_cond
);
8242 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8243 null_cond
, null_pointer_node
);
8244 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8246 return gfc_finish_block (&globalblock
);
8250 /* Helper function to abstract whether coarray processing is enabled. */
8253 caf_enabled (int caf_mode
)
8255 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8256 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8260 /* Helper function to abstract whether coarray processing is enabled
8261 and we are in a derived type coarray. */
8264 caf_in_coarray (int caf_mode
)
8266 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8267 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8268 return (caf_mode
& pat
) == pat
;
8272 /* Helper function to abstract whether coarray is to deallocate only. */
8275 gfc_caf_is_dealloc_only (int caf_mode
)
8277 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8278 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8282 /* Recursively traverse an object of derived type, generating code to
8283 deallocate, nullify or copy allocatable components. This is the work horse
8284 function for the functions named in this enum. */
8286 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8287 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8288 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8290 static gfc_actual_arglist
*pdt_param_list
;
8293 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8294 tree dest
, int rank
, int purpose
, int caf_mode
)
8298 stmtblock_t fnblock
;
8299 stmtblock_t loopbody
;
8300 stmtblock_t tmpblock
;
8311 tree null_cond
= NULL_TREE
;
8312 tree add_when_allocated
;
8313 tree dealloc_fndecl
;
8317 symbol_attribute
*attr
;
8318 bool deallocate_called
;
8320 gfc_init_block (&fnblock
);
8322 decl_type
= TREE_TYPE (decl
);
8324 if ((POINTER_TYPE_P (decl_type
))
8325 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8327 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8328 /* Deref dest in sync with decl, but only when it is not NULL. */
8330 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8332 /* Update the decl_type because it got dereferenced. */
8333 decl_type
= TREE_TYPE (decl
);
8336 /* If this is an array of derived types with allocatable components
8337 build a loop and recursively call this function. */
8338 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8339 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8341 tmp
= gfc_conv_array_data (decl
);
8342 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8344 /* Get the number of elements - 1 and set the counter. */
8345 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8347 /* Use the descriptor for an allocatable array. Since this
8348 is a full array reference, we only need the descriptor
8349 information from dimension = rank. */
8350 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8351 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8352 gfc_array_index_type
, tmp
,
8353 gfc_index_one_node
);
8355 null_cond
= gfc_conv_descriptor_data_get (decl
);
8356 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8357 logical_type_node
, null_cond
,
8358 build_int_cst (TREE_TYPE (null_cond
), 0));
8362 /* Otherwise use the TYPE_DOMAIN information. */
8363 tmp
= array_type_nelts (decl_type
);
8364 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8367 /* Remember that this is, in fact, the no. of elements - 1. */
8368 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8369 index
= gfc_create_var (gfc_array_index_type
, "S");
8371 /* Build the body of the loop. */
8372 gfc_init_block (&loopbody
);
8374 vref
= gfc_build_array_ref (var
, index
, NULL
);
8376 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8377 && !caf_enabled (caf_mode
))
8379 tmp
= build_fold_indirect_ref_loc (input_location
,
8380 gfc_conv_array_data (dest
));
8381 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8382 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8383 COPY_ALLOC_COMP
, 0);
8386 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8389 gfc_add_expr_to_block (&loopbody
, tmp
);
8391 /* Build the loop and return. */
8392 gfc_init_loopinfo (&loop
);
8394 loop
.from
[0] = gfc_index_zero_node
;
8395 loop
.loopvar
[0] = index
;
8396 loop
.to
[0] = nelems
;
8397 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8398 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8400 tmp
= gfc_finish_block (&fnblock
);
8401 /* When copying allocateable components, the above implements the
8402 deep copy. Nevertheless is a deep copy only allowed, when the current
8403 component is allocated, for which code will be generated in
8404 gfc_duplicate_allocatable (), where the deep copy code is just added
8405 into the if's body, by adding tmp (the deep copy code) as last
8406 argument to gfc_duplicate_allocatable (). */
8407 if (purpose
== COPY_ALLOC_COMP
8408 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8409 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8411 else if (null_cond
!= NULL_TREE
)
8412 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8413 build_empty_stmt (input_location
));
8418 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8420 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8421 DEALLOCATE_PDT_COMP
, 0);
8422 gfc_add_expr_to_block (&fnblock
, tmp
);
8424 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8426 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8427 NULLIFY_ALLOC_COMP
, 0);
8428 gfc_add_expr_to_block (&fnblock
, tmp
);
8431 /* Otherwise, act on the components or recursively call self to
8432 act on a chain of components. */
8433 for (c
= der_type
->components
; c
; c
= c
->next
)
8435 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8436 || c
->ts
.type
== BT_CLASS
)
8437 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8438 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8439 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8441 cdecl = c
->backend_decl
;
8442 ctype
= TREE_TYPE (cdecl);
8446 case DEALLOCATE_ALLOC_COMP
:
8448 gfc_init_block (&tmpblock
);
8450 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8451 decl
, cdecl, NULL_TREE
);
8453 /* Shortcut to get the attributes of the component. */
8454 if (c
->ts
.type
== BT_CLASS
)
8456 attr
= &CLASS_DATA (c
)->attr
;
8457 if (attr
->class_pointer
)
8467 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8468 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8469 /* Call the finalizer, which will free the memory and nullify the
8470 pointer of an array. */
8471 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8472 caf_enabled (caf_mode
))
8475 deallocate_called
= false;
8477 /* Add the _class ref for classes. */
8478 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8479 comp
= gfc_class_data_get (comp
);
8481 add_when_allocated
= NULL_TREE
;
8482 if (cmp_has_alloc_comps
8483 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8485 && !deallocate_called
)
8487 /* Add checked deallocation of the components. This code is
8488 obviously added because the finalizer is not trusted to free
8490 if (c
->ts
.type
== BT_CLASS
)
8492 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8494 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8495 comp
, NULL_TREE
, rank
, purpose
,
8500 rank
= c
->as
? c
->as
->rank
: 0;
8501 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8508 if (attr
->allocatable
&& !same_type
8509 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8511 /* Handle all types of components besides components of the
8512 same_type as the current one, because those would create an
8515 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8516 ? (gfc_caf_is_dealloc_only (caf_mode
)
8517 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8518 : GFC_CAF_COARRAY_DEREGISTER
)
8519 : GFC_CAF_COARRAY_NOCOARRAY
;
8521 caf_token
= NULL_TREE
;
8522 /* Coarray components are handled directly by
8523 deallocate_with_status. */
8524 if (!attr
->codimension
8525 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8528 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8529 TREE_TYPE (c
->caf_token
),
8530 decl
, c
->caf_token
, NULL_TREE
);
8531 else if (attr
->dimension
&& !attr
->proc_pointer
)
8532 caf_token
= gfc_conv_descriptor_token (comp
);
8534 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8535 /* When this is an array but not in conjunction with a coarray
8536 then add the data-ref. For coarray'ed arrays the data-ref
8537 is added by deallocate_with_status. */
8538 comp
= gfc_conv_descriptor_data_get (comp
);
8540 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8541 NULL_TREE
, NULL_TREE
, true,
8542 NULL
, caf_dereg_mode
,
8543 add_when_allocated
, caf_token
);
8545 gfc_add_expr_to_block (&tmpblock
, tmp
);
8547 else if (attr
->allocatable
&& !attr
->codimension
8548 && !deallocate_called
)
8550 /* Case of recursive allocatable derived types. */
8554 stmtblock_t dealloc_block
;
8556 gfc_init_block (&dealloc_block
);
8557 if (add_when_allocated
)
8558 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8560 /* Convert the component into a rank 1 descriptor type. */
8561 if (attr
->dimension
)
8563 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8564 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8565 c
->ts
.type
== BT_CLASS
8566 ? CLASS_DATA (c
)->as
->rank
8571 tmp
= TREE_TYPE (comp
);
8572 ubound
= build_int_cst (gfc_array_index_type
, 1);
8575 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8577 GFC_ARRAY_ALLOCATABLE
, false);
8579 cdesc
= gfc_create_var (cdesc
, "cdesc");
8580 DECL_ARTIFICIAL (cdesc
) = 1;
8582 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8583 gfc_get_dtype_rank_type (1, tmp
));
8584 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8585 gfc_index_zero_node
,
8586 gfc_index_one_node
);
8587 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8588 gfc_index_zero_node
,
8589 gfc_index_one_node
);
8590 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8591 gfc_index_zero_node
, ubound
);
8593 if (attr
->dimension
)
8594 comp
= gfc_conv_descriptor_data_get (comp
);
8596 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8598 /* Now call the deallocator. */
8599 vtab
= gfc_find_vtab (&c
->ts
);
8600 if (vtab
->backend_decl
== NULL
)
8601 gfc_get_symbol_decl (vtab
);
8602 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8603 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8604 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8606 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8607 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8608 logical_type_node
, tmp
,
8610 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8612 tmp
= build_call_expr_loc (input_location
,
8615 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8617 tmp
= gfc_finish_block (&dealloc_block
);
8619 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8620 void_type_node
, is_allocated
, tmp
,
8621 build_empty_stmt (input_location
));
8623 gfc_add_expr_to_block (&tmpblock
, tmp
);
8625 else if (add_when_allocated
)
8626 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8628 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8629 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8631 /* Finally, reset the vptr to the declared type vtable and, if
8632 necessary reset the _len field.
8634 First recover the reference to the component and obtain
8636 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8637 decl
, cdecl, NULL_TREE
);
8638 tmp
= gfc_class_vptr_get (comp
);
8640 if (UNLIMITED_POLY (c
))
8642 /* Both vptr and _len field should be nulled. */
8643 gfc_add_modify (&tmpblock
, tmp
,
8644 build_int_cst (TREE_TYPE (tmp
), 0));
8645 tmp
= gfc_class_len_get (comp
);
8646 gfc_add_modify (&tmpblock
, tmp
,
8647 build_int_cst (TREE_TYPE (tmp
), 0));
8651 /* Build the vtable address and set the vptr with it. */
8654 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8655 vtab
= vtable
->backend_decl
;
8656 if (vtab
== NULL_TREE
)
8657 vtab
= gfc_get_symbol_decl (vtable
);
8658 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8659 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8660 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8664 /* Now add the deallocation of this component. */
8665 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8668 case NULLIFY_ALLOC_COMP
:
8670 - allocatable components (regular or in class)
8671 - components that have allocatable components
8672 - pointer components when in a coarray.
8673 Skip everything else especially proc_pointers, which may come
8674 coupled with the regular pointer attribute. */
8675 if (c
->attr
.proc_pointer
8676 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8677 && CLASS_DATA (c
)->attr
.allocatable
)
8678 || (cmp_has_alloc_comps
8679 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8680 || (c
->ts
.type
== BT_CLASS
8681 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8682 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8685 /* Process class components first, because they always have the
8686 pointer-attribute set which would be caught wrong else. */
8687 if (c
->ts
.type
== BT_CLASS
8688 && (CLASS_DATA (c
)->attr
.allocatable
8689 || CLASS_DATA (c
)->attr
.class_pointer
))
8691 /* Allocatable CLASS components. */
8692 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8693 decl
, cdecl, NULL_TREE
);
8695 comp
= gfc_class_data_get (comp
);
8696 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8697 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8701 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8702 void_type_node
, comp
,
8703 build_int_cst (TREE_TYPE (comp
), 0));
8704 gfc_add_expr_to_block (&fnblock
, tmp
);
8706 cmp_has_alloc_comps
= false;
8708 /* Coarrays need the component to be nulled before the api-call
8710 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8712 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8713 decl
, cdecl, NULL_TREE
);
8714 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8715 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8718 gfc_add_modify (&fnblock
, comp
,
8719 build_int_cst (TREE_TYPE (comp
), 0));
8720 if (gfc_deferred_strlen (c
, &comp
))
8722 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8724 decl
, comp
, NULL_TREE
);
8725 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8726 TREE_TYPE (comp
), comp
,
8727 build_int_cst (TREE_TYPE (comp
), 0));
8728 gfc_add_expr_to_block (&fnblock
, tmp
);
8730 cmp_has_alloc_comps
= false;
8733 if (flag_coarray
== GFC_FCOARRAY_LIB
8734 && (caf_in_coarray (caf_mode
) || c
->attr
.codimension
))
8736 /* Register the component with the coarray library. */
8739 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8740 decl
, cdecl, NULL_TREE
);
8741 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8743 /* Set the dtype, because caf_register needs it. */
8744 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8745 gfc_get_dtype (TREE_TYPE (comp
)));
8746 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8747 decl
, cdecl, NULL_TREE
);
8748 token
= gfc_conv_descriptor_token (tmp
);
8754 gfc_init_se (&se
, NULL
);
8755 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8756 pvoid_type_node
, decl
, c
->caf_token
,
8758 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8759 c
->ts
.type
== BT_CLASS
8760 ? CLASS_DATA (c
)->attr
8762 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8765 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8766 gfc_build_addr_expr (NULL_TREE
,
8768 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8769 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8772 if (cmp_has_alloc_comps
)
8774 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8775 decl
, cdecl, NULL_TREE
);
8776 rank
= c
->as
? c
->as
->rank
: 0;
8777 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8778 rank
, purpose
, caf_mode
);
8779 gfc_add_expr_to_block (&fnblock
, tmp
);
8783 case REASSIGN_CAF_COMP
:
8784 if (caf_enabled (caf_mode
)
8785 && (c
->attr
.codimension
8786 || (c
->ts
.type
== BT_CLASS
8787 && (CLASS_DATA (c
)->attr
.coarray_comp
8788 || caf_in_coarray (caf_mode
)))
8789 || (c
->ts
.type
== BT_DERIVED
8790 && (c
->ts
.u
.derived
->attr
.coarray_comp
8791 || caf_in_coarray (caf_mode
))))
8794 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8795 decl
, cdecl, NULL_TREE
);
8796 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8797 dest
, cdecl, NULL_TREE
);
8799 if (c
->attr
.codimension
)
8801 if (c
->ts
.type
== BT_CLASS
)
8803 comp
= gfc_class_data_get (comp
);
8804 dcmp
= gfc_class_data_get (dcmp
);
8806 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8807 gfc_conv_descriptor_data_get (comp
));
8811 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8812 rank
, purpose
, caf_mode
8813 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8814 gfc_add_expr_to_block (&fnblock
, tmp
);
8819 case COPY_ALLOC_COMP
:
8820 if (c
->attr
.pointer
)
8823 /* We need source and destination components. */
8824 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8826 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8828 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8830 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8838 dst_data
= gfc_class_data_get (dcmp
);
8839 src_data
= gfc_class_data_get (comp
);
8840 size
= fold_convert (size_type_node
,
8841 gfc_class_vtab_size_get (comp
));
8843 if (CLASS_DATA (c
)->attr
.dimension
)
8845 nelems
= gfc_conv_descriptor_size (src_data
,
8846 CLASS_DATA (c
)->as
->rank
);
8847 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8848 size_type_node
, size
,
8849 fold_convert (size_type_node
,
8853 nelems
= build_int_cst (size_type_node
, 1);
8855 if (CLASS_DATA (c
)->attr
.dimension
8856 || CLASS_DATA (c
)->attr
.codimension
)
8858 src_data
= gfc_conv_descriptor_data_get (src_data
);
8859 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8862 gfc_init_block (&tmpblock
);
8864 /* Coarray component have to have the same allocation status and
8865 shape/type-parameter/effective-type on the LHS and RHS of an
8866 intrinsic assignment. Hence, we did not deallocated them - and
8867 do not allocate them here. */
8868 if (!CLASS_DATA (c
)->attr
.codimension
)
8870 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8871 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8872 gfc_add_modify (&tmpblock
, dst_data
,
8873 fold_convert (TREE_TYPE (dst_data
), tmp
));
8876 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8877 UNLIMITED_POLY (c
));
8878 gfc_add_expr_to_block (&tmpblock
, tmp
);
8879 tmp
= gfc_finish_block (&tmpblock
);
8881 gfc_init_block (&tmpblock
);
8882 gfc_add_modify (&tmpblock
, dst_data
,
8883 fold_convert (TREE_TYPE (dst_data
),
8884 null_pointer_node
));
8885 null_data
= gfc_finish_block (&tmpblock
);
8887 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8888 logical_type_node
, src_data
,
8891 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8896 /* To implement guarded deep copy, i.e., deep copy only allocatable
8897 components that are really allocated, the deep copy code has to
8898 be generated first and then added to the if-block in
8899 gfc_duplicate_allocatable (). */
8900 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
8903 rank
= c
->as
? c
->as
->rank
: 0;
8904 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8905 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8906 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8912 add_when_allocated
= NULL_TREE
;
8914 if (gfc_deferred_strlen (c
, &tmp
))
8918 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8920 decl
, len
, NULL_TREE
);
8921 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8923 dest
, len
, NULL_TREE
);
8924 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8925 TREE_TYPE (len
), len
, tmp
);
8926 gfc_add_expr_to_block (&fnblock
, tmp
);
8927 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8928 /* This component can not have allocatable components,
8929 therefore add_when_allocated of duplicate_allocatable ()
8931 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8932 false, false, size
, NULL_TREE
);
8933 gfc_add_expr_to_block (&fnblock
, tmp
);
8935 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
&& !same_type
8936 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
8937 || caf_in_coarray (caf_mode
)))
8939 rank
= c
->as
? c
->as
->rank
: 0;
8940 if (c
->attr
.codimension
)
8941 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8942 else if (flag_coarray
== GFC_FCOARRAY_LIB
8943 && caf_in_coarray (caf_mode
))
8945 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
8946 : fold_build3_loc (input_location
,
8948 pvoid_type_node
, dest
,
8951 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
8955 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8956 add_when_allocated
);
8957 gfc_add_expr_to_block (&fnblock
, tmp
);
8960 if (cmp_has_alloc_comps
)
8961 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8965 case ALLOCATE_PDT_COMP
:
8967 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8968 decl
, cdecl, NULL_TREE
);
8970 /* Set the PDT KIND and LEN fields. */
8971 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
8974 gfc_expr
*c_expr
= NULL
;
8975 gfc_actual_arglist
*param
= pdt_param_list
;
8976 gfc_init_se (&tse
, NULL
);
8977 for (; param
; param
= param
->next
)
8978 if (!strcmp (c
->name
, param
->name
))
8979 c_expr
= param
->expr
;
8982 c_expr
= c
->initializer
;
8986 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
8987 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
8991 if (c
->attr
.pdt_string
)
8994 gfc_init_se (&tse
, NULL
);
8996 /* Convert the parameterized string length to its value. The
8997 string length is stored in a hidden field in the same way as
8998 deferred string lengths. */
8999 gfc_insert_parameter_exprs (c
->ts
.u
.cl
->length
, pdt_param_list
);
9000 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
9002 gfc_conv_expr_type (&tse
, c
->ts
.u
.cl
->length
,
9003 TREE_TYPE (strlen
));
9004 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9006 decl
, strlen
, NULL_TREE
);
9007 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9008 c
->ts
.u
.cl
->backend_decl
= strlen
;
9010 /* Scalar parameterizied strings can be allocated now. */
9013 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9014 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9015 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9016 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9017 gfc_add_modify (&fnblock
, comp
, tmp
);
9021 /* Allocate paramterized arrays of parameterized derived types. */
9022 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9023 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9024 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9027 if (c
->ts
.type
== BT_CLASS
)
9028 comp
= gfc_class_data_get (comp
);
9030 if (c
->attr
.pdt_array
)
9034 tree size
= gfc_index_one_node
;
9035 tree offset
= gfc_index_zero_node
;
9039 /* This chunk takes the expressions for 'lower' and 'upper'
9040 in the arrayspec and substitutes in the expressions for
9041 the parameters from 'pdt_param_list'. The descriptor
9042 fields can then be filled from the values so obtained. */
9043 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9044 for (i
= 0; i
< c
->as
->rank
; i
++)
9046 gfc_init_se (&tse
, NULL
);
9047 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9048 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9049 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9052 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9055 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9056 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9057 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9060 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9063 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9066 size
= gfc_evaluate_now (size
, &fnblock
);
9067 offset
= fold_build2_loc (input_location
,
9069 gfc_array_index_type
,
9071 offset
= gfc_evaluate_now (offset
, &fnblock
);
9072 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9073 gfc_array_index_type
,
9075 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9076 gfc_array_index_type
,
9077 tmp
, gfc_index_one_node
);
9078 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9079 gfc_array_index_type
, size
, tmp
);
9081 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9082 if (c
->ts
.type
== BT_CLASS
)
9084 tmp
= gfc_get_vptr_from_expr (comp
);
9085 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9086 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9087 tmp
= gfc_vptr_size_get (tmp
);
9090 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9091 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9092 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9093 gfc_array_index_type
, size
, tmp
);
9094 size
= gfc_evaluate_now (size
, &fnblock
);
9095 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9096 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9097 tmp
= gfc_conv_descriptor_dtype (comp
);
9098 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9101 /* Recurse in to PDT components. */
9102 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9103 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9104 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9106 bool is_deferred
= false;
9107 gfc_actual_arglist
*tail
= c
->param_list
;
9109 for (; tail
; tail
= tail
->next
)
9113 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9114 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9115 c
->as
? c
->as
->rank
: 0,
9117 gfc_add_expr_to_block (&fnblock
, tmp
);
9122 case DEALLOCATE_PDT_COMP
:
9123 /* Deallocate array or parameterized string length components
9124 of parameterized derived types. */
9125 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9126 && !c
->attr
.pdt_string
9127 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9128 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9131 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9132 decl
, cdecl, NULL_TREE
);
9133 if (c
->ts
.type
== BT_CLASS
)
9134 comp
= gfc_class_data_get (comp
);
9136 /* Recurse in to PDT components. */
9137 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9138 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9139 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9141 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9142 c
->as
? c
->as
->rank
: 0);
9143 gfc_add_expr_to_block (&fnblock
, tmp
);
9146 if (c
->attr
.pdt_array
)
9148 tmp
= gfc_conv_descriptor_data_get (comp
);
9149 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9150 logical_type_node
, tmp
,
9151 build_int_cst (TREE_TYPE (tmp
), 0));
9152 tmp
= gfc_call_free (tmp
);
9153 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9154 build_empty_stmt (input_location
));
9155 gfc_add_expr_to_block (&fnblock
, tmp
);
9156 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9158 else if (c
->attr
.pdt_string
)
9160 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9161 logical_type_node
, comp
,
9162 build_int_cst (TREE_TYPE (comp
), 0));
9163 tmp
= gfc_call_free (comp
);
9164 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9165 build_empty_stmt (input_location
));
9166 gfc_add_expr_to_block (&fnblock
, tmp
);
9167 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9168 gfc_add_modify (&fnblock
, comp
, tmp
);
9173 case CHECK_PDT_DUMMY
:
9175 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9176 decl
, cdecl, NULL_TREE
);
9177 if (c
->ts
.type
== BT_CLASS
)
9178 comp
= gfc_class_data_get (comp
);
9180 /* Recurse in to PDT components. */
9181 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9182 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9184 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9185 c
->as
? c
->as
->rank
: 0,
9187 gfc_add_expr_to_block (&fnblock
, tmp
);
9190 if (!c
->attr
.pdt_len
)
9195 gfc_expr
*c_expr
= NULL
;
9196 gfc_actual_arglist
*param
= pdt_param_list
;
9198 gfc_init_se (&tse
, NULL
);
9199 for (; param
; param
= param
->next
)
9200 if (!strcmp (c
->name
, param
->name
))
9201 c_expr
= param
->expr
;
9205 tree error
, cond
, cname
;
9206 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9207 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9210 cname
= gfc_build_cstring_const (c
->name
);
9211 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9212 error
= gfc_trans_runtime_error (true, NULL
,
9213 "The value of the PDT LEN "
9214 "parameter '%s' does not "
9215 "agree with that in the "
9216 "dummy declaration",
9218 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9219 void_type_node
, cond
, error
,
9220 build_empty_stmt (input_location
));
9221 gfc_add_expr_to_block (&fnblock
, tmp
);
9232 return gfc_finish_block (&fnblock
);
9235 /* Recursively traverse an object of derived type, generating code to
9236 nullify allocatable components. */
9239 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9242 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9244 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9248 /* Recursively traverse an object of derived type, generating code to
9249 deallocate allocatable components. */
9252 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9255 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9256 DEALLOCATE_ALLOC_COMP
,
9257 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9261 /* Recursively traverse an object of derived type, generating code to
9262 deallocate allocatable components. But do not deallocate coarrays.
9263 To be used for intrinsic assignment, which may not change the allocation
9264 status of coarrays. */
9267 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9269 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9270 DEALLOCATE_ALLOC_COMP
, 0);
9275 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9277 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9278 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9282 /* Recursively traverse an object of derived type, generating code to
9283 copy it and its allocatable components. */
9286 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9289 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9294 /* Recursively traverse an object of derived type, generating code to
9295 copy only its allocatable components. */
9298 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9300 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9301 COPY_ONLY_ALLOC_COMP
, 0);
9305 /* Recursively traverse an object of paramterized derived type, generating
9306 code to allocate parameterized components. */
9309 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9310 gfc_actual_arglist
*param_list
)
9313 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9314 pdt_param_list
= param_list
;
9315 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9316 ALLOCATE_PDT_COMP
, 0);
9317 pdt_param_list
= old_param_list
;
9321 /* Recursively traverse an object of paramterized derived type, generating
9322 code to deallocate parameterized components. */
9325 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9327 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9328 DEALLOCATE_PDT_COMP
, 0);
9332 /* Recursively traverse a dummy of paramterized derived type to check the
9333 values of LEN parameters. */
9336 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9337 gfc_actual_arglist
*param_list
)
9340 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9341 pdt_param_list
= param_list
;
9342 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9343 CHECK_PDT_DUMMY
, 0);
9344 pdt_param_list
= old_param_list
;
9349 /* Returns the value of LBOUND for an expression. This could be broken out
9350 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9351 called by gfc_alloc_allocatable_for_assignment. */
9353 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9358 tree cond
, cond1
, cond3
, cond4
;
9362 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9364 tmp
= gfc_rank_cst
[dim
];
9365 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9366 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9367 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9368 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9370 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9371 stride
, gfc_index_zero_node
);
9372 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9373 logical_type_node
, cond3
, cond1
);
9374 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9375 stride
, gfc_index_zero_node
);
9377 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9378 tmp
, build_int_cst (gfc_array_index_type
,
9381 cond
= logical_false_node
;
9383 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9384 logical_type_node
, cond3
, cond4
);
9385 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9386 logical_type_node
, cond
, cond1
);
9388 return fold_build3_loc (input_location
, COND_EXPR
,
9389 gfc_array_index_type
, cond
,
9390 lbound
, gfc_index_one_node
);
9393 if (expr
->expr_type
== EXPR_FUNCTION
)
9395 /* A conversion function, so use the argument. */
9396 gcc_assert (expr
->value
.function
.isym
9397 && expr
->value
.function
.isym
->conversion
);
9398 expr
= expr
->value
.function
.actual
->expr
;
9401 if (expr
->expr_type
== EXPR_VARIABLE
)
9403 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9404 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9406 if (ref
->type
== REF_COMPONENT
9407 && ref
->u
.c
.component
->as
9409 && ref
->next
->u
.ar
.type
== AR_FULL
)
9410 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9412 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9415 return gfc_index_one_node
;
9419 /* Returns true if an expression represents an lhs that can be reallocated
9423 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9430 /* An allocatable class variable with no reference. */
9431 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
9432 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.allocatable
9433 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
9434 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9435 && expr
->ref
->next
== NULL
)
9438 /* An allocatable variable. */
9439 if (expr
->symtree
->n
.sym
->attr
.allocatable
9441 && expr
->ref
->type
== REF_ARRAY
9442 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9445 /* All that can be left are allocatable components. */
9446 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9447 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9448 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
9451 /* Find a component ref followed by an array reference. */
9452 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9454 && ref
->type
== REF_COMPONENT
9455 && ref
->next
->type
== REF_ARRAY
9456 && !ref
->next
->next
)
9462 /* Return true if valid reallocatable lhs. */
9463 if (ref
->u
.c
.component
->attr
.allocatable
9464 && ref
->next
->u
.ar
.type
== AR_FULL
)
9472 concat_str_length (gfc_expr
* expr
)
9479 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9480 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9481 if (len1
== NULL_TREE
)
9483 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9484 len1
= concat_str_length (expr
->value
.op
.op1
);
9485 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9486 len1
= build_int_cst (gfc_charlen_type_node
,
9487 expr
->value
.op
.op1
->value
.character
.length
);
9488 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9490 gfc_init_se (&se
, NULL
);
9491 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9497 gfc_init_se (&se
, NULL
);
9498 se
.want_pointer
= 1;
9499 se
.descriptor_only
= 1;
9500 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9501 len1
= se
.string_length
;
9505 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9506 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9507 if (len2
== NULL_TREE
)
9509 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9510 len2
= concat_str_length (expr
->value
.op
.op2
);
9511 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9512 len2
= build_int_cst (gfc_charlen_type_node
,
9513 expr
->value
.op
.op2
->value
.character
.length
);
9514 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9516 gfc_init_se (&se
, NULL
);
9517 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9523 gfc_init_se (&se
, NULL
);
9524 se
.want_pointer
= 1;
9525 se
.descriptor_only
= 1;
9526 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9527 len2
= se
.string_length
;
9531 gcc_assert(len1
&& len2
);
9532 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9533 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9535 return fold_build2_loc (input_location
, PLUS_EXPR
,
9536 gfc_charlen_type_node
, len1
, len2
);
9540 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9544 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9548 stmtblock_t realloc_block
;
9549 stmtblock_t alloc_block
;
9553 gfc_array_info
*linfo
;
9575 gfc_array_spec
* as
;
9576 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9577 && gfc_caf_attr (expr1
, true).codimension
);
9581 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9582 Find the lhs expression in the loop chain and set expr1 and
9583 expr2 accordingly. */
9584 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9587 /* Find the ss for the lhs. */
9589 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9590 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9592 if (lss
== gfc_ss_terminator
)
9594 expr1
= lss
->info
->expr
;
9597 /* Bail out if this is not a valid allocate on assignment. */
9598 if (!gfc_is_reallocatable_lhs (expr1
)
9599 || (expr2
&& !expr2
->rank
))
9602 /* Find the ss for the lhs. */
9604 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9605 if (lss
->info
->expr
== expr1
)
9608 if (lss
== gfc_ss_terminator
)
9611 linfo
= &lss
->info
->data
.array
;
9613 /* Find an ss for the rhs. For operator expressions, we see the
9614 ss's for the operands. Any one of these will do. */
9616 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9617 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9620 if (expr2
&& rss
== gfc_ss_terminator
)
9623 gfc_start_block (&fblock
);
9625 /* Since the lhs is allocatable, this must be a descriptor type.
9626 Get the data and array size. */
9627 desc
= linfo
->descriptor
;
9628 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9629 array1
= gfc_conv_descriptor_data_get (desc
);
9631 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9632 deallocated if expr is an array of different shape or any of the
9633 corresponding length type parameter values of variable and expr
9634 differ." This assures F95 compatibility. */
9635 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9636 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9638 /* Allocate if data is NULL. */
9639 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9640 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9642 if (expr1
->ts
.deferred
)
9643 cond_null
= gfc_evaluate_now (logical_true_node
, &fblock
);
9645 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9647 tmp
= build3_v (COND_EXPR
, cond_null
,
9648 build1_v (GOTO_EXPR
, jump_label1
),
9649 build_empty_stmt (input_location
));
9650 gfc_add_expr_to_block (&fblock
, tmp
);
9652 /* Get arrayspec if expr is a full array. */
9653 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9654 && expr2
->value
.function
.isym
9655 && expr2
->value
.function
.isym
->conversion
)
9657 /* For conversion functions, take the arg. */
9658 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9659 as
= gfc_get_full_arrayspec_from_expr (arg
);
9662 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9666 /* If the lhs shape is not the same as the rhs jump to setting the
9667 bounds and doing the reallocation....... */
9668 for (n
= 0; n
< expr1
->rank
; n
++)
9670 /* Check the shape. */
9671 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9672 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9673 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9674 gfc_array_index_type
,
9675 loop
->to
[n
], loop
->from
[n
]);
9676 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9677 gfc_array_index_type
,
9679 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9680 gfc_array_index_type
,
9682 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9684 tmp
, gfc_index_zero_node
);
9685 tmp
= build3_v (COND_EXPR
, cond
,
9686 build1_v (GOTO_EXPR
, jump_label1
),
9687 build_empty_stmt (input_location
));
9688 gfc_add_expr_to_block (&fblock
, tmp
);
9691 /* ....else jump past the (re)alloc code. */
9692 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9693 gfc_add_expr_to_block (&fblock
, tmp
);
9695 /* Add the label to start automatic (re)allocation. */
9696 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9697 gfc_add_expr_to_block (&fblock
, tmp
);
9699 /* If the lhs has not been allocated, its bounds will not have been
9700 initialized and so its size is set to zero. */
9701 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9702 gfc_init_block (&alloc_block
);
9703 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9704 gfc_init_block (&realloc_block
);
9705 gfc_add_modify (&realloc_block
, size1
,
9706 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9707 tmp
= build3_v (COND_EXPR
, cond_null
,
9708 gfc_finish_block (&alloc_block
),
9709 gfc_finish_block (&realloc_block
));
9710 gfc_add_expr_to_block (&fblock
, tmp
);
9712 /* Get the rhs size and fix it. */
9714 desc2
= rss
->info
->data
.array
.descriptor
;
9718 size2
= gfc_index_one_node
;
9719 for (n
= 0; n
< expr2
->rank
; n
++)
9721 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9722 gfc_array_index_type
,
9723 loop
->to
[n
], loop
->from
[n
]);
9724 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9725 gfc_array_index_type
,
9726 tmp
, gfc_index_one_node
);
9727 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9728 gfc_array_index_type
,
9731 size2
= gfc_evaluate_now (size2
, &fblock
);
9733 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9736 /* If the lhs is deferred length, assume that the element size
9737 changes and force a reallocation. */
9738 if (expr1
->ts
.deferred
)
9739 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
9741 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9743 /* Deallocation of allocatable components will have to occur on
9744 reallocation. Fix the old descriptor now. */
9745 if ((expr1
->ts
.type
== BT_DERIVED
)
9746 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9747 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9749 old_desc
= NULL_TREE
;
9751 /* Now modify the lhs descriptor and the associated scalarizer
9752 variables. F2003 7.4.1.3: "If variable is or becomes an
9753 unallocated allocatable variable, then it is allocated with each
9754 deferred type parameter equal to the corresponding type parameters
9755 of expr , with the shape of expr , and with each lower bound equal
9756 to the corresponding element of LBOUND(expr)."
9757 Reuse size1 to keep a dimension-by-dimension track of the
9758 stride of the new array. */
9759 size1
= gfc_index_one_node
;
9760 offset
= gfc_index_zero_node
;
9762 for (n
= 0; n
< expr2
->rank
; n
++)
9764 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9765 gfc_array_index_type
,
9766 loop
->to
[n
], loop
->from
[n
]);
9767 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9768 gfc_array_index_type
,
9769 tmp
, gfc_index_one_node
);
9771 lbound
= gfc_index_one_node
;
9776 lbd
= get_std_lbound (expr2
, desc2
, n
,
9777 as
->type
== AS_ASSUMED_SIZE
);
9778 ubound
= fold_build2_loc (input_location
,
9780 gfc_array_index_type
,
9782 ubound
= fold_build2_loc (input_location
,
9784 gfc_array_index_type
,
9789 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9792 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9795 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9798 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9800 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9801 gfc_array_index_type
,
9803 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9804 gfc_array_index_type
,
9806 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9807 gfc_array_index_type
,
9811 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9812 the array offset is saved and the info.offset is used for a
9813 running offset. Use the saved_offset instead. */
9814 tmp
= gfc_conv_descriptor_offset (desc
);
9815 gfc_add_modify (&fblock
, tmp
, offset
);
9816 if (linfo
->saved_offset
9817 && VAR_P (linfo
->saved_offset
))
9818 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9820 /* Now set the deltas for the lhs. */
9821 for (n
= 0; n
< expr1
->rank
; n
++)
9823 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9825 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9826 gfc_array_index_type
, tmp
,
9828 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9829 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9832 /* Get the new lhs size in bytes. */
9833 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9835 if (expr2
->ts
.deferred
)
9837 if (VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9838 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9840 tmp
= rss
->info
->string_length
;
9844 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9845 if (!tmp
&& expr2
->expr_type
== EXPR_OP
9846 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
9848 tmp
= concat_str_length (expr2
);
9849 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
9851 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
9854 if (expr1
->ts
.u
.cl
->backend_decl
9855 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
9856 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
9858 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
9860 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
9862 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
9863 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9864 gfc_array_index_type
, tmp
,
9865 expr1
->ts
.u
.cl
->backend_decl
);
9868 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9869 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9870 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9871 gfc_array_index_type
,
9873 size2
= fold_convert (size_type_node
, size2
);
9874 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9875 size2
, size_one_node
);
9876 size2
= gfc_evaluate_now (size2
, &fblock
);
9878 /* For deferred character length, the 'size' field of the dtype might
9879 have changed so set the dtype. */
9880 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9881 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9884 tmp
= gfc_conv_descriptor_dtype (desc
);
9885 if (expr2
->ts
.u
.cl
->backend_decl
)
9886 type
= gfc_typenode_for_spec (&expr2
->ts
);
9888 type
= gfc_typenode_for_spec (&expr1
->ts
);
9890 gfc_add_modify (&fblock
, tmp
,
9891 gfc_get_dtype_rank_type (expr1
->rank
,type
));
9893 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9895 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
9896 gfc_get_dtype (TREE_TYPE (desc
)));
9899 /* Realloc expression. Note that the scalarizer uses desc.data
9900 in the array reference - (*desc.data)[<element>]. */
9901 gfc_init_block (&realloc_block
);
9902 gfc_init_se (&caf_se
, NULL
);
9906 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
9907 if (token
== NULL_TREE
)
9909 tmp
= gfc_get_tree_for_caf_expr (expr1
);
9910 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9911 tmp
= build_fold_indirect_ref (tmp
);
9912 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
9914 token
= gfc_build_addr_expr (NULL_TREE
, token
);
9917 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
9919 if ((expr1
->ts
.type
== BT_DERIVED
)
9920 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9922 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
9924 gfc_add_expr_to_block (&realloc_block
, tmp
);
9929 tmp
= build_call_expr_loc (input_location
,
9930 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
9931 fold_convert (pvoid_type_node
, array1
),
9933 gfc_conv_descriptor_data_set (&realloc_block
,
9938 tmp
= build_call_expr_loc (input_location
,
9939 gfor_fndecl_caf_deregister
, 5, token
,
9940 build_int_cst (integer_type_node
,
9941 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
9942 null_pointer_node
, null_pointer_node
,
9944 gfc_add_expr_to_block (&realloc_block
, tmp
);
9945 tmp
= build_call_expr_loc (input_location
,
9946 gfor_fndecl_caf_register
,
9948 build_int_cst (integer_type_node
,
9949 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
9950 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9951 null_pointer_node
, null_pointer_node
,
9953 gfc_add_expr_to_block (&realloc_block
, tmp
);
9956 if ((expr1
->ts
.type
== BT_DERIVED
)
9957 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9959 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
9961 gfc_add_expr_to_block (&realloc_block
, tmp
);
9964 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
9965 realloc_expr
= gfc_finish_block (&realloc_block
);
9967 /* Only reallocate if sizes are different. */
9968 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
9969 build_empty_stmt (input_location
));
9973 /* Malloc expression. */
9974 gfc_init_block (&alloc_block
);
9977 tmp
= build_call_expr_loc (input_location
,
9978 builtin_decl_explicit (BUILT_IN_MALLOC
),
9980 gfc_conv_descriptor_data_set (&alloc_block
,
9985 tmp
= build_call_expr_loc (input_location
,
9986 gfor_fndecl_caf_register
,
9988 build_int_cst (integer_type_node
,
9989 GFC_CAF_COARRAY_ALLOC
),
9990 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9991 null_pointer_node
, null_pointer_node
,
9993 gfc_add_expr_to_block (&alloc_block
, tmp
);
9997 /* We already set the dtype in the case of deferred character
9999 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
10000 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10003 tmp
= gfc_conv_descriptor_dtype (desc
);
10004 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10007 if ((expr1
->ts
.type
== BT_DERIVED
)
10008 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10010 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10012 gfc_add_expr_to_block (&alloc_block
, tmp
);
10014 alloc_expr
= gfc_finish_block (&alloc_block
);
10016 /* Malloc if not allocated; realloc otherwise. */
10017 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10018 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10021 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10022 gfc_add_expr_to_block (&fblock
, tmp
);
10024 /* Make sure that the scalarizer data pointer is updated. */
10025 if (linfo
->data
&& VAR_P (linfo
->data
))
10027 tmp
= gfc_conv_descriptor_data_get (desc
);
10028 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10031 /* Add the exit label. */
10032 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10033 gfc_add_expr_to_block (&fblock
, tmp
);
10035 return gfc_finish_block (&fblock
);
10039 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10040 Do likewise, recursively if necessary, with the allocatable components of
10044 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10050 stmtblock_t cleanup
;
10053 bool sym_has_alloc_comp
, has_finalizer
;
10055 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10056 || sym
->ts
.type
== BT_CLASS
)
10057 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10058 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10059 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10061 /* Make sure the frontend gets these right. */
10062 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10065 gfc_save_backend_locus (&loc
);
10066 gfc_set_backend_locus (&sym
->declared_at
);
10067 gfc_init_block (&init
);
10069 gcc_assert (VAR_P (sym
->backend_decl
)
10070 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10072 if (sym
->ts
.type
== BT_CHARACTER
10073 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10075 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10076 gfc_trans_vla_type_sizes (sym
, &init
);
10079 /* Dummy, use associated and result variables don't need anything special. */
10080 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10082 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10083 gfc_restore_backend_locus (&loc
);
10087 descriptor
= sym
->backend_decl
;
10089 /* Although static, derived types with default initializers and
10090 allocatable components must not be nulled wholesale; instead they
10091 are treated component by component. */
10092 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10094 /* SAVEd variables are not freed on exit. */
10095 gfc_trans_static_array_pointer (sym
);
10097 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10098 gfc_restore_backend_locus (&loc
);
10102 /* Get the descriptor type. */
10103 type
= TREE_TYPE (sym
->backend_decl
);
10105 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10106 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10108 if (!sym
->attr
.save
10109 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10111 if (sym
->value
== NULL
10112 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10114 rank
= sym
->as
? sym
->as
->rank
: 0;
10115 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10117 gfc_add_expr_to_block (&init
, tmp
);
10120 gfc_init_default_dt (sym
, &init
, false);
10123 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10125 /* If the backend_decl is not a descriptor, we must have a pointer
10127 descriptor
= build_fold_indirect_ref_loc (input_location
,
10128 sym
->backend_decl
);
10129 type
= TREE_TYPE (descriptor
);
10132 /* NULLIFY the data pointer, for non-saved allocatables. */
10133 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10135 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10136 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10138 /* Declare the variable static so its array descriptor stays present
10139 after leaving the scope. It may still be accessed through another
10140 image. This may happen, for example, with the caf_mpi
10142 TREE_STATIC (descriptor
) = 1;
10143 tmp
= gfc_conv_descriptor_token (descriptor
);
10144 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10145 null_pointer_node
));
10149 gfc_restore_backend_locus (&loc
);
10150 gfc_init_block (&cleanup
);
10152 /* Allocatable arrays need to be freed when they go out of scope.
10153 The allocatable components of pointers must not be touched. */
10154 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10155 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10156 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10159 sym
->attr
.referenced
= 1;
10160 e
= gfc_lval_expr_from_sym (sym
);
10161 gfc_add_finalizer_call (&cleanup
, e
);
10164 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10165 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10166 && !sym
->attr
.pointer
&& !sym
->attr
.save
10167 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10170 rank
= sym
->as
? sym
->as
->rank
: 0;
10171 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10172 gfc_add_expr_to_block (&cleanup
, tmp
);
10175 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10176 && !sym
->attr
.save
&& !sym
->attr
.result
10177 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10180 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10181 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10182 NULL_TREE
, NULL_TREE
, true, e
,
10183 sym
->attr
.codimension
10184 ? GFC_CAF_COARRAY_DEREGISTER
10185 : GFC_CAF_COARRAY_NOCOARRAY
);
10188 gfc_add_expr_to_block (&cleanup
, tmp
);
10191 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10192 gfc_finish_block (&cleanup
));
10195 /************ Expression Walking Functions ******************/
10197 /* Walk a variable reference.
10199 Possible extension - multiple component subscripts.
10200 x(:,:) = foo%a(:)%b(:)
10202 forall (i=..., j=...)
10203 x(i,j) = foo%a(j)%b(i)
10205 This adds a fair amount of complexity because you need to deal with more
10206 than one ref. Maybe handle in a similar manner to vector subscripts.
10207 Maybe not worth the effort. */
10211 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10215 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10216 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10219 return gfc_walk_array_ref (ss
, expr
, ref
);
10224 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10230 for (; ref
; ref
= ref
->next
)
10232 if (ref
->type
== REF_SUBSTRING
)
10234 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10235 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10238 /* We're only interested in array sections from now on. */
10239 if (ref
->type
!= REF_ARRAY
)
10247 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10248 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10252 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10253 newss
->info
->data
.array
.ref
= ref
;
10255 /* Make sure array is the same as array(:,:), this way
10256 we don't need to special case all the time. */
10257 ar
->dimen
= ar
->as
->rank
;
10258 for (n
= 0; n
< ar
->dimen
; n
++)
10260 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10262 gcc_assert (ar
->start
[n
] == NULL
);
10263 gcc_assert (ar
->end
[n
] == NULL
);
10264 gcc_assert (ar
->stride
[n
] == NULL
);
10270 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10271 newss
->info
->data
.array
.ref
= ref
;
10273 /* We add SS chains for all the subscripts in the section. */
10274 for (n
= 0; n
< ar
->dimen
; n
++)
10278 switch (ar
->dimen_type
[n
])
10280 case DIMEN_ELEMENT
:
10281 /* Add SS for elemental (scalar) subscripts. */
10282 gcc_assert (ar
->start
[n
]);
10283 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10284 indexss
->loop_chain
= gfc_ss_terminator
;
10285 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10289 /* We don't add anything for sections, just remember this
10290 dimension for later. */
10291 newss
->dim
[newss
->dimen
] = n
;
10296 /* Create a GFC_SS_VECTOR index in which we can store
10297 the vector's descriptor. */
10298 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10300 indexss
->loop_chain
= gfc_ss_terminator
;
10301 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10302 newss
->dim
[newss
->dimen
] = n
;
10307 /* We should know what sort of section it is by now. */
10308 gcc_unreachable ();
10311 /* We should have at least one non-elemental dimension,
10312 unless we are creating a descriptor for a (scalar) coarray. */
10313 gcc_assert (newss
->dimen
> 0
10314 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10319 /* We should know what sort of section it is by now. */
10320 gcc_unreachable ();
10328 /* Walk an expression operator. If only one operand of a binary expression is
10329 scalar, we must also add the scalar term to the SS chain. */
10332 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10337 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10338 if (expr
->value
.op
.op2
== NULL
)
10341 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10343 /* All operands are scalar. Pass back and let the caller deal with it. */
10347 /* All operands require scalarization. */
10348 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10351 /* One of the operands needs scalarization, the other is scalar.
10352 Create a gfc_ss for the scalar expression. */
10355 /* First operand is scalar. We build the chain in reverse order, so
10356 add the scalar SS after the second operand. */
10358 while (head
&& head
->next
!= ss
)
10360 /* Check we haven't somehow broken the chain. */
10362 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10364 else /* head2 == head */
10366 gcc_assert (head2
== head
);
10367 /* Second operand is scalar. */
10368 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10375 /* Reverse a SS chain. */
10378 gfc_reverse_ss (gfc_ss
* ss
)
10383 gcc_assert (ss
!= NULL
);
10385 head
= gfc_ss_terminator
;
10386 while (ss
!= gfc_ss_terminator
)
10389 /* Check we didn't somehow break the chain. */
10390 gcc_assert (next
!= NULL
);
10400 /* Given an expression referring to a procedure, return the symbol of its
10401 interface. We can't get the procedure symbol directly as we have to handle
10402 the case of (deferred) type-bound procedures. */
10405 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10410 if (procedure_ref
== NULL
)
10413 /* Normal procedure case. */
10414 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10415 && procedure_ref
->value
.function
.esym
)
10416 sym
= procedure_ref
->value
.function
.esym
;
10418 sym
= procedure_ref
->symtree
->n
.sym
;
10420 /* Typebound procedure case. */
10421 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10423 if (ref
->type
== REF_COMPONENT
10424 && ref
->u
.c
.component
->attr
.proc_pointer
)
10425 sym
= ref
->u
.c
.component
->ts
.interface
;
10434 /* Walk the arguments of an elemental function.
10435 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10436 it is NULL, we don't do the check and the argument is assumed to be present.
10440 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10441 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10443 gfc_formal_arglist
*dummy_arg
;
10449 head
= gfc_ss_terminator
;
10453 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10458 for (; arg
; arg
= arg
->next
)
10460 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10461 goto loop_continue
;
10463 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10466 /* Scalar argument. */
10467 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10468 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10469 newss
->info
->type
= type
;
10471 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10476 if (dummy_arg
!= NULL
10477 && dummy_arg
->sym
->attr
.optional
10478 && arg
->expr
->expr_type
== EXPR_VARIABLE
10479 && (gfc_expr_attr (arg
->expr
).optional
10480 || gfc_expr_attr (arg
->expr
).allocatable
10481 || gfc_expr_attr (arg
->expr
).pointer
))
10482 newss
->info
->can_be_null_ref
= true;
10488 while (tail
->next
!= gfc_ss_terminator
)
10493 if (dummy_arg
!= NULL
)
10494 dummy_arg
= dummy_arg
->next
;
10499 /* If all the arguments are scalar we don't need the argument SS. */
10500 gfc_free_ss_chain (head
);
10501 /* Pass it back. */
10505 /* Add it onto the existing chain. */
10511 /* Walk a function call. Scalar functions are passed back, and taken out of
10512 scalarization loops. For elemental functions we walk their arguments.
10513 The result of functions returning arrays is stored in a temporary outside
10514 the loop, so that the function is only called once. Hence we do not need
10515 to walk their arguments. */
10518 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10520 gfc_intrinsic_sym
*isym
;
10522 gfc_component
*comp
= NULL
;
10524 isym
= expr
->value
.function
.isym
;
10526 /* Handle intrinsic functions separately. */
10528 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10530 sym
= expr
->value
.function
.esym
;
10532 sym
= expr
->symtree
->n
.sym
;
10534 if (gfc_is_class_array_function (expr
))
10535 return gfc_get_array_ss (ss
, expr
,
10536 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10539 /* A function that returns arrays. */
10540 comp
= gfc_get_proc_ptr_comp (expr
);
10541 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10542 || (comp
&& comp
->attr
.dimension
))
10543 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10545 /* Walk the parameters of an elemental function. For now we always pass
10547 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10549 gfc_ss
*old_ss
= ss
;
10551 ss
= gfc_walk_elemental_function_args (old_ss
,
10552 expr
->value
.function
.actual
,
10553 gfc_get_proc_ifc_for_expr (expr
),
10557 || sym
->attr
.proc_pointer
10558 || sym
->attr
.if_source
!= IFSRC_DECL
10559 || sym
->attr
.array_outer_dependency
))
10560 ss
->info
->array_outer_dependency
= 1;
10563 /* Scalar functions are OK as these are evaluated outside the scalarization
10564 loop. Pass back and let the caller deal with it. */
10569 /* An array temporary is constructed for array constructors. */
10572 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10574 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10578 /* Walk an expression. Add walked expressions to the head of the SS chain.
10579 A wholly scalar expression will not be added. */
10582 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10586 switch (expr
->expr_type
)
10588 case EXPR_VARIABLE
:
10589 head
= gfc_walk_variable_expr (ss
, expr
);
10593 head
= gfc_walk_op_expr (ss
, expr
);
10596 case EXPR_FUNCTION
:
10597 head
= gfc_walk_function_expr (ss
, expr
);
10600 case EXPR_CONSTANT
:
10602 case EXPR_STRUCTURE
:
10603 /* Pass back and let the caller deal with it. */
10607 head
= gfc_walk_array_constructor (ss
, expr
);
10610 case EXPR_SUBSTRING
:
10611 /* Pass back and let the caller deal with it. */
10615 gfc_internal_error ("bad expression type during walk (%d)",
10622 /* Entry point for expression walking.
10623 A return value equal to the passed chain means this is
10624 a scalar expression. It is up to the caller to take whatever action is
10625 necessary to translate these. */
10628 gfc_walk_expr (gfc_expr
* expr
)
10632 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10633 return gfc_reverse_ss (res
);