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 gfc_conv_expr (&se
, expr
);
2795 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2796 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2797 ss_info
->string_length
= se
.string_length
;
2800 case GFC_SS_CONSTRUCTOR
:
2801 if (expr
->ts
.type
== BT_CHARACTER
2802 && ss_info
->string_length
== NULL
2804 && expr
->ts
.u
.cl
->length
2805 && expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2807 gfc_init_se (&se
, NULL
);
2808 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2809 gfc_charlen_type_node
);
2810 ss_info
->string_length
= se
.expr
;
2811 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2812 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2814 trans_array_constructor (ss
, where
);
2818 case GFC_SS_COMPONENT
:
2819 /* Do nothing. These are handled elsewhere. */
2828 for (nested_loop
= loop
->nested
; nested_loop
;
2829 nested_loop
= nested_loop
->next
)
2830 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2834 /* Translate expressions for the descriptor and data pointer of a SS. */
2838 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2841 gfc_ss_info
*ss_info
;
2842 gfc_array_info
*info
;
2846 info
= &ss_info
->data
.array
;
2848 /* Get the descriptor for the array to be scalarized. */
2849 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2850 gfc_init_se (&se
, NULL
);
2851 se
.descriptor_only
= 1;
2852 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2853 gfc_add_block_to_block (block
, &se
.pre
);
2854 info
->descriptor
= se
.expr
;
2855 ss_info
->string_length
= se
.string_length
;
2859 if (ss_info
->expr
->ts
.type
== BT_CHARACTER
&& !ss_info
->expr
->ts
.deferred
2860 && ss_info
->expr
->ts
.u
.cl
->length
== NULL
)
2862 /* Emit a DECL_EXPR for the variable sized array type in
2863 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2864 sizes works correctly. */
2865 tree arraytype
= TREE_TYPE (
2866 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info
->descriptor
)));
2867 if (! TYPE_NAME (arraytype
))
2868 TYPE_NAME (arraytype
) = build_decl (UNKNOWN_LOCATION
, TYPE_DECL
,
2869 NULL_TREE
, arraytype
);
2870 gfc_add_expr_to_block (block
, build1 (DECL_EXPR
, arraytype
,
2871 TYPE_NAME (arraytype
)));
2873 /* Also the data pointer. */
2874 tmp
= gfc_conv_array_data (se
.expr
);
2875 /* If this is a variable or address of a variable we use it directly.
2876 Otherwise we must evaluate it now to avoid breaking dependency
2877 analysis by pulling the expressions for elemental array indices
2880 || (TREE_CODE (tmp
) == ADDR_EXPR
2881 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2882 tmp
= gfc_evaluate_now (tmp
, block
);
2885 tmp
= gfc_conv_array_offset (se
.expr
);
2886 info
->offset
= gfc_evaluate_now (tmp
, block
);
2888 /* Make absolutely sure that the saved_offset is indeed saved
2889 so that the variable is still accessible after the loops
2891 info
->saved_offset
= info
->offset
;
2896 /* Initialize a gfc_loopinfo structure. */
2899 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2903 memset (loop
, 0, sizeof (gfc_loopinfo
));
2904 gfc_init_block (&loop
->pre
);
2905 gfc_init_block (&loop
->post
);
2907 /* Initially scalarize in order and default to no loop reversal. */
2908 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2911 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2914 loop
->ss
= gfc_ss_terminator
;
2918 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2922 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2928 /* Return an expression for the data pointer of an array. */
2931 gfc_conv_array_data (tree descriptor
)
2935 type
= TREE_TYPE (descriptor
);
2936 if (GFC_ARRAY_TYPE_P (type
))
2938 if (TREE_CODE (type
) == POINTER_TYPE
)
2942 /* Descriptorless arrays. */
2943 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2947 return gfc_conv_descriptor_data_get (descriptor
);
2951 /* Return an expression for the base offset of an array. */
2954 gfc_conv_array_offset (tree descriptor
)
2958 type
= TREE_TYPE (descriptor
);
2959 if (GFC_ARRAY_TYPE_P (type
))
2960 return GFC_TYPE_ARRAY_OFFSET (type
);
2962 return gfc_conv_descriptor_offset_get (descriptor
);
2966 /* Get an expression for the array stride. */
2969 gfc_conv_array_stride (tree descriptor
, int dim
)
2974 type
= TREE_TYPE (descriptor
);
2976 /* For descriptorless arrays use the array size. */
2977 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2978 if (tmp
!= NULL_TREE
)
2981 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2986 /* Like gfc_conv_array_stride, but for the lower bound. */
2989 gfc_conv_array_lbound (tree descriptor
, int dim
)
2994 type
= TREE_TYPE (descriptor
);
2996 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2997 if (tmp
!= NULL_TREE
)
3000 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
3005 /* Like gfc_conv_array_stride, but for the upper bound. */
3008 gfc_conv_array_ubound (tree descriptor
, int dim
)
3013 type
= TREE_TYPE (descriptor
);
3015 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3016 if (tmp
!= NULL_TREE
)
3019 /* This should only ever happen when passing an assumed shape array
3020 as an actual parameter. The value will never be used. */
3021 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
3022 return gfc_index_zero_node
;
3024 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
3029 /* Generate code to perform an array index bound check. */
3032 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
3033 locus
* where
, bool check_upper
)
3036 tree tmp_lo
, tmp_up
;
3039 const char * name
= NULL
;
3041 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
3044 descriptor
= ss
->info
->data
.array
.descriptor
;
3046 index
= gfc_evaluate_now (index
, &se
->pre
);
3048 /* We find a name for the error message. */
3049 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
3050 gcc_assert (name
!= NULL
);
3052 if (VAR_P (descriptor
))
3053 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
3055 /* If upper bound is present, include both bounds in the error message. */
3058 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3059 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
3062 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3063 "outside of expected range (%%ld:%%ld)", n
+1, name
);
3065 msg
= xasprintf ("Index '%%ld' of dimension %d "
3066 "outside of expected range (%%ld:%%ld)", n
+1);
3068 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3070 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3071 fold_convert (long_integer_type_node
, index
),
3072 fold_convert (long_integer_type_node
, tmp_lo
),
3073 fold_convert (long_integer_type_node
, tmp_up
));
3074 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3076 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3077 fold_convert (long_integer_type_node
, index
),
3078 fold_convert (long_integer_type_node
, tmp_lo
),
3079 fold_convert (long_integer_type_node
, tmp_up
));
3084 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
3087 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3088 "below lower bound of %%ld", n
+1, name
);
3090 msg
= xasprintf ("Index '%%ld' of dimension %d "
3091 "below lower bound of %%ld", n
+1);
3093 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3095 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
3096 fold_convert (long_integer_type_node
, index
),
3097 fold_convert (long_integer_type_node
, tmp_lo
));
3105 /* Return the offset for an index. Performs bound checking for elemental
3106 dimensions. Single element references are processed separately.
3107 DIM is the array dimension, I is the loop dimension. */
3110 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
3111 gfc_array_ref
* ar
, tree stride
)
3113 gfc_array_info
*info
;
3118 info
= &ss
->info
->data
.array
;
3120 /* Get the index into the array for this dimension. */
3123 gcc_assert (ar
->type
!= AR_ELEMENT
);
3124 switch (ar
->dimen_type
[dim
])
3126 case DIMEN_THIS_IMAGE
:
3130 /* Elemental dimension. */
3131 gcc_assert (info
->subscript
[dim
]
3132 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
3133 /* We've already translated this value outside the loop. */
3134 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
3136 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3137 ar
->as
->type
!= AS_ASSUMED_SIZE
3138 || dim
< ar
->dimen
- 1);
3142 gcc_assert (info
&& se
->loop
);
3143 gcc_assert (info
->subscript
[dim
]
3144 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
3145 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
3147 /* Get a zero-based index into the vector. */
3148 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3149 gfc_array_index_type
,
3150 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
3152 /* Multiply the index by the stride. */
3153 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3154 gfc_array_index_type
,
3155 index
, gfc_conv_array_stride (desc
, 0));
3157 /* Read the vector to get an index into info->descriptor. */
3158 data
= build_fold_indirect_ref_loc (input_location
,
3159 gfc_conv_array_data (desc
));
3160 index
= gfc_build_array_ref (data
, index
, NULL
);
3161 index
= gfc_evaluate_now (index
, &se
->pre
);
3162 index
= fold_convert (gfc_array_index_type
, index
);
3164 /* Do any bounds checking on the final info->descriptor index. */
3165 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
3166 ar
->as
->type
!= AS_ASSUMED_SIZE
3167 || dim
< ar
->dimen
- 1);
3171 /* Scalarized dimension. */
3172 gcc_assert (info
&& se
->loop
);
3174 /* Multiply the loop variable by the stride and delta. */
3175 index
= se
->loop
->loopvar
[i
];
3176 if (!integer_onep (info
->stride
[dim
]))
3177 index
= fold_build2_loc (input_location
, MULT_EXPR
,
3178 gfc_array_index_type
, index
,
3180 if (!integer_zerop (info
->delta
[dim
]))
3181 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3182 gfc_array_index_type
, index
,
3192 /* Temporary array or derived type component. */
3193 gcc_assert (se
->loop
);
3194 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
3196 /* Pointer functions can have stride[0] different from unity.
3197 Use the stride returned by the function call and stored in
3198 the descriptor for the temporary. */
3199 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
3200 && se
->ss
->info
->expr
3201 && se
->ss
->info
->expr
->symtree
3202 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
3203 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
3204 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
3207 if (info
->delta
[dim
] && !integer_zerop (info
->delta
[dim
]))
3208 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3209 gfc_array_index_type
, index
, info
->delta
[dim
]);
3212 /* Multiply by the stride. */
3213 if (!integer_onep (stride
))
3214 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3221 /* Build a scalarized array reference using the vptr 'size'. */
3224 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
3229 tree decl
= NULL_TREE
;
3231 gfc_expr
*expr
= se
->ss
->info
->expr
;
3233 gfc_ref
*class_ref
= NULL
;
3236 if (se
->expr
&& DECL_P (se
->expr
) && DECL_LANG_SPECIFIC (se
->expr
)
3237 && GFC_DECL_SAVED_DESCRIPTOR (se
->expr
)
3238 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se
->expr
))))
3243 || (expr
->ts
.type
!= BT_CLASS
3244 && !gfc_is_alloc_class_array_function (expr
)
3245 && !gfc_is_class_array_ref (expr
, NULL
)))
3248 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
3249 ts
= &expr
->symtree
->n
.sym
->ts
;
3253 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3255 if (ref
->type
== REF_COMPONENT
3256 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
3257 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
3258 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
3260 && ref
->next
->next
->type
== REF_ARRAY
3261 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
3263 ts
= &ref
->u
.c
.component
->ts
;
3273 if (class_ref
== NULL
&& expr
&& expr
->symtree
->n
.sym
->attr
.function
3274 && expr
->symtree
->n
.sym
== expr
->symtree
->n
.sym
->result
)
3276 gcc_assert (expr
->symtree
->n
.sym
->backend_decl
== current_function_decl
);
3277 decl
= gfc_get_fake_result_decl (expr
->symtree
->n
.sym
, 0);
3279 else if (expr
&& gfc_is_alloc_class_array_function (expr
))
3283 for (tmp
= base
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
3286 type
= TREE_TYPE (tmp
);
3289 if (GFC_CLASS_TYPE_P (type
))
3291 if (type
!= TYPE_CANONICAL (type
))
3292 type
= TYPE_CANONICAL (type
);
3300 if (decl
== NULL_TREE
)
3303 else if (class_ref
== NULL
)
3305 if (decl
== NULL_TREE
)
3306 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3307 /* For class arrays the tree containing the class is stored in
3308 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3309 For all others it's sym's backend_decl directly. */
3310 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
3311 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
3315 /* Remove everything after the last class reference, convert the
3316 expression and then recover its tailend once more. */
3318 ref
= class_ref
->next
;
3319 class_ref
->next
= NULL
;
3320 gfc_init_se (&tmpse
, NULL
);
3321 gfc_conv_expr (&tmpse
, expr
);
3322 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3324 class_ref
->next
= ref
;
3327 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
3328 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
3330 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
3333 size
= gfc_class_vtab_size_get (decl
);
3335 /* For unlimited polymorphic entities then _len component needs to be
3336 multiplied with the size. If no _len component is present, then
3337 gfc_class_len_or_zero_get () return a zero_node. */
3338 tmp
= gfc_class_len_or_zero_get (decl
);
3339 if (!integer_zerop (tmp
))
3340 size
= fold_build2 (MULT_EXPR
, TREE_TYPE (index
),
3341 fold_convert (TREE_TYPE (index
), size
),
3342 fold_build2 (MAX_EXPR
, TREE_TYPE (index
),
3343 fold_convert (TREE_TYPE (index
), tmp
),
3344 fold_convert (TREE_TYPE (index
),
3345 integer_one_node
)));
3347 size
= fold_convert (TREE_TYPE (index
), size
);
3349 /* Build the address of the element. */
3350 type
= TREE_TYPE (TREE_TYPE (base
));
3351 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3352 gfc_array_index_type
,
3354 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3355 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3356 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3358 /* Return the element in the se expression. */
3359 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3364 /* Build a scalarized reference to an array. */
3367 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3369 gfc_array_info
*info
;
3370 tree decl
= NULL_TREE
;
3378 expr
= ss
->info
->expr
;
3379 info
= &ss
->info
->data
.array
;
3381 n
= se
->loop
->order
[0];
3385 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3386 /* Add the offset for this dimension to the stored offset for all other
3388 if (info
->offset
&& !integer_zerop (info
->offset
))
3389 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3390 index
, info
->offset
);
3392 if (expr
&& ((is_subref_array (expr
)
3393 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info
->descriptor
)))
3394 || (expr
->ts
.deferred
&& (expr
->expr_type
== EXPR_VARIABLE
3395 || expr
->expr_type
== EXPR_FUNCTION
))))
3396 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3398 /* A pointer array component can be detected from its field decl. Fix
3399 the descriptor, mark the resulting variable decl and pass it to
3400 gfc_build_array_ref. */
3401 if (is_pointer_array (info
->descriptor
))
3403 if (TREE_CODE (info
->descriptor
) == COMPONENT_REF
)
3405 decl
= gfc_evaluate_now (info
->descriptor
, &se
->pre
);
3406 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
3407 TREE_USED (decl
) = 1;
3409 else if (TREE_CODE (info
->descriptor
) == INDIRECT_REF
)
3410 decl
= TREE_OPERAND (info
->descriptor
, 0);
3412 if (decl
== NULL_TREE
)
3413 decl
= info
->descriptor
;
3416 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3418 /* Use the vptr 'size' field to access a class the element of a class
3420 if (build_class_array_ref (se
, tmp
, index
))
3423 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3427 /* Translate access of temporary array. */
3430 gfc_conv_tmp_array_ref (gfc_se
* se
)
3432 se
->string_length
= se
->ss
->info
->string_length
;
3433 gfc_conv_scalarized_array_ref (se
, NULL
);
3434 gfc_advance_se_ss_chain (se
);
3437 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3440 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3442 if (TREE_CODE (t
) == INTEGER_CST
)
3443 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3446 if (!integer_zerop (*offset
))
3447 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3448 gfc_array_index_type
, *offset
, t
);
3456 build_array_ref (tree desc
, tree offset
, tree decl
, tree vptr
)
3462 /* For class arrays the class declaration is stored in the saved
3464 if (INDIRECT_REF_P (desc
)
3465 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc
, 0))
3466 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc
, 0)))
3467 cdesc
= gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3468 TREE_OPERAND (desc
, 0)));
3472 /* Class container types do not always have the GFC_CLASS_TYPE_P
3473 but the canonical type does. */
3474 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc
))
3475 && TREE_CODE (cdesc
) == COMPONENT_REF
)
3477 type
= TREE_TYPE (TREE_OPERAND (cdesc
, 0));
3478 if (TYPE_CANONICAL (type
)
3479 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type
)))
3480 vptr
= gfc_class_vptr_get (TREE_OPERAND (cdesc
, 0));
3483 tmp
= gfc_conv_array_data (desc
);
3484 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3485 tmp
= gfc_build_array_ref (tmp
, offset
, decl
, vptr
);
3490 /* Build an array reference. se->expr already holds the array descriptor.
3491 This should be either a variable, indirect variable reference or component
3492 reference. For arrays which do not have a descriptor, se->expr will be
3494 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3497 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_expr
*expr
,
3501 tree offset
, cst_offset
;
3504 tree decl
= NULL_TREE
;
3507 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
3508 char *var_name
= NULL
;
3512 gcc_assert (ar
->codimen
);
3514 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3515 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3518 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3519 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3520 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3522 /* Use the actual tree type and not the wrapped coarray. */
3523 if (!se
->want_pointer
)
3524 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3531 /* Handle scalarized references separately. */
3532 if (ar
->type
!= AR_ELEMENT
)
3534 gfc_conv_scalarized_array_ref (se
, ar
);
3535 gfc_advance_se_ss_chain (se
);
3539 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3544 len
= strlen (sym
->name
) + 1;
3545 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3547 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3549 if (ref
->type
== REF_COMPONENT
)
3550 len
+= 2 + strlen (ref
->u
.c
.component
->name
);
3553 var_name
= XALLOCAVEC (char, len
);
3554 strcpy (var_name
, sym
->name
);
3556 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3558 if (ref
->type
== REF_ARRAY
&& &ref
->u
.ar
== ar
)
3560 if (ref
->type
== REF_COMPONENT
)
3562 strcat (var_name
, "%%");
3563 strcat (var_name
, ref
->u
.c
.component
->name
);
3568 cst_offset
= offset
= gfc_index_zero_node
;
3569 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3571 /* Calculate the offsets from all the dimensions. Make sure to associate
3572 the final offset so that we form a chain of loop invariant summands. */
3573 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3575 /* Calculate the index for this dimension. */
3576 gfc_init_se (&indexse
, se
);
3577 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3578 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3580 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3582 /* Check array bounds. */
3586 /* Evaluate the indexse.expr only once. */
3587 indexse
.expr
= save_expr (indexse
.expr
);
3590 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3591 if (sym
->attr
.temporary
)
3593 gfc_init_se (&tmpse
, se
);
3594 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3595 gfc_array_index_type
);
3596 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3600 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3602 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3603 "below lower bound of %%ld", n
+1, var_name
);
3604 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3605 fold_convert (long_integer_type_node
,
3607 fold_convert (long_integer_type_node
, tmp
));
3610 /* Upper bound, but not for the last dimension of assumed-size
3612 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3614 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3615 if (sym
->attr
.temporary
)
3617 gfc_init_se (&tmpse
, se
);
3618 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3619 gfc_array_index_type
);
3620 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3624 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3625 logical_type_node
, indexse
.expr
, tmp
);
3626 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3627 "above upper bound of %%ld", n
+1, var_name
);
3628 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3629 fold_convert (long_integer_type_node
,
3631 fold_convert (long_integer_type_node
, tmp
));
3636 /* Multiply the index by the stride. */
3637 stride
= gfc_conv_array_stride (se
->expr
, n
);
3638 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3639 indexse
.expr
, stride
);
3641 /* And add it to the total. */
3642 add_to_offset (&cst_offset
, &offset
, tmp
);
3645 if (!integer_zerop (cst_offset
))
3646 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3647 gfc_array_index_type
, offset
, cst_offset
);
3649 /* A pointer array component can be detected from its field decl. Fix
3650 the descriptor, mark the resulting variable decl and pass it to
3652 if (!expr
->ts
.deferred
&& !sym
->attr
.codimension
3653 && is_pointer_array (se
->expr
))
3655 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
3657 decl
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3658 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
3659 TREE_USED (decl
) = 1;
3661 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
3662 decl
= TREE_OPERAND (se
->expr
, 0);
3666 else if (expr
->ts
.deferred
3667 || (sym
->ts
.type
== BT_CHARACTER
3668 && sym
->attr
.select_type_temporary
))
3669 decl
= sym
->backend_decl
;
3670 else if (sym
->ts
.type
== BT_CLASS
)
3673 se
->expr
= build_array_ref (se
->expr
, offset
, decl
, se
->class_vptr
);
3677 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3678 LOOP_DIM dimension (if any) to array's offset. */
3681 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3682 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3685 gfc_array_info
*info
;
3688 info
= &ss
->info
->data
.array
;
3690 gfc_init_se (&se
, NULL
);
3692 se
.expr
= info
->descriptor
;
3693 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3694 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3695 gfc_add_block_to_block (pblock
, &se
.pre
);
3697 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3698 gfc_array_index_type
,
3699 info
->offset
, index
);
3700 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3704 /* Generate the code to be executed immediately before entering a
3705 scalarization loop. */
3708 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3709 stmtblock_t
* pblock
)
3712 gfc_ss_info
*ss_info
;
3713 gfc_array_info
*info
;
3714 gfc_ss_type ss_type
;
3716 gfc_loopinfo
*ploop
;
3720 /* This code will be executed before entering the scalarization loop
3721 for this dimension. */
3722 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3726 if ((ss_info
->useflags
& flag
) == 0)
3729 ss_type
= ss_info
->type
;
3730 if (ss_type
!= GFC_SS_SECTION
3731 && ss_type
!= GFC_SS_FUNCTION
3732 && ss_type
!= GFC_SS_CONSTRUCTOR
3733 && ss_type
!= GFC_SS_COMPONENT
)
3736 info
= &ss_info
->data
.array
;
3738 gcc_assert (dim
< ss
->dimen
);
3739 gcc_assert (ss
->dimen
== loop
->dimen
);
3742 ar
= &info
->ref
->u
.ar
;
3746 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3748 /* If we are in the outermost dimension of this loop, the previous
3749 dimension shall be in the parent loop. */
3750 gcc_assert (ss
->parent
!= NULL
);
3753 ploop
= loop
->parent
;
3755 /* ss and ss->parent are about the same array. */
3756 gcc_assert (ss_info
== pss
->info
);
3764 if (dim
== loop
->dimen
- 1)
3769 /* For the time being, there is no loop reordering. */
3770 gcc_assert (i
== ploop
->order
[i
]);
3771 i
= ploop
->order
[i
];
3773 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3775 stride
= gfc_conv_array_stride (info
->descriptor
,
3776 innermost_ss (ss
)->dim
[i
]);
3778 /* Calculate the stride of the innermost loop. Hopefully this will
3779 allow the backend optimizers to do their stuff more effectively.
3781 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3783 /* For the outermost loop calculate the offset due to any
3784 elemental dimensions. It will have been initialized with the
3785 base offset of the array. */
3788 for (i
= 0; i
< ar
->dimen
; i
++)
3790 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3793 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3798 /* Add the offset for the previous loop dimension. */
3799 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3801 /* Remember this offset for the second loop. */
3802 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3803 info
->saved_offset
= info
->offset
;
3808 /* Start a scalarized expression. Creates a scope and declares loop
3812 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3818 gcc_assert (!loop
->array_parameter
);
3820 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3822 n
= loop
->order
[dim
];
3824 gfc_start_block (&loop
->code
[n
]);
3826 /* Create the loop variable. */
3827 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3829 if (dim
< loop
->temp_dim
)
3833 /* Calculate values that will be constant within this loop. */
3834 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3836 gfc_start_block (pbody
);
3840 /* Generates the actual loop code for a scalarization loop. */
3843 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3844 stmtblock_t
* pbody
)
3855 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
3856 | OMPWS_SCALARIZER_BODY
))
3857 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3858 && n
== loop
->dimen
- 1)
3860 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3861 init
= make_tree_vec (1);
3862 cond
= make_tree_vec (1);
3863 incr
= make_tree_vec (1);
3865 /* Cycle statement is implemented with a goto. Exit statement must not
3866 be present for this loop. */
3867 exit_label
= gfc_build_label_decl (NULL_TREE
);
3868 TREE_USED (exit_label
) = 1;
3870 /* Label for cycle statements (if needed). */
3871 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3872 gfc_add_expr_to_block (pbody
, tmp
);
3874 stmt
= make_node (OMP_FOR
);
3876 TREE_TYPE (stmt
) = void_type_node
;
3877 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3879 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3880 OMP_CLAUSE_SCHEDULE
);
3881 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3882 = OMP_CLAUSE_SCHEDULE_STATIC
;
3883 if (ompws_flags
& OMPWS_NOWAIT
)
3884 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3885 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3887 /* Initialize the loopvar. */
3888 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3890 OMP_FOR_INIT (stmt
) = init
;
3891 /* The exit condition. */
3892 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3894 loop
->loopvar
[n
], loop
->to
[n
]);
3895 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3896 OMP_FOR_COND (stmt
) = cond
;
3897 /* Increment the loopvar. */
3898 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3899 loop
->loopvar
[n
], gfc_index_one_node
);
3900 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3901 void_type_node
, loop
->loopvar
[n
], tmp
);
3902 OMP_FOR_INCR (stmt
) = incr
;
3904 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3905 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3909 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3910 && (loop
->temp_ss
== NULL
);
3912 loopbody
= gfc_finish_block (pbody
);
3915 std::swap (loop
->from
[n
], loop
->to
[n
]);
3917 /* Initialize the loopvar. */
3918 if (loop
->loopvar
[n
] != loop
->from
[n
])
3919 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3921 exit_label
= gfc_build_label_decl (NULL_TREE
);
3923 /* Generate the loop body. */
3924 gfc_init_block (&block
);
3926 /* The exit condition. */
3927 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3928 logical_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3929 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3930 TREE_USED (exit_label
) = 1;
3931 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3932 gfc_add_expr_to_block (&block
, tmp
);
3934 /* The main body. */
3935 gfc_add_expr_to_block (&block
, loopbody
);
3937 /* Increment the loopvar. */
3938 tmp
= fold_build2_loc (input_location
,
3939 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3940 gfc_array_index_type
, loop
->loopvar
[n
],
3941 gfc_index_one_node
);
3943 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3945 /* Build the loop. */
3946 tmp
= gfc_finish_block (&block
);
3947 tmp
= build1_v (LOOP_EXPR
, tmp
);
3948 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3950 /* Add the exit label. */
3951 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3952 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3958 /* Finishes and generates the loops for a scalarized expression. */
3961 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3966 stmtblock_t
*pblock
;
3970 /* Generate the loops. */
3971 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3973 n
= loop
->order
[dim
];
3974 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3975 loop
->loopvar
[n
] = NULL_TREE
;
3976 pblock
= &loop
->code
[n
];
3979 tmp
= gfc_finish_block (pblock
);
3980 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3982 /* Clear all the used flags. */
3983 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3984 if (ss
->parent
== NULL
)
3985 ss
->info
->useflags
= 0;
3989 /* Finish the main body of a scalarized expression, and start the secondary
3993 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3997 stmtblock_t
*pblock
;
4001 /* We finish as many loops as are used by the temporary. */
4002 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
4004 n
= loop
->order
[dim
];
4005 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4006 loop
->loopvar
[n
] = NULL_TREE
;
4007 pblock
= &loop
->code
[n
];
4010 /* We don't want to finish the outermost loop entirely. */
4011 n
= loop
->order
[loop
->temp_dim
- 1];
4012 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
4014 /* Restore the initial offsets. */
4015 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4017 gfc_ss_type ss_type
;
4018 gfc_ss_info
*ss_info
;
4022 if ((ss_info
->useflags
& 2) == 0)
4025 ss_type
= ss_info
->type
;
4026 if (ss_type
!= GFC_SS_SECTION
4027 && ss_type
!= GFC_SS_FUNCTION
4028 && ss_type
!= GFC_SS_CONSTRUCTOR
4029 && ss_type
!= GFC_SS_COMPONENT
)
4032 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
4035 /* Restart all the inner loops we just finished. */
4036 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
4038 n
= loop
->order
[dim
];
4040 gfc_start_block (&loop
->code
[n
]);
4042 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
4044 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
4047 /* Start a block for the secondary copying code. */
4048 gfc_start_block (body
);
4052 /* Precalculate (either lower or upper) bound of an array section.
4053 BLOCK: Block in which the (pre)calculation code will go.
4054 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4055 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4056 DESC: Array descriptor from which the bound will be picked if unspecified
4057 (either lower or upper bound according to LBOUND). */
4060 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
4061 tree desc
, int dim
, bool lbound
, bool deferred
)
4064 gfc_expr
* input_val
= values
[dim
];
4065 tree
*output
= &bounds
[dim
];
4070 /* Specified section bound. */
4071 gfc_init_se (&se
, NULL
);
4072 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
4073 gfc_add_block_to_block (block
, &se
.pre
);
4076 else if (deferred
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
4078 /* The gfc_conv_array_lbound () routine returns a constant zero for
4079 deferred length arrays, which in the scalarizer wreaks havoc, when
4080 copying to a (newly allocated) one-based array.
4081 Keep returning the actual result in sync for both bounds. */
4082 *output
= lbound
? gfc_conv_descriptor_lbound_get (desc
,
4084 gfc_conv_descriptor_ubound_get (desc
,
4089 /* No specific bound specified so use the bound of the array. */
4090 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
4091 gfc_conv_array_ubound (desc
, dim
);
4093 *output
= gfc_evaluate_now (*output
, block
);
4097 /* Calculate the lower bound of an array section. */
4100 gfc_conv_section_startstride (stmtblock_t
* block
, gfc_ss
* ss
, int dim
)
4102 gfc_expr
*stride
= NULL
;
4105 gfc_array_info
*info
;
4108 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
4110 info
= &ss
->info
->data
.array
;
4111 ar
= &info
->ref
->u
.ar
;
4113 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
4115 /* We use a zero-based index to access the vector. */
4116 info
->start
[dim
] = gfc_index_zero_node
;
4117 info
->end
[dim
] = NULL
;
4118 info
->stride
[dim
] = gfc_index_one_node
;
4122 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
4123 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
4124 desc
= info
->descriptor
;
4125 stride
= ar
->stride
[dim
];
4128 /* Calculate the start of the range. For vector subscripts this will
4129 be the range of the vector. */
4130 evaluate_bound (block
, info
->start
, ar
->start
, desc
, dim
, true,
4131 ar
->as
->type
== AS_DEFERRED
);
4133 /* Similarly calculate the end. Although this is not used in the
4134 scalarizer, it is needed when checking bounds and where the end
4135 is an expression with side-effects. */
4136 evaluate_bound (block
, info
->end
, ar
->end
, desc
, dim
, false,
4137 ar
->as
->type
== AS_DEFERRED
);
4140 /* Calculate the stride. */
4142 info
->stride
[dim
] = gfc_index_one_node
;
4145 gfc_init_se (&se
, NULL
);
4146 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
4147 gfc_add_block_to_block (block
, &se
.pre
);
4148 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, block
);
4153 /* Calculates the range start and stride for a SS chain. Also gets the
4154 descriptor and data pointer. The range of vector subscripts is the size
4155 of the vector. Array bounds are also checked. */
4158 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
4165 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4168 /* Determine the rank of the loop. */
4169 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4171 switch (ss
->info
->type
)
4173 case GFC_SS_SECTION
:
4174 case GFC_SS_CONSTRUCTOR
:
4175 case GFC_SS_FUNCTION
:
4176 case GFC_SS_COMPONENT
:
4177 loop
->dimen
= ss
->dimen
;
4180 /* As usual, lbound and ubound are exceptions!. */
4181 case GFC_SS_INTRINSIC
:
4182 switch (ss
->info
->expr
->value
.function
.isym
->id
)
4184 case GFC_ISYM_LBOUND
:
4185 case GFC_ISYM_UBOUND
:
4186 case GFC_ISYM_LCOBOUND
:
4187 case GFC_ISYM_UCOBOUND
:
4188 case GFC_ISYM_THIS_IMAGE
:
4189 loop
->dimen
= ss
->dimen
;
4201 /* We should have determined the rank of the expression by now. If
4202 not, that's bad news. */
4206 /* Loop over all the SS in the chain. */
4207 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4209 gfc_ss_info
*ss_info
;
4210 gfc_array_info
*info
;
4214 expr
= ss_info
->expr
;
4215 info
= &ss_info
->data
.array
;
4217 if (expr
&& expr
->shape
&& !info
->shape
)
4218 info
->shape
= expr
->shape
;
4220 switch (ss_info
->type
)
4222 case GFC_SS_SECTION
:
4223 /* Get the descriptor for the array. If it is a cross loops array,
4224 we got the descriptor already in the outermost loop. */
4225 if (ss
->parent
== NULL
)
4226 gfc_conv_ss_descriptor (&outer_loop
->pre
, ss
,
4227 !loop
->array_parameter
);
4229 for (n
= 0; n
< ss
->dimen
; n
++)
4230 gfc_conv_section_startstride (&outer_loop
->pre
, ss
, ss
->dim
[n
]);
4233 case GFC_SS_INTRINSIC
:
4234 switch (expr
->value
.function
.isym
->id
)
4236 /* Fall through to supply start and stride. */
4237 case GFC_ISYM_LBOUND
:
4238 case GFC_ISYM_UBOUND
:
4242 /* This is the variant without DIM=... */
4243 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
4245 arg
= expr
->value
.function
.actual
->expr
;
4246 if (arg
->rank
== -1)
4251 /* The rank (hence the return value's shape) is unknown,
4252 we have to retrieve it. */
4253 gfc_init_se (&se
, NULL
);
4254 se
.descriptor_only
= 1;
4255 gfc_conv_expr (&se
, arg
);
4256 /* This is a bare variable, so there is no preliminary
4258 gcc_assert (se
.pre
.head
== NULL_TREE
4259 && se
.post
.head
== NULL_TREE
);
4260 rank
= gfc_conv_descriptor_rank (se
.expr
);
4261 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4262 gfc_array_index_type
,
4263 fold_convert (gfc_array_index_type
,
4265 gfc_index_one_node
);
4266 info
->end
[0] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
4267 info
->start
[0] = gfc_index_zero_node
;
4268 info
->stride
[0] = gfc_index_one_node
;
4271 /* Otherwise fall through GFC_SS_FUNCTION. */
4274 case GFC_ISYM_LCOBOUND
:
4275 case GFC_ISYM_UCOBOUND
:
4276 case GFC_ISYM_THIS_IMAGE
:
4284 case GFC_SS_CONSTRUCTOR
:
4285 case GFC_SS_FUNCTION
:
4286 for (n
= 0; n
< ss
->dimen
; n
++)
4288 int dim
= ss
->dim
[n
];
4290 info
->start
[dim
] = gfc_index_zero_node
;
4291 info
->end
[dim
] = gfc_index_zero_node
;
4292 info
->stride
[dim
] = gfc_index_one_node
;
4301 /* The rest is just runtime bound checking. */
4302 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4305 tree lbound
, ubound
;
4307 tree size
[GFC_MAX_DIMENSIONS
];
4308 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
4309 gfc_array_info
*info
;
4313 gfc_start_block (&block
);
4315 for (n
= 0; n
< loop
->dimen
; n
++)
4316 size
[n
] = NULL_TREE
;
4318 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4321 gfc_ss_info
*ss_info
;
4324 const char *expr_name
;
4327 if (ss_info
->type
!= GFC_SS_SECTION
)
4330 /* Catch allocatable lhs in f2003. */
4331 if (flag_realloc_lhs
&& ss
->is_alloc_lhs
)
4334 expr
= ss_info
->expr
;
4335 expr_loc
= &expr
->where
;
4336 expr_name
= expr
->symtree
->name
;
4338 gfc_start_block (&inner
);
4340 /* TODO: range checking for mapped dimensions. */
4341 info
= &ss_info
->data
.array
;
4343 /* This code only checks ranges. Elemental and vector
4344 dimensions are checked later. */
4345 for (n
= 0; n
< loop
->dimen
; n
++)
4350 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4353 if (dim
== info
->ref
->u
.ar
.dimen
- 1
4354 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
4355 check_upper
= false;
4359 /* Zero stride is not allowed. */
4360 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4361 info
->stride
[dim
], gfc_index_zero_node
);
4362 msg
= xasprintf ("Zero stride is not allowed, for dimension %d "
4363 "of array '%s'", dim
+ 1, expr_name
);
4364 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4368 desc
= info
->descriptor
;
4370 /* This is the run-time equivalent of resolve.c's
4371 check_dimension(). The logical is more readable there
4372 than it is here, with all the trees. */
4373 lbound
= gfc_conv_array_lbound (desc
, dim
);
4374 end
= info
->end
[dim
];
4376 ubound
= gfc_conv_array_ubound (desc
, dim
);
4380 /* non_zerosized is true when the selected range is not
4382 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
4383 logical_type_node
, info
->stride
[dim
],
4384 gfc_index_zero_node
);
4385 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4386 info
->start
[dim
], end
);
4387 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4388 logical_type_node
, stride_pos
, tmp
);
4390 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
4392 info
->stride
[dim
], gfc_index_zero_node
);
4393 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
4394 info
->start
[dim
], end
);
4395 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4398 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4400 stride_pos
, stride_neg
);
4402 /* Check the start of the range against the lower and upper
4403 bounds of the array, if the range is not empty.
4404 If upper bound is present, include both bounds in the
4408 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4410 info
->start
[dim
], lbound
);
4411 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4413 non_zerosized
, tmp
);
4414 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
4416 info
->start
[dim
], ubound
);
4417 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4419 non_zerosized
, tmp2
);
4420 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4421 "outside of expected range (%%ld:%%ld)",
4422 dim
+ 1, expr_name
);
4423 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4425 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4426 fold_convert (long_integer_type_node
, lbound
),
4427 fold_convert (long_integer_type_node
, ubound
));
4428 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4430 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4431 fold_convert (long_integer_type_node
, lbound
),
4432 fold_convert (long_integer_type_node
, ubound
));
4437 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4439 info
->start
[dim
], lbound
);
4440 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4441 logical_type_node
, non_zerosized
, tmp
);
4442 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4443 "below lower bound of %%ld",
4444 dim
+ 1, expr_name
);
4445 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4447 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4448 fold_convert (long_integer_type_node
, lbound
));
4452 /* Compute the last element of the range, which is not
4453 necessarily "end" (think 0:5:3, which doesn't contain 5)
4454 and check it against both lower and upper bounds. */
4456 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4457 gfc_array_index_type
, end
,
4459 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4460 gfc_array_index_type
, tmp
,
4462 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4463 gfc_array_index_type
, end
, tmp
);
4464 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4465 logical_type_node
, tmp
, lbound
);
4466 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4467 logical_type_node
, non_zerosized
, tmp2
);
4470 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4471 logical_type_node
, tmp
, ubound
);
4472 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4473 logical_type_node
, non_zerosized
, tmp3
);
4474 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4475 "outside of expected range (%%ld:%%ld)",
4476 dim
+ 1, expr_name
);
4477 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4479 fold_convert (long_integer_type_node
, tmp
),
4480 fold_convert (long_integer_type_node
, ubound
),
4481 fold_convert (long_integer_type_node
, lbound
));
4482 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4484 fold_convert (long_integer_type_node
, tmp
),
4485 fold_convert (long_integer_type_node
, ubound
),
4486 fold_convert (long_integer_type_node
, lbound
));
4491 msg
= xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4492 "below lower bound of %%ld",
4493 dim
+ 1, expr_name
);
4494 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4496 fold_convert (long_integer_type_node
, tmp
),
4497 fold_convert (long_integer_type_node
, lbound
));
4501 /* Check the section sizes match. */
4502 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4503 gfc_array_index_type
, end
,
4505 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4506 gfc_array_index_type
, tmp
,
4508 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4509 gfc_array_index_type
,
4510 gfc_index_one_node
, tmp
);
4511 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4512 gfc_array_index_type
, tmp
,
4513 build_int_cst (gfc_array_index_type
, 0));
4514 /* We remember the size of the first section, and check all the
4515 others against this. */
4518 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4519 logical_type_node
, tmp
, size
[n
]);
4520 msg
= xasprintf ("Array bound mismatch for dimension %d "
4521 "of array '%s' (%%ld/%%ld)",
4522 dim
+ 1, expr_name
);
4524 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4526 fold_convert (long_integer_type_node
, tmp
),
4527 fold_convert (long_integer_type_node
, size
[n
]));
4532 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4535 tmp
= gfc_finish_block (&inner
);
4537 /* For optional arguments, only check bounds if the argument is
4539 if (expr
->symtree
->n
.sym
->attr
.optional
4540 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4541 tmp
= build3_v (COND_EXPR
,
4542 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4543 tmp
, build_empty_stmt (input_location
));
4545 gfc_add_expr_to_block (&block
, tmp
);
4549 tmp
= gfc_finish_block (&block
);
4550 gfc_add_expr_to_block (&outer_loop
->pre
, tmp
);
4553 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4554 gfc_conv_ss_startstride (loop
);
4557 /* Return true if both symbols could refer to the same data object. Does
4558 not take account of aliasing due to equivalence statements. */
4561 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4562 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4564 /* Aliasing isn't possible if the symbols have different base types. */
4565 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4568 /* Pointers can point to other pointers and target objects. */
4570 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4571 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4574 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4575 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4577 if (lsym_target
&& rsym_target
4578 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4579 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4580 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4581 && (!rsym
->attr
.dimension
4582 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4589 /* Return true if the two SS could be aliased, i.e. both point to the same data
4591 /* TODO: resolve aliases based on frontend expressions. */
4594 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4598 gfc_expr
*lexpr
, *rexpr
;
4601 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4603 lexpr
= lss
->info
->expr
;
4604 rexpr
= rss
->info
->expr
;
4606 lsym
= lexpr
->symtree
->n
.sym
;
4607 rsym
= rexpr
->symtree
->n
.sym
;
4609 lsym_pointer
= lsym
->attr
.pointer
;
4610 lsym_target
= lsym
->attr
.target
;
4611 rsym_pointer
= rsym
->attr
.pointer
;
4612 rsym_target
= rsym
->attr
.target
;
4614 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4615 rsym_pointer
, rsym_target
))
4618 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4619 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4622 /* For derived types we must check all the component types. We can ignore
4623 array references as these will have the same base type as the previous
4625 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4627 if (lref
->type
!= REF_COMPONENT
)
4630 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4631 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4633 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4634 rsym_pointer
, rsym_target
))
4637 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4638 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4640 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4645 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4648 if (rref
->type
!= REF_COMPONENT
)
4651 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4652 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4654 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4655 lsym_pointer
, lsym_target
,
4656 rsym_pointer
, rsym_target
))
4659 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4660 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4662 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4663 &rref
->u
.c
.sym
->ts
))
4665 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4666 &rref
->u
.c
.component
->ts
))
4668 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4669 &rref
->u
.c
.component
->ts
))
4675 lsym_pointer
= lsym
->attr
.pointer
;
4676 lsym_target
= lsym
->attr
.target
;
4677 lsym_pointer
= lsym
->attr
.pointer
;
4678 lsym_target
= lsym
->attr
.target
;
4680 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4682 if (rref
->type
!= REF_COMPONENT
)
4685 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4686 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4688 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4689 lsym_pointer
, lsym_target
,
4690 rsym_pointer
, rsym_target
))
4693 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4694 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4696 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4705 /* Resolve array data dependencies. Creates a temporary if required. */
4706 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4710 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4716 gfc_ss_info
*ss_info
;
4717 gfc_expr
*dest_expr
;
4722 loop
->temp_ss
= NULL
;
4723 dest_expr
= dest
->info
->expr
;
4725 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4728 ss_expr
= ss_info
->expr
;
4730 if (ss_info
->array_outer_dependency
)
4736 if (ss_info
->type
!= GFC_SS_SECTION
)
4738 if (flag_realloc_lhs
4739 && dest_expr
!= ss_expr
4740 && gfc_is_reallocatable_lhs (dest_expr
)
4742 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, true);
4744 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4745 if (!nDepend
&& dest_expr
->rank
> 0
4746 && dest_expr
->ts
.type
== BT_CHARACTER
4747 && ss_expr
->expr_type
== EXPR_VARIABLE
)
4749 nDepend
= gfc_check_dependency (dest_expr
, ss_expr
, false);
4751 if (ss_info
->type
== GFC_SS_REFERENCE
4752 && gfc_check_dependency (dest_expr
, ss_expr
, false))
4753 ss_info
->data
.scalar
.needs_temporary
= 1;
4761 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4763 if (gfc_could_be_alias (dest
, ss
)
4764 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4772 lref
= dest_expr
->ref
;
4773 rref
= ss_expr
->ref
;
4775 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4780 for (i
= 0; i
< dest
->dimen
; i
++)
4781 for (j
= 0; j
< ss
->dimen
; j
++)
4783 && dest
->dim
[i
] == ss
->dim
[j
])
4785 /* If we don't access array elements in the same order,
4786 there is a dependency. */
4791 /* TODO : loop shifting. */
4794 /* Mark the dimensions for LOOP SHIFTING */
4795 for (n
= 0; n
< loop
->dimen
; n
++)
4797 int dim
= dest
->data
.info
.dim
[n
];
4799 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4801 else if (! gfc_is_same_range (&lref
->u
.ar
,
4802 &rref
->u
.ar
, dim
, 0))
4806 /* Put all the dimensions with dependencies in the
4809 for (n
= 0; n
< loop
->dimen
; n
++)
4811 gcc_assert (loop
->order
[n
] == n
);
4813 loop
->order
[dim
++] = n
;
4815 for (n
= 0; n
< loop
->dimen
; n
++)
4818 loop
->order
[dim
++] = n
;
4821 gcc_assert (dim
== loop
->dimen
);
4832 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4833 if (GFC_ARRAY_TYPE_P (base_type
)
4834 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4835 base_type
= gfc_get_element_type (base_type
);
4836 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4838 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4841 loop
->temp_ss
= NULL
;
4845 /* Browse through each array's information from the scalarizer and set the loop
4846 bounds according to the "best" one (per dimension), i.e. the one which
4847 provides the most information (constant bounds, shape, etc.). */
4850 set_loop_bounds (gfc_loopinfo
*loop
)
4852 int n
, dim
, spec_dim
;
4853 gfc_array_info
*info
;
4854 gfc_array_info
*specinfo
;
4858 bool dynamic
[GFC_MAX_DIMENSIONS
];
4861 bool nonoptional_arr
;
4863 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
4865 loopspec
= loop
->specloop
;
4868 for (n
= 0; n
< loop
->dimen
; n
++)
4873 /* If there are both optional and nonoptional array arguments, scalarize
4874 over the nonoptional; otherwise, it does not matter as then all
4875 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4877 nonoptional_arr
= false;
4879 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4880 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4881 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4883 nonoptional_arr
= true;
4887 /* We use one SS term, and use that to determine the bounds of the
4888 loop for this dimension. We try to pick the simplest term. */
4889 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4891 gfc_ss_type ss_type
;
4893 ss_type
= ss
->info
->type
;
4894 if (ss_type
== GFC_SS_SCALAR
4895 || ss_type
== GFC_SS_TEMP
4896 || ss_type
== GFC_SS_REFERENCE
4897 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4900 info
= &ss
->info
->data
.array
;
4903 if (loopspec
[n
] != NULL
)
4905 specinfo
= &loopspec
[n
]->info
->data
.array
;
4906 spec_dim
= loopspec
[n
]->dim
[n
];
4910 /* Silence uninitialized warnings. */
4917 gcc_assert (info
->shape
[dim
]);
4918 /* The frontend has worked out the size for us. */
4921 || !integer_zerop (specinfo
->start
[spec_dim
]))
4922 /* Prefer zero-based descriptors if possible. */
4927 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4929 gfc_constructor_base base
;
4930 /* An unknown size constructor will always be rank one.
4931 Higher rank constructors will either have known shape,
4932 or still be wrapped in a call to reshape. */
4933 gcc_assert (loop
->dimen
== 1);
4935 /* Always prefer to use the constructor bounds if the size
4936 can be determined at compile time. Prefer not to otherwise,
4937 since the general case involves realloc, and it's better to
4938 avoid that overhead if possible. */
4939 base
= ss
->info
->expr
->value
.constructor
;
4940 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4941 if (!dynamic
[n
] || !loopspec
[n
])
4946 /* Avoid using an allocatable lhs in an assignment, since
4947 there might be a reallocation coming. */
4948 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4953 /* Criteria for choosing a loop specifier (most important first):
4954 doesn't need realloc
4960 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4962 else if (integer_onep (info
->stride
[dim
])
4963 && !integer_onep (specinfo
->stride
[spec_dim
]))
4965 else if (INTEGER_CST_P (info
->stride
[dim
])
4966 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4968 else if (INTEGER_CST_P (info
->start
[dim
])
4969 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4970 && integer_onep (info
->stride
[dim
])
4971 == integer_onep (specinfo
->stride
[spec_dim
])
4972 && INTEGER_CST_P (info
->stride
[dim
])
4973 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4975 /* We don't work out the upper bound.
4976 else if (INTEGER_CST_P (info->finish[n])
4977 && ! INTEGER_CST_P (specinfo->finish[n]))
4978 loopspec[n] = ss; */
4981 /* We should have found the scalarization loop specifier. If not,
4983 gcc_assert (loopspec
[n
]);
4985 info
= &loopspec
[n
]->info
->data
.array
;
4986 dim
= loopspec
[n
]->dim
[n
];
4988 /* Set the extents of this range. */
4989 cshape
= info
->shape
;
4990 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4991 && INTEGER_CST_P (info
->stride
[dim
]))
4993 loop
->from
[n
] = info
->start
[dim
];
4994 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4995 mpz_sub_ui (i
, i
, 1);
4996 /* To = from + (size - 1) * stride. */
4997 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4998 if (!integer_onep (info
->stride
[dim
]))
4999 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5000 gfc_array_index_type
, tmp
,
5002 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
5003 gfc_array_index_type
,
5004 loop
->from
[n
], tmp
);
5008 loop
->from
[n
] = info
->start
[dim
];
5009 switch (loopspec
[n
]->info
->type
)
5011 case GFC_SS_CONSTRUCTOR
:
5012 /* The upper bound is calculated when we expand the
5014 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5017 case GFC_SS_SECTION
:
5018 /* Use the end expression if it exists and is not constant,
5019 so that it is only evaluated once. */
5020 loop
->to
[n
] = info
->end
[dim
];
5023 case GFC_SS_FUNCTION
:
5024 /* The loop bound will be set when we generate the call. */
5025 gcc_assert (loop
->to
[n
] == NULL_TREE
);
5028 case GFC_SS_INTRINSIC
:
5030 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
5032 /* The {l,u}bound of an assumed rank. */
5033 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
5034 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
5035 && expr
->value
.function
.actual
->next
->expr
== NULL
5036 && expr
->value
.function
.actual
->expr
->rank
== -1);
5038 loop
->to
[n
] = info
->end
[dim
];
5047 /* Transform everything so we have a simple incrementing variable. */
5048 if (integer_onep (info
->stride
[dim
]))
5049 info
->delta
[dim
] = gfc_index_zero_node
;
5052 /* Set the delta for this section. */
5053 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &outer_loop
->pre
);
5054 /* Number of iterations is (end - start + step) / step.
5055 with start = 0, this simplifies to
5057 for (i = 0; i<=last; i++){...}; */
5058 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5059 gfc_array_index_type
, loop
->to
[n
],
5061 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
5062 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
5063 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5064 tmp
, build_int_cst (gfc_array_index_type
, -1));
5065 loop
->to
[n
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5066 /* Make the loop variable start at 0. */
5067 loop
->from
[n
] = gfc_index_zero_node
;
5072 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5073 set_loop_bounds (loop
);
5077 /* Initialize the scalarization loop. Creates the loop variables. Determines
5078 the range of the loop variables. Creates a temporary if required.
5079 Also generates code for scalar expressions which have been
5080 moved outside the loop. */
5083 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
5088 set_loop_bounds (loop
);
5090 /* Add all the scalar code that can be taken out of the loops.
5091 This may include calculating the loop bounds, so do it before
5092 allocating the temporary. */
5093 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
5095 tmp_ss
= loop
->temp_ss
;
5096 /* If we want a temporary then create it. */
5099 gfc_ss_info
*tmp_ss_info
;
5101 tmp_ss_info
= tmp_ss
->info
;
5102 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
5103 gcc_assert (loop
->parent
== NULL
);
5105 /* Make absolutely sure that this is a complete type. */
5106 if (tmp_ss_info
->string_length
)
5107 tmp_ss_info
->data
.temp
.type
5108 = gfc_get_character_type_len_for_eltype
5109 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
5110 tmp_ss_info
->string_length
);
5112 tmp
= tmp_ss_info
->data
.temp
.type
;
5113 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
5114 tmp_ss_info
->type
= GFC_SS_SECTION
;
5116 gcc_assert (tmp_ss
->dimen
!= 0);
5118 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
5119 NULL_TREE
, false, true, false, where
);
5122 /* For array parameters we don't have loop variables, so don't calculate the
5124 if (!loop
->array_parameter
)
5125 gfc_set_delta (loop
);
5129 /* Calculates how to transform from loop variables to array indices for each
5130 array: once loop bounds are chosen, sets the difference (DELTA field) between
5131 loop bounds and array reference bounds, for each array info. */
5134 gfc_set_delta (gfc_loopinfo
*loop
)
5136 gfc_ss
*ss
, **loopspec
;
5137 gfc_array_info
*info
;
5141 gfc_loopinfo
* const outer_loop
= outermost_loop (loop
);
5143 loopspec
= loop
->specloop
;
5145 /* Calculate the translation from loop variables to array indices. */
5146 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
5148 gfc_ss_type ss_type
;
5150 ss_type
= ss
->info
->type
;
5151 if (ss_type
!= GFC_SS_SECTION
5152 && ss_type
!= GFC_SS_COMPONENT
5153 && ss_type
!= GFC_SS_CONSTRUCTOR
)
5156 info
= &ss
->info
->data
.array
;
5158 for (n
= 0; n
< ss
->dimen
; n
++)
5160 /* If we are specifying the range the delta is already set. */
5161 if (loopspec
[n
] != ss
)
5165 /* Calculate the offset relative to the loop variable.
5166 First multiply by the stride. */
5167 tmp
= loop
->from
[n
];
5168 if (!integer_onep (info
->stride
[dim
]))
5169 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5170 gfc_array_index_type
,
5171 tmp
, info
->stride
[dim
]);
5173 /* Then subtract this from our starting value. */
5174 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5175 gfc_array_index_type
,
5176 info
->start
[dim
], tmp
);
5178 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &outer_loop
->pre
);
5183 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
5184 gfc_set_delta (loop
);
5188 /* Calculate the size of a given array dimension from the bounds. This
5189 is simply (ubound - lbound + 1) if this expression is positive
5190 or 0 if it is negative (pick either one if it is zero). Optionally
5191 (if or_expr is present) OR the (expression != 0) condition to it. */
5194 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
5199 /* Calculate (ubound - lbound + 1). */
5200 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5202 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
5203 gfc_index_one_node
);
5205 /* Check whether the size for this dimension is negative. */
5206 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, res
,
5207 gfc_index_zero_node
);
5208 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
5209 gfc_index_zero_node
, res
);
5211 /* Build OR expression. */
5213 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5214 logical_type_node
, *or_expr
, cond
);
5220 /* For an array descriptor, get the total number of elements. This is just
5221 the product of the extents along from_dim to to_dim. */
5224 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
5229 res
= gfc_index_one_node
;
5231 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
5237 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
5238 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
5240 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5241 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5249 /* Full size of an array. */
5252 gfc_conv_descriptor_size (tree desc
, int rank
)
5254 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
5258 /* Size of a coarray for all dimensions but the last. */
5261 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
5263 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
5267 /* Fills in an array descriptor, and returns the size of the array.
5268 The size will be a simple_val, ie a variable or a constant. Also
5269 calculates the offset of the base. The pointer argument overflow,
5270 which should be of integer type, will increase in value if overflow
5271 occurs during the size calculation. Returns the size of the array.
5275 for (n = 0; n < rank; n++)
5277 a.lbound[n] = specified_lower_bound;
5278 offset = offset + a.lbond[n] * stride;
5280 a.ubound[n] = specified_upper_bound;
5281 a.stride[n] = stride;
5282 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5283 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5284 stride = stride * size;
5286 for (n = rank; n < rank+corank; n++)
5287 (Set lcobound/ucobound as above.)
5288 element_size = sizeof (array element);
5291 stride = (size_t) stride;
5292 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5293 stride = stride * element_size;
5299 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
5300 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
5301 stmtblock_t
* descriptor_block
, tree
* overflow
,
5302 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
,
5303 tree expr3_desc
, bool e3_is_array_constr
, gfc_expr
*expr
)
5316 stmtblock_t thenblock
;
5317 stmtblock_t elseblock
;
5322 type
= TREE_TYPE (descriptor
);
5324 stride
= gfc_index_one_node
;
5325 offset
= gfc_index_zero_node
;
5327 /* Set the dtype before the alloc, because registration of coarrays needs
5329 if (expr
->ts
.type
== BT_CHARACTER
5330 && expr
->ts
.deferred
5331 && VAR_P (expr
->ts
.u
.cl
->backend_decl
))
5333 type
= gfc_typenode_for_spec (&expr
->ts
);
5334 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5335 gfc_add_modify (pblock
, tmp
, gfc_get_dtype_rank_type (rank
, type
));
5339 tmp
= gfc_conv_descriptor_dtype (descriptor
);
5340 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (type
));
5343 or_expr
= logical_false_node
;
5345 for (n
= 0; n
< rank
; n
++)
5350 /* We have 3 possibilities for determining the size of the array:
5351 lower == NULL => lbound = 1, ubound = upper[n]
5352 upper[n] = NULL => lbound = 1, ubound = lower[n]
5353 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5356 /* Set lower bound. */
5357 gfc_init_se (&se
, NULL
);
5358 if (expr3_desc
!= NULL_TREE
)
5360 if (e3_is_array_constr
)
5361 /* The lbound of a constant array [] starts at zero, but when
5362 allocating it, the standard expects the array to start at
5364 se
.expr
= gfc_index_one_node
;
5366 se
.expr
= gfc_conv_descriptor_lbound_get (expr3_desc
,
5369 else if (lower
== NULL
)
5370 se
.expr
= gfc_index_one_node
;
5373 gcc_assert (lower
[n
]);
5376 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5377 gfc_add_block_to_block (pblock
, &se
.pre
);
5381 se
.expr
= gfc_index_one_node
;
5385 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5386 gfc_rank_cst
[n
], se
.expr
);
5387 conv_lbound
= se
.expr
;
5389 /* Work out the offset for this component. */
5390 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5392 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5393 gfc_array_index_type
, offset
, tmp
);
5395 /* Set upper bound. */
5396 gfc_init_se (&se
, NULL
);
5397 if (expr3_desc
!= NULL_TREE
)
5399 if (e3_is_array_constr
)
5401 /* The lbound of a constant array [] starts at zero, but when
5402 allocating it, the standard expects the array to start at
5403 one. Therefore fix the upper bound to be
5404 (desc.ubound - desc.lbound)+ 1. */
5405 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5406 gfc_array_index_type
,
5407 gfc_conv_descriptor_ubound_get (
5408 expr3_desc
, gfc_rank_cst
[n
]),
5409 gfc_conv_descriptor_lbound_get (
5410 expr3_desc
, gfc_rank_cst
[n
]));
5411 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5412 gfc_array_index_type
, tmp
,
5413 gfc_index_one_node
);
5414 se
.expr
= gfc_evaluate_now (tmp
, pblock
);
5417 se
.expr
= gfc_conv_descriptor_ubound_get (expr3_desc
,
5422 gcc_assert (ubound
);
5423 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5424 gfc_add_block_to_block (pblock
, &se
.pre
);
5425 if (ubound
->expr_type
== EXPR_FUNCTION
)
5426 se
.expr
= gfc_evaluate_now (se
.expr
, pblock
);
5428 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5429 gfc_rank_cst
[n
], se
.expr
);
5430 conv_ubound
= se
.expr
;
5432 /* Store the stride. */
5433 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
5434 gfc_rank_cst
[n
], stride
);
5436 /* Calculate size and check whether extent is negative. */
5437 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
5438 size
= gfc_evaluate_now (size
, pblock
);
5440 /* Check whether multiplying the stride by the number of
5441 elements in this dimension would overflow. We must also check
5442 whether the current dimension has zero size in order to avoid
5445 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5446 gfc_array_index_type
,
5447 fold_convert (gfc_array_index_type
,
5448 TYPE_MAX_VALUE (gfc_array_index_type
)),
5450 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5451 logical_type_node
, tmp
, stride
),
5452 PRED_FORTRAN_OVERFLOW
);
5453 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5454 integer_one_node
, integer_zero_node
);
5455 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5456 logical_type_node
, size
,
5457 gfc_index_zero_node
),
5458 PRED_FORTRAN_SIZE_ZERO
);
5459 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5460 integer_zero_node
, tmp
);
5461 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5463 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5465 /* Multiply the stride by the number of elements in this dimension. */
5466 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5467 gfc_array_index_type
, stride
, size
);
5468 stride
= gfc_evaluate_now (stride
, pblock
);
5471 for (n
= rank
; n
< rank
+ corank
; n
++)
5475 /* Set lower bound. */
5476 gfc_init_se (&se
, NULL
);
5477 if (lower
== NULL
|| lower
[n
] == NULL
)
5479 gcc_assert (n
== rank
+ corank
- 1);
5480 se
.expr
= gfc_index_one_node
;
5484 if (ubound
|| n
== rank
+ corank
- 1)
5486 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
5487 gfc_add_block_to_block (pblock
, &se
.pre
);
5491 se
.expr
= gfc_index_one_node
;
5495 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
5496 gfc_rank_cst
[n
], se
.expr
);
5498 if (n
< rank
+ corank
- 1)
5500 gfc_init_se (&se
, NULL
);
5501 gcc_assert (ubound
);
5502 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
5503 gfc_add_block_to_block (pblock
, &se
.pre
);
5504 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
5505 gfc_rank_cst
[n
], se
.expr
);
5509 /* The stride is the number of elements in the array, so multiply by the
5510 size of an element to get the total size. Obviously, if there is a
5511 SOURCE expression (expr3) we must use its element size. */
5512 if (expr3_elem_size
!= NULL_TREE
)
5513 tmp
= expr3_elem_size
;
5514 else if (expr3
!= NULL
)
5516 if (expr3
->ts
.type
== BT_CLASS
)
5519 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5520 gfc_add_vptr_component (sz
);
5521 gfc_add_size_component (sz
);
5522 gfc_init_se (&se_sz
, NULL
);
5523 gfc_conv_expr (&se_sz
, sz
);
5529 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5530 tmp
= TYPE_SIZE_UNIT (tmp
);
5534 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5536 /* Convert to size_t. */
5537 element_size
= fold_convert (size_type_node
, tmp
);
5540 return element_size
;
5542 *nelems
= gfc_evaluate_now (stride
, pblock
);
5543 stride
= fold_convert (size_type_node
, stride
);
5545 /* First check for overflow. Since an array of type character can
5546 have zero element_size, we must check for that before
5548 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5550 TYPE_MAX_VALUE (size_type_node
), element_size
);
5551 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5552 logical_type_node
, tmp
, stride
),
5553 PRED_FORTRAN_OVERFLOW
);
5554 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5555 integer_one_node
, integer_zero_node
);
5556 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5557 logical_type_node
, element_size
,
5558 build_int_cst (size_type_node
, 0)),
5559 PRED_FORTRAN_SIZE_ZERO
);
5560 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5561 integer_zero_node
, tmp
);
5562 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5564 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5566 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5567 stride
, element_size
);
5569 if (poffset
!= NULL
)
5571 offset
= gfc_evaluate_now (offset
, pblock
);
5575 if (integer_zerop (or_expr
))
5577 if (integer_onep (or_expr
))
5578 return build_int_cst (size_type_node
, 0);
5580 var
= gfc_create_var (TREE_TYPE (size
), "size");
5581 gfc_start_block (&thenblock
);
5582 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5583 thencase
= gfc_finish_block (&thenblock
);
5585 gfc_start_block (&elseblock
);
5586 gfc_add_modify (&elseblock
, var
, size
);
5587 elsecase
= gfc_finish_block (&elseblock
);
5589 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5590 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5591 gfc_add_expr_to_block (pblock
, tmp
);
5597 /* Retrieve the last ref from the chain. This routine is specific to
5598 gfc_array_allocate ()'s needs. */
5601 retrieve_last_ref (gfc_ref
**ref_in
, gfc_ref
**prev_ref_in
)
5603 gfc_ref
*ref
, *prev_ref
;
5606 /* Prevent warnings for uninitialized variables. */
5607 prev_ref
= *prev_ref_in
;
5608 while (ref
&& ref
->next
!= NULL
)
5610 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5611 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5616 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5620 *prev_ref_in
= prev_ref
;
5624 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5625 the work for an ALLOCATE statement. */
5629 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5630 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5631 tree
*nelems
, gfc_expr
*expr3
, tree e3_arr_desc
,
5632 bool e3_is_array_constr
)
5636 tree offset
= NULL_TREE
;
5637 tree token
= NULL_TREE
;
5640 tree error
= NULL_TREE
;
5641 tree overflow
; /* Boolean storing whether size calculation overflows. */
5642 tree var_overflow
= NULL_TREE
;
5644 tree set_descriptor
;
5645 stmtblock_t set_descriptor_block
;
5646 stmtblock_t elseblock
;
5649 gfc_ref
*ref
, *prev_ref
= NULL
, *coref
;
5650 bool allocatable
, coarray
, dimension
, alloc_w_e3_arr_spec
= false,
5651 non_ulimate_coarray_ptr_comp
;
5655 /* Find the last reference in the chain. */
5656 if (!retrieve_last_ref (&ref
, &prev_ref
))
5659 /* Take the allocatable and coarray properties solely from the expr-ref's
5660 attributes and not from source=-expression. */
5663 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5664 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5665 non_ulimate_coarray_ptr_comp
= false;
5669 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5670 /* Pointer components in coarrayed derived types must be treated
5671 specially in that they are registered without a check if the are
5672 already associated. This does not hold for ultimate coarray
5674 non_ulimate_coarray_ptr_comp
= (prev_ref
->u
.c
.component
->attr
.pointer
5675 && !prev_ref
->u
.c
.component
->attr
.codimension
);
5676 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5679 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5680 a coarray. In this case it does not matter whether we are on this_image
5683 for (coref
= expr
->ref
; coref
; coref
= coref
->next
)
5684 if (coref
->type
== REF_ARRAY
&& coref
->u
.ar
.codimen
> 0)
5691 gcc_assert (coarray
);
5693 if (ref
->u
.ar
.type
== AR_FULL
&& expr3
!= NULL
)
5695 gfc_ref
*old_ref
= ref
;
5696 /* F08:C633: Array shape from expr3. */
5699 /* Find the last reference in the chain. */
5700 if (!retrieve_last_ref (&ref
, &prev_ref
))
5702 if (expr3
->expr_type
== EXPR_FUNCTION
5703 && gfc_expr_attr (expr3
).dimension
)
5708 alloc_w_e3_arr_spec
= true;
5711 /* Figure out the size of the array. */
5712 switch (ref
->u
.ar
.type
)
5718 upper
= ref
->u
.ar
.start
;
5724 lower
= ref
->u
.ar
.start
;
5725 upper
= ref
->u
.ar
.end
;
5729 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
5730 || alloc_w_e3_arr_spec
);
5732 lower
= ref
->u
.ar
.as
->lower
;
5733 upper
= ref
->u
.ar
.as
->upper
;
5741 overflow
= integer_zero_node
;
5743 gfc_init_block (&set_descriptor_block
);
5744 /* Take the corank only from the actual ref and not from the coref. The
5745 later will mislead the generation of the array dimensions for allocatable/
5746 pointer components in derived types. */
5747 size
= gfc_array_init_size (se
->expr
, alloc_w_e3_arr_spec
? expr
->rank
5748 : ref
->u
.ar
.as
->rank
,
5749 coarray
? ref
->u
.ar
.as
->corank
: 0,
5750 &offset
, lower
, upper
,
5751 &se
->pre
, &set_descriptor_block
, &overflow
,
5752 expr3_elem_size
, nelems
, expr3
, e3_arr_desc
,
5753 e3_is_array_constr
, expr
);
5757 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5758 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5760 if (status
== NULL_TREE
)
5762 /* Generate the block of code handling overflow. */
5763 msg
= gfc_build_addr_expr (pchar_type_node
,
5764 gfc_build_localized_cstring_const
5765 ("Integer overflow when calculating the amount of "
5766 "memory to allocate"));
5767 error
= build_call_expr_loc (input_location
,
5768 gfor_fndecl_runtime_error
, 1, msg
);
5772 tree status_type
= TREE_TYPE (status
);
5773 stmtblock_t set_status_block
;
5775 gfc_start_block (&set_status_block
);
5776 gfc_add_modify (&set_status_block
, status
,
5777 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5778 error
= gfc_finish_block (&set_status_block
);
5782 gfc_start_block (&elseblock
);
5784 /* Allocate memory to store the data. */
5785 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5786 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5788 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
5790 pointer
= non_ulimate_coarray_ptr_comp
? se
->expr
5791 : gfc_conv_descriptor_data_get (se
->expr
);
5792 token
= gfc_conv_descriptor_token (se
->expr
);
5793 token
= gfc_build_addr_expr (NULL_TREE
, token
);
5796 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5797 STRIP_NOPS (pointer
);
5799 /* The allocatable variant takes the old pointer as first argument. */
5801 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5802 status
, errmsg
, errlen
, label_finish
, expr
,
5803 coref
!= NULL
? coref
->u
.ar
.as
->corank
: 0);
5804 else if (non_ulimate_coarray_ptr_comp
&& token
)
5805 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5806 gfc_allocate_using_caf_lib (&elseblock
, pointer
, size
, token
, status
,
5808 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
);
5810 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5814 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5815 logical_type_node
, var_overflow
, integer_zero_node
),
5816 PRED_FORTRAN_OVERFLOW
);
5817 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5818 error
, gfc_finish_block (&elseblock
));
5821 tmp
= gfc_finish_block (&elseblock
);
5823 gfc_add_expr_to_block (&se
->pre
, tmp
);
5825 /* Update the array descriptors. */
5827 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5829 /* Pointer arrays need the span field to be set. */
5830 if (is_pointer_array (se
->expr
)
5831 || (expr
->ts
.type
== BT_CLASS
5832 && CLASS_DATA (expr
)->attr
.class_pointer
))
5834 if (expr3
&& expr3_elem_size
!= NULL_TREE
)
5835 tmp
= expr3_elem_size
;
5837 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se
->expr
)));
5838 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5839 gfc_conv_descriptor_span_set (&set_descriptor_block
, se
->expr
, tmp
);
5842 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5843 if (status
!= NULL_TREE
)
5845 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5846 logical_type_node
, status
,
5847 build_int_cst (TREE_TYPE (status
), 0));
5848 gfc_add_expr_to_block (&se
->pre
,
5849 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5852 build_empty_stmt (input_location
)));
5855 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5861 /* Create an array constructor from an initialization expression.
5862 We assume the frontend already did any expansions and conversions. */
5865 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5872 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5874 if (expr
->expr_type
== EXPR_VARIABLE
5875 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5876 && expr
->symtree
->n
.sym
->value
)
5877 expr
= expr
->symtree
->n
.sym
->value
;
5879 switch (expr
->expr_type
)
5882 case EXPR_STRUCTURE
:
5883 /* A single scalar or derived type value. Create an array with all
5884 elements equal to that value. */
5885 gfc_init_se (&se
, NULL
);
5887 if (expr
->expr_type
== EXPR_CONSTANT
)
5888 gfc_conv_constant (&se
, expr
);
5890 gfc_conv_structure (&se
, expr
, 1);
5892 wtmp
= wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) + 1;
5893 /* This will probably eat buckets of memory for large arrays. */
5896 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5902 /* Create a vector of all the elements. */
5903 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5904 c
; c
= gfc_constructor_next (c
))
5908 /* Problems occur when we get something like
5909 integer :: a(lots) = (/(i, i=1, lots)/) */
5910 gfc_fatal_error ("The number of elements in the array "
5911 "constructor at %L requires an increase of "
5912 "the allowed %d upper limit. See "
5913 "%<-fmax-array-constructor%> option",
5914 &expr
->where
, flag_max_array_constructor
);
5917 if (mpz_cmp_si (c
->offset
, 0) != 0)
5918 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5922 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5928 mpz_add (maxval
, c
->offset
, c
->repeat
);
5929 mpz_sub_ui (maxval
, maxval
, 1);
5930 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5931 if (mpz_cmp_si (c
->offset
, 0) != 0)
5933 mpz_add_ui (maxval
, c
->offset
, 1);
5934 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5937 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5939 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5945 gfc_init_se (&se
, NULL
);
5946 switch (c
->expr
->expr_type
)
5949 gfc_conv_constant (&se
, c
->expr
);
5952 case EXPR_STRUCTURE
:
5953 gfc_conv_structure (&se
, c
->expr
, 1);
5957 /* Catch those occasional beasts that do not simplify
5958 for one reason or another, assuming that if they are
5959 standard defying the frontend will catch them. */
5960 gfc_conv_expr (&se
, c
->expr
);
5964 if (range
== NULL_TREE
)
5965 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5968 if (index
!= NULL_TREE
)
5969 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5970 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5976 return gfc_build_null_descriptor (type
);
5982 /* Create a constructor from the list of elements. */
5983 tmp
= build_constructor (type
, v
);
5984 TREE_CONSTANT (tmp
) = 1;
5989 /* Generate code to evaluate non-constant coarray cobounds. */
5992 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5993 const gfc_symbol
*sym
)
6001 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6003 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
6005 /* Evaluate non-constant array bound expressions. */
6006 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6007 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6009 gfc_init_se (&se
, NULL
);
6010 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6011 gfc_add_block_to_block (pblock
, &se
.pre
);
6012 gfc_add_modify (pblock
, lbound
, se
.expr
);
6014 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6015 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6017 gfc_init_se (&se
, NULL
);
6018 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6019 gfc_add_block_to_block (pblock
, &se
.pre
);
6020 gfc_add_modify (pblock
, ubound
, se
.expr
);
6026 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
6027 returns the size (in elements) of the array. */
6030 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
6031 stmtblock_t
* pblock
)
6044 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6046 size
= gfc_index_one_node
;
6047 offset
= gfc_index_zero_node
;
6048 for (dim
= 0; dim
< as
->rank
; dim
++)
6050 /* Evaluate non-constant array bound expressions. */
6051 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
6052 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
6054 gfc_init_se (&se
, NULL
);
6055 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
6056 gfc_add_block_to_block (pblock
, &se
.pre
);
6057 gfc_add_modify (pblock
, lbound
, se
.expr
);
6059 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
6060 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
6062 gfc_init_se (&se
, NULL
);
6063 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
6064 gfc_add_block_to_block (pblock
, &se
.pre
);
6065 gfc_add_modify (pblock
, ubound
, se
.expr
);
6067 /* The offset of this dimension. offset = offset - lbound * stride. */
6068 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6070 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6073 /* The size of this dimension, and the stride of the next. */
6074 if (dim
+ 1 < as
->rank
)
6075 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
6077 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6079 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
6081 /* Calculate stride = size * (ubound + 1 - lbound). */
6082 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6083 gfc_array_index_type
,
6084 gfc_index_one_node
, lbound
);
6085 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6086 gfc_array_index_type
, ubound
, tmp
);
6087 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6088 gfc_array_index_type
, size
, tmp
);
6090 gfc_add_modify (pblock
, stride
, tmp
);
6092 stride
= gfc_evaluate_now (tmp
, pblock
);
6094 /* Make sure that negative size arrays are translated
6095 to being zero size. */
6096 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6097 stride
, gfc_index_zero_node
);
6098 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6099 gfc_array_index_type
, tmp
,
6100 stride
, gfc_index_zero_node
);
6101 gfc_add_modify (pblock
, stride
, tmp
);
6107 gfc_trans_array_cobounds (type
, pblock
, sym
);
6108 gfc_trans_vla_type_sizes (sym
, pblock
);
6115 /* Generate code to initialize/allocate an array variable. */
6118 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
6119 gfc_wrapped_block
* block
)
6123 tree tmp
= NULL_TREE
;
6130 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
6132 /* Do nothing for USEd variables. */
6133 if (sym
->attr
.use_assoc
)
6136 type
= TREE_TYPE (decl
);
6137 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6138 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
6140 gfc_init_block (&init
);
6142 /* Evaluate character string length. */
6143 if (sym
->ts
.type
== BT_CHARACTER
6144 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6146 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6148 gfc_trans_vla_type_sizes (sym
, &init
);
6150 /* Emit a DECL_EXPR for this variable, which will cause the
6151 gimplifier to allocate storage, and all that good stuff. */
6152 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
6153 gfc_add_expr_to_block (&init
, tmp
);
6158 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6162 type
= TREE_TYPE (type
);
6164 gcc_assert (!sym
->attr
.use_assoc
);
6165 gcc_assert (!TREE_STATIC (decl
));
6166 gcc_assert (!sym
->module
);
6168 if (sym
->ts
.type
== BT_CHARACTER
6169 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6170 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6172 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6174 /* Don't actually allocate space for Cray Pointees. */
6175 if (sym
->attr
.cray_pointee
)
6177 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6178 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6180 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6184 if (flag_stack_arrays
)
6186 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
6187 space
= build_decl (sym
->declared_at
.lb
->location
,
6188 VAR_DECL
, create_tmp_var_name ("A"),
6189 TREE_TYPE (TREE_TYPE (decl
)));
6190 gfc_trans_vla_type_sizes (sym
, &init
);
6194 /* The size is the number of elements in the array, so multiply by the
6195 size of an element to get the total size. */
6196 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6197 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6198 size
, fold_convert (gfc_array_index_type
, tmp
));
6200 /* Allocate memory to hold the data. */
6201 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
6202 gfc_add_modify (&init
, decl
, tmp
);
6204 /* Free the temporary. */
6205 tmp
= gfc_call_free (decl
);
6209 /* Set offset of the array. */
6210 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6211 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6213 /* Automatic arrays should not have initializers. */
6214 gcc_assert (!sym
->value
);
6216 inittree
= gfc_finish_block (&init
);
6223 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6224 where also space is located. */
6225 gfc_init_block (&init
);
6226 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6227 TREE_TYPE (space
), space
);
6228 gfc_add_expr_to_block (&init
, tmp
);
6229 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
6230 ADDR_EXPR
, TREE_TYPE (decl
), space
);
6231 gfc_add_modify (&init
, decl
, addr
);
6232 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6235 gfc_add_init_cleanup (block
, inittree
, tmp
);
6239 /* Generate entry and exit code for g77 calling convention arrays. */
6242 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6252 gfc_save_backend_locus (&loc
);
6253 gfc_set_backend_locus (&sym
->declared_at
);
6255 /* Descriptor type. */
6256 parm
= sym
->backend_decl
;
6257 type
= TREE_TYPE (parm
);
6258 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6260 gfc_start_block (&init
);
6262 if (sym
->ts
.type
== BT_CHARACTER
6263 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6264 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6266 /* Evaluate the bounds of the array. */
6267 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
6269 /* Set the offset. */
6270 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6271 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6273 /* Set the pointer itself if we aren't using the parameter directly. */
6274 if (TREE_CODE (parm
) != PARM_DECL
)
6276 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
6277 gfc_add_modify (&init
, parm
, tmp
);
6279 stmt
= gfc_finish_block (&init
);
6281 gfc_restore_backend_locus (&loc
);
6283 /* Add the initialization code to the start of the function. */
6285 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
6287 tmp
= gfc_conv_expr_present (sym
);
6288 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6291 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
6295 /* Modify the descriptor of an array parameter so that it has the
6296 correct lower bound. Also move the upper bound accordingly.
6297 If the array is not packed, it will be copied into a temporary.
6298 For each dimension we set the new lower and upper bounds. Then we copy the
6299 stride and calculate the offset for this dimension. We also work out
6300 what the stride of a packed array would be, and see it the two match.
6301 If the array need repacking, we set the stride to the values we just
6302 calculated, recalculate the offset and copy the array data.
6303 Code is also added to copy the data back at the end of the function.
6307 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
6308 gfc_wrapped_block
* block
)
6315 tree stmtInit
, stmtCleanup
;
6322 tree stride
, stride2
;
6332 bool is_classarray
= IS_CLASS_ARRAY (sym
);
6334 /* Do nothing for pointer and allocatable arrays. */
6335 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
6336 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
6337 || sym
->attr
.allocatable
6338 || (is_classarray
&& CLASS_DATA (sym
)->attr
.allocatable
))
6341 if (!is_classarray
&& sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
6343 gfc_trans_g77_array (sym
, block
);
6348 gfc_save_backend_locus (&loc
);
6349 /* loc.nextc is not set by save_backend_locus but the location routines
6351 if (loc
.nextc
== NULL
)
6352 loc
.nextc
= loc
.lb
->line
;
6353 gfc_set_backend_locus (&sym
->declared_at
);
6355 /* Descriptor type. */
6356 type
= TREE_TYPE (tmpdesc
);
6357 gcc_assert (GFC_ARRAY_TYPE_P (type
));
6358 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6360 /* For a class array the dummy array descriptor is in the _class
6362 dumdesc
= gfc_class_data_get (dumdesc
);
6364 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6365 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
6366 gfc_start_block (&init
);
6368 if (sym
->ts
.type
== BT_CHARACTER
6369 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
6370 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6372 checkparm
= (as
->type
== AS_EXPLICIT
6373 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
6375 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
6376 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
6378 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
6380 /* For non-constant shape arrays we only check if the first dimension
6381 is contiguous. Repacking higher dimensions wouldn't gain us
6382 anything as we still don't know the array stride. */
6383 partial
= gfc_create_var (logical_type_node
, "partial");
6384 TREE_USED (partial
) = 1;
6385 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6386 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
6387 gfc_index_one_node
);
6388 gfc_add_modify (&init
, partial
, tmp
);
6391 partial
= NULL_TREE
;
6393 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6394 here, however I think it does the right thing. */
6397 /* Set the first stride. */
6398 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
6399 stride
= gfc_evaluate_now (stride
, &init
);
6401 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6402 stride
, gfc_index_zero_node
);
6403 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
6404 tmp
, gfc_index_one_node
, stride
);
6405 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
6406 gfc_add_modify (&init
, stride
, tmp
);
6408 /* Allow the user to disable array repacking. */
6409 stmt_unpacked
= NULL_TREE
;
6413 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
6414 /* A library call to repack the array if necessary. */
6415 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6416 stmt_unpacked
= build_call_expr_loc (input_location
,
6417 gfor_fndecl_in_pack
, 1, tmp
);
6419 stride
= gfc_index_one_node
;
6421 if (warn_array_temporaries
)
6422 gfc_warning (OPT_Warray_temporaries
,
6423 "Creating array temporary at %L", &loc
);
6426 /* This is for the case where the array data is used directly without
6427 calling the repack function. */
6428 if (no_repack
|| partial
!= NULL_TREE
)
6429 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
6431 stmt_packed
= NULL_TREE
;
6433 /* Assign the data pointer. */
6434 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6436 /* Don't repack unknown shape arrays when the first stride is 1. */
6437 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
6438 partial
, stmt_packed
, stmt_unpacked
);
6441 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
6442 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
6444 offset
= gfc_index_zero_node
;
6445 size
= gfc_index_one_node
;
6447 /* Evaluate the bounds of the array. */
6448 for (n
= 0; n
< as
->rank
; n
++)
6450 if (checkparm
|| !as
->upper
[n
])
6452 /* Get the bounds of the actual parameter. */
6453 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
6454 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
6458 dubound
= NULL_TREE
;
6459 dlbound
= NULL_TREE
;
6462 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
6463 if (!INTEGER_CST_P (lbound
))
6465 gfc_init_se (&se
, NULL
);
6466 gfc_conv_expr_type (&se
, as
->lower
[n
],
6467 gfc_array_index_type
);
6468 gfc_add_block_to_block (&init
, &se
.pre
);
6469 gfc_add_modify (&init
, lbound
, se
.expr
);
6472 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
6473 /* Set the desired upper bound. */
6476 /* We know what we want the upper bound to be. */
6477 if (!INTEGER_CST_P (ubound
))
6479 gfc_init_se (&se
, NULL
);
6480 gfc_conv_expr_type (&se
, as
->upper
[n
],
6481 gfc_array_index_type
);
6482 gfc_add_block_to_block (&init
, &se
.pre
);
6483 gfc_add_modify (&init
, ubound
, se
.expr
);
6486 /* Check the sizes match. */
6489 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6493 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6494 gfc_array_index_type
, ubound
, lbound
);
6495 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6496 gfc_array_index_type
,
6497 gfc_index_one_node
, temp
);
6498 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
6499 gfc_array_index_type
, dubound
,
6501 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
6502 gfc_array_index_type
,
6503 gfc_index_one_node
, stride2
);
6504 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6505 gfc_array_index_type
, temp
, stride2
);
6506 msg
= xasprintf ("Dimension %d of array '%s' has extent "
6507 "%%ld instead of %%ld", n
+1, sym
->name
);
6509 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
6510 fold_convert (long_integer_type_node
, temp
),
6511 fold_convert (long_integer_type_node
, stride2
));
6518 /* For assumed shape arrays move the upper bound by the same amount
6519 as the lower bound. */
6520 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6521 gfc_array_index_type
, dubound
, dlbound
);
6522 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6523 gfc_array_index_type
, tmp
, lbound
);
6524 gfc_add_modify (&init
, ubound
, tmp
);
6526 /* The offset of this dimension. offset = offset - lbound * stride. */
6527 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6529 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6530 gfc_array_index_type
, offset
, tmp
);
6532 /* The size of this dimension, and the stride of the next. */
6533 if (n
+ 1 < as
->rank
)
6535 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
6537 if (no_repack
|| partial
!= NULL_TREE
)
6539 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
6541 /* Figure out the stride if not a known constant. */
6542 if (!INTEGER_CST_P (stride
))
6545 stmt_packed
= NULL_TREE
;
6548 /* Calculate stride = size * (ubound + 1 - lbound). */
6549 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6550 gfc_array_index_type
,
6551 gfc_index_one_node
, lbound
);
6552 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6553 gfc_array_index_type
, ubound
, tmp
);
6554 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6555 gfc_array_index_type
, size
, tmp
);
6559 /* Assign the stride. */
6560 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6561 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6562 gfc_array_index_type
, partial
,
6563 stmt_unpacked
, stmt_packed
);
6565 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6566 gfc_add_modify (&init
, stride
, tmp
);
6571 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6573 if (stride
&& !INTEGER_CST_P (stride
))
6575 /* Calculate size = stride * (ubound + 1 - lbound). */
6576 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6577 gfc_array_index_type
,
6578 gfc_index_one_node
, lbound
);
6579 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6580 gfc_array_index_type
,
6582 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6583 gfc_array_index_type
,
6584 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6585 gfc_add_modify (&init
, stride
, tmp
);
6590 gfc_trans_array_cobounds (type
, &init
, sym
);
6592 /* Set the offset. */
6593 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
6594 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6596 gfc_trans_vla_type_sizes (sym
, &init
);
6598 stmtInit
= gfc_finish_block (&init
);
6600 /* Only do the entry/initialization code if the arg is present. */
6601 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6602 optional_arg
= (sym
->attr
.optional
6603 || (sym
->ns
->proc_name
->attr
.entry_master
6604 && sym
->attr
.dummy
));
6607 tmp
= gfc_conv_expr_present (sym
);
6608 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6609 build_empty_stmt (input_location
));
6614 stmtCleanup
= NULL_TREE
;
6617 stmtblock_t cleanup
;
6618 gfc_start_block (&cleanup
);
6620 if (sym
->attr
.intent
!= INTENT_IN
)
6622 /* Copy the data back. */
6623 tmp
= build_call_expr_loc (input_location
,
6624 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6625 gfc_add_expr_to_block (&cleanup
, tmp
);
6628 /* Free the temporary. */
6629 tmp
= gfc_call_free (tmpdesc
);
6630 gfc_add_expr_to_block (&cleanup
, tmp
);
6632 stmtCleanup
= gfc_finish_block (&cleanup
);
6634 /* Only do the cleanup if the array was repacked. */
6636 /* For a class array the dummy array descriptor is in the _class
6638 tmp
= gfc_class_data_get (dumdesc
);
6640 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6641 tmp
= gfc_conv_descriptor_data_get (tmp
);
6642 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6644 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6645 build_empty_stmt (input_location
));
6649 tmp
= gfc_conv_expr_present (sym
);
6650 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6651 build_empty_stmt (input_location
));
6655 /* We don't need to free any memory allocated by internal_pack as it will
6656 be freed at the end of the function by pop_context. */
6657 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6659 gfc_restore_backend_locus (&loc
);
6663 /* Calculate the overall offset, including subreferences. */
6665 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6666 bool subref
, gfc_expr
*expr
)
6676 /* If offset is NULL and this is not a subreferenced array, there is
6678 if (offset
== NULL_TREE
)
6681 offset
= gfc_index_zero_node
;
6686 tmp
= build_array_ref (desc
, offset
, NULL
, NULL
);
6688 /* Offset the data pointer for pointer assignments from arrays with
6689 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6692 /* Go past the array reference. */
6693 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6694 if (ref
->type
== REF_ARRAY
&&
6695 ref
->u
.ar
.type
!= AR_ELEMENT
)
6701 /* Calculate the offset for each subsequent subreference. */
6702 for (; ref
; ref
= ref
->next
)
6707 field
= ref
->u
.c
.component
->backend_decl
;
6708 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6709 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6711 tmp
, field
, NULL_TREE
);
6715 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6716 gfc_init_se (&start
, NULL
);
6717 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6718 gfc_add_block_to_block (block
, &start
.pre
);
6719 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6723 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6724 && ref
->u
.ar
.type
== AR_ELEMENT
);
6726 /* TODO - Add bounds checking. */
6727 stride
= gfc_index_one_node
;
6728 index
= gfc_index_zero_node
;
6729 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6734 /* Update the index. */
6735 gfc_init_se (&start
, NULL
);
6736 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6737 itmp
= gfc_evaluate_now (start
.expr
, block
);
6738 gfc_init_se (&start
, NULL
);
6739 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6740 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6741 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6742 gfc_array_index_type
, itmp
, jtmp
);
6743 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6744 gfc_array_index_type
, itmp
, stride
);
6745 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6746 gfc_array_index_type
, itmp
, index
);
6747 index
= gfc_evaluate_now (index
, block
);
6749 /* Update the stride. */
6750 gfc_init_se (&start
, NULL
);
6751 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6752 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6753 gfc_array_index_type
, start
.expr
,
6755 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6756 gfc_array_index_type
,
6757 gfc_index_one_node
, itmp
);
6758 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6759 gfc_array_index_type
, stride
, itmp
);
6760 stride
= gfc_evaluate_now (stride
, block
);
6763 /* Apply the index to obtain the array element. */
6764 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6774 /* Set the target data pointer. */
6775 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6776 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6780 /* gfc_conv_expr_descriptor needs the string length an expression
6781 so that the size of the temporary can be obtained. This is done
6782 by adding up the string lengths of all the elements in the
6783 expression. Function with non-constant expressions have their
6784 string lengths mapped onto the actual arguments using the
6785 interface mapping machinery in trans-expr.c. */
6787 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6789 gfc_interface_mapping mapping
;
6790 gfc_formal_arglist
*formal
;
6791 gfc_actual_arglist
*arg
;
6794 if (expr
->ts
.u
.cl
->length
6795 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6797 if (!expr
->ts
.u
.cl
->backend_decl
)
6798 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6802 switch (expr
->expr_type
)
6805 get_array_charlen (expr
->value
.op
.op1
, se
);
6807 /* For parentheses the expression ts.u.cl is identical. */
6808 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6811 expr
->ts
.u
.cl
->backend_decl
=
6812 gfc_create_var (gfc_charlen_type_node
, "sln");
6814 if (expr
->value
.op
.op2
)
6816 get_array_charlen (expr
->value
.op
.op2
, se
);
6818 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6820 /* Add the string lengths and assign them to the expression
6821 string length backend declaration. */
6822 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6823 fold_build2_loc (input_location
, PLUS_EXPR
,
6824 gfc_charlen_type_node
,
6825 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6826 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6829 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6830 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6834 if (expr
->value
.function
.esym
== NULL
6835 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6837 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6841 /* Map expressions involving the dummy arguments onto the actual
6842 argument expressions. */
6843 gfc_init_interface_mapping (&mapping
);
6844 formal
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
6845 arg
= expr
->value
.function
.actual
;
6847 /* Set se = NULL in the calls to the interface mapping, to suppress any
6849 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6854 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6857 gfc_init_se (&tse
, NULL
);
6859 /* Build the expression for the character length and convert it. */
6860 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6862 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6863 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6864 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6865 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6866 gfc_charlen_type_node
, tse
.expr
,
6867 build_int_cst (gfc_charlen_type_node
, 0));
6868 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6869 gfc_free_interface_mapping (&mapping
);
6873 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6879 /* Helper function to check dimensions. */
6881 transposed_dims (gfc_ss
*ss
)
6885 for (n
= 0; n
< ss
->dimen
; n
++)
6886 if (ss
->dim
[n
] != n
)
6892 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6893 AR_FULL, suitable for the scalarizer. */
6896 walk_coarray (gfc_expr
*e
)
6900 gcc_assert (gfc_get_corank (e
) > 0);
6902 ss
= gfc_walk_expr (e
);
6904 /* Fix scalar coarray. */
6905 if (ss
== gfc_ss_terminator
)
6912 if (ref
->type
== REF_ARRAY
6913 && ref
->u
.ar
.codimen
> 0)
6919 gcc_assert (ref
!= NULL
);
6920 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6921 ref
->u
.ar
.type
= AR_SECTION
;
6922 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
6929 /* Convert an array for passing as an actual argument. Expressions and
6930 vector subscripts are evaluated and stored in a temporary, which is then
6931 passed. For whole arrays the descriptor is passed. For array sections
6932 a modified copy of the descriptor is passed, but using the original data.
6934 This function is also used for array pointer assignments, and there
6937 - se->want_pointer && !se->direct_byref
6938 EXPR is an actual argument. On exit, se->expr contains a
6939 pointer to the array descriptor.
6941 - !se->want_pointer && !se->direct_byref
6942 EXPR is an actual argument to an intrinsic function or the
6943 left-hand side of a pointer assignment. On exit, se->expr
6944 contains the descriptor for EXPR.
6946 - !se->want_pointer && se->direct_byref
6947 EXPR is the right-hand side of a pointer assignment and
6948 se->expr is the descriptor for the previously-evaluated
6949 left-hand side. The function creates an assignment from
6953 The se->force_tmp flag disables the non-copying descriptor optimization
6954 that is used for transpose. It may be used in cases where there is an
6955 alias between the transpose argument and another argument in the same
6959 gfc_conv_expr_descriptor (gfc_se
*se
, gfc_expr
*expr
)
6962 gfc_ss_type ss_type
;
6963 gfc_ss_info
*ss_info
;
6965 gfc_array_info
*info
;
6974 bool subref_array_target
= false;
6975 gfc_expr
*arg
, *ss_expr
;
6977 if (se
->want_coarray
)
6978 ss
= walk_coarray (expr
);
6980 ss
= gfc_walk_expr (expr
);
6982 gcc_assert (ss
!= NULL
);
6983 gcc_assert (ss
!= gfc_ss_terminator
);
6986 ss_type
= ss_info
->type
;
6987 ss_expr
= ss_info
->expr
;
6989 /* Special case: TRANSPOSE which needs no temporary. */
6990 while (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
6991 && NULL
!= (arg
= gfc_get_noncopying_intrinsic_argument (expr
)))
6993 /* This is a call to transpose which has already been handled by the
6994 scalarizer, so that we just need to get its argument's descriptor. */
6995 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6996 expr
= expr
->value
.function
.actual
->expr
;
6999 /* Special case things we know we can pass easily. */
7000 switch (expr
->expr_type
)
7003 /* If we have a linear array section, we can pass it directly.
7004 Otherwise we need to copy it into a temporary. */
7006 gcc_assert (ss_type
== GFC_SS_SECTION
);
7007 gcc_assert (ss_expr
== expr
);
7008 info
= &ss_info
->data
.array
;
7010 /* Get the descriptor for the array. */
7011 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
7012 desc
= info
->descriptor
;
7014 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
7015 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
7016 && !subref_array_target
;
7023 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7025 /* Create a new descriptor if the array doesn't have one. */
7028 else if (info
->ref
->u
.ar
.type
== AR_FULL
|| se
->descriptor_only
)
7030 else if (se
->direct_byref
)
7033 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
7035 if (full
&& !transposed_dims (ss
))
7037 if (se
->direct_byref
&& !se
->byref_noassign
)
7039 /* Copy the descriptor for pointer assignments. */
7040 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
7042 /* Add any offsets from subreferences. */
7043 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
7044 subref_array_target
, expr
);
7046 /* ....and set the span field. */
7047 tmp
= get_array_span (desc
, expr
);
7048 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7050 else if (se
->want_pointer
)
7052 /* We pass full arrays directly. This means that pointers and
7053 allocatable arrays should also work. */
7054 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7061 if (expr
->ts
.type
== BT_CHARACTER
)
7062 se
->string_length
= gfc_get_expr_charlen (expr
);
7064 gfc_free_ss_chain (ss
);
7070 /* A transformational function return value will be a temporary
7071 array descriptor. We still need to go through the scalarizer
7072 to create the descriptor. Elemental functions are handled as
7073 arbitrary expressions, i.e. copy to a temporary. */
7075 if (se
->direct_byref
)
7077 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
7079 /* For pointer assignments pass the descriptor directly. */
7083 gcc_assert (se
->ss
== ss
);
7085 if (!is_pointer_array (se
->expr
))
7087 tmp
= gfc_get_element_type (TREE_TYPE (se
->expr
));
7088 tmp
= fold_convert (gfc_array_index_type
,
7089 size_in_bytes (tmp
));
7090 gfc_conv_descriptor_span_set (&se
->pre
, se
->expr
, tmp
);
7093 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7094 gfc_conv_expr (se
, expr
);
7096 gfc_free_ss_chain (ss
);
7100 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
7102 if (ss_expr
!= expr
)
7103 /* Elemental function. */
7104 gcc_assert ((expr
->value
.function
.esym
!= NULL
7105 && expr
->value
.function
.esym
->attr
.elemental
)
7106 || (expr
->value
.function
.isym
!= NULL
7107 && expr
->value
.function
.isym
->elemental
)
7108 || gfc_inline_intrinsic_function_p (expr
));
7110 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
7113 if (expr
->ts
.type
== BT_CHARACTER
7114 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7115 get_array_charlen (expr
, se
);
7121 /* Transformational function. */
7122 info
= &ss_info
->data
.array
;
7128 /* Constant array constructors don't need a temporary. */
7129 if (ss_type
== GFC_SS_CONSTRUCTOR
7130 && expr
->ts
.type
!= BT_CHARACTER
7131 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
7134 info
= &ss_info
->data
.array
;
7144 /* Something complicated. Copy it into a temporary. */
7150 /* If we are creating a temporary, we don't need to bother about aliases
7155 gfc_init_loopinfo (&loop
);
7157 /* Associate the SS with the loop. */
7158 gfc_add_ss_to_loop (&loop
, ss
);
7160 /* Tell the scalarizer not to bother creating loop variables, etc. */
7162 loop
.array_parameter
= 1;
7164 /* The right-hand side of a pointer assignment mustn't use a temporary. */
7165 gcc_assert (!se
->direct_byref
);
7167 /* Setup the scalarizing loops and bounds. */
7168 gfc_conv_ss_startstride (&loop
);
7172 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
7173 get_array_charlen (expr
, se
);
7175 /* Tell the scalarizer to make a temporary. */
7176 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
7177 ((expr
->ts
.type
== BT_CHARACTER
)
7178 ? expr
->ts
.u
.cl
->backend_decl
7182 se
->string_length
= loop
.temp_ss
->info
->string_length
;
7183 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
7184 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
7187 gfc_conv_loop_setup (&loop
, & expr
->where
);
7191 /* Copy into a temporary and pass that. We don't need to copy the data
7192 back because expressions and vector subscripts must be INTENT_IN. */
7193 /* TODO: Optimize passing function return values. */
7198 /* Start the copying loops. */
7199 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
7200 gfc_mark_ss_chain_used (ss
, 1);
7201 gfc_start_scalarized_body (&loop
, &block
);
7203 /* Copy each data element. */
7204 gfc_init_se (&lse
, NULL
);
7205 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7206 gfc_init_se (&rse
, NULL
);
7207 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7209 lse
.ss
= loop
.temp_ss
;
7212 gfc_conv_scalarized_array_ref (&lse
, NULL
);
7213 if (expr
->ts
.type
== BT_CHARACTER
)
7215 gfc_conv_expr (&rse
, expr
);
7216 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
7217 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7221 gfc_conv_expr_val (&rse
, expr
);
7223 gfc_add_block_to_block (&block
, &rse
.pre
);
7224 gfc_add_block_to_block (&block
, &lse
.pre
);
7226 lse
.string_length
= rse
.string_length
;
7228 deep_copy
= !se
->data_not_needed
7229 && (expr
->expr_type
== EXPR_VARIABLE
7230 || expr
->expr_type
== EXPR_ARRAY
);
7231 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
7233 gfc_add_expr_to_block (&block
, tmp
);
7235 /* Finish the copying loops. */
7236 gfc_trans_scalarizing_loops (&loop
, &block
);
7238 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
7240 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
7242 desc
= info
->descriptor
;
7243 se
->string_length
= ss_info
->string_length
;
7247 /* We pass sections without copying to a temporary. Make a new
7248 descriptor and point it at the section we want. The loop variable
7249 limits will be the limits of the section.
7250 A function may decide to repack the array to speed up access, but
7251 we're not bothered about that here. */
7252 int dim
, ndim
, codim
;
7259 bool onebased
= false, rank_remap
;
7261 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
7262 rank_remap
= ss
->dimen
< ndim
;
7264 if (se
->want_coarray
)
7266 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
7268 codim
= gfc_get_corank (expr
);
7269 for (n
= 0; n
< codim
- 1; n
++)
7271 /* Make sure we are not lost somehow. */
7272 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
7274 /* Make sure the call to gfc_conv_section_startstride won't
7275 generate unnecessary code to calculate stride. */
7276 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
7278 gfc_conv_section_startstride (&loop
.pre
, ss
, n
+ ndim
);
7279 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7280 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
7283 gcc_assert (n
== codim
- 1);
7284 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
7285 info
->descriptor
, n
+ ndim
, true,
7286 ar
->as
->type
== AS_DEFERRED
);
7287 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
7292 /* Set the string_length for a character array. */
7293 if (expr
->ts
.type
== BT_CHARACTER
)
7294 se
->string_length
= gfc_get_expr_charlen (expr
);
7296 /* If we have an array section or are assigning make sure that
7297 the lower bound is 1. References to the full
7298 array should otherwise keep the original bounds. */
7299 if ((!info
->ref
|| info
->ref
->u
.ar
.type
!= AR_FULL
) && !se
->want_pointer
)
7300 for (dim
= 0; dim
< loop
.dimen
; dim
++)
7301 if (!integer_onep (loop
.from
[dim
]))
7303 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7304 gfc_array_index_type
, gfc_index_one_node
,
7306 loop
.to
[dim
] = fold_build2_loc (input_location
, PLUS_EXPR
,
7307 gfc_array_index_type
,
7309 loop
.from
[dim
] = gfc_index_one_node
;
7312 desc
= info
->descriptor
;
7313 if (se
->direct_byref
&& !se
->byref_noassign
)
7315 /* For pointer assignments we fill in the destination.... */
7317 parmtype
= TREE_TYPE (parm
);
7319 /* ....and set the span field. */
7320 tmp
= get_array_span (desc
, expr
);
7321 gfc_conv_descriptor_span_set (&loop
.pre
, parm
, tmp
);
7325 /* Otherwise make a new one. */
7326 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
7327 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
7328 loop
.from
, loop
.to
, 0,
7329 GFC_ARRAY_UNKNOWN
, false);
7330 parm
= gfc_create_var (parmtype
, "parm");
7332 /* When expression is a class object, then add the class' handle to
7334 if (expr
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_VARIABLE
)
7336 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (expr
);
7339 /* class_expr can be NULL, when no _class ref is in expr.
7340 We must not fix this here with a gfc_fix_class_ref (). */
7343 gfc_init_se (&classse
, NULL
);
7344 gfc_conv_expr (&classse
, class_expr
);
7345 gfc_free_expr (class_expr
);
7347 gcc_assert (classse
.pre
.head
== NULL_TREE
7348 && classse
.post
.head
== NULL_TREE
);
7349 gfc_allocate_lang_decl (parm
);
7350 GFC_DECL_SAVED_DESCRIPTOR (parm
) = classse
.expr
;
7355 offset
= gfc_index_zero_node
;
7357 /* The following can be somewhat confusing. We have two
7358 descriptors, a new one and the original array.
7359 {parm, parmtype, dim} refer to the new one.
7360 {desc, type, n, loop} refer to the original, which maybe
7361 a descriptorless array.
7362 The bounds of the scalarization are the bounds of the section.
7363 We don't have to worry about numeric overflows when calculating
7364 the offsets because all elements are within the array data. */
7366 /* Set the dtype. */
7367 tmp
= gfc_conv_descriptor_dtype (parm
);
7368 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
7370 /* Set offset for assignments to pointer only to zero if it is not
7372 if ((se
->direct_byref
|| se
->use_offset
)
7373 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7374 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7375 base
= gfc_index_zero_node
;
7376 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7377 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
7381 for (n
= 0; n
< ndim
; n
++)
7383 stride
= gfc_conv_array_stride (desc
, n
);
7385 /* Work out the offset. */
7387 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7389 gcc_assert (info
->subscript
[n
]
7390 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
7391 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
7395 /* Evaluate and remember the start of the section. */
7396 start
= info
->start
[n
];
7397 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
7400 tmp
= gfc_conv_array_lbound (desc
, n
);
7401 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
7403 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7405 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
7409 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
7411 /* For elemental dimensions, we only need the offset. */
7415 /* Vector subscripts need copying and are handled elsewhere. */
7417 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
7419 /* look for the corresponding scalarizer dimension: dim. */
7420 for (dim
= 0; dim
< ndim
; dim
++)
7421 if (ss
->dim
[dim
] == n
)
7424 /* loop exited early: the DIM being looked for has been found. */
7425 gcc_assert (dim
< ndim
);
7427 /* Set the new lower bound. */
7428 from
= loop
.from
[dim
];
7431 onebased
= integer_onep (from
);
7432 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7433 gfc_rank_cst
[dim
], from
);
7435 /* Set the new upper bound. */
7436 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7437 gfc_rank_cst
[dim
], to
);
7439 /* Multiply the stride by the section stride to get the
7441 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7442 gfc_array_index_type
,
7443 stride
, info
->stride
[n
]);
7445 if ((se
->direct_byref
|| se
->use_offset
)
7446 && ((info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
7447 || (expr
->expr_type
== EXPR_ARRAY
&& se
->use_offset
)))
7449 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
7450 TREE_TYPE (base
), base
, stride
);
7452 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)) || se
->use_offset
)
7455 tmp
= gfc_conv_array_lbound (desc
, n
);
7456 toonebased
= integer_onep (tmp
);
7457 // lb(arr) - from (- start + 1)
7458 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7459 TREE_TYPE (base
), tmp
, from
);
7460 if (onebased
&& toonebased
)
7462 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7463 TREE_TYPE (base
), tmp
, start
);
7464 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7465 TREE_TYPE (base
), tmp
,
7466 gfc_index_one_node
);
7468 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7469 TREE_TYPE (base
), tmp
,
7470 gfc_conv_array_stride (desc
, n
));
7471 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
7472 TREE_TYPE (base
), tmp
, base
);
7475 /* Store the new stride. */
7476 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
7477 gfc_rank_cst
[dim
], stride
);
7480 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
7482 from
= loop
.from
[n
];
7484 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
7485 gfc_rank_cst
[n
], from
);
7486 if (n
< loop
.dimen
+ codim
- 1)
7487 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
7488 gfc_rank_cst
[n
], to
);
7491 if (se
->data_not_needed
)
7492 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
7493 gfc_index_zero_node
);
7495 /* Point the data pointer at the 1st element in the section. */
7496 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
7497 subref_array_target
, expr
);
7499 /* Force the offset to be -1, when the lower bound of the highest
7500 dimension is one and the symbol is present and is not a
7501 pointer/allocatable or associated. */
7502 if (((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7503 && !se
->data_not_needed
)
7504 || (se
->use_offset
&& base
!= NULL_TREE
))
7506 /* Set the offset depending on base. */
7507 tmp
= rank_remap
&& !se
->direct_byref
?
7508 fold_build2_loc (input_location
, PLUS_EXPR
,
7509 gfc_array_index_type
, base
,
7512 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7514 else if (IS_CLASS_ARRAY (expr
) && !se
->data_not_needed
7515 && (!rank_remap
|| se
->use_offset
)
7516 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7518 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
,
7519 gfc_conv_descriptor_offset_get (desc
));
7521 else if (onebased
&& (!rank_remap
|| se
->use_offset
)
7523 && !(expr
->symtree
->n
.sym
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7524 && !CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.class_pointer
)
7525 && !expr
->symtree
->n
.sym
->attr
.allocatable
7526 && !expr
->symtree
->n
.sym
->attr
.pointer
7527 && !expr
->symtree
->n
.sym
->attr
.host_assoc
7528 && !expr
->symtree
->n
.sym
->attr
.use_assoc
)
7530 /* Set the offset to -1. */
7532 mpz_init_set_si (minus_one
, -1);
7533 tmp
= gfc_conv_mpz_to_tree (minus_one
, gfc_index_integer_kind
);
7534 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, tmp
);
7538 /* Only the callee knows what the correct offset it, so just set
7540 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
7545 /* For class arrays add the class tree into the saved descriptor to
7546 enable getting of _vptr and the like. */
7547 if (expr
->expr_type
== EXPR_VARIABLE
&& VAR_P (desc
)
7548 && IS_CLASS_ARRAY (expr
->symtree
->n
.sym
))
7550 gfc_allocate_lang_decl (desc
);
7551 GFC_DECL_SAVED_DESCRIPTOR (desc
) =
7552 DECL_LANG_SPECIFIC (expr
->symtree
->n
.sym
->backend_decl
) ?
7553 GFC_DECL_SAVED_DESCRIPTOR (expr
->symtree
->n
.sym
->backend_decl
)
7554 : expr
->symtree
->n
.sym
->backend_decl
;
7556 else if (expr
->expr_type
== EXPR_ARRAY
&& VAR_P (desc
)
7557 && IS_CLASS_ARRAY (expr
))
7560 gfc_allocate_lang_decl (desc
);
7561 tmp
= gfc_create_var (expr
->ts
.u
.derived
->backend_decl
, "class");
7562 GFC_DECL_SAVED_DESCRIPTOR (desc
) = tmp
;
7563 vtype
= gfc_class_vptr_get (tmp
);
7564 gfc_add_modify (&se
->pre
, vtype
,
7565 gfc_build_addr_expr (TREE_TYPE (vtype
),
7566 gfc_find_vtab (&expr
->ts
)->backend_decl
));
7568 if (!se
->direct_byref
|| se
->byref_noassign
)
7570 /* Get a pointer to the new descriptor. */
7571 if (se
->want_pointer
)
7572 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
7577 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
7578 gfc_add_block_to_block (&se
->post
, &loop
.post
);
7580 /* Cleanup the scalarizer. */
7581 gfc_cleanup_loop (&loop
);
7584 /* Helper function for gfc_conv_array_parameter if array size needs to be
7588 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
7591 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
7592 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
7593 else if (expr
->rank
> 1)
7594 *size
= build_call_expr_loc (input_location
,
7595 gfor_fndecl_size0
, 1,
7596 gfc_build_addr_expr (NULL
, desc
));
7599 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
7600 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
7602 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
7603 gfc_array_index_type
, ubound
, lbound
);
7604 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7605 *size
, gfc_index_one_node
);
7606 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7607 *size
, gfc_index_zero_node
);
7609 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
7610 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7611 *size
, fold_convert (gfc_array_index_type
, elem
));
7614 /* Convert an array for passing as an actual parameter. */
7615 /* TODO: Optimize passing g77 arrays. */
7618 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, bool g77
,
7619 const gfc_symbol
*fsym
, const char *proc_name
,
7624 tree tmp
= NULL_TREE
;
7626 tree parent
= DECL_CONTEXT (current_function_decl
);
7627 bool full_array_var
;
7628 bool this_array_result
;
7631 bool array_constructor
;
7632 bool good_allocatable
;
7633 bool ultimate_ptr_comp
;
7634 bool ultimate_alloc_comp
;
7639 ultimate_ptr_comp
= false;
7640 ultimate_alloc_comp
= false;
7642 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7644 if (ref
->next
== NULL
)
7647 if (ref
->type
== REF_COMPONENT
)
7649 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
7650 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
7654 full_array_var
= false;
7657 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
7658 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
7660 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
7662 /* The symbol should have an array specification. */
7663 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
7665 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
7667 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
7668 expr
->ts
.u
.cl
->backend_decl
= tmp
;
7669 se
->string_length
= tmp
;
7672 /* Is this the result of the enclosing procedure? */
7673 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
7674 if (this_array_result
7675 && (sym
->backend_decl
!= current_function_decl
)
7676 && (sym
->backend_decl
!= parent
))
7677 this_array_result
= false;
7679 /* Passing address of the array if it is not pointer or assumed-shape. */
7680 if (full_array_var
&& g77
&& !this_array_result
7681 && sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
7683 tmp
= gfc_get_symbol_decl (sym
);
7685 if (sym
->ts
.type
== BT_CHARACTER
)
7686 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7688 if (!sym
->attr
.pointer
7690 && sym
->as
->type
!= AS_ASSUMED_SHAPE
7691 && sym
->as
->type
!= AS_DEFERRED
7692 && sym
->as
->type
!= AS_ASSUMED_RANK
7693 && !sym
->attr
.allocatable
)
7695 /* Some variables are declared directly, others are declared as
7696 pointers and allocated on the heap. */
7697 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
7700 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7702 array_parameter_size (tmp
, expr
, size
);
7706 if (sym
->attr
.allocatable
)
7708 if (sym
->attr
.dummy
|| sym
->attr
.result
)
7710 gfc_conv_expr_descriptor (se
, expr
);
7714 array_parameter_size (tmp
, expr
, size
);
7715 se
->expr
= gfc_conv_array_data (tmp
);
7720 /* A convenient reduction in scope. */
7721 contiguous
= g77
&& !this_array_result
&& contiguous
;
7723 /* There is no need to pack and unpack the array, if it is contiguous
7724 and not a deferred- or assumed-shape array, or if it is simply
7726 no_pack
= ((sym
&& sym
->as
7727 && !sym
->attr
.pointer
7728 && sym
->as
->type
!= AS_DEFERRED
7729 && sym
->as
->type
!= AS_ASSUMED_RANK
7730 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7732 (ref
&& ref
->u
.ar
.as
7733 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7734 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7735 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7737 gfc_is_simply_contiguous (expr
, false, true));
7739 no_pack
= contiguous
&& no_pack
;
7741 /* Array constructors are always contiguous and do not need packing. */
7742 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7744 /* Same is true of contiguous sections from allocatable variables. */
7745 good_allocatable
= contiguous
7747 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7749 /* Or ultimate allocatable components. */
7750 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7752 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7754 gfc_conv_expr_descriptor (se
, expr
);
7755 /* Deallocate the allocatable components of structures that are
7757 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7758 && expr
->ts
.u
.derived
->attr
.alloc_comp
7759 && expr
->expr_type
!= EXPR_VARIABLE
)
7761 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
->expr
, expr
->rank
);
7763 /* The components shall be deallocated before their containing entity. */
7764 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7766 if (expr
->ts
.type
== BT_CHARACTER
)
7767 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7769 array_parameter_size (se
->expr
, expr
, size
);
7770 se
->expr
= gfc_conv_array_data (se
->expr
);
7774 if (this_array_result
)
7776 /* Result of the enclosing function. */
7777 gfc_conv_expr_descriptor (se
, expr
);
7779 array_parameter_size (se
->expr
, expr
, size
);
7780 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7782 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7783 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7784 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7791 /* Every other type of array. */
7792 se
->want_pointer
= 1;
7793 gfc_conv_expr_descriptor (se
, expr
);
7796 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7801 /* Deallocate the allocatable components of structures that are
7802 not variable, for descriptorless arguments.
7803 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7804 if (g77
&& (expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7805 && expr
->ts
.u
.derived
->attr
.alloc_comp
7806 && expr
->expr_type
!= EXPR_VARIABLE
)
7808 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7809 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7811 /* The components shall be deallocated before their containing entity. */
7812 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7815 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7816 && !gfc_is_simply_contiguous (expr
, false, true)))
7818 tree origptr
= NULL_TREE
;
7822 /* For contiguous arrays, save the original value of the descriptor. */
7825 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7826 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7827 tmp
= gfc_conv_array_data (tmp
);
7828 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7829 TREE_TYPE (origptr
), origptr
,
7830 fold_convert (TREE_TYPE (origptr
), tmp
));
7831 gfc_add_expr_to_block (&se
->pre
, tmp
);
7834 /* Repack the array. */
7835 if (warn_array_temporaries
)
7838 gfc_warning (OPT_Warray_temporaries
,
7839 "Creating array temporary at %L for argument %qs",
7840 &expr
->where
, fsym
->name
);
7842 gfc_warning (OPT_Warray_temporaries
,
7843 "Creating array temporary at %L", &expr
->where
);
7846 ptr
= build_call_expr_loc (input_location
,
7847 gfor_fndecl_in_pack
, 1, desc
);
7849 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7851 tmp
= gfc_conv_expr_present (sym
);
7852 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7853 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7854 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7857 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7859 /* Use the packed data for the actual argument, except for contiguous arrays,
7860 where the descriptor's data component is set. */
7865 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7867 gfc_ss
* ss
= gfc_walk_expr (expr
);
7868 if (!transposed_dims (ss
))
7869 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7872 tree old_field
, new_field
;
7874 /* The original descriptor has transposed dims so we can't reuse
7875 it directly; we have to create a new one. */
7876 tree old_desc
= tmp
;
7877 tree new_desc
= gfc_create_var (TREE_TYPE (old_desc
), "arg_desc");
7879 old_field
= gfc_conv_descriptor_dtype (old_desc
);
7880 new_field
= gfc_conv_descriptor_dtype (new_desc
);
7881 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7883 old_field
= gfc_conv_descriptor_offset (old_desc
);
7884 new_field
= gfc_conv_descriptor_offset (new_desc
);
7885 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7887 for (int i
= 0; i
< expr
->rank
; i
++)
7889 old_field
= gfc_conv_descriptor_dimension (old_desc
,
7890 gfc_rank_cst
[get_array_ref_dim_for_loop_dim (ss
, i
)]);
7891 new_field
= gfc_conv_descriptor_dimension (new_desc
,
7893 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7896 if (flag_coarray
== GFC_FCOARRAY_LIB
7897 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc
))
7898 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc
))
7899 == GFC_ARRAY_ALLOCATABLE
)
7901 old_field
= gfc_conv_descriptor_token (old_desc
);
7902 new_field
= gfc_conv_descriptor_token (new_desc
);
7903 gfc_add_modify (&se
->pre
, new_field
, old_field
);
7906 gfc_conv_descriptor_data_set (&se
->pre
, new_desc
, ptr
);
7907 se
->expr
= gfc_build_addr_expr (NULL_TREE
, new_desc
);
7912 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7916 if (fsym
&& proc_name
)
7917 msg
= xasprintf ("An array temporary was created for argument "
7918 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7920 msg
= xasprintf ("An array temporary was created");
7922 tmp
= build_fold_indirect_ref_loc (input_location
,
7924 tmp
= gfc_conv_array_data (tmp
);
7925 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7926 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7928 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7929 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7931 gfc_conv_expr_present (sym
), tmp
);
7933 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7938 gfc_start_block (&block
);
7940 /* Copy the data back. */
7941 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7943 tmp
= build_call_expr_loc (input_location
,
7944 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7945 gfc_add_expr_to_block (&block
, tmp
);
7948 /* Free the temporary. */
7949 tmp
= gfc_call_free (ptr
);
7950 gfc_add_expr_to_block (&block
, tmp
);
7952 stmt
= gfc_finish_block (&block
);
7954 gfc_init_block (&block
);
7955 /* Only if it was repacked. This code needs to be executed before the
7956 loop cleanup code. */
7957 tmp
= build_fold_indirect_ref_loc (input_location
,
7959 tmp
= gfc_conv_array_data (tmp
);
7960 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7961 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7963 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7964 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7966 gfc_conv_expr_present (sym
), tmp
);
7968 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7970 gfc_add_expr_to_block (&block
, tmp
);
7971 gfc_add_block_to_block (&block
, &se
->post
);
7973 gfc_init_block (&se
->post
);
7975 /* Reset the descriptor pointer. */
7978 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7979 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7982 gfc_add_block_to_block (&se
->post
, &block
);
7987 /* This helper function calculates the size in words of a full array. */
7990 gfc_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7995 idx
= gfc_rank_cst
[rank
- 1];
7996 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7997 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7998 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8000 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8001 tmp
, gfc_index_one_node
);
8002 tmp
= gfc_evaluate_now (tmp
, block
);
8004 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
8005 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8007 return gfc_evaluate_now (tmp
, block
);
8011 /* Allocate dest to the same size as src, and copy src -> dest.
8012 If no_malloc is set, only the copy is done. */
8015 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8016 bool no_malloc
, bool no_memcpy
, tree str_sz
,
8017 tree add_when_allocated
)
8026 /* If the source is null, set the destination to null. Then,
8027 allocate memory to the destination. */
8028 gfc_init_block (&block
);
8030 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8032 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8033 null_data
= gfc_finish_block (&block
);
8035 gfc_init_block (&block
);
8036 if (str_sz
!= NULL_TREE
)
8039 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8043 tmp
= gfc_call_malloc (&block
, type
, size
);
8044 gfc_add_modify (&block
, dest
, fold_convert (type
, tmp
));
8049 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8050 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8051 fold_convert (size_type_node
, size
));
8052 gfc_add_expr_to_block (&block
, tmp
);
8057 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8058 null_data
= gfc_finish_block (&block
);
8060 gfc_init_block (&block
);
8062 nelems
= gfc_full_array_size (&block
, src
, rank
);
8064 nelems
= gfc_index_one_node
;
8066 if (str_sz
!= NULL_TREE
)
8067 tmp
= fold_convert (gfc_array_index_type
, str_sz
);
8069 tmp
= fold_convert (gfc_array_index_type
,
8070 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8071 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8075 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
8076 tmp
= gfc_call_malloc (&block
, tmp
, size
);
8077 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
8080 /* We know the temporary and the value will be the same length,
8081 so can use memcpy. */
8084 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8085 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8086 gfc_conv_descriptor_data_get (dest
),
8087 gfc_conv_descriptor_data_get (src
),
8088 fold_convert (size_type_node
, size
));
8089 gfc_add_expr_to_block (&block
, tmp
);
8093 gfc_add_expr_to_block (&block
, add_when_allocated
);
8094 tmp
= gfc_finish_block (&block
);
8096 /* Null the destination if the source is null; otherwise do
8097 the allocate and copy. */
8098 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8101 null_cond
= gfc_conv_descriptor_data_get (src
);
8103 null_cond
= convert (pvoid_type_node
, null_cond
);
8104 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8105 null_cond
, null_pointer_node
);
8106 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
8110 /* Allocate dest to the same size as src, and copy data src -> dest. */
8113 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
8114 tree add_when_allocated
)
8116 return duplicate_allocatable (dest
, src
, type
, rank
, false, false,
8117 NULL_TREE
, add_when_allocated
);
8121 /* Copy data src -> dest. */
8124 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
8126 return duplicate_allocatable (dest
, src
, type
, rank
, true, false,
8127 NULL_TREE
, NULL_TREE
);
8130 /* Allocate dest to the same size as src, but don't copy anything. */
8133 gfc_duplicate_allocatable_nocopy (tree dest
, tree src
, tree type
, int rank
)
8135 return duplicate_allocatable (dest
, src
, type
, rank
, false, true,
8136 NULL_TREE
, NULL_TREE
);
8141 duplicate_allocatable_coarray (tree dest
, tree dest_tok
, tree src
,
8142 tree type
, int rank
)
8149 stmtblock_t block
, globalblock
;
8151 /* If the source is null, set the destination to null. Then,
8152 allocate memory to the destination. */
8153 gfc_init_block (&block
);
8154 gfc_init_block (&globalblock
);
8156 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8159 symbol_attribute attr
;
8162 gfc_init_se (&se
, NULL
);
8163 gfc_clear_attr (&attr
);
8164 attr
.allocatable
= 1;
8165 dummy_desc
= gfc_conv_scalar_to_descriptor (&se
, dest
, attr
);
8166 gfc_add_block_to_block (&globalblock
, &se
.pre
);
8167 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
8169 gfc_add_modify (&block
, dest
, fold_convert (type
, null_pointer_node
));
8170 gfc_allocate_using_caf_lib (&block
, dummy_desc
, size
,
8171 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8172 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8173 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8174 null_data
= gfc_finish_block (&block
);
8176 gfc_init_block (&block
);
8178 gfc_allocate_using_caf_lib (&block
, dummy_desc
,
8179 fold_convert (size_type_node
, size
),
8180 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8181 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8182 GFC_CAF_COARRAY_ALLOC
);
8184 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8185 tmp
= build_call_expr_loc (input_location
, tmp
, 3, dest
, src
,
8186 fold_convert (size_type_node
, size
));
8187 gfc_add_expr_to_block (&block
, tmp
);
8191 /* Set the rank or unitialized memory access may be reported. */
8192 tmp
= gfc_conv_descriptor_dtype (dest
);
8193 gfc_add_modify (&globalblock
, tmp
, build_int_cst (TREE_TYPE (tmp
), rank
));
8196 nelems
= gfc_full_array_size (&block
, src
, rank
);
8198 nelems
= integer_one_node
;
8200 tmp
= fold_convert (size_type_node
,
8201 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
8202 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
8203 fold_convert (size_type_node
, nelems
), tmp
);
8205 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8206 gfc_allocate_using_caf_lib (&block
, dest
, fold_convert (size_type_node
,
8208 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8209 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8210 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8211 null_data
= gfc_finish_block (&block
);
8213 gfc_init_block (&block
);
8214 gfc_allocate_using_caf_lib (&block
, dest
,
8215 fold_convert (size_type_node
, size
),
8216 gfc_build_addr_expr (NULL_TREE
, dest_tok
),
8217 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8218 GFC_CAF_COARRAY_ALLOC
);
8220 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
8221 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
8222 gfc_conv_descriptor_data_get (dest
),
8223 gfc_conv_descriptor_data_get (src
),
8224 fold_convert (size_type_node
, size
));
8225 gfc_add_expr_to_block (&block
, tmp
);
8228 tmp
= gfc_finish_block (&block
);
8230 /* Null the destination if the source is null; otherwise do
8231 the register and copy. */
8232 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src
)))
8235 null_cond
= gfc_conv_descriptor_data_get (src
);
8237 null_cond
= convert (pvoid_type_node
, null_cond
);
8238 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8239 null_cond
, null_pointer_node
);
8240 gfc_add_expr_to_block (&globalblock
, build3_v (COND_EXPR
, null_cond
, tmp
,
8242 return gfc_finish_block (&globalblock
);
8246 /* Helper function to abstract whether coarray processing is enabled. */
8249 caf_enabled (int caf_mode
)
8251 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
)
8252 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
;
8256 /* Helper function to abstract whether coarray processing is enabled
8257 and we are in a derived type coarray. */
8260 caf_in_coarray (int caf_mode
)
8262 static const int pat
= GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8263 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
;
8264 return (caf_mode
& pat
) == pat
;
8268 /* Helper function to abstract whether coarray is to deallocate only. */
8271 gfc_caf_is_dealloc_only (int caf_mode
)
8273 return (caf_mode
& GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
)
8274 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
;
8278 /* Recursively traverse an object of derived type, generating code to
8279 deallocate, nullify or copy allocatable components. This is the work horse
8280 function for the functions named in this enum. */
8282 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
,
8283 COPY_ALLOC_COMP
, COPY_ONLY_ALLOC_COMP
, REASSIGN_CAF_COMP
,
8284 ALLOCATE_PDT_COMP
, DEALLOCATE_PDT_COMP
, CHECK_PDT_DUMMY
};
8286 static gfc_actual_arglist
*pdt_param_list
;
8289 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
8290 tree dest
, int rank
, int purpose
, int caf_mode
)
8294 stmtblock_t fnblock
;
8295 stmtblock_t loopbody
;
8296 stmtblock_t tmpblock
;
8307 tree null_cond
= NULL_TREE
;
8308 tree add_when_allocated
;
8309 tree dealloc_fndecl
;
8313 symbol_attribute
*attr
;
8314 bool deallocate_called
;
8316 gfc_init_block (&fnblock
);
8318 decl_type
= TREE_TYPE (decl
);
8320 if ((POINTER_TYPE_P (decl_type
))
8321 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
8323 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
8324 /* Deref dest in sync with decl, but only when it is not NULL. */
8326 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
8328 /* Update the decl_type because it got dereferenced. */
8329 decl_type
= TREE_TYPE (decl
);
8332 /* If this is an array of derived types with allocatable components
8333 build a loop and recursively call this function. */
8334 if (TREE_CODE (decl_type
) == ARRAY_TYPE
8335 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
8337 tmp
= gfc_conv_array_data (decl
);
8338 var
= build_fold_indirect_ref_loc (input_location
, tmp
);
8340 /* Get the number of elements - 1 and set the counter. */
8341 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
8343 /* Use the descriptor for an allocatable array. Since this
8344 is a full array reference, we only need the descriptor
8345 information from dimension = rank. */
8346 tmp
= gfc_full_array_size (&fnblock
, decl
, rank
);
8347 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8348 gfc_array_index_type
, tmp
,
8349 gfc_index_one_node
);
8351 null_cond
= gfc_conv_descriptor_data_get (decl
);
8352 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8353 logical_type_node
, null_cond
,
8354 build_int_cst (TREE_TYPE (null_cond
), 0));
8358 /* Otherwise use the TYPE_DOMAIN information. */
8359 tmp
= array_type_nelts (decl_type
);
8360 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8363 /* Remember that this is, in fact, the no. of elements - 1. */
8364 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
8365 index
= gfc_create_var (gfc_array_index_type
, "S");
8367 /* Build the body of the loop. */
8368 gfc_init_block (&loopbody
);
8370 vref
= gfc_build_array_ref (var
, index
, NULL
);
8372 if ((purpose
== COPY_ALLOC_COMP
|| purpose
== COPY_ONLY_ALLOC_COMP
)
8373 && !caf_enabled (caf_mode
))
8375 tmp
= build_fold_indirect_ref_loc (input_location
,
8376 gfc_conv_array_data (dest
));
8377 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
8378 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
8379 COPY_ALLOC_COMP
, 0);
8382 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
,
8385 gfc_add_expr_to_block (&loopbody
, tmp
);
8387 /* Build the loop and return. */
8388 gfc_init_loopinfo (&loop
);
8390 loop
.from
[0] = gfc_index_zero_node
;
8391 loop
.loopvar
[0] = index
;
8392 loop
.to
[0] = nelems
;
8393 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
8394 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
8396 tmp
= gfc_finish_block (&fnblock
);
8397 /* When copying allocateable components, the above implements the
8398 deep copy. Nevertheless is a deep copy only allowed, when the current
8399 component is allocated, for which code will be generated in
8400 gfc_duplicate_allocatable (), where the deep copy code is just added
8401 into the if's body, by adding tmp (the deep copy code) as last
8402 argument to gfc_duplicate_allocatable (). */
8403 if (purpose
== COPY_ALLOC_COMP
8404 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
8405 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
,
8407 else if (null_cond
!= NULL_TREE
)
8408 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
8409 build_empty_stmt (input_location
));
8414 if (purpose
== DEALLOCATE_ALLOC_COMP
&& der_type
->attr
.pdt_type
)
8416 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8417 DEALLOCATE_PDT_COMP
, 0);
8418 gfc_add_expr_to_block (&fnblock
, tmp
);
8420 else if (purpose
== ALLOCATE_PDT_COMP
&& der_type
->attr
.alloc_comp
)
8422 tmp
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
8423 NULLIFY_ALLOC_COMP
, 0);
8424 gfc_add_expr_to_block (&fnblock
, tmp
);
8427 /* Otherwise, act on the components or recursively call self to
8428 act on a chain of components. */
8429 for (c
= der_type
->components
; c
; c
= c
->next
)
8431 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
8432 || c
->ts
.type
== BT_CLASS
)
8433 && c
->ts
.u
.derived
->attr
.alloc_comp
;
8434 bool same_type
= (c
->ts
.type
== BT_DERIVED
&& der_type
== c
->ts
.u
.derived
)
8435 || (c
->ts
.type
== BT_CLASS
&& der_type
== CLASS_DATA (c
)->ts
.u
.derived
);
8437 cdecl = c
->backend_decl
;
8438 ctype
= TREE_TYPE (cdecl);
8442 case DEALLOCATE_ALLOC_COMP
:
8444 gfc_init_block (&tmpblock
);
8446 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8447 decl
, cdecl, NULL_TREE
);
8449 /* Shortcut to get the attributes of the component. */
8450 if (c
->ts
.type
== BT_CLASS
)
8452 attr
= &CLASS_DATA (c
)->attr
;
8453 if (attr
->class_pointer
)
8463 if ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8464 || (c
->ts
.type
== BT_CLASS
&& !CLASS_DATA (c
)->attr
.class_pointer
))
8465 /* Call the finalizer, which will free the memory and nullify the
8466 pointer of an array. */
8467 deallocate_called
= gfc_add_comp_finalizer_call (&tmpblock
, comp
, c
,
8468 caf_enabled (caf_mode
))
8471 deallocate_called
= false;
8473 /* Add the _class ref for classes. */
8474 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
)
8475 comp
= gfc_class_data_get (comp
);
8477 add_when_allocated
= NULL_TREE
;
8478 if (cmp_has_alloc_comps
8479 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
8481 && !deallocate_called
)
8483 /* Add checked deallocation of the components. This code is
8484 obviously added because the finalizer is not trusted to free
8486 if (c
->ts
.type
== BT_CLASS
)
8488 rank
= CLASS_DATA (c
)->as
? CLASS_DATA (c
)->as
->rank
: 0;
8490 = structure_alloc_comps (CLASS_DATA (c
)->ts
.u
.derived
,
8491 comp
, NULL_TREE
, rank
, purpose
,
8496 rank
= c
->as
? c
->as
->rank
: 0;
8497 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8504 if (attr
->allocatable
&& !same_type
8505 && (!attr
->codimension
|| caf_enabled (caf_mode
)))
8507 /* Handle all types of components besides components of the
8508 same_type as the current one, because those would create an
8511 = (caf_in_coarray (caf_mode
) || attr
->codimension
)
8512 ? (gfc_caf_is_dealloc_only (caf_mode
)
8513 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8514 : GFC_CAF_COARRAY_DEREGISTER
)
8515 : GFC_CAF_COARRAY_NOCOARRAY
;
8517 caf_token
= NULL_TREE
;
8518 /* Coarray components are handled directly by
8519 deallocate_with_status. */
8520 if (!attr
->codimension
8521 && caf_dereg_mode
!= GFC_CAF_COARRAY_NOCOARRAY
)
8524 caf_token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8525 TREE_TYPE (c
->caf_token
),
8526 decl
, c
->caf_token
, NULL_TREE
);
8527 else if (attr
->dimension
&& !attr
->proc_pointer
)
8528 caf_token
= gfc_conv_descriptor_token (comp
);
8530 if (attr
->dimension
&& !attr
->codimension
&& !attr
->proc_pointer
)
8531 /* When this is an array but not in conjunction with a coarray
8532 then add the data-ref. For coarray'ed arrays the data-ref
8533 is added by deallocate_with_status. */
8534 comp
= gfc_conv_descriptor_data_get (comp
);
8536 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, NULL_TREE
,
8537 NULL_TREE
, NULL_TREE
, true,
8538 NULL
, caf_dereg_mode
,
8539 add_when_allocated
, caf_token
);
8541 gfc_add_expr_to_block (&tmpblock
, tmp
);
8543 else if (attr
->allocatable
&& !attr
->codimension
8544 && !deallocate_called
)
8546 /* Case of recursive allocatable derived types. */
8550 stmtblock_t dealloc_block
;
8552 gfc_init_block (&dealloc_block
);
8553 if (add_when_allocated
)
8554 gfc_add_expr_to_block (&dealloc_block
, add_when_allocated
);
8556 /* Convert the component into a rank 1 descriptor type. */
8557 if (attr
->dimension
)
8559 tmp
= gfc_get_element_type (TREE_TYPE (comp
));
8560 ubound
= gfc_full_array_size (&dealloc_block
, comp
,
8561 c
->ts
.type
== BT_CLASS
8562 ? CLASS_DATA (c
)->as
->rank
8567 tmp
= TREE_TYPE (comp
);
8568 ubound
= build_int_cst (gfc_array_index_type
, 1);
8571 cdesc
= gfc_get_array_type_bounds (tmp
, 1, 0, &gfc_index_one_node
,
8573 GFC_ARRAY_ALLOCATABLE
, false);
8575 cdesc
= gfc_create_var (cdesc
, "cdesc");
8576 DECL_ARTIFICIAL (cdesc
) = 1;
8578 gfc_add_modify (&dealloc_block
, gfc_conv_descriptor_dtype (cdesc
),
8579 gfc_get_dtype_rank_type (1, tmp
));
8580 gfc_conv_descriptor_lbound_set (&dealloc_block
, cdesc
,
8581 gfc_index_zero_node
,
8582 gfc_index_one_node
);
8583 gfc_conv_descriptor_stride_set (&dealloc_block
, cdesc
,
8584 gfc_index_zero_node
,
8585 gfc_index_one_node
);
8586 gfc_conv_descriptor_ubound_set (&dealloc_block
, cdesc
,
8587 gfc_index_zero_node
, ubound
);
8589 if (attr
->dimension
)
8590 comp
= gfc_conv_descriptor_data_get (comp
);
8592 gfc_conv_descriptor_data_set (&dealloc_block
, cdesc
, comp
);
8594 /* Now call the deallocator. */
8595 vtab
= gfc_find_vtab (&c
->ts
);
8596 if (vtab
->backend_decl
== NULL
)
8597 gfc_get_symbol_decl (vtab
);
8598 tmp
= gfc_build_addr_expr (NULL_TREE
, vtab
->backend_decl
);
8599 dealloc_fndecl
= gfc_vptr_deallocate_get (tmp
);
8600 dealloc_fndecl
= build_fold_indirect_ref_loc (input_location
,
8602 tmp
= build_int_cst (TREE_TYPE (comp
), 0);
8603 is_allocated
= fold_build2_loc (input_location
, NE_EXPR
,
8604 logical_type_node
, tmp
,
8606 cdesc
= gfc_build_addr_expr (NULL_TREE
, cdesc
);
8608 tmp
= build_call_expr_loc (input_location
,
8611 gfc_add_expr_to_block (&dealloc_block
, tmp
);
8613 tmp
= gfc_finish_block (&dealloc_block
);
8615 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
8616 void_type_node
, is_allocated
, tmp
,
8617 build_empty_stmt (input_location
));
8619 gfc_add_expr_to_block (&tmpblock
, tmp
);
8621 else if (add_when_allocated
)
8622 gfc_add_expr_to_block (&tmpblock
, add_when_allocated
);
8624 if (c
->ts
.type
== BT_CLASS
&& attr
->allocatable
8625 && (!attr
->codimension
|| !caf_enabled (caf_mode
)))
8627 /* Finally, reset the vptr to the declared type vtable and, if
8628 necessary reset the _len field.
8630 First recover the reference to the component and obtain
8632 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8633 decl
, cdecl, NULL_TREE
);
8634 tmp
= gfc_class_vptr_get (comp
);
8636 if (UNLIMITED_POLY (c
))
8638 /* Both vptr and _len field should be nulled. */
8639 gfc_add_modify (&tmpblock
, tmp
,
8640 build_int_cst (TREE_TYPE (tmp
), 0));
8641 tmp
= gfc_class_len_get (comp
);
8642 gfc_add_modify (&tmpblock
, tmp
,
8643 build_int_cst (TREE_TYPE (tmp
), 0));
8647 /* Build the vtable address and set the vptr with it. */
8650 vtable
= gfc_find_derived_vtab (c
->ts
.u
.derived
);
8651 vtab
= vtable
->backend_decl
;
8652 if (vtab
== NULL_TREE
)
8653 vtab
= gfc_get_symbol_decl (vtable
);
8654 vtab
= gfc_build_addr_expr (NULL
, vtab
);
8655 vtab
= fold_convert (TREE_TYPE (tmp
), vtab
);
8656 gfc_add_modify (&tmpblock
, tmp
, vtab
);
8660 /* Now add the deallocation of this component. */
8661 gfc_add_block_to_block (&fnblock
, &tmpblock
);
8664 case NULLIFY_ALLOC_COMP
:
8666 - allocatable components (regular or in class)
8667 - components that have allocatable components
8668 - pointer components when in a coarray.
8669 Skip everything else especially proc_pointers, which may come
8670 coupled with the regular pointer attribute. */
8671 if (c
->attr
.proc_pointer
8672 || !(c
->attr
.allocatable
|| (c
->ts
.type
== BT_CLASS
8673 && CLASS_DATA (c
)->attr
.allocatable
)
8674 || (cmp_has_alloc_comps
8675 && ((c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
)
8676 || (c
->ts
.type
== BT_CLASS
8677 && !CLASS_DATA (c
)->attr
.class_pointer
)))
8678 || (caf_in_coarray (caf_mode
) && c
->attr
.pointer
)))
8681 /* Process class components first, because they always have the
8682 pointer-attribute set which would be caught wrong else. */
8683 if (c
->ts
.type
== BT_CLASS
8684 && (CLASS_DATA (c
)->attr
.allocatable
8685 || CLASS_DATA (c
)->attr
.class_pointer
))
8687 /* Allocatable CLASS components. */
8688 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8689 decl
, cdecl, NULL_TREE
);
8691 comp
= gfc_class_data_get (comp
);
8692 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)))
8693 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8697 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8698 void_type_node
, comp
,
8699 build_int_cst (TREE_TYPE (comp
), 0));
8700 gfc_add_expr_to_block (&fnblock
, tmp
);
8702 cmp_has_alloc_comps
= false;
8704 /* Coarrays need the component to be nulled before the api-call
8706 else if (c
->attr
.pointer
|| c
->attr
.allocatable
)
8708 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8709 decl
, cdecl, NULL_TREE
);
8710 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8711 gfc_conv_descriptor_data_set (&fnblock
, comp
,
8714 gfc_add_modify (&fnblock
, comp
,
8715 build_int_cst (TREE_TYPE (comp
), 0));
8716 if (gfc_deferred_strlen (c
, &comp
))
8718 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8720 decl
, comp
, NULL_TREE
);
8721 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8722 TREE_TYPE (comp
), comp
,
8723 build_int_cst (TREE_TYPE (comp
), 0));
8724 gfc_add_expr_to_block (&fnblock
, tmp
);
8726 cmp_has_alloc_comps
= false;
8729 if (flag_coarray
== GFC_FCOARRAY_LIB
8730 && (caf_in_coarray (caf_mode
) || c
->attr
.codimension
))
8732 /* Register the component with the coarray library. */
8735 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8736 decl
, cdecl, NULL_TREE
);
8737 if (c
->attr
.dimension
|| c
->attr
.codimension
)
8739 /* Set the dtype, because caf_register needs it. */
8740 gfc_add_modify (&fnblock
, gfc_conv_descriptor_dtype (comp
),
8741 gfc_get_dtype (TREE_TYPE (comp
)));
8742 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8743 decl
, cdecl, NULL_TREE
);
8744 token
= gfc_conv_descriptor_token (tmp
);
8750 gfc_init_se (&se
, NULL
);
8751 token
= fold_build3_loc (input_location
, COMPONENT_REF
,
8752 pvoid_type_node
, decl
, c
->caf_token
,
8754 comp
= gfc_conv_scalar_to_descriptor (&se
, comp
,
8755 c
->ts
.type
== BT_CLASS
8756 ? CLASS_DATA (c
)->attr
8758 gfc_add_block_to_block (&fnblock
, &se
.pre
);
8761 gfc_allocate_using_caf_lib (&fnblock
, comp
, size_zero_node
,
8762 gfc_build_addr_expr (NULL_TREE
,
8764 NULL_TREE
, NULL_TREE
, NULL_TREE
,
8765 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
);
8768 if (cmp_has_alloc_comps
)
8770 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8771 decl
, cdecl, NULL_TREE
);
8772 rank
= c
->as
? c
->as
->rank
: 0;
8773 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
8774 rank
, purpose
, caf_mode
);
8775 gfc_add_expr_to_block (&fnblock
, tmp
);
8779 case REASSIGN_CAF_COMP
:
8780 if (caf_enabled (caf_mode
)
8781 && (c
->attr
.codimension
8782 || (c
->ts
.type
== BT_CLASS
8783 && (CLASS_DATA (c
)->attr
.coarray_comp
8784 || caf_in_coarray (caf_mode
)))
8785 || (c
->ts
.type
== BT_DERIVED
8786 && (c
->ts
.u
.derived
->attr
.coarray_comp
8787 || caf_in_coarray (caf_mode
))))
8790 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8791 decl
, cdecl, NULL_TREE
);
8792 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8793 dest
, cdecl, NULL_TREE
);
8795 if (c
->attr
.codimension
)
8797 if (c
->ts
.type
== BT_CLASS
)
8799 comp
= gfc_class_data_get (comp
);
8800 dcmp
= gfc_class_data_get (dcmp
);
8802 gfc_conv_descriptor_data_set (&fnblock
, dcmp
,
8803 gfc_conv_descriptor_data_get (comp
));
8807 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
8808 rank
, purpose
, caf_mode
8809 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
8810 gfc_add_expr_to_block (&fnblock
, tmp
);
8815 case COPY_ALLOC_COMP
:
8816 if (c
->attr
.pointer
)
8819 /* We need source and destination components. */
8820 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
8822 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
8824 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
8826 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
8834 dst_data
= gfc_class_data_get (dcmp
);
8835 src_data
= gfc_class_data_get (comp
);
8836 size
= fold_convert (size_type_node
,
8837 gfc_class_vtab_size_get (comp
));
8839 if (CLASS_DATA (c
)->attr
.dimension
)
8841 nelems
= gfc_conv_descriptor_size (src_data
,
8842 CLASS_DATA (c
)->as
->rank
);
8843 size
= fold_build2_loc (input_location
, MULT_EXPR
,
8844 size_type_node
, size
,
8845 fold_convert (size_type_node
,
8849 nelems
= build_int_cst (size_type_node
, 1);
8851 if (CLASS_DATA (c
)->attr
.dimension
8852 || CLASS_DATA (c
)->attr
.codimension
)
8854 src_data
= gfc_conv_descriptor_data_get (src_data
);
8855 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
8858 gfc_init_block (&tmpblock
);
8860 /* Coarray component have to have the same allocation status and
8861 shape/type-parameter/effective-type on the LHS and RHS of an
8862 intrinsic assignment. Hence, we did not deallocated them - and
8863 do not allocate them here. */
8864 if (!CLASS_DATA (c
)->attr
.codimension
)
8866 ftn_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
8867 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 1, size
);
8868 gfc_add_modify (&tmpblock
, dst_data
,
8869 fold_convert (TREE_TYPE (dst_data
), tmp
));
8872 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
,
8873 UNLIMITED_POLY (c
));
8874 gfc_add_expr_to_block (&tmpblock
, tmp
);
8875 tmp
= gfc_finish_block (&tmpblock
);
8877 gfc_init_block (&tmpblock
);
8878 gfc_add_modify (&tmpblock
, dst_data
,
8879 fold_convert (TREE_TYPE (dst_data
),
8880 null_pointer_node
));
8881 null_data
= gfc_finish_block (&tmpblock
);
8883 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
8884 logical_type_node
, src_data
,
8887 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
8892 /* To implement guarded deep copy, i.e., deep copy only allocatable
8893 components that are really allocated, the deep copy code has to
8894 be generated first and then added to the if-block in
8895 gfc_duplicate_allocatable (). */
8896 if (cmp_has_alloc_comps
&& !c
->attr
.proc_pointer
8899 rank
= c
->as
? c
->as
->rank
: 0;
8900 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
8901 gfc_add_modify (&fnblock
, dcmp
, tmp
);
8902 add_when_allocated
= structure_alloc_comps (c
->ts
.u
.derived
,
8908 add_when_allocated
= NULL_TREE
;
8910 if (gfc_deferred_strlen (c
, &tmp
))
8914 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
8916 decl
, len
, NULL_TREE
);
8917 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
8919 dest
, len
, NULL_TREE
);
8920 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8921 TREE_TYPE (len
), len
, tmp
);
8922 gfc_add_expr_to_block (&fnblock
, tmp
);
8923 size
= size_of_string_in_bytes (c
->ts
.kind
, len
);
8924 /* This component can not have allocatable components,
8925 therefore add_when_allocated of duplicate_allocatable ()
8927 tmp
= duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8928 false, false, size
, NULL_TREE
);
8929 gfc_add_expr_to_block (&fnblock
, tmp
);
8931 else if (c
->attr
.allocatable
&& !c
->attr
.proc_pointer
&& !same_type
8932 && (!(cmp_has_alloc_comps
&& c
->as
) || c
->attr
.codimension
8933 || caf_in_coarray (caf_mode
)))
8935 rank
= c
->as
? c
->as
->rank
: 0;
8936 if (c
->attr
.codimension
)
8937 tmp
= gfc_copy_allocatable_data (dcmp
, comp
, ctype
, rank
);
8938 else if (flag_coarray
== GFC_FCOARRAY_LIB
8939 && caf_in_coarray (caf_mode
))
8941 tree dst_tok
= c
->as
? gfc_conv_descriptor_token (dcmp
)
8942 : fold_build3_loc (input_location
,
8944 pvoid_type_node
, dest
,
8947 tmp
= duplicate_allocatable_coarray (dcmp
, dst_tok
, comp
,
8951 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
,
8952 add_when_allocated
);
8953 gfc_add_expr_to_block (&fnblock
, tmp
);
8956 if (cmp_has_alloc_comps
)
8957 gfc_add_expr_to_block (&fnblock
, add_when_allocated
);
8961 case ALLOCATE_PDT_COMP
:
8963 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
8964 decl
, cdecl, NULL_TREE
);
8966 /* Set the PDT KIND and LEN fields. */
8967 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
8970 gfc_expr
*c_expr
= NULL
;
8971 gfc_actual_arglist
*param
= pdt_param_list
;
8972 gfc_init_se (&tse
, NULL
);
8973 for (; param
; param
= param
->next
)
8974 if (!strcmp (c
->name
, param
->name
))
8975 c_expr
= param
->expr
;
8978 c_expr
= c
->initializer
;
8982 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
8983 gfc_add_modify (&fnblock
, comp
, tse
.expr
);
8987 if (c
->attr
.pdt_string
)
8990 gfc_init_se (&tse
, NULL
);
8992 /* Convert the parameterized string length to its value. The
8993 string length is stored in a hidden field in the same way as
8994 deferred string lengths. */
8995 gfc_insert_parameter_exprs (c
->ts
.u
.cl
->length
, pdt_param_list
);
8996 if (gfc_deferred_strlen (c
, &strlen
) && strlen
!= NULL_TREE
)
8998 gfc_conv_expr_type (&tse
, c
->ts
.u
.cl
->length
,
8999 TREE_TYPE (strlen
));
9000 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9002 decl
, strlen
, NULL_TREE
);
9003 gfc_add_modify (&fnblock
, strlen
, tse
.expr
);
9004 c
->ts
.u
.cl
->backend_decl
= strlen
;
9006 /* Scalar parameterizied strings can be allocated now. */
9009 tmp
= fold_convert (gfc_array_index_type
, strlen
);
9010 tmp
= size_of_string_in_bytes (c
->ts
.kind
, tmp
);
9011 tmp
= gfc_evaluate_now (tmp
, &fnblock
);
9012 tmp
= gfc_call_malloc (&fnblock
, TREE_TYPE (comp
), tmp
);
9013 gfc_add_modify (&fnblock
, comp
, tmp
);
9017 /* Allocate paramterized arrays of parameterized derived types. */
9018 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9019 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9020 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9023 if (c
->ts
.type
== BT_CLASS
)
9024 comp
= gfc_class_data_get (comp
);
9026 if (c
->attr
.pdt_array
)
9030 tree size
= gfc_index_one_node
;
9031 tree offset
= gfc_index_zero_node
;
9035 /* This chunk takes the expressions for 'lower' and 'upper'
9036 in the arrayspec and substitutes in the expressions for
9037 the parameters from 'pdt_param_list'. The descriptor
9038 fields can then be filled from the values so obtained. */
9039 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp
)));
9040 for (i
= 0; i
< c
->as
->rank
; i
++)
9042 gfc_init_se (&tse
, NULL
);
9043 e
= gfc_copy_expr (c
->as
->lower
[i
]);
9044 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9045 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9048 gfc_conv_descriptor_lbound_set (&fnblock
, comp
,
9051 e
= gfc_copy_expr (c
->as
->upper
[i
]);
9052 gfc_insert_parameter_exprs (e
, pdt_param_list
);
9053 gfc_conv_expr_type (&tse
, e
, gfc_array_index_type
);
9056 gfc_conv_descriptor_ubound_set (&fnblock
, comp
,
9059 gfc_conv_descriptor_stride_set (&fnblock
, comp
,
9062 size
= gfc_evaluate_now (size
, &fnblock
);
9063 offset
= fold_build2_loc (input_location
,
9065 gfc_array_index_type
,
9067 offset
= gfc_evaluate_now (offset
, &fnblock
);
9068 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9069 gfc_array_index_type
,
9071 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9072 gfc_array_index_type
,
9073 tmp
, gfc_index_one_node
);
9074 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9075 gfc_array_index_type
, size
, tmp
);
9077 gfc_conv_descriptor_offset_set (&fnblock
, comp
, offset
);
9078 if (c
->ts
.type
== BT_CLASS
)
9080 tmp
= gfc_get_vptr_from_expr (comp
);
9081 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9082 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
9083 tmp
= gfc_vptr_size_get (tmp
);
9086 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (ctype
));
9087 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9088 size
= fold_build2_loc (input_location
, MULT_EXPR
,
9089 gfc_array_index_type
, size
, tmp
);
9090 size
= gfc_evaluate_now (size
, &fnblock
);
9091 tmp
= gfc_call_malloc (&fnblock
, NULL
, size
);
9092 gfc_conv_descriptor_data_set (&fnblock
, comp
, tmp
);
9093 tmp
= gfc_conv_descriptor_dtype (comp
);
9094 gfc_add_modify (&fnblock
, tmp
, gfc_get_dtype (ctype
));
9097 /* Recurse in to PDT components. */
9098 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9099 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9100 && !(c
->attr
.pointer
|| c
->attr
.allocatable
))
9102 bool is_deferred
= false;
9103 gfc_actual_arglist
*tail
= c
->param_list
;
9105 for (; tail
; tail
= tail
->next
)
9109 tail
= is_deferred
? pdt_param_list
: c
->param_list
;
9110 tmp
= gfc_allocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9111 c
->as
? c
->as
->rank
: 0,
9113 gfc_add_expr_to_block (&fnblock
, tmp
);
9118 case DEALLOCATE_PDT_COMP
:
9119 /* Deallocate array or parameterized string length components
9120 of parameterized derived types. */
9121 if (!(c
->attr
.pdt_array
&& c
->as
&& c
->as
->type
== AS_EXPLICIT
)
9122 && !c
->attr
.pdt_string
9123 && !((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9124 && (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)))
9127 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9128 decl
, cdecl, NULL_TREE
);
9129 if (c
->ts
.type
== BT_CLASS
)
9130 comp
= gfc_class_data_get (comp
);
9132 /* Recurse in to PDT components. */
9133 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9134 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
9135 && (!c
->attr
.pointer
&& !c
->attr
.allocatable
))
9137 tmp
= gfc_deallocate_pdt_comp (c
->ts
.u
.derived
, comp
,
9138 c
->as
? c
->as
->rank
: 0);
9139 gfc_add_expr_to_block (&fnblock
, tmp
);
9142 if (c
->attr
.pdt_array
)
9144 tmp
= gfc_conv_descriptor_data_get (comp
);
9145 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9146 logical_type_node
, tmp
,
9147 build_int_cst (TREE_TYPE (tmp
), 0));
9148 tmp
= gfc_call_free (tmp
);
9149 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9150 build_empty_stmt (input_location
));
9151 gfc_add_expr_to_block (&fnblock
, tmp
);
9152 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
9154 else if (c
->attr
.pdt_string
)
9156 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
9157 logical_type_node
, comp
,
9158 build_int_cst (TREE_TYPE (comp
), 0));
9159 tmp
= gfc_call_free (comp
);
9160 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
9161 build_empty_stmt (input_location
));
9162 gfc_add_expr_to_block (&fnblock
, tmp
);
9163 tmp
= fold_convert (TREE_TYPE (comp
), null_pointer_node
);
9164 gfc_add_modify (&fnblock
, comp
, tmp
);
9169 case CHECK_PDT_DUMMY
:
9171 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
9172 decl
, cdecl, NULL_TREE
);
9173 if (c
->ts
.type
== BT_CLASS
)
9174 comp
= gfc_class_data_get (comp
);
9176 /* Recurse in to PDT components. */
9177 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
9178 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
)
9180 tmp
= gfc_check_pdt_dummy (c
->ts
.u
.derived
, comp
,
9181 c
->as
? c
->as
->rank
: 0,
9183 gfc_add_expr_to_block (&fnblock
, tmp
);
9186 if (!c
->attr
.pdt_len
)
9191 gfc_expr
*c_expr
= NULL
;
9192 gfc_actual_arglist
*param
= pdt_param_list
;
9194 gfc_init_se (&tse
, NULL
);
9195 for (; param
; param
= param
->next
)
9196 if (!strcmp (c
->name
, param
->name
))
9197 c_expr
= param
->expr
;
9201 tree error
, cond
, cname
;
9202 gfc_conv_expr_type (&tse
, c_expr
, TREE_TYPE (comp
));
9203 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9206 cname
= gfc_build_cstring_const (c
->name
);
9207 cname
= gfc_build_addr_expr (pchar_type_node
, cname
);
9208 error
= gfc_trans_runtime_error (true, NULL
,
9209 "The value of the PDT LEN "
9210 "parameter '%s' does not "
9211 "agree with that in the "
9212 "dummy declaration",
9214 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
9215 void_type_node
, cond
, error
,
9216 build_empty_stmt (input_location
));
9217 gfc_add_expr_to_block (&fnblock
, tmp
);
9228 return gfc_finish_block (&fnblock
);
9231 /* Recursively traverse an object of derived type, generating code to
9232 nullify allocatable components. */
9235 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9238 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9240 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9244 /* Recursively traverse an object of derived type, generating code to
9245 deallocate allocatable components. */
9248 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9251 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9252 DEALLOCATE_ALLOC_COMP
,
9253 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
| caf_mode
);
9257 /* Recursively traverse an object of derived type, generating code to
9258 deallocate allocatable components. But do not deallocate coarrays.
9259 To be used for intrinsic assignment, which may not change the allocation
9260 status of coarrays. */
9263 gfc_deallocate_alloc_comp_no_caf (gfc_symbol
* der_type
, tree decl
, int rank
)
9265 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9266 DEALLOCATE_ALLOC_COMP
, 0);
9271 gfc_reassign_alloc_comp_caf (gfc_symbol
*der_type
, tree decl
, tree dest
)
9273 return structure_alloc_comps (der_type
, decl
, dest
, 0, REASSIGN_CAF_COMP
,
9274 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
);
9278 /* Recursively traverse an object of derived type, generating code to
9279 copy it and its allocatable components. */
9282 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
,
9285 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
,
9290 /* Recursively traverse an object of derived type, generating code to
9291 copy only its allocatable components. */
9294 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
9296 return structure_alloc_comps (der_type
, decl
, dest
, rank
,
9297 COPY_ONLY_ALLOC_COMP
, 0);
9301 /* Recursively traverse an object of paramterized derived type, generating
9302 code to allocate parameterized components. */
9305 gfc_allocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
,
9306 gfc_actual_arglist
*param_list
)
9309 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9310 pdt_param_list
= param_list
;
9311 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9312 ALLOCATE_PDT_COMP
, 0);
9313 pdt_param_list
= old_param_list
;
9317 /* Recursively traverse an object of paramterized derived type, generating
9318 code to deallocate parameterized components. */
9321 gfc_deallocate_pdt_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
9323 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9324 DEALLOCATE_PDT_COMP
, 0);
9328 /* Recursively traverse a dummy of paramterized derived type to check the
9329 values of LEN parameters. */
9332 gfc_check_pdt_dummy (gfc_symbol
* der_type
, tree decl
, int rank
,
9333 gfc_actual_arglist
*param_list
)
9336 gfc_actual_arglist
*old_param_list
= pdt_param_list
;
9337 pdt_param_list
= param_list
;
9338 res
= structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
9339 CHECK_PDT_DUMMY
, 0);
9340 pdt_param_list
= old_param_list
;
9345 /* Returns the value of LBOUND for an expression. This could be broken out
9346 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
9347 called by gfc_alloc_allocatable_for_assignment. */
9349 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
9354 tree cond
, cond1
, cond3
, cond4
;
9358 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9360 tmp
= gfc_rank_cst
[dim
];
9361 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
9362 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
9363 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
9364 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9366 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
9367 stride
, gfc_index_zero_node
);
9368 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9369 logical_type_node
, cond3
, cond1
);
9370 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9371 stride
, gfc_index_zero_node
);
9373 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9374 tmp
, build_int_cst (gfc_array_index_type
,
9377 cond
= logical_false_node
;
9379 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9380 logical_type_node
, cond3
, cond4
);
9381 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9382 logical_type_node
, cond
, cond1
);
9384 return fold_build3_loc (input_location
, COND_EXPR
,
9385 gfc_array_index_type
, cond
,
9386 lbound
, gfc_index_one_node
);
9389 if (expr
->expr_type
== EXPR_FUNCTION
)
9391 /* A conversion function, so use the argument. */
9392 gcc_assert (expr
->value
.function
.isym
9393 && expr
->value
.function
.isym
->conversion
);
9394 expr
= expr
->value
.function
.actual
->expr
;
9397 if (expr
->expr_type
== EXPR_VARIABLE
)
9399 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
9400 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9402 if (ref
->type
== REF_COMPONENT
9403 && ref
->u
.c
.component
->as
9405 && ref
->next
->u
.ar
.type
== AR_FULL
)
9406 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
9408 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
9411 return gfc_index_one_node
;
9415 /* Returns true if an expression represents an lhs that can be reallocated
9419 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
9426 /* An allocatable class variable with no reference. */
9427 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
9428 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.allocatable
9429 && expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
9430 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0
9431 && expr
->ref
->next
== NULL
)
9434 /* An allocatable variable. */
9435 if (expr
->symtree
->n
.sym
->attr
.allocatable
9437 && expr
->ref
->type
== REF_ARRAY
9438 && expr
->ref
->u
.ar
.type
== AR_FULL
)
9441 /* All that can be left are allocatable components. */
9442 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9443 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9444 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
9447 /* Find a component ref followed by an array reference. */
9448 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9450 && ref
->type
== REF_COMPONENT
9451 && ref
->next
->type
== REF_ARRAY
9452 && !ref
->next
->next
)
9458 /* Return true if valid reallocatable lhs. */
9459 if (ref
->u
.c
.component
->attr
.allocatable
9460 && ref
->next
->u
.ar
.type
== AR_FULL
)
9468 concat_str_length (gfc_expr
* expr
)
9475 type
= gfc_typenode_for_spec (&expr
->value
.op
.op1
->ts
);
9476 len1
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9477 if (len1
== NULL_TREE
)
9479 if (expr
->value
.op
.op1
->expr_type
== EXPR_OP
)
9480 len1
= concat_str_length (expr
->value
.op
.op1
);
9481 else if (expr
->value
.op
.op1
->expr_type
== EXPR_CONSTANT
)
9482 len1
= build_int_cst (gfc_charlen_type_node
,
9483 expr
->value
.op
.op1
->value
.character
.length
);
9484 else if (expr
->value
.op
.op1
->ts
.u
.cl
->length
)
9486 gfc_init_se (&se
, NULL
);
9487 gfc_conv_expr (&se
, expr
->value
.op
.op1
->ts
.u
.cl
->length
);
9493 gfc_init_se (&se
, NULL
);
9494 se
.want_pointer
= 1;
9495 se
.descriptor_only
= 1;
9496 gfc_conv_expr (&se
, expr
->value
.op
.op1
);
9497 len1
= se
.string_length
;
9501 type
= gfc_typenode_for_spec (&expr
->value
.op
.op2
->ts
);
9502 len2
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
9503 if (len2
== NULL_TREE
)
9505 if (expr
->value
.op
.op2
->expr_type
== EXPR_OP
)
9506 len2
= concat_str_length (expr
->value
.op
.op2
);
9507 else if (expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
9508 len2
= build_int_cst (gfc_charlen_type_node
,
9509 expr
->value
.op
.op2
->value
.character
.length
);
9510 else if (expr
->value
.op
.op2
->ts
.u
.cl
->length
)
9512 gfc_init_se (&se
, NULL
);
9513 gfc_conv_expr (&se
, expr
->value
.op
.op2
->ts
.u
.cl
->length
);
9519 gfc_init_se (&se
, NULL
);
9520 se
.want_pointer
= 1;
9521 se
.descriptor_only
= 1;
9522 gfc_conv_expr (&se
, expr
->value
.op
.op2
);
9523 len2
= se
.string_length
;
9527 gcc_assert(len1
&& len2
);
9528 len1
= fold_convert (gfc_charlen_type_node
, len1
);
9529 len2
= fold_convert (gfc_charlen_type_node
, len2
);
9531 return fold_build2_loc (input_location
, PLUS_EXPR
,
9532 gfc_charlen_type_node
, len1
, len2
);
9536 /* Allocate the lhs of an assignment to an allocatable array, otherwise
9540 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
9544 stmtblock_t realloc_block
;
9545 stmtblock_t alloc_block
;
9549 gfc_array_info
*linfo
;
9571 gfc_array_spec
* as
;
9572 bool coarray
= (flag_coarray
== GFC_FCOARRAY_LIB
9573 && gfc_caf_attr (expr1
, true).codimension
);
9577 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9578 Find the lhs expression in the loop chain and set expr1 and
9579 expr2 accordingly. */
9580 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
9583 /* Find the ss for the lhs. */
9585 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9586 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
9588 if (lss
== gfc_ss_terminator
)
9590 expr1
= lss
->info
->expr
;
9593 /* Bail out if this is not a valid allocate on assignment. */
9594 if (!gfc_is_reallocatable_lhs (expr1
)
9595 || (expr2
&& !expr2
->rank
))
9598 /* Find the ss for the lhs. */
9600 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
9601 if (lss
->info
->expr
== expr1
)
9604 if (lss
== gfc_ss_terminator
)
9607 linfo
= &lss
->info
->data
.array
;
9609 /* Find an ss for the rhs. For operator expressions, we see the
9610 ss's for the operands. Any one of these will do. */
9612 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
9613 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
9616 if (expr2
&& rss
== gfc_ss_terminator
)
9619 gfc_start_block (&fblock
);
9621 /* Since the lhs is allocatable, this must be a descriptor type.
9622 Get the data and array size. */
9623 desc
= linfo
->descriptor
;
9624 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
9625 array1
= gfc_conv_descriptor_data_get (desc
);
9627 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9628 deallocated if expr is an array of different shape or any of the
9629 corresponding length type parameter values of variable and expr
9630 differ." This assures F95 compatibility. */
9631 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9632 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9634 /* Allocate if data is NULL. */
9635 cond_null
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9636 array1
, build_int_cst (TREE_TYPE (array1
), 0));
9638 if (expr1
->ts
.deferred
)
9639 cond_null
= gfc_evaluate_now (logical_true_node
, &fblock
);
9641 cond_null
= gfc_evaluate_now (cond_null
, &fblock
);
9643 tmp
= build3_v (COND_EXPR
, cond_null
,
9644 build1_v (GOTO_EXPR
, jump_label1
),
9645 build_empty_stmt (input_location
));
9646 gfc_add_expr_to_block (&fblock
, tmp
);
9648 /* Get arrayspec if expr is a full array. */
9649 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
9650 && expr2
->value
.function
.isym
9651 && expr2
->value
.function
.isym
->conversion
)
9653 /* For conversion functions, take the arg. */
9654 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
9655 as
= gfc_get_full_arrayspec_from_expr (arg
);
9658 as
= gfc_get_full_arrayspec_from_expr (expr2
);
9662 /* If the lhs shape is not the same as the rhs jump to setting the
9663 bounds and doing the reallocation....... */
9664 for (n
= 0; n
< expr1
->rank
; n
++)
9666 /* Check the shape. */
9667 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9668 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9669 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9670 gfc_array_index_type
,
9671 loop
->to
[n
], loop
->from
[n
]);
9672 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9673 gfc_array_index_type
,
9675 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9676 gfc_array_index_type
,
9678 cond
= fold_build2_loc (input_location
, NE_EXPR
,
9680 tmp
, gfc_index_zero_node
);
9681 tmp
= build3_v (COND_EXPR
, cond
,
9682 build1_v (GOTO_EXPR
, jump_label1
),
9683 build_empty_stmt (input_location
));
9684 gfc_add_expr_to_block (&fblock
, tmp
);
9687 /* ....else jump past the (re)alloc code. */
9688 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9689 gfc_add_expr_to_block (&fblock
, tmp
);
9691 /* Add the label to start automatic (re)allocation. */
9692 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9693 gfc_add_expr_to_block (&fblock
, tmp
);
9695 /* If the lhs has not been allocated, its bounds will not have been
9696 initialized and so its size is set to zero. */
9697 size1
= gfc_create_var (gfc_array_index_type
, NULL
);
9698 gfc_init_block (&alloc_block
);
9699 gfc_add_modify (&alloc_block
, size1
, gfc_index_zero_node
);
9700 gfc_init_block (&realloc_block
);
9701 gfc_add_modify (&realloc_block
, size1
,
9702 gfc_conv_descriptor_size (desc
, expr1
->rank
));
9703 tmp
= build3_v (COND_EXPR
, cond_null
,
9704 gfc_finish_block (&alloc_block
),
9705 gfc_finish_block (&realloc_block
));
9706 gfc_add_expr_to_block (&fblock
, tmp
);
9708 /* Get the rhs size and fix it. */
9710 desc2
= rss
->info
->data
.array
.descriptor
;
9714 size2
= gfc_index_one_node
;
9715 for (n
= 0; n
< expr2
->rank
; n
++)
9717 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9718 gfc_array_index_type
,
9719 loop
->to
[n
], loop
->from
[n
]);
9720 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9721 gfc_array_index_type
,
9722 tmp
, gfc_index_one_node
);
9723 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9724 gfc_array_index_type
,
9727 size2
= gfc_evaluate_now (size2
, &fblock
);
9729 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9732 /* If the lhs is deferred length, assume that the element size
9733 changes and force a reallocation. */
9734 if (expr1
->ts
.deferred
)
9735 neq_size
= gfc_evaluate_now (logical_true_node
, &fblock
);
9737 neq_size
= gfc_evaluate_now (cond
, &fblock
);
9739 /* Deallocation of allocatable components will have to occur on
9740 reallocation. Fix the old descriptor now. */
9741 if ((expr1
->ts
.type
== BT_DERIVED
)
9742 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9743 old_desc
= gfc_evaluate_now (desc
, &fblock
);
9745 old_desc
= NULL_TREE
;
9747 /* Now modify the lhs descriptor and the associated scalarizer
9748 variables. F2003 7.4.1.3: "If variable is or becomes an
9749 unallocated allocatable variable, then it is allocated with each
9750 deferred type parameter equal to the corresponding type parameters
9751 of expr , with the shape of expr , and with each lower bound equal
9752 to the corresponding element of LBOUND(expr)."
9753 Reuse size1 to keep a dimension-by-dimension track of the
9754 stride of the new array. */
9755 size1
= gfc_index_one_node
;
9756 offset
= gfc_index_zero_node
;
9758 for (n
= 0; n
< expr2
->rank
; n
++)
9760 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9761 gfc_array_index_type
,
9762 loop
->to
[n
], loop
->from
[n
]);
9763 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9764 gfc_array_index_type
,
9765 tmp
, gfc_index_one_node
);
9767 lbound
= gfc_index_one_node
;
9772 lbd
= get_std_lbound (expr2
, desc2
, n
,
9773 as
->type
== AS_ASSUMED_SIZE
);
9774 ubound
= fold_build2_loc (input_location
,
9776 gfc_array_index_type
,
9778 ubound
= fold_build2_loc (input_location
,
9780 gfc_array_index_type
,
9785 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
9788 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
9791 gfc_conv_descriptor_stride_set (&fblock
, desc
,
9794 lbound
= gfc_conv_descriptor_lbound_get (desc
,
9796 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
9797 gfc_array_index_type
,
9799 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9800 gfc_array_index_type
,
9802 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
9803 gfc_array_index_type
,
9807 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9808 the array offset is saved and the info.offset is used for a
9809 running offset. Use the saved_offset instead. */
9810 tmp
= gfc_conv_descriptor_offset (desc
);
9811 gfc_add_modify (&fblock
, tmp
, offset
);
9812 if (linfo
->saved_offset
9813 && VAR_P (linfo
->saved_offset
))
9814 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
9816 /* Now set the deltas for the lhs. */
9817 for (n
= 0; n
< expr1
->rank
; n
++)
9819 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9821 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9822 gfc_array_index_type
, tmp
,
9824 if (linfo
->delta
[dim
] && VAR_P (linfo
->delta
[dim
]))
9825 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
9828 /* Get the new lhs size in bytes. */
9829 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9831 if (expr2
->ts
.deferred
)
9833 if (VAR_P (expr2
->ts
.u
.cl
->backend_decl
))
9834 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9836 tmp
= rss
->info
->string_length
;
9840 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
9841 if (!tmp
&& expr2
->expr_type
== EXPR_OP
9842 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
9844 tmp
= concat_str_length (expr2
);
9845 expr2
->ts
.u
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &fblock
);
9847 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
9850 if (expr1
->ts
.u
.cl
->backend_decl
9851 && VAR_P (expr1
->ts
.u
.cl
->backend_decl
))
9852 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
9854 gfc_add_modify (&fblock
, lss
->info
->string_length
, tmp
);
9856 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
9858 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
9859 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9860 gfc_array_index_type
, tmp
,
9861 expr1
->ts
.u
.cl
->backend_decl
);
9864 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9865 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9866 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
9867 gfc_array_index_type
,
9869 size2
= fold_convert (size_type_node
, size2
);
9870 size2
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9871 size2
, size_one_node
);
9872 size2
= gfc_evaluate_now (size2
, &fblock
);
9874 /* For deferred character length, the 'size' field of the dtype might
9875 have changed so set the dtype. */
9876 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9877 && expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9880 tmp
= gfc_conv_descriptor_dtype (desc
);
9881 if (expr2
->ts
.u
.cl
->backend_decl
)
9882 type
= gfc_typenode_for_spec (&expr2
->ts
);
9884 type
= gfc_typenode_for_spec (&expr1
->ts
);
9886 gfc_add_modify (&fblock
, tmp
,
9887 gfc_get_dtype_rank_type (expr1
->rank
,type
));
9889 else if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
9891 gfc_add_modify (&fblock
, gfc_conv_descriptor_dtype (desc
),
9892 gfc_get_dtype (TREE_TYPE (desc
)));
9895 /* Realloc expression. Note that the scalarizer uses desc.data
9896 in the array reference - (*desc.data)[<element>]. */
9897 gfc_init_block (&realloc_block
);
9898 gfc_init_se (&caf_se
, NULL
);
9902 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se
, expr1
);
9903 if (token
== NULL_TREE
)
9905 tmp
= gfc_get_tree_for_caf_expr (expr1
);
9906 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
9907 tmp
= build_fold_indirect_ref (tmp
);
9908 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, tmp
, NULL_TREE
,
9910 token
= gfc_build_addr_expr (NULL_TREE
, token
);
9913 gfc_add_block_to_block (&realloc_block
, &caf_se
.pre
);
9915 if ((expr1
->ts
.type
== BT_DERIVED
)
9916 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9918 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, old_desc
,
9920 gfc_add_expr_to_block (&realloc_block
, tmp
);
9925 tmp
= build_call_expr_loc (input_location
,
9926 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
9927 fold_convert (pvoid_type_node
, array1
),
9929 gfc_conv_descriptor_data_set (&realloc_block
,
9934 tmp
= build_call_expr_loc (input_location
,
9935 gfor_fndecl_caf_deregister
, 5, token
,
9936 build_int_cst (integer_type_node
,
9937 GFC_CAF_COARRAY_DEALLOCATE_ONLY
),
9938 null_pointer_node
, null_pointer_node
,
9940 gfc_add_expr_to_block (&realloc_block
, tmp
);
9941 tmp
= build_call_expr_loc (input_location
,
9942 gfor_fndecl_caf_register
,
9944 build_int_cst (integer_type_node
,
9945 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
),
9946 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9947 null_pointer_node
, null_pointer_node
,
9949 gfc_add_expr_to_block (&realloc_block
, tmp
);
9952 if ((expr1
->ts
.type
== BT_DERIVED
)
9953 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9955 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
9957 gfc_add_expr_to_block (&realloc_block
, tmp
);
9960 gfc_add_block_to_block (&realloc_block
, &caf_se
.post
);
9961 realloc_expr
= gfc_finish_block (&realloc_block
);
9963 /* Only reallocate if sizes are different. */
9964 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
9965 build_empty_stmt (input_location
));
9969 /* Malloc expression. */
9970 gfc_init_block (&alloc_block
);
9973 tmp
= build_call_expr_loc (input_location
,
9974 builtin_decl_explicit (BUILT_IN_MALLOC
),
9976 gfc_conv_descriptor_data_set (&alloc_block
,
9981 tmp
= build_call_expr_loc (input_location
,
9982 gfor_fndecl_caf_register
,
9984 build_int_cst (integer_type_node
,
9985 GFC_CAF_COARRAY_ALLOC
),
9986 token
, gfc_build_addr_expr (NULL_TREE
, desc
),
9987 null_pointer_node
, null_pointer_node
,
9989 gfc_add_expr_to_block (&alloc_block
, tmp
);
9993 /* We already set the dtype in the case of deferred character
9995 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
9996 && ((expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9999 tmp
= gfc_conv_descriptor_dtype (desc
);
10000 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10003 if ((expr1
->ts
.type
== BT_DERIVED
)
10004 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10006 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, desc
,
10008 gfc_add_expr_to_block (&alloc_block
, tmp
);
10010 alloc_expr
= gfc_finish_block (&alloc_block
);
10012 /* Malloc if not allocated; realloc otherwise. */
10013 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
10014 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10017 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
10018 gfc_add_expr_to_block (&fblock
, tmp
);
10020 /* Make sure that the scalarizer data pointer is updated. */
10021 if (linfo
->data
&& VAR_P (linfo
->data
))
10023 tmp
= gfc_conv_descriptor_data_get (desc
);
10024 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
10027 /* Add the exit label. */
10028 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10029 gfc_add_expr_to_block (&fblock
, tmp
);
10031 return gfc_finish_block (&fblock
);
10035 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
10036 Do likewise, recursively if necessary, with the allocatable components of
10040 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
10046 stmtblock_t cleanup
;
10049 bool sym_has_alloc_comp
, has_finalizer
;
10051 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
10052 || sym
->ts
.type
== BT_CLASS
)
10053 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
10054 has_finalizer
= sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
10055 ? gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
) : false;
10057 /* Make sure the frontend gets these right. */
10058 gcc_assert (sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
10061 gfc_save_backend_locus (&loc
);
10062 gfc_set_backend_locus (&sym
->declared_at
);
10063 gfc_init_block (&init
);
10065 gcc_assert (VAR_P (sym
->backend_decl
)
10066 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
10068 if (sym
->ts
.type
== BT_CHARACTER
10069 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
10071 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
10072 gfc_trans_vla_type_sizes (sym
, &init
);
10075 /* Dummy, use associated and result variables don't need anything special. */
10076 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
10078 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10079 gfc_restore_backend_locus (&loc
);
10083 descriptor
= sym
->backend_decl
;
10085 /* Although static, derived types with default initializers and
10086 allocatable components must not be nulled wholesale; instead they
10087 are treated component by component. */
10088 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
&& !has_finalizer
)
10090 /* SAVEd variables are not freed on exit. */
10091 gfc_trans_static_array_pointer (sym
);
10093 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
10094 gfc_restore_backend_locus (&loc
);
10098 /* Get the descriptor type. */
10099 type
= TREE_TYPE (sym
->backend_decl
);
10101 if ((sym_has_alloc_comp
|| (has_finalizer
&& sym
->ts
.type
!= BT_CLASS
))
10102 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10104 if (!sym
->attr
.save
10105 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
10107 if (sym
->value
== NULL
10108 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
10110 rank
= sym
->as
? sym
->as
->rank
: 0;
10111 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
10113 gfc_add_expr_to_block (&init
, tmp
);
10116 gfc_init_default_dt (sym
, &init
, false);
10119 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
10121 /* If the backend_decl is not a descriptor, we must have a pointer
10123 descriptor
= build_fold_indirect_ref_loc (input_location
,
10124 sym
->backend_decl
);
10125 type
= TREE_TYPE (descriptor
);
10128 /* NULLIFY the data pointer, for non-saved allocatables. */
10129 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
&& sym
->attr
.allocatable
)
10131 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
10132 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
10134 /* Declare the variable static so its array descriptor stays present
10135 after leaving the scope. It may still be accessed through another
10136 image. This may happen, for example, with the caf_mpi
10138 TREE_STATIC (descriptor
) = 1;
10139 tmp
= gfc_conv_descriptor_token (descriptor
);
10140 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
10141 null_pointer_node
));
10145 gfc_restore_backend_locus (&loc
);
10146 gfc_init_block (&cleanup
);
10148 /* Allocatable arrays need to be freed when they go out of scope.
10149 The allocatable components of pointers must not be touched. */
10150 if (!sym
->attr
.allocatable
&& has_finalizer
&& sym
->ts
.type
!= BT_CLASS
10151 && !sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
10152 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10155 sym
->attr
.referenced
= 1;
10156 e
= gfc_lval_expr_from_sym (sym
);
10157 gfc_add_finalizer_call (&cleanup
, e
);
10160 else if ((!sym
->attr
.allocatable
|| !has_finalizer
)
10161 && sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
10162 && !sym
->attr
.pointer
&& !sym
->attr
.save
10163 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10166 rank
= sym
->as
? sym
->as
->rank
: 0;
10167 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
10168 gfc_add_expr_to_block (&cleanup
, tmp
);
10171 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
10172 && !sym
->attr
.save
&& !sym
->attr
.result
10173 && !sym
->ns
->proc_name
->attr
.is_main_program
)
10176 e
= has_finalizer
? gfc_lval_expr_from_sym (sym
) : NULL
;
10177 tmp
= gfc_deallocate_with_status (sym
->backend_decl
, NULL_TREE
, NULL_TREE
,
10178 NULL_TREE
, NULL_TREE
, true, e
,
10179 sym
->attr
.codimension
10180 ? GFC_CAF_COARRAY_DEREGISTER
10181 : GFC_CAF_COARRAY_NOCOARRAY
);
10184 gfc_add_expr_to_block (&cleanup
, tmp
);
10187 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
10188 gfc_finish_block (&cleanup
));
10191 /************ Expression Walking Functions ******************/
10193 /* Walk a variable reference.
10195 Possible extension - multiple component subscripts.
10196 x(:,:) = foo%a(:)%b(:)
10198 forall (i=..., j=...)
10199 x(i,j) = foo%a(j)%b(i)
10201 This adds a fair amount of complexity because you need to deal with more
10202 than one ref. Maybe handle in a similar manner to vector subscripts.
10203 Maybe not worth the effort. */
10207 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10211 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10212 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
10215 return gfc_walk_array_ref (ss
, expr
, ref
);
10220 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
10226 for (; ref
; ref
= ref
->next
)
10228 if (ref
->type
== REF_SUBSTRING
)
10230 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
10231 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
10234 /* We're only interested in array sections from now on. */
10235 if (ref
->type
!= REF_ARRAY
)
10243 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
10244 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
10248 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
10249 newss
->info
->data
.array
.ref
= ref
;
10251 /* Make sure array is the same as array(:,:), this way
10252 we don't need to special case all the time. */
10253 ar
->dimen
= ar
->as
->rank
;
10254 for (n
= 0; n
< ar
->dimen
; n
++)
10256 ar
->dimen_type
[n
] = DIMEN_RANGE
;
10258 gcc_assert (ar
->start
[n
] == NULL
);
10259 gcc_assert (ar
->end
[n
] == NULL
);
10260 gcc_assert (ar
->stride
[n
] == NULL
);
10266 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
10267 newss
->info
->data
.array
.ref
= ref
;
10269 /* We add SS chains for all the subscripts in the section. */
10270 for (n
= 0; n
< ar
->dimen
; n
++)
10274 switch (ar
->dimen_type
[n
])
10276 case DIMEN_ELEMENT
:
10277 /* Add SS for elemental (scalar) subscripts. */
10278 gcc_assert (ar
->start
[n
]);
10279 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
10280 indexss
->loop_chain
= gfc_ss_terminator
;
10281 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10285 /* We don't add anything for sections, just remember this
10286 dimension for later. */
10287 newss
->dim
[newss
->dimen
] = n
;
10292 /* Create a GFC_SS_VECTOR index in which we can store
10293 the vector's descriptor. */
10294 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
10296 indexss
->loop_chain
= gfc_ss_terminator
;
10297 newss
->info
->data
.array
.subscript
[n
] = indexss
;
10298 newss
->dim
[newss
->dimen
] = n
;
10303 /* We should know what sort of section it is by now. */
10304 gcc_unreachable ();
10307 /* We should have at least one non-elemental dimension,
10308 unless we are creating a descriptor for a (scalar) coarray. */
10309 gcc_assert (newss
->dimen
> 0
10310 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
10315 /* We should know what sort of section it is by now. */
10316 gcc_unreachable ();
10324 /* Walk an expression operator. If only one operand of a binary expression is
10325 scalar, we must also add the scalar term to the SS chain. */
10328 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10333 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
10334 if (expr
->value
.op
.op2
== NULL
)
10337 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
10339 /* All operands are scalar. Pass back and let the caller deal with it. */
10343 /* All operands require scalarization. */
10344 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
10347 /* One of the operands needs scalarization, the other is scalar.
10348 Create a gfc_ss for the scalar expression. */
10351 /* First operand is scalar. We build the chain in reverse order, so
10352 add the scalar SS after the second operand. */
10354 while (head
&& head
->next
!= ss
)
10356 /* Check we haven't somehow broken the chain. */
10358 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
10360 else /* head2 == head */
10362 gcc_assert (head2
== head
);
10363 /* Second operand is scalar. */
10364 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
10371 /* Reverse a SS chain. */
10374 gfc_reverse_ss (gfc_ss
* ss
)
10379 gcc_assert (ss
!= NULL
);
10381 head
= gfc_ss_terminator
;
10382 while (ss
!= gfc_ss_terminator
)
10385 /* Check we didn't somehow break the chain. */
10386 gcc_assert (next
!= NULL
);
10396 /* Given an expression referring to a procedure, return the symbol of its
10397 interface. We can't get the procedure symbol directly as we have to handle
10398 the case of (deferred) type-bound procedures. */
10401 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
10406 if (procedure_ref
== NULL
)
10409 /* Normal procedure case. */
10410 if (procedure_ref
->expr_type
== EXPR_FUNCTION
10411 && procedure_ref
->value
.function
.esym
)
10412 sym
= procedure_ref
->value
.function
.esym
;
10414 sym
= procedure_ref
->symtree
->n
.sym
;
10416 /* Typebound procedure case. */
10417 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
10419 if (ref
->type
== REF_COMPONENT
10420 && ref
->u
.c
.component
->attr
.proc_pointer
)
10421 sym
= ref
->u
.c
.component
->ts
.interface
;
10430 /* Walk the arguments of an elemental function.
10431 PROC_EXPR is used to check whether an argument is permitted to be absent. If
10432 it is NULL, we don't do the check and the argument is assumed to be present.
10436 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
10437 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
10439 gfc_formal_arglist
*dummy_arg
;
10445 head
= gfc_ss_terminator
;
10449 dummy_arg
= gfc_sym_get_dummy_args (proc_ifc
);
10454 for (; arg
; arg
= arg
->next
)
10456 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
10457 goto loop_continue
;
10459 newss
= gfc_walk_subexpr (head
, arg
->expr
);
10462 /* Scalar argument. */
10463 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
10464 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
10465 newss
->info
->type
= type
;
10467 newss
->info
->data
.scalar
.dummy_arg
= dummy_arg
->sym
;
10472 if (dummy_arg
!= NULL
10473 && dummy_arg
->sym
->attr
.optional
10474 && arg
->expr
->expr_type
== EXPR_VARIABLE
10475 && (gfc_expr_attr (arg
->expr
).optional
10476 || gfc_expr_attr (arg
->expr
).allocatable
10477 || gfc_expr_attr (arg
->expr
).pointer
))
10478 newss
->info
->can_be_null_ref
= true;
10484 while (tail
->next
!= gfc_ss_terminator
)
10489 if (dummy_arg
!= NULL
)
10490 dummy_arg
= dummy_arg
->next
;
10495 /* If all the arguments are scalar we don't need the argument SS. */
10496 gfc_free_ss_chain (head
);
10497 /* Pass it back. */
10501 /* Add it onto the existing chain. */
10507 /* Walk a function call. Scalar functions are passed back, and taken out of
10508 scalarization loops. For elemental functions we walk their arguments.
10509 The result of functions returning arrays is stored in a temporary outside
10510 the loop, so that the function is only called once. Hence we do not need
10511 to walk their arguments. */
10514 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
10516 gfc_intrinsic_sym
*isym
;
10518 gfc_component
*comp
= NULL
;
10520 isym
= expr
->value
.function
.isym
;
10522 /* Handle intrinsic functions separately. */
10524 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
10526 sym
= expr
->value
.function
.esym
;
10528 sym
= expr
->symtree
->n
.sym
;
10530 if (gfc_is_alloc_class_array_function (expr
))
10531 return gfc_get_array_ss (ss
, expr
,
10532 CLASS_DATA (expr
->value
.function
.esym
->result
)->as
->rank
,
10535 /* A function that returns arrays. */
10536 comp
= gfc_get_proc_ptr_comp (expr
);
10537 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
10538 || (comp
&& comp
->attr
.dimension
))
10539 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10541 /* Walk the parameters of an elemental function. For now we always pass
10543 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
10545 gfc_ss
*old_ss
= ss
;
10547 ss
= gfc_walk_elemental_function_args (old_ss
,
10548 expr
->value
.function
.actual
,
10549 gfc_get_proc_ifc_for_expr (expr
),
10553 || sym
->attr
.proc_pointer
10554 || sym
->attr
.if_source
!= IFSRC_DECL
10555 || sym
->attr
.array_outer_dependency
))
10556 ss
->info
->array_outer_dependency
= 1;
10559 /* Scalar functions are OK as these are evaluated outside the scalarization
10560 loop. Pass back and let the caller deal with it. */
10565 /* An array temporary is constructed for array constructors. */
10568 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
10570 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
10574 /* Walk an expression. Add walked expressions to the head of the SS chain.
10575 A wholly scalar expression will not be added. */
10578 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
10582 switch (expr
->expr_type
)
10584 case EXPR_VARIABLE
:
10585 head
= gfc_walk_variable_expr (ss
, expr
);
10589 head
= gfc_walk_op_expr (ss
, expr
);
10592 case EXPR_FUNCTION
:
10593 head
= gfc_walk_function_expr (ss
, expr
);
10596 case EXPR_CONSTANT
:
10598 case EXPR_STRUCTURE
:
10599 /* Pass back and let the caller deal with it. */
10603 head
= gfc_walk_array_constructor (ss
, expr
);
10606 case EXPR_SUBSTRING
:
10607 /* Pass back and let the caller deal with it. */
10611 gfc_internal_error ("bad expression type during walk (%d)",
10618 /* Entry point for expression walking.
10619 A return value equal to the passed chain means this is
10620 a scalar expression. It is up to the caller to take whatever action is
10621 necessary to translate these. */
10624 gfc_walk_expr (gfc_expr
* expr
)
10628 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
10629 return gfc_reverse_ss (res
);