1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In Fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subscripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
84 #include "gimple.h" /* For create_tmp_var_name. */
85 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
88 #include "constructor.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
98 /* The contents of this structure aren't actually used, just the address. */
99 static gfc_ss gfc_ss_terminator_var
;
100 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
104 gfc_array_dataptr_type (tree desc
)
106 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
110 /* Build expressions to access the members of an array descriptor.
111 It's surprisingly easy to mess up here, so never access
112 an array descriptor by "brute force", always use these
113 functions. This also avoids problems if we change the format
114 of an array descriptor.
116 To understand these magic numbers, look at the comments
117 before gfc_build_array_type() in trans-types.c.
119 The code within these defines should be the only code which knows the format
120 of an array descriptor.
122 Any code just needing to read obtain the bounds of an array should use
123 gfc_conv_array_* rather than the following functions as these will return
124 know constant values, and work with arrays which do not have descriptors.
126 Don't forget to #undef these! */
129 #define OFFSET_FIELD 1
130 #define DTYPE_FIELD 2
131 #define DIMENSION_FIELD 3
132 #define CAF_TOKEN_FIELD 4
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc
)
146 type
= TREE_TYPE (desc
);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
149 field
= TYPE_FIELDS (type
);
150 gcc_assert (DATA_FIELD
== 0);
152 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
154 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set. */
168 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
172 type
= TREE_TYPE (desc
);
173 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
175 field
= TYPE_FIELDS (type
);
176 gcc_assert (DATA_FIELD
== 0);
178 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
180 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
184 /* This provides address access to the data field. This should only be
185 used by array allocation, passing this on to the runtime. */
188 gfc_conv_descriptor_data_addr (tree desc
)
192 type
= TREE_TYPE (desc
);
193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
195 field
= TYPE_FIELDS (type
);
196 gcc_assert (DATA_FIELD
== 0);
198 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
200 return gfc_build_addr_expr (NULL_TREE
, t
);
204 gfc_conv_descriptor_offset (tree desc
)
209 type
= TREE_TYPE (desc
);
210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
212 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
213 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
215 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
216 desc
, field
, NULL_TREE
);
220 gfc_conv_descriptor_offset_get (tree desc
)
222 return gfc_conv_descriptor_offset (desc
);
226 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
229 tree t
= gfc_conv_descriptor_offset (desc
);
230 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
235 gfc_conv_descriptor_dtype (tree desc
)
240 type
= TREE_TYPE (desc
);
241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
243 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
244 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
246 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
247 desc
, field
, NULL_TREE
);
252 gfc_conv_descriptor_rank (tree desc
)
257 dtype
= gfc_conv_descriptor_dtype (desc
);
258 tmp
= build_int_cst (TREE_TYPE (dtype
), GFC_DTYPE_RANK_MASK
);
259 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (dtype
),
261 return fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
266 gfc_get_descriptor_dimension (tree desc
)
270 type
= TREE_TYPE (desc
);
271 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
273 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
274 gcc_assert (field
!= NULL_TREE
275 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
276 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
278 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
279 desc
, field
, NULL_TREE
);
284 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
288 tmp
= gfc_get_descriptor_dimension (desc
);
290 return gfc_build_array_ref (tmp
, dim
, NULL
);
295 gfc_conv_descriptor_token (tree desc
)
300 type
= TREE_TYPE (desc
);
301 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
302 gcc_assert (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
);
303 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
304 field
= gfc_advance_chain (TYPE_FIELDS (type
), CAF_TOKEN_FIELD
);
305 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == prvoid_type_node
);
307 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
308 desc
, field
, NULL_TREE
);
313 gfc_conv_descriptor_stride (tree desc
, tree dim
)
318 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
319 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
320 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
321 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
323 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
324 tmp
, field
, NULL_TREE
);
329 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
331 tree type
= TREE_TYPE (desc
);
332 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
333 if (integer_zerop (dim
)
334 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
335 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
336 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
337 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
338 return gfc_index_one_node
;
340 return gfc_conv_descriptor_stride (desc
, dim
);
344 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
345 tree dim
, tree value
)
347 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
348 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
352 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
357 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
358 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
359 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
360 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
362 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
363 tmp
, field
, NULL_TREE
);
368 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
370 return gfc_conv_descriptor_lbound (desc
, dim
);
374 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
375 tree dim
, tree value
)
377 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
378 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
382 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
387 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
388 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
389 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
390 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
392 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
393 tmp
, field
, NULL_TREE
);
398 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
400 return gfc_conv_descriptor_ubound (desc
, dim
);
404 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
405 tree dim
, tree value
)
407 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
408 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
411 /* Build a null array descriptor constructor. */
414 gfc_build_null_descriptor (tree type
)
419 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
420 gcc_assert (DATA_FIELD
== 0);
421 field
= TYPE_FIELDS (type
);
423 /* Set a NULL data pointer. */
424 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
425 TREE_CONSTANT (tmp
) = 1;
426 /* All other fields are ignored. */
432 /* Modify a descriptor such that the lbound of a given dimension is the value
433 specified. This also updates ubound and offset accordingly. */
436 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
437 int dim
, tree new_lbound
)
439 tree offs
, ubound
, lbound
, stride
;
440 tree diff
, offs_diff
;
442 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
444 offs
= gfc_conv_descriptor_offset_get (desc
);
445 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
446 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
447 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
449 /* Get difference (new - old) by which to shift stuff. */
450 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
453 /* Shift ubound and offset accordingly. This has to be done before
454 updating the lbound, as they depend on the lbound expression! */
455 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
457 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
458 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
460 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
462 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
464 /* Finally set lbound to value we want. */
465 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
469 /* Cleanup those #defines. */
474 #undef DIMENSION_FIELD
475 #undef CAF_TOKEN_FIELD
476 #undef STRIDE_SUBFIELD
477 #undef LBOUND_SUBFIELD
478 #undef UBOUND_SUBFIELD
481 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
482 flags & 1 = Main loop body.
483 flags & 2 = temp copy loop. */
486 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
488 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
489 ss
->info
->useflags
= flags
;
493 /* Free a gfc_ss chain. */
496 gfc_free_ss_chain (gfc_ss
* ss
)
500 while (ss
!= gfc_ss_terminator
)
502 gcc_assert (ss
!= NULL
);
511 free_ss_info (gfc_ss_info
*ss_info
)
514 if (ss_info
->refcount
> 0)
517 gcc_assert (ss_info
->refcount
== 0);
525 gfc_free_ss (gfc_ss
* ss
)
527 gfc_ss_info
*ss_info
;
532 switch (ss_info
->type
)
535 for (n
= 0; n
< ss
->dimen
; n
++)
537 if (ss_info
->data
.array
.subscript
[ss
->dim
[n
]])
538 gfc_free_ss_chain (ss_info
->data
.array
.subscript
[ss
->dim
[n
]]);
546 free_ss_info (ss_info
);
551 /* Creates and initializes an array type gfc_ss struct. */
554 gfc_get_array_ss (gfc_ss
*next
, gfc_expr
*expr
, int dimen
, gfc_ss_type type
)
557 gfc_ss_info
*ss_info
;
560 ss_info
= gfc_get_ss_info ();
562 ss_info
->type
= type
;
563 ss_info
->expr
= expr
;
569 for (i
= 0; i
< ss
->dimen
; i
++)
576 /* Creates and initializes a temporary type gfc_ss struct. */
579 gfc_get_temp_ss (tree type
, tree string_length
, int dimen
)
582 gfc_ss_info
*ss_info
;
585 ss_info
= gfc_get_ss_info ();
587 ss_info
->type
= GFC_SS_TEMP
;
588 ss_info
->string_length
= string_length
;
589 ss_info
->data
.temp
.type
= type
;
593 ss
->next
= gfc_ss_terminator
;
595 for (i
= 0; i
< ss
->dimen
; i
++)
602 /* Creates and initializes a scalar type gfc_ss struct. */
605 gfc_get_scalar_ss (gfc_ss
*next
, gfc_expr
*expr
)
608 gfc_ss_info
*ss_info
;
610 ss_info
= gfc_get_ss_info ();
612 ss_info
->type
= GFC_SS_SCALAR
;
613 ss_info
->expr
= expr
;
623 /* Free all the SS associated with a loop. */
626 gfc_cleanup_loop (gfc_loopinfo
* loop
)
628 gfc_loopinfo
*loop_next
, **ploop
;
633 while (ss
!= gfc_ss_terminator
)
635 gcc_assert (ss
!= NULL
);
636 next
= ss
->loop_chain
;
641 /* Remove reference to self in the parent loop. */
643 for (ploop
= &loop
->parent
->nested
; *ploop
; ploop
= &(*ploop
)->next
)
650 /* Free non-freed nested loops. */
651 for (loop
= loop
->nested
; loop
; loop
= loop_next
)
653 loop_next
= loop
->next
;
654 gfc_cleanup_loop (loop
);
661 set_ss_loop (gfc_ss
*ss
, gfc_loopinfo
*loop
)
665 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
669 if (ss
->info
->type
== GFC_SS_SCALAR
670 || ss
->info
->type
== GFC_SS_REFERENCE
671 || ss
->info
->type
== GFC_SS_TEMP
)
674 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
675 if (ss
->info
->data
.array
.subscript
[n
] != NULL
)
676 set_ss_loop (ss
->info
->data
.array
.subscript
[n
], loop
);
681 /* Associate a SS chain with a loop. */
684 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
687 gfc_loopinfo
*nested_loop
;
689 if (head
== gfc_ss_terminator
)
692 set_ss_loop (head
, loop
);
695 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
699 nested_loop
= ss
->nested_ss
->loop
;
701 /* More than one ss can belong to the same loop. Hence, we add the
702 loop to the chain only if it is different from the previously
703 added one, to avoid duplicate nested loops. */
704 if (nested_loop
!= loop
->nested
)
706 gcc_assert (nested_loop
->parent
== NULL
);
707 nested_loop
->parent
= loop
;
709 gcc_assert (nested_loop
->next
== NULL
);
710 nested_loop
->next
= loop
->nested
;
711 loop
->nested
= nested_loop
;
714 gcc_assert (nested_loop
->parent
== loop
);
717 if (ss
->next
== gfc_ss_terminator
)
718 ss
->loop_chain
= loop
->ss
;
720 ss
->loop_chain
= ss
->next
;
722 gcc_assert (ss
== gfc_ss_terminator
);
727 /* Generate an initializer for a static pointer or allocatable array. */
730 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
734 gcc_assert (TREE_STATIC (sym
->backend_decl
));
735 /* Just zero the data member. */
736 type
= TREE_TYPE (sym
->backend_decl
);
737 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
741 /* If the bounds of SE's loop have not yet been set, see if they can be
742 determined from array spec AS, which is the array spec of a called
743 function. MAPPING maps the callee's dummy arguments to the values
744 that the caller is passing. Add any initialization and finalization
748 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
749 gfc_se
* se
, gfc_array_spec
* as
)
751 int n
, dim
, total_dim
;
760 if (!as
|| as
->type
!= AS_EXPLICIT
)
763 for (ss
= se
->ss
; ss
; ss
= ss
->parent
)
765 total_dim
+= ss
->loop
->dimen
;
766 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
768 /* The bound is known, nothing to do. */
769 if (ss
->loop
->to
[n
] != NULL_TREE
)
773 gcc_assert (dim
< as
->rank
);
774 gcc_assert (ss
->loop
->dimen
<= as
->rank
);
776 /* Evaluate the lower bound. */
777 gfc_init_se (&tmpse
, NULL
);
778 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
779 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
780 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
781 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
783 /* ...and the upper bound. */
784 gfc_init_se (&tmpse
, NULL
);
785 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
786 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
787 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
788 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
790 /* Set the upper bound of the loop to UPPER - LOWER. */
791 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
792 gfc_array_index_type
, upper
, lower
);
793 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
794 ss
->loop
->to
[n
] = tmp
;
798 gcc_assert (total_dim
== as
->rank
);
802 /* Generate code to allocate an array temporary, or create a variable to
803 hold the data. If size is NULL, zero the descriptor so that the
804 callee will allocate the array. If DEALLOC is true, also generate code to
805 free the array afterwards.
807 If INITIAL is not NULL, it is packed using internal_pack and the result used
808 as data instead of allocating a fresh, unitialized area of memory.
810 Initialization code is added to PRE and finalization code to POST.
811 DYNAMIC is true if the caller may want to extend the array later
812 using realloc. This prevents us from putting the array on the stack. */
815 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
816 gfc_array_info
* info
, tree size
, tree nelem
,
817 tree initial
, bool dynamic
, bool dealloc
)
823 desc
= info
->descriptor
;
824 info
->offset
= gfc_index_zero_node
;
825 if (size
== NULL_TREE
|| integer_zerop (size
))
827 /* A callee allocated array. */
828 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
833 /* Allocate the temporary. */
834 onstack
= !dynamic
&& initial
== NULL_TREE
835 && (gfc_option
.flag_stack_arrays
836 || gfc_can_put_var_on_stack (size
));
840 /* Make a temporary variable to hold the data. */
841 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
842 nelem
, gfc_index_one_node
);
843 tmp
= gfc_evaluate_now (tmp
, pre
);
844 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
846 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
848 tmp
= gfc_create_var (tmp
, "A");
849 /* If we're here only because of -fstack-arrays we have to
850 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
851 if (!gfc_can_put_var_on_stack (size
))
852 gfc_add_expr_to_block (pre
,
853 fold_build1_loc (input_location
,
854 DECL_EXPR
, TREE_TYPE (tmp
),
856 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
857 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
861 /* Allocate memory to hold the data or call internal_pack. */
862 if (initial
== NULL_TREE
)
864 tmp
= gfc_call_malloc (pre
, NULL
, size
);
865 tmp
= gfc_evaluate_now (tmp
, pre
);
872 stmtblock_t do_copying
;
874 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
875 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
876 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
877 tmp
= gfc_get_element_type (tmp
);
878 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
879 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
881 tmp
= build_call_expr_loc (input_location
,
882 gfor_fndecl_in_pack
, 1, initial
);
883 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
884 gfc_add_modify (pre
, packed
, tmp
);
886 tmp
= build_fold_indirect_ref_loc (input_location
,
888 source_data
= gfc_conv_descriptor_data_get (tmp
);
890 /* internal_pack may return source->data without any allocation
891 or copying if it is already packed. If that's the case, we
892 need to allocate and copy manually. */
894 gfc_start_block (&do_copying
);
895 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
896 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
897 gfc_add_modify (&do_copying
, packed
, tmp
);
898 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
899 gfc_add_expr_to_block (&do_copying
, tmp
);
901 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
902 boolean_type_node
, packed
,
904 tmp
= gfc_finish_block (&do_copying
);
905 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
906 build_empty_stmt (input_location
));
907 gfc_add_expr_to_block (pre
, tmp
);
909 tmp
= fold_convert (pvoid_type_node
, packed
);
912 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
915 info
->data
= gfc_conv_descriptor_data_get (desc
);
917 /* The offset is zero because we create temporaries with a zero
919 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
921 if (dealloc
&& !onstack
)
923 /* Free the temporary. */
924 tmp
= gfc_conv_descriptor_data_get (desc
);
925 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
926 gfc_add_expr_to_block (post
, tmp
);
931 /* Get the scalarizer array dimension corresponding to actual array dimension
934 For example, if SS represents the array ref a(1,:,:,1), it is a
935 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
936 and 1 for ARRAY_DIM=2.
937 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
938 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
940 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
941 array. If called on the inner ss, the result would be respectively 0,1,2 for
942 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
943 for ARRAY_DIM=1,2. */
946 get_scalarizer_dim_for_array_dim (gfc_ss
*ss
, int array_dim
)
953 for (; ss
; ss
= ss
->parent
)
954 for (n
= 0; n
< ss
->dimen
; n
++)
955 if (ss
->dim
[n
] < array_dim
)
958 return array_ref_dim
;
963 innermost_ss (gfc_ss
*ss
)
965 while (ss
->nested_ss
!= NULL
)
973 /* Get the array reference dimension corresponding to the given loop dimension.
974 It is different from the true array dimension given by the dim array in
975 the case of a partial array reference (i.e. a(:,:,1,:) for example)
976 It is different from the loop dimension in the case of a transposed array.
980 get_array_ref_dim_for_loop_dim (gfc_ss
*ss
, int loop_dim
)
982 return get_scalarizer_dim_for_array_dim (innermost_ss (ss
),
987 /* Generate code to create and initialize the descriptor for a temporary
988 array. This is used for both temporaries needed by the scalarizer, and
989 functions returning arrays. Adjusts the loop variables to be
990 zero-based, and calculates the loop bounds for callee allocated arrays.
991 Allocate the array unless it's callee allocated (we have a callee
992 allocated array if 'callee_alloc' is true, or if loop->to[n] is
993 NULL_TREE for any n). Also fills in the descriptor, data and offset
994 fields of info if known. Returns the size of the array, or NULL for a
995 callee allocated array.
997 'eltype' == NULL signals that the temporary should be a class object.
998 The 'initial' expression is used to obtain the size of the dynamic
999 type; otherwise the allocation and initialisation proceeds as for any
1002 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1003 gfc_trans_allocate_array_storage. */
1006 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
, gfc_ss
* ss
,
1007 tree eltype
, tree initial
, bool dynamic
,
1008 bool dealloc
, bool callee_alloc
, locus
* where
)
1012 gfc_array_info
*info
;
1013 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
1021 tree class_expr
= NULL_TREE
;
1022 int n
, dim
, tmp_dim
;
1025 /* This signals a class array for which we need the size of the
1026 dynamic type. Generate an eltype and then the class expression. */
1027 if (eltype
== NULL_TREE
&& initial
)
1029 if (POINTER_TYPE_P (TREE_TYPE (initial
)))
1030 class_expr
= build_fold_indirect_ref_loc (input_location
, initial
);
1031 eltype
= TREE_TYPE (class_expr
);
1032 eltype
= gfc_get_element_type (eltype
);
1033 /* Obtain the structure (class) expression. */
1034 class_expr
= TREE_OPERAND (class_expr
, 0);
1035 gcc_assert (class_expr
);
1038 memset (from
, 0, sizeof (from
));
1039 memset (to
, 0, sizeof (to
));
1041 info
= &ss
->info
->data
.array
;
1043 gcc_assert (ss
->dimen
> 0);
1044 gcc_assert (ss
->loop
->dimen
== ss
->dimen
);
1046 if (gfc_option
.warn_array_temp
&& where
)
1047 gfc_warning ("Creating array temporary at %L", where
);
1049 /* Set the lower bound to zero. */
1050 for (s
= ss
; s
; s
= s
->parent
)
1054 total_dim
+= loop
->dimen
;
1055 for (n
= 0; n
< loop
->dimen
; n
++)
1059 /* Callee allocated arrays may not have a known bound yet. */
1061 loop
->to
[n
] = gfc_evaluate_now (
1062 fold_build2_loc (input_location
, MINUS_EXPR
,
1063 gfc_array_index_type
,
1064 loop
->to
[n
], loop
->from
[n
]),
1066 loop
->from
[n
] = gfc_index_zero_node
;
1068 /* We have just changed the loop bounds, we must clear the
1069 corresponding specloop, so that delta calculation is not skipped
1070 later in gfc_set_delta. */
1071 loop
->specloop
[n
] = NULL
;
1073 /* We are constructing the temporary's descriptor based on the loop
1074 dimensions. As the dimensions may be accessed in arbitrary order
1075 (think of transpose) the size taken from the n'th loop may not map
1076 to the n'th dimension of the array. We need to reconstruct loop
1077 infos in the right order before using it to set the descriptor
1079 tmp_dim
= get_scalarizer_dim_for_array_dim (ss
, dim
);
1080 from
[tmp_dim
] = loop
->from
[n
];
1081 to
[tmp_dim
] = loop
->to
[n
];
1083 info
->delta
[dim
] = gfc_index_zero_node
;
1084 info
->start
[dim
] = gfc_index_zero_node
;
1085 info
->end
[dim
] = gfc_index_zero_node
;
1086 info
->stride
[dim
] = gfc_index_one_node
;
1090 /* Initialize the descriptor. */
1092 gfc_get_array_type_bounds (eltype
, total_dim
, 0, from
, to
, 1,
1093 GFC_ARRAY_UNKNOWN
, true);
1094 desc
= gfc_create_var (type
, "atmp");
1095 GFC_DECL_PACKED_ARRAY (desc
) = 1;
1097 info
->descriptor
= desc
;
1098 size
= gfc_index_one_node
;
1100 /* Fill in the array dtype. */
1101 tmp
= gfc_conv_descriptor_dtype (desc
);
1102 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
1105 Fill in the bounds and stride. This is a packed array, so:
1108 for (n = 0; n < rank; n++)
1111 delta = ubound[n] + 1 - lbound[n];
1112 size = size * delta;
1114 size = size * sizeof(element);
1117 or_expr
= NULL_TREE
;
1119 /* If there is at least one null loop->to[n], it is a callee allocated
1121 for (n
= 0; n
< total_dim
; n
++)
1122 if (to
[n
] == NULL_TREE
)
1128 if (size
== NULL_TREE
)
1129 for (s
= ss
; s
; s
= s
->parent
)
1130 for (n
= 0; n
< s
->loop
->dimen
; n
++)
1132 dim
= get_scalarizer_dim_for_array_dim (ss
, s
->dim
[n
]);
1134 /* For a callee allocated array express the loop bounds in terms
1135 of the descriptor fields. */
1136 tmp
= fold_build2_loc (input_location
,
1137 MINUS_EXPR
, gfc_array_index_type
,
1138 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
1139 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
1140 s
->loop
->to
[n
] = tmp
;
1144 for (n
= 0; n
< total_dim
; n
++)
1146 /* Store the stride and bound components in the descriptor. */
1147 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
1149 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
1150 gfc_index_zero_node
);
1152 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], to
[n
]);
1154 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1155 gfc_array_index_type
,
1156 to
[n
], gfc_index_one_node
);
1158 /* Check whether the size for this dimension is negative. */
1159 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1160 tmp
, gfc_index_zero_node
);
1161 cond
= gfc_evaluate_now (cond
, pre
);
1166 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1167 boolean_type_node
, or_expr
, cond
);
1169 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1170 gfc_array_index_type
, size
, tmp
);
1171 size
= gfc_evaluate_now (size
, pre
);
1175 /* Get the size of the array. */
1176 if (size
&& !callee_alloc
)
1179 /* If or_expr is true, then the extent in at least one
1180 dimension is zero and the size is set to zero. */
1181 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
1182 or_expr
, gfc_index_zero_node
, size
);
1185 if (class_expr
== NULL_TREE
)
1186 elemsize
= fold_convert (gfc_array_index_type
,
1187 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1189 elemsize
= gfc_vtable_size_get (class_expr
);
1191 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1200 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
1206 if (ss
->dimen
> ss
->loop
->temp_dim
)
1207 ss
->loop
->temp_dim
= ss
->dimen
;
1213 /* Return the number of iterations in a loop that starts at START,
1214 ends at END, and has step STEP. */
1217 gfc_get_iteration_count (tree start
, tree end
, tree step
)
1222 type
= TREE_TYPE (step
);
1223 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
1224 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
1225 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
1226 build_int_cst (type
, 1));
1227 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
1228 build_int_cst (type
, 0));
1229 return fold_convert (gfc_array_index_type
, tmp
);
1233 /* Extend the data in array DESC by EXTRA elements. */
1236 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
1243 if (integer_zerop (extra
))
1246 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1248 /* Add EXTRA to the upper bound. */
1249 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1251 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
1253 /* Get the value of the current data pointer. */
1254 arg0
= gfc_conv_descriptor_data_get (desc
);
1256 /* Calculate the new array size. */
1257 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
1258 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1259 ubound
, gfc_index_one_node
);
1260 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
1261 fold_convert (size_type_node
, tmp
),
1262 fold_convert (size_type_node
, size
));
1264 /* Call the realloc() function. */
1265 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
1266 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
1270 /* Return true if the bounds of iterator I can only be determined
1274 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
1276 return (i
->start
->expr_type
!= EXPR_CONSTANT
1277 || i
->end
->expr_type
!= EXPR_CONSTANT
1278 || i
->step
->expr_type
!= EXPR_CONSTANT
);
1282 /* Split the size of constructor element EXPR into the sum of two terms,
1283 one of which can be determined at compile time and one of which must
1284 be calculated at run time. Set *SIZE to the former and return true
1285 if the latter might be nonzero. */
1288 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
1290 if (expr
->expr_type
== EXPR_ARRAY
)
1291 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1292 else if (expr
->rank
> 0)
1294 /* Calculate everything at run time. */
1295 mpz_set_ui (*size
, 0);
1300 /* A single element. */
1301 mpz_set_ui (*size
, 1);
1307 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1308 of array constructor C. */
1311 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1319 mpz_set_ui (*size
, 0);
1324 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1327 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1331 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1334 /* Multiply the static part of the element size by the
1335 number of iterations. */
1336 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1337 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1338 mpz_add_ui (val
, val
, 1);
1339 if (mpz_sgn (val
) > 0)
1340 mpz_mul (len
, len
, val
);
1342 mpz_set_ui (len
, 0);
1344 mpz_add (*size
, *size
, len
);
1353 /* Make sure offset is a variable. */
1356 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1359 /* We should have already created the offset variable. We cannot
1360 create it here because we may be in an inner scope. */
1361 gcc_assert (*offsetvar
!= NULL_TREE
);
1362 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1363 *poffset
= *offsetvar
;
1364 TREE_USED (*offsetvar
) = 1;
1368 /* Variables needed for bounds-checking. */
1369 static bool first_len
;
1370 static tree first_len_val
;
1371 static bool typespec_chararray_ctor
;
1374 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1375 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1379 gfc_conv_expr (se
, expr
);
1381 /* Store the value. */
1382 tmp
= build_fold_indirect_ref_loc (input_location
,
1383 gfc_conv_descriptor_data_get (desc
));
1384 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1386 if (expr
->ts
.type
== BT_CHARACTER
)
1388 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1391 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1392 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1393 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1394 gfc_charlen_type_node
, esize
,
1395 build_int_cst (gfc_charlen_type_node
,
1396 gfc_character_kinds
[i
].bit_size
/ 8));
1398 gfc_conv_string_parameter (se
);
1399 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1401 /* The temporary is an array of pointers. */
1402 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1403 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1407 /* The temporary is an array of string values. */
1408 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1409 /* We know the temporary and the value will be the same length,
1410 so can use memcpy. */
1411 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1412 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1414 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1418 gfc_add_modify (&se
->pre
, first_len_val
,
1424 /* Verify that all constructor elements are of the same
1426 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1427 boolean_type_node
, first_len_val
,
1429 gfc_trans_runtime_check
1430 (true, false, cond
, &se
->pre
, &expr
->where
,
1431 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1432 fold_convert (long_integer_type_node
, first_len_val
),
1433 fold_convert (long_integer_type_node
, se
->string_length
));
1439 /* TODO: Should the frontend already have done this conversion? */
1440 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1441 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1444 gfc_add_block_to_block (pblock
, &se
->pre
);
1445 gfc_add_block_to_block (pblock
, &se
->post
);
1449 /* Add the contents of an array to the constructor. DYNAMIC is as for
1450 gfc_trans_array_constructor_value. */
1453 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1454 tree type ATTRIBUTE_UNUSED
,
1455 tree desc
, gfc_expr
* expr
,
1456 tree
* poffset
, tree
* offsetvar
,
1467 /* We need this to be a variable so we can increment it. */
1468 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1470 gfc_init_se (&se
, NULL
);
1472 /* Walk the array expression. */
1473 ss
= gfc_walk_expr (expr
);
1474 gcc_assert (ss
!= gfc_ss_terminator
);
1476 /* Initialize the scalarizer. */
1477 gfc_init_loopinfo (&loop
);
1478 gfc_add_ss_to_loop (&loop
, ss
);
1480 /* Initialize the loop. */
1481 gfc_conv_ss_startstride (&loop
);
1482 gfc_conv_loop_setup (&loop
, &expr
->where
);
1484 /* Make sure the constructed array has room for the new data. */
1487 /* Set SIZE to the total number of elements in the subarray. */
1488 size
= gfc_index_one_node
;
1489 for (n
= 0; n
< loop
.dimen
; n
++)
1491 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1492 gfc_index_one_node
);
1493 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1494 gfc_array_index_type
, size
, tmp
);
1497 /* Grow the constructed array by SIZE elements. */
1498 gfc_grow_array (&loop
.pre
, desc
, size
);
1501 /* Make the loop body. */
1502 gfc_mark_ss_chain_used (ss
, 1);
1503 gfc_start_scalarized_body (&loop
, &body
);
1504 gfc_copy_loopinfo_to_se (&se
, &loop
);
1507 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1508 gcc_assert (se
.ss
== gfc_ss_terminator
);
1510 /* Increment the offset. */
1511 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1512 *poffset
, gfc_index_one_node
);
1513 gfc_add_modify (&body
, *poffset
, tmp
);
1515 /* Finish the loop. */
1516 gfc_trans_scalarizing_loops (&loop
, &body
);
1517 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1518 tmp
= gfc_finish_block (&loop
.pre
);
1519 gfc_add_expr_to_block (pblock
, tmp
);
1521 gfc_cleanup_loop (&loop
);
1525 /* Assign the values to the elements of an array constructor. DYNAMIC
1526 is true if descriptor DESC only contains enough data for the static
1527 size calculated by gfc_get_array_constructor_size. When true, memory
1528 for the dynamic parts must be allocated using realloc. */
1531 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1532 tree desc
, gfc_constructor_base base
,
1533 tree
* poffset
, tree
* offsetvar
,
1537 tree start
= NULL_TREE
;
1538 tree end
= NULL_TREE
;
1539 tree step
= NULL_TREE
;
1545 tree shadow_loopvar
= NULL_TREE
;
1546 gfc_saved_var saved_loopvar
;
1549 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1551 /* If this is an iterator or an array, the offset must be a variable. */
1552 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1553 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1555 /* Shadowing the iterator avoids changing its value and saves us from
1556 keeping track of it. Further, it makes sure that there's always a
1557 backend-decl for the symbol, even if there wasn't one before,
1558 e.g. in the case of an iterator that appears in a specification
1559 expression in an interface mapping. */
1565 /* Evaluate loop bounds before substituting the loop variable
1566 in case they depend on it. Such a case is invalid, but it is
1567 not more expensive to do the right thing here.
1569 gfc_init_se (&se
, NULL
);
1570 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1571 gfc_add_block_to_block (pblock
, &se
.pre
);
1572 start
= gfc_evaluate_now (se
.expr
, pblock
);
1574 gfc_init_se (&se
, NULL
);
1575 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1576 gfc_add_block_to_block (pblock
, &se
.pre
);
1577 end
= gfc_evaluate_now (se
.expr
, pblock
);
1579 gfc_init_se (&se
, NULL
);
1580 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1581 gfc_add_block_to_block (pblock
, &se
.pre
);
1582 step
= gfc_evaluate_now (se
.expr
, pblock
);
1584 sym
= c
->iterator
->var
->symtree
->n
.sym
;
1585 type
= gfc_typenode_for_spec (&sym
->ts
);
1587 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1588 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1591 gfc_start_block (&body
);
1593 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1595 /* Array constructors can be nested. */
1596 gfc_trans_array_constructor_value (&body
, type
, desc
,
1597 c
->expr
->value
.constructor
,
1598 poffset
, offsetvar
, dynamic
);
1600 else if (c
->expr
->rank
> 0)
1602 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1603 poffset
, offsetvar
, dynamic
);
1607 /* This code really upsets the gimplifier so don't bother for now. */
1614 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1616 p
= gfc_constructor_next (p
);
1621 /* Scalar values. */
1622 gfc_init_se (&se
, NULL
);
1623 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1626 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1627 gfc_array_index_type
,
1628 *poffset
, gfc_index_one_node
);
1632 /* Collect multiple scalar constants into a constructor. */
1633 VEC(constructor_elt
,gc
) *v
= NULL
;
1637 HOST_WIDE_INT idx
= 0;
1640 /* Count the number of consecutive scalar constants. */
1641 while (p
&& !(p
->iterator
1642 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1644 gfc_init_se (&se
, NULL
);
1645 gfc_conv_constant (&se
, p
->expr
);
1647 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1648 se
.expr
= fold_convert (type
, se
.expr
);
1649 /* For constant character array constructors we build
1650 an array of pointers. */
1651 else if (POINTER_TYPE_P (type
))
1652 se
.expr
= gfc_build_addr_expr
1653 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1656 CONSTRUCTOR_APPEND_ELT (v
,
1657 build_int_cst (gfc_array_index_type
,
1661 p
= gfc_constructor_next (p
);
1664 bound
= size_int (n
- 1);
1665 /* Create an array type to hold them. */
1666 tmptype
= build_range_type (gfc_array_index_type
,
1667 gfc_index_zero_node
, bound
);
1668 tmptype
= build_array_type (type
, tmptype
);
1670 init
= build_constructor (tmptype
, v
);
1671 TREE_CONSTANT (init
) = 1;
1672 TREE_STATIC (init
) = 1;
1673 /* Create a static variable to hold the data. */
1674 tmp
= gfc_create_var (tmptype
, "data");
1675 TREE_STATIC (tmp
) = 1;
1676 TREE_CONSTANT (tmp
) = 1;
1677 TREE_READONLY (tmp
) = 1;
1678 DECL_INITIAL (tmp
) = init
;
1681 /* Use BUILTIN_MEMCPY to assign the values. */
1682 tmp
= gfc_conv_descriptor_data_get (desc
);
1683 tmp
= build_fold_indirect_ref_loc (input_location
,
1685 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1686 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1687 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1689 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1690 bound
= build_int_cst (size_type_node
, n
* size
);
1691 tmp
= build_call_expr_loc (input_location
,
1692 builtin_decl_explicit (BUILT_IN_MEMCPY
),
1693 3, tmp
, init
, bound
);
1694 gfc_add_expr_to_block (&body
, tmp
);
1696 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1697 gfc_array_index_type
, *poffset
,
1698 build_int_cst (gfc_array_index_type
, n
));
1700 if (!INTEGER_CST_P (*poffset
))
1702 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1703 *poffset
= *offsetvar
;
1707 /* The frontend should already have done any expansions
1711 /* Pass the code as is. */
1712 tmp
= gfc_finish_block (&body
);
1713 gfc_add_expr_to_block (pblock
, tmp
);
1717 /* Build the implied do-loop. */
1718 stmtblock_t implied_do_block
;
1724 loopbody
= gfc_finish_block (&body
);
1726 /* Create a new block that holds the implied-do loop. A temporary
1727 loop-variable is used. */
1728 gfc_start_block(&implied_do_block
);
1730 /* Initialize the loop. */
1731 gfc_add_modify (&implied_do_block
, shadow_loopvar
, start
);
1733 /* If this array expands dynamically, and the number of iterations
1734 is not constant, we won't have allocated space for the static
1735 part of C->EXPR's size. Do that now. */
1736 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1738 /* Get the number of iterations. */
1739 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1741 /* Get the static part of C->EXPR's size. */
1742 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1743 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1745 /* Grow the array by TMP * TMP2 elements. */
1746 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1747 gfc_array_index_type
, tmp
, tmp2
);
1748 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1751 /* Generate the loop body. */
1752 exit_label
= gfc_build_label_decl (NULL_TREE
);
1753 gfc_start_block (&body
);
1755 /* Generate the exit condition. Depending on the sign of
1756 the step variable we have to generate the correct
1758 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1759 step
, build_int_cst (TREE_TYPE (step
), 0));
1760 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1761 boolean_type_node
, tmp
,
1762 fold_build2_loc (input_location
, GT_EXPR
,
1763 boolean_type_node
, shadow_loopvar
, end
),
1764 fold_build2_loc (input_location
, LT_EXPR
,
1765 boolean_type_node
, shadow_loopvar
, end
));
1766 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1767 TREE_USED (exit_label
) = 1;
1768 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1769 build_empty_stmt (input_location
));
1770 gfc_add_expr_to_block (&body
, tmp
);
1772 /* The main loop body. */
1773 gfc_add_expr_to_block (&body
, loopbody
);
1775 /* Increase loop variable by step. */
1776 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1777 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1779 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1781 /* Finish the loop. */
1782 tmp
= gfc_finish_block (&body
);
1783 tmp
= build1_v (LOOP_EXPR
, tmp
);
1784 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1786 /* Add the exit label. */
1787 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1788 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1790 /* Finish the implied-do loop. */
1791 tmp
= gfc_finish_block(&implied_do_block
);
1792 gfc_add_expr_to_block(pblock
, tmp
);
1794 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1801 /* A catch-all to obtain the string length for anything that is not
1802 a substring of non-constant length, a constant, array or variable. */
1805 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1810 /* Don't bother if we already know the length is a constant. */
1811 if (*len
&& INTEGER_CST_P (*len
))
1814 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1815 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1818 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1819 *len
= e
->ts
.u
.cl
->backend_decl
;
1823 /* Otherwise, be brutal even if inefficient. */
1824 ss
= gfc_walk_expr (e
);
1825 gfc_init_se (&se
, NULL
);
1827 /* No function call, in case of side effects. */
1828 se
.no_function_call
= 1;
1829 if (ss
== gfc_ss_terminator
)
1830 gfc_conv_expr (&se
, e
);
1832 gfc_conv_expr_descriptor (&se
, e
, ss
);
1834 /* Fix the value. */
1835 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1837 gfc_add_block_to_block (block
, &se
.pre
);
1838 gfc_add_block_to_block (block
, &se
.post
);
1840 e
->ts
.u
.cl
->backend_decl
= *len
;
1845 /* Figure out the string length of a variable reference expression.
1846 Used by get_array_ctor_strlen. */
1849 get_array_ctor_var_strlen (stmtblock_t
*block
, gfc_expr
* expr
, tree
* len
)
1855 /* Don't bother if we already know the length is a constant. */
1856 if (*len
&& INTEGER_CST_P (*len
))
1859 ts
= &expr
->symtree
->n
.sym
->ts
;
1860 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1865 /* Array references don't change the string length. */
1869 /* Use the length of the component. */
1870 ts
= &ref
->u
.c
.component
->ts
;
1874 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1875 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1877 /* Note that this might evaluate expr. */
1878 get_array_ctor_all_strlen (block
, expr
, len
);
1881 mpz_init_set_ui (char_len
, 1);
1882 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1883 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1884 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1885 *len
= convert (gfc_charlen_type_node
, *len
);
1886 mpz_clear (char_len
);
1894 *len
= ts
->u
.cl
->backend_decl
;
1898 /* Figure out the string length of a character array constructor.
1899 If len is NULL, don't calculate the length; this happens for recursive calls
1900 when a sub-array-constructor is an element but not at the first position,
1901 so when we're not interested in the length.
1902 Returns TRUE if all elements are character constants. */
1905 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1912 if (gfc_constructor_first (base
) == NULL
)
1915 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1919 /* Loop over all constructor elements to find out is_const, but in len we
1920 want to store the length of the first, not the last, element. We can
1921 of course exit the loop as soon as is_const is found to be false. */
1922 for (c
= gfc_constructor_first (base
);
1923 c
&& is_const
; c
= gfc_constructor_next (c
))
1925 switch (c
->expr
->expr_type
)
1928 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1929 *len
= build_int_cstu (gfc_charlen_type_node
,
1930 c
->expr
->value
.character
.length
);
1934 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1941 get_array_ctor_var_strlen (block
, c
->expr
, len
);
1947 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1951 /* After the first iteration, we don't want the length modified. */
1958 /* Check whether the array constructor C consists entirely of constant
1959 elements, and if so returns the number of those elements, otherwise
1960 return zero. Note, an empty or NULL array constructor returns zero. */
1962 unsigned HOST_WIDE_INT
1963 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1965 unsigned HOST_WIDE_INT nelem
= 0;
1967 gfc_constructor
*c
= gfc_constructor_first (base
);
1971 || c
->expr
->rank
> 0
1972 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1974 c
= gfc_constructor_next (c
);
1981 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1982 and the tree type of it's elements, TYPE, return a static constant
1983 variable that is compile-time initialized. */
1986 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1988 tree tmptype
, init
, tmp
;
1989 HOST_WIDE_INT nelem
;
1994 VEC(constructor_elt
,gc
) *v
= NULL
;
1996 /* First traverse the constructor list, converting the constants
1997 to tree to build an initializer. */
1999 c
= gfc_constructor_first (expr
->value
.constructor
);
2002 gfc_init_se (&se
, NULL
);
2003 gfc_conv_constant (&se
, c
->expr
);
2004 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
2005 se
.expr
= fold_convert (type
, se
.expr
);
2006 else if (POINTER_TYPE_P (type
))
2007 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
2009 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
2011 c
= gfc_constructor_next (c
);
2015 /* Next determine the tree type for the array. We use the gfortran
2016 front-end's gfc_get_nodesc_array_type in order to create a suitable
2017 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2019 memset (&as
, 0, sizeof (gfc_array_spec
));
2021 as
.rank
= expr
->rank
;
2022 as
.type
= AS_EXPLICIT
;
2025 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2026 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
2030 for (i
= 0; i
< expr
->rank
; i
++)
2032 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
2033 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2034 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
2038 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
2040 /* as is not needed anymore. */
2041 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
2043 gfc_free_expr (as
.lower
[i
]);
2044 gfc_free_expr (as
.upper
[i
]);
2047 init
= build_constructor (tmptype
, v
);
2049 TREE_CONSTANT (init
) = 1;
2050 TREE_STATIC (init
) = 1;
2052 tmp
= gfc_create_var (tmptype
, "A");
2053 TREE_STATIC (tmp
) = 1;
2054 TREE_CONSTANT (tmp
) = 1;
2055 TREE_READONLY (tmp
) = 1;
2056 DECL_INITIAL (tmp
) = init
;
2062 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2063 This mostly initializes the scalarizer state info structure with the
2064 appropriate values to directly use the array created by the function
2065 gfc_build_constant_array_constructor. */
2068 trans_constant_array_constructor (gfc_ss
* ss
, tree type
)
2070 gfc_array_info
*info
;
2074 tmp
= gfc_build_constant_array_constructor (ss
->info
->expr
, type
);
2076 info
= &ss
->info
->data
.array
;
2078 info
->descriptor
= tmp
;
2079 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2080 info
->offset
= gfc_index_zero_node
;
2082 for (i
= 0; i
< ss
->dimen
; i
++)
2084 info
->delta
[i
] = gfc_index_zero_node
;
2085 info
->start
[i
] = gfc_index_zero_node
;
2086 info
->end
[i
] = gfc_index_zero_node
;
2087 info
->stride
[i
] = gfc_index_one_node
;
2093 get_rank (gfc_loopinfo
*loop
)
2098 for (; loop
; loop
= loop
->parent
)
2099 rank
+= loop
->dimen
;
2105 /* Helper routine of gfc_trans_array_constructor to determine if the
2106 bounds of the loop specified by LOOP are constant and simple enough
2107 to use with trans_constant_array_constructor. Returns the
2108 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2111 constant_array_constructor_loop_size (gfc_loopinfo
* l
)
2114 tree size
= gfc_index_one_node
;
2118 total_dim
= get_rank (l
);
2120 for (loop
= l
; loop
; loop
= loop
->parent
)
2122 for (i
= 0; i
< loop
->dimen
; i
++)
2124 /* If the bounds aren't constant, return NULL_TREE. */
2125 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
2127 if (!integer_zerop (loop
->from
[i
]))
2129 /* Only allow nonzero "from" in one-dimensional arrays. */
2132 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2133 gfc_array_index_type
,
2134 loop
->to
[i
], loop
->from
[i
]);
2138 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2139 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2140 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2141 gfc_array_index_type
, size
, tmp
);
2150 get_loop_upper_bound_for_array (gfc_ss
*array
, int array_dim
)
2155 gcc_assert (array
->nested_ss
== NULL
);
2157 for (ss
= array
; ss
; ss
= ss
->parent
)
2158 for (n
= 0; n
< ss
->loop
->dimen
; n
++)
2159 if (array_dim
== get_array_ref_dim_for_loop_dim (ss
, n
))
2160 return &(ss
->loop
->to
[n
]);
2166 static gfc_loopinfo
*
2167 outermost_loop (gfc_loopinfo
* loop
)
2169 while (loop
->parent
!= NULL
)
2170 loop
= loop
->parent
;
2176 /* Array constructors are handled by constructing a temporary, then using that
2177 within the scalarization loop. This is not optimal, but seems by far the
2181 trans_array_constructor (gfc_ss
* ss
, locus
* where
)
2183 gfc_constructor_base c
;
2191 bool old_first_len
, old_typespec_chararray_ctor
;
2192 tree old_first_len_val
;
2193 gfc_loopinfo
*loop
, *outer_loop
;
2194 gfc_ss_info
*ss_info
;
2198 /* Save the old values for nested checking. */
2199 old_first_len
= first_len
;
2200 old_first_len_val
= first_len_val
;
2201 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
2204 outer_loop
= outermost_loop (loop
);
2206 expr
= ss_info
->expr
;
2208 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2209 typespec was given for the array constructor. */
2210 typespec_chararray_ctor
= (expr
->ts
.u
.cl
2211 && expr
->ts
.u
.cl
->length_from_typespec
);
2213 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2214 && expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
2216 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
2220 gcc_assert (ss
->dimen
== ss
->loop
->dimen
);
2222 c
= expr
->value
.constructor
;
2223 if (expr
->ts
.type
== BT_CHARACTER
)
2227 /* get_array_ctor_strlen walks the elements of the constructor, if a
2228 typespec was given, we already know the string length and want the one
2230 if (typespec_chararray_ctor
&& expr
->ts
.u
.cl
->length
2231 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2235 const_string
= false;
2236 gfc_init_se (&length_se
, NULL
);
2237 gfc_conv_expr_type (&length_se
, expr
->ts
.u
.cl
->length
,
2238 gfc_charlen_type_node
);
2239 ss_info
->string_length
= length_se
.expr
;
2240 gfc_add_block_to_block (&outer_loop
->pre
, &length_se
.pre
);
2241 gfc_add_block_to_block (&outer_loop
->post
, &length_se
.post
);
2244 const_string
= get_array_ctor_strlen (&outer_loop
->pre
, c
,
2245 &ss_info
->string_length
);
2247 /* Complex character array constructors should have been taken care of
2248 and not end up here. */
2249 gcc_assert (ss_info
->string_length
);
2251 expr
->ts
.u
.cl
->backend_decl
= ss_info
->string_length
;
2253 type
= gfc_get_character_type_len (expr
->ts
.kind
, ss_info
->string_length
);
2255 type
= build_pointer_type (type
);
2258 type
= gfc_typenode_for_spec (&expr
->ts
);
2260 /* See if the constructor determines the loop bounds. */
2263 loop_ubound0
= get_loop_upper_bound_for_array (ss
, 0);
2265 if (expr
->shape
&& get_rank (loop
) > 1 && *loop_ubound0
== NULL_TREE
)
2267 /* We have a multidimensional parameter. */
2268 for (s
= ss
; s
; s
= s
->parent
)
2271 for (n
= 0; n
< s
->loop
->dimen
; n
++)
2273 s
->loop
->from
[n
] = gfc_index_zero_node
;
2274 s
->loop
->to
[n
] = gfc_conv_mpz_to_tree (expr
->shape
[s
->dim
[n
]],
2275 gfc_index_integer_kind
);
2276 s
->loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
2277 gfc_array_index_type
,
2279 gfc_index_one_node
);
2284 if (*loop_ubound0
== NULL_TREE
)
2288 /* We should have a 1-dimensional, zero-based loop. */
2289 gcc_assert (loop
->parent
== NULL
&& loop
->nested
== NULL
);
2290 gcc_assert (loop
->dimen
== 1);
2291 gcc_assert (integer_zerop (loop
->from
[0]));
2293 /* Split the constructor size into a static part and a dynamic part.
2294 Allocate the static size up-front and record whether the dynamic
2295 size might be nonzero. */
2297 dynamic
= gfc_get_array_constructor_size (&size
, c
);
2298 mpz_sub_ui (size
, size
, 1);
2299 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
2303 /* Special case constant array constructors. */
2306 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
2309 tree size
= constant_array_constructor_loop_size (loop
);
2310 if (size
&& compare_tree_int (size
, nelem
) == 0)
2312 trans_constant_array_constructor (ss
, type
);
2318 if (TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2321 gfc_trans_create_temp_array (&outer_loop
->pre
, &outer_loop
->post
, ss
, type
,
2322 NULL_TREE
, dynamic
, true, false, where
);
2324 desc
= ss_info
->data
.array
.descriptor
;
2325 offset
= gfc_index_zero_node
;
2326 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
2327 TREE_NO_WARNING (offsetvar
) = 1;
2328 TREE_USED (offsetvar
) = 0;
2329 gfc_trans_array_constructor_value (&outer_loop
->pre
, type
, desc
, c
,
2330 &offset
, &offsetvar
, dynamic
);
2332 /* If the array grows dynamically, the upper bound of the loop variable
2333 is determined by the array's final upper bound. */
2336 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2337 gfc_array_index_type
,
2338 offsetvar
, gfc_index_one_node
);
2339 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2340 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
2341 if (*loop_ubound0
&& TREE_CODE (*loop_ubound0
) == VAR_DECL
)
2342 gfc_add_modify (&outer_loop
->pre
, *loop_ubound0
, tmp
);
2344 *loop_ubound0
= tmp
;
2347 if (TREE_USED (offsetvar
))
2348 pushdecl (offsetvar
);
2350 gcc_assert (INTEGER_CST_P (offset
));
2353 /* Disable bound checking for now because it's probably broken. */
2354 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2361 /* Restore old values of globals. */
2362 first_len
= old_first_len
;
2363 first_len_val
= old_first_len_val
;
2364 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2368 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2369 called after evaluating all of INFO's vector dimensions. Go through
2370 each such vector dimension and see if we can now fill in any missing
2374 set_vector_loop_bounds (gfc_ss
* ss
)
2376 gfc_loopinfo
*loop
, *outer_loop
;
2377 gfc_array_info
*info
;
2385 outer_loop
= outermost_loop (ss
->loop
);
2387 info
= &ss
->info
->data
.array
;
2389 for (; ss
; ss
= ss
->parent
)
2393 for (n
= 0; n
< loop
->dimen
; n
++)
2396 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_VECTOR
2397 || loop
->to
[n
] != NULL
)
2400 /* Loop variable N indexes vector dimension DIM, and we don't
2401 yet know the upper bound of loop variable N. Set it to the
2402 difference between the vector's upper and lower bounds. */
2403 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2404 gcc_assert (info
->subscript
[dim
]
2405 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2407 gfc_init_se (&se
, NULL
);
2408 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2409 zero
= gfc_rank_cst
[0];
2410 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2411 gfc_array_index_type
,
2412 gfc_conv_descriptor_ubound_get (desc
, zero
),
2413 gfc_conv_descriptor_lbound_get (desc
, zero
));
2414 tmp
= gfc_evaluate_now (tmp
, &outer_loop
->pre
);
2421 /* Add the pre and post chains for all the scalar expressions in a SS chain
2422 to loop. This is called after the loop parameters have been calculated,
2423 but before the actual scalarizing loops. */
2426 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2429 gfc_loopinfo
*nested_loop
, *outer_loop
;
2431 gfc_ss_info
*ss_info
;
2432 gfc_array_info
*info
;
2436 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2437 arguments could get evaluated multiple times. */
2438 if (ss
->is_alloc_lhs
)
2441 outer_loop
= outermost_loop (loop
);
2443 /* TODO: This can generate bad code if there are ordering dependencies,
2444 e.g., a callee allocated function and an unknown size constructor. */
2445 gcc_assert (ss
!= NULL
);
2447 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2451 /* Cross loop arrays are handled from within the most nested loop. */
2452 if (ss
->nested_ss
!= NULL
)
2456 expr
= ss_info
->expr
;
2457 info
= &ss_info
->data
.array
;
2459 switch (ss_info
->type
)
2462 /* Scalar expression. Evaluate this now. This includes elemental
2463 dimension indices, but not array section bounds. */
2464 gfc_init_se (&se
, NULL
);
2465 gfc_conv_expr (&se
, expr
);
2466 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2468 if (expr
->ts
.type
!= BT_CHARACTER
)
2470 /* Move the evaluation of scalar expressions outside the
2471 scalarization loop, except for WHERE assignments. */
2473 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2474 if (!ss_info
->where
)
2475 se
.expr
= gfc_evaluate_now (se
.expr
, &outer_loop
->pre
);
2476 gfc_add_block_to_block (&outer_loop
->pre
, &se
.post
);
2479 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2481 ss_info
->data
.scalar
.value
= se
.expr
;
2482 ss_info
->string_length
= se
.string_length
;
2485 case GFC_SS_REFERENCE
:
2486 /* Scalar argument to elemental procedure. */
2487 gfc_init_se (&se
, NULL
);
2488 if (ss_info
->can_be_null_ref
)
2490 /* If the actual argument can be absent (in other words, it can
2491 be a NULL reference), don't try to evaluate it; pass instead
2492 the reference directly. */
2493 gfc_conv_expr_reference (&se
, expr
);
2497 /* Otherwise, evaluate the argument outside the loop and pass
2498 a reference to the value. */
2499 gfc_conv_expr (&se
, expr
);
2501 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2502 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2503 if (gfc_is_class_scalar_expr (expr
))
2504 /* This is necessary because the dynamic type will always be
2505 large than the declared type. In consequence, assigning
2506 the value to a temporary could segfault.
2507 OOP-TODO: see if this is generally correct or is the value
2508 has to be written to an allocated temporary, whose address
2509 is passed via ss_info. */
2510 ss_info
->data
.scalar
.value
= se
.expr
;
2512 ss_info
->data
.scalar
.value
= gfc_evaluate_now (se
.expr
,
2515 ss_info
->string_length
= se
.string_length
;
2518 case GFC_SS_SECTION
:
2519 /* Add the expressions for scalar and vector subscripts. */
2520 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2521 if (info
->subscript
[n
])
2522 gfc_add_loop_ss_code (loop
, info
->subscript
[n
], true, where
);
2524 set_vector_loop_bounds (ss
);
2528 /* Get the vector's descriptor and store it in SS. */
2529 gfc_init_se (&se
, NULL
);
2530 gfc_conv_expr_descriptor (&se
, expr
, gfc_walk_expr (expr
));
2531 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2532 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2533 info
->descriptor
= se
.expr
;
2536 case GFC_SS_INTRINSIC
:
2537 gfc_add_intrinsic_ss_code (loop
, ss
);
2540 case GFC_SS_FUNCTION
:
2541 /* Array function return value. We call the function and save its
2542 result in a temporary for use inside the loop. */
2543 gfc_init_se (&se
, NULL
);
2546 gfc_conv_expr (&se
, expr
);
2547 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2548 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2549 ss_info
->string_length
= se
.string_length
;
2552 case GFC_SS_CONSTRUCTOR
:
2553 if (expr
->ts
.type
== BT_CHARACTER
2554 && ss_info
->string_length
== NULL
2556 && expr
->ts
.u
.cl
->length
)
2558 gfc_init_se (&se
, NULL
);
2559 gfc_conv_expr_type (&se
, expr
->ts
.u
.cl
->length
,
2560 gfc_charlen_type_node
);
2561 ss_info
->string_length
= se
.expr
;
2562 gfc_add_block_to_block (&outer_loop
->pre
, &se
.pre
);
2563 gfc_add_block_to_block (&outer_loop
->post
, &se
.post
);
2565 trans_array_constructor (ss
, where
);
2569 case GFC_SS_COMPONENT
:
2570 /* Do nothing. These are handled elsewhere. */
2579 for (nested_loop
= loop
->nested
; nested_loop
;
2580 nested_loop
= nested_loop
->next
)
2581 gfc_add_loop_ss_code (nested_loop
, nested_loop
->ss
, subscript
, where
);
2585 /* Translate expressions for the descriptor and data pointer of a SS. */
2589 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2592 gfc_ss_info
*ss_info
;
2593 gfc_array_info
*info
;
2597 info
= &ss_info
->data
.array
;
2599 /* Get the descriptor for the array to be scalarized. */
2600 gcc_assert (ss_info
->expr
->expr_type
== EXPR_VARIABLE
);
2601 gfc_init_se (&se
, NULL
);
2602 se
.descriptor_only
= 1;
2603 gfc_conv_expr_lhs (&se
, ss_info
->expr
);
2604 gfc_add_block_to_block (block
, &se
.pre
);
2605 info
->descriptor
= se
.expr
;
2606 ss_info
->string_length
= se
.string_length
;
2610 /* Also the data pointer. */
2611 tmp
= gfc_conv_array_data (se
.expr
);
2612 /* If this is a variable or address of a variable we use it directly.
2613 Otherwise we must evaluate it now to avoid breaking dependency
2614 analysis by pulling the expressions for elemental array indices
2617 || (TREE_CODE (tmp
) == ADDR_EXPR
2618 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2619 tmp
= gfc_evaluate_now (tmp
, block
);
2622 tmp
= gfc_conv_array_offset (se
.expr
);
2623 info
->offset
= gfc_evaluate_now (tmp
, block
);
2625 /* Make absolutely sure that the saved_offset is indeed saved
2626 so that the variable is still accessible after the loops
2628 info
->saved_offset
= info
->offset
;
2633 /* Initialize a gfc_loopinfo structure. */
2636 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2640 memset (loop
, 0, sizeof (gfc_loopinfo
));
2641 gfc_init_block (&loop
->pre
);
2642 gfc_init_block (&loop
->post
);
2644 /* Initially scalarize in order and default to no loop reversal. */
2645 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2648 loop
->reverse
[n
] = GFC_INHIBIT_REVERSE
;
2651 loop
->ss
= gfc_ss_terminator
;
2655 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2659 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2665 /* Return an expression for the data pointer of an array. */
2668 gfc_conv_array_data (tree descriptor
)
2672 type
= TREE_TYPE (descriptor
);
2673 if (GFC_ARRAY_TYPE_P (type
))
2675 if (TREE_CODE (type
) == POINTER_TYPE
)
2679 /* Descriptorless arrays. */
2680 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2684 return gfc_conv_descriptor_data_get (descriptor
);
2688 /* Return an expression for the base offset of an array. */
2691 gfc_conv_array_offset (tree descriptor
)
2695 type
= TREE_TYPE (descriptor
);
2696 if (GFC_ARRAY_TYPE_P (type
))
2697 return GFC_TYPE_ARRAY_OFFSET (type
);
2699 return gfc_conv_descriptor_offset_get (descriptor
);
2703 /* Get an expression for the array stride. */
2706 gfc_conv_array_stride (tree descriptor
, int dim
)
2711 type
= TREE_TYPE (descriptor
);
2713 /* For descriptorless arrays use the array size. */
2714 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2715 if (tmp
!= NULL_TREE
)
2718 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2723 /* Like gfc_conv_array_stride, but for the lower bound. */
2726 gfc_conv_array_lbound (tree descriptor
, int dim
)
2731 type
= TREE_TYPE (descriptor
);
2733 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2734 if (tmp
!= NULL_TREE
)
2737 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2742 /* Like gfc_conv_array_stride, but for the upper bound. */
2745 gfc_conv_array_ubound (tree descriptor
, int dim
)
2750 type
= TREE_TYPE (descriptor
);
2752 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2753 if (tmp
!= NULL_TREE
)
2756 /* This should only ever happen when passing an assumed shape array
2757 as an actual parameter. The value will never be used. */
2758 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2759 return gfc_index_zero_node
;
2761 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2766 /* Generate code to perform an array index bound check. */
2769 trans_array_bound_check (gfc_se
* se
, gfc_ss
*ss
, tree index
, int n
,
2770 locus
* where
, bool check_upper
)
2773 tree tmp_lo
, tmp_up
;
2776 const char * name
= NULL
;
2778 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2781 descriptor
= ss
->info
->data
.array
.descriptor
;
2783 index
= gfc_evaluate_now (index
, &se
->pre
);
2785 /* We find a name for the error message. */
2786 name
= ss
->info
->expr
->symtree
->n
.sym
->name
;
2787 gcc_assert (name
!= NULL
);
2789 if (TREE_CODE (descriptor
) == VAR_DECL
)
2790 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2792 /* If upper bound is present, include both bounds in the error message. */
2795 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2796 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2799 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2800 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2802 asprintf (&msg
, "Index '%%ld' of dimension %d "
2803 "outside of expected range (%%ld:%%ld)", n
+1);
2805 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2807 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2808 fold_convert (long_integer_type_node
, index
),
2809 fold_convert (long_integer_type_node
, tmp_lo
),
2810 fold_convert (long_integer_type_node
, tmp_up
));
2811 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2813 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2814 fold_convert (long_integer_type_node
, index
),
2815 fold_convert (long_integer_type_node
, tmp_lo
),
2816 fold_convert (long_integer_type_node
, tmp_up
));
2821 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2824 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2825 "below lower bound of %%ld", n
+1, name
);
2827 asprintf (&msg
, "Index '%%ld' of dimension %d "
2828 "below lower bound of %%ld", n
+1);
2830 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2832 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2833 fold_convert (long_integer_type_node
, index
),
2834 fold_convert (long_integer_type_node
, tmp_lo
));
2842 /* Return the offset for an index. Performs bound checking for elemental
2843 dimensions. Single element references are processed separately.
2844 DIM is the array dimension, I is the loop dimension. */
2847 conv_array_index_offset (gfc_se
* se
, gfc_ss
* ss
, int dim
, int i
,
2848 gfc_array_ref
* ar
, tree stride
)
2850 gfc_array_info
*info
;
2855 info
= &ss
->info
->data
.array
;
2857 /* Get the index into the array for this dimension. */
2860 gcc_assert (ar
->type
!= AR_ELEMENT
);
2861 switch (ar
->dimen_type
[dim
])
2863 case DIMEN_THIS_IMAGE
:
2867 /* Elemental dimension. */
2868 gcc_assert (info
->subscript
[dim
]
2869 && info
->subscript
[dim
]->info
->type
== GFC_SS_SCALAR
);
2870 /* We've already translated this value outside the loop. */
2871 index
= info
->subscript
[dim
]->info
->data
.scalar
.value
;
2873 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2874 ar
->as
->type
!= AS_ASSUMED_SIZE
2875 || dim
< ar
->dimen
- 1);
2879 gcc_assert (info
&& se
->loop
);
2880 gcc_assert (info
->subscript
[dim
]
2881 && info
->subscript
[dim
]->info
->type
== GFC_SS_VECTOR
);
2882 desc
= info
->subscript
[dim
]->info
->data
.array
.descriptor
;
2884 /* Get a zero-based index into the vector. */
2885 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2886 gfc_array_index_type
,
2887 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2889 /* Multiply the index by the stride. */
2890 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2891 gfc_array_index_type
,
2892 index
, gfc_conv_array_stride (desc
, 0));
2894 /* Read the vector to get an index into info->descriptor. */
2895 data
= build_fold_indirect_ref_loc (input_location
,
2896 gfc_conv_array_data (desc
));
2897 index
= gfc_build_array_ref (data
, index
, NULL
);
2898 index
= gfc_evaluate_now (index
, &se
->pre
);
2899 index
= fold_convert (gfc_array_index_type
, index
);
2901 /* Do any bounds checking on the final info->descriptor index. */
2902 index
= trans_array_bound_check (se
, ss
, index
, dim
, &ar
->where
,
2903 ar
->as
->type
!= AS_ASSUMED_SIZE
2904 || dim
< ar
->dimen
- 1);
2908 /* Scalarized dimension. */
2909 gcc_assert (info
&& se
->loop
);
2911 /* Multiply the loop variable by the stride and delta. */
2912 index
= se
->loop
->loopvar
[i
];
2913 if (!integer_onep (info
->stride
[dim
]))
2914 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2915 gfc_array_index_type
, index
,
2917 if (!integer_zerop (info
->delta
[dim
]))
2918 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2919 gfc_array_index_type
, index
,
2929 /* Temporary array or derived type component. */
2930 gcc_assert (se
->loop
);
2931 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2933 /* Pointer functions can have stride[0] different from unity.
2934 Use the stride returned by the function call and stored in
2935 the descriptor for the temporary. */
2936 if (se
->ss
&& se
->ss
->info
->type
== GFC_SS_FUNCTION
2937 && se
->ss
->info
->expr
2938 && se
->ss
->info
->expr
->symtree
2939 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
2940 && se
->ss
->info
->expr
->symtree
->n
.sym
->result
->attr
.pointer
)
2941 stride
= gfc_conv_descriptor_stride_get (info
->descriptor
,
2944 if (!integer_zerop (info
->delta
[dim
]))
2945 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2946 gfc_array_index_type
, index
, info
->delta
[dim
]);
2949 /* Multiply by the stride. */
2950 if (!integer_onep (stride
))
2951 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2958 /* Build a scalarized array reference using the vptr 'size'. */
2961 build_class_array_ref (gfc_se
*se
, tree base
, tree index
)
2968 gfc_expr
*expr
= se
->ss
->info
->expr
;
2973 if (expr
== NULL
|| expr
->ts
.type
!= BT_CLASS
)
2976 if (expr
->symtree
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2977 ts
= &expr
->symtree
->n
.sym
->ts
;
2982 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2984 if (ref
->type
== REF_COMPONENT
2985 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
2986 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
2987 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
2989 && ref
->next
->next
->type
== REF_ARRAY
2990 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
2992 ts
= &ref
->u
.c
.component
->ts
;
3001 if (class_ref
== NULL
)
3002 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3005 /* Remove everything after the last class reference, convert the
3006 expression and then recover its tailend once more. */
3008 ref
= class_ref
->next
;
3009 class_ref
->next
= NULL
;
3010 gfc_init_se (&tmpse
, NULL
);
3011 gfc_conv_expr (&tmpse
, expr
);
3013 class_ref
->next
= ref
;
3016 size
= gfc_vtable_size_get (decl
);
3018 /* Build the address of the element. */
3019 type
= TREE_TYPE (TREE_TYPE (base
));
3020 size
= fold_convert (TREE_TYPE (index
), size
);
3021 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
3022 gfc_array_index_type
,
3024 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
3025 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
3026 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3028 /* Return the element in the se expression. */
3029 se
->expr
= build_fold_indirect_ref_loc (input_location
, tmp
);
3034 /* Build a scalarized reference to an array. */
3037 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
3039 gfc_array_info
*info
;
3040 tree decl
= NULL_TREE
;
3048 expr
= ss
->info
->expr
;
3049 info
= &ss
->info
->data
.array
;
3051 n
= se
->loop
->order
[0];
3055 index
= conv_array_index_offset (se
, ss
, ss
->dim
[n
], n
, ar
, info
->stride0
);
3056 /* Add the offset for this dimension to the stored offset for all other
3058 if (!integer_zerop (info
->offset
))
3059 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3060 index
, info
->offset
);
3062 if (expr
&& is_subref_array (expr
))
3063 decl
= expr
->symtree
->n
.sym
->backend_decl
;
3065 tmp
= build_fold_indirect_ref_loc (input_location
, info
->data
);
3067 /* Use the vptr 'size' field to access a class the element of a class
3069 if (build_class_array_ref (se
, tmp
, index
))
3072 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
3076 /* Translate access of temporary array. */
3079 gfc_conv_tmp_array_ref (gfc_se
* se
)
3081 se
->string_length
= se
->ss
->info
->string_length
;
3082 gfc_conv_scalarized_array_ref (se
, NULL
);
3083 gfc_advance_se_ss_chain (se
);
3086 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3089 add_to_offset (tree
*cst_offset
, tree
*offset
, tree t
)
3091 if (TREE_CODE (t
) == INTEGER_CST
)
3092 *cst_offset
= int_const_binop (PLUS_EXPR
, *cst_offset
, t
);
3095 if (!integer_zerop (*offset
))
3096 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3097 gfc_array_index_type
, *offset
, t
);
3105 build_array_ref (tree desc
, tree offset
, tree decl
)
3109 /* Class array references need special treatment because the assigned
3110 type size needs to be used to point to the element. */
3111 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
))
3112 && TREE_CODE (desc
) == COMPONENT_REF
3113 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc
, 0))))
3115 tree type
= gfc_get_element_type (TREE_TYPE (desc
));
3116 tmp
= TREE_OPERAND (desc
, 0);
3117 tmp
= gfc_get_class_array_ref (offset
, tmp
);
3118 tmp
= fold_convert (build_pointer_type (type
), tmp
);
3119 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3123 tmp
= gfc_conv_array_data (desc
);
3124 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3125 tmp
= gfc_build_array_ref (tmp
, offset
, decl
);
3133 /* Build an array reference. se->expr already holds the array descriptor.
3134 This should be either a variable, indirect variable reference or component
3135 reference. For arrays which do not have a descriptor, se->expr will be
3137 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3140 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
3144 tree offset
, cst_offset
;
3152 gcc_assert (ar
->codimen
);
3154 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
)))
3155 se
->expr
= build_fold_indirect_ref (gfc_conv_array_data (se
->expr
));
3158 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
))
3159 && TREE_CODE (TREE_TYPE (se
->expr
)) == POINTER_TYPE
)
3160 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3162 /* Use the actual tree type and not the wrapped coarray. */
3163 if (!se
->want_pointer
)
3164 se
->expr
= fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se
->expr
)),
3171 /* Handle scalarized references separately. */
3172 if (ar
->type
!= AR_ELEMENT
)
3174 gfc_conv_scalarized_array_ref (se
, ar
);
3175 gfc_advance_se_ss_chain (se
);
3179 cst_offset
= offset
= gfc_index_zero_node
;
3180 add_to_offset (&cst_offset
, &offset
, gfc_conv_array_offset (se
->expr
));
3182 /* Calculate the offsets from all the dimensions. Make sure to associate
3183 the final offset so that we form a chain of loop invariant summands. */
3184 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
3186 /* Calculate the index for this dimension. */
3187 gfc_init_se (&indexse
, se
);
3188 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
3189 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
3191 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3193 /* Check array bounds. */
3197 /* Evaluate the indexse.expr only once. */
3198 indexse
.expr
= save_expr (indexse
.expr
);
3201 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
3202 if (sym
->attr
.temporary
)
3204 gfc_init_se (&tmpse
, se
);
3205 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
3206 gfc_array_index_type
);
3207 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3211 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3213 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3214 "below lower bound of %%ld", n
+1, sym
->name
);
3215 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3216 fold_convert (long_integer_type_node
,
3218 fold_convert (long_integer_type_node
, tmp
));
3221 /* Upper bound, but not for the last dimension of assumed-size
3223 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
3225 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
3226 if (sym
->attr
.temporary
)
3228 gfc_init_se (&tmpse
, se
);
3229 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
3230 gfc_array_index_type
);
3231 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
3235 cond
= fold_build2_loc (input_location
, GT_EXPR
,
3236 boolean_type_node
, indexse
.expr
, tmp
);
3237 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3238 "above upper bound of %%ld", n
+1, sym
->name
);
3239 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
3240 fold_convert (long_integer_type_node
,
3242 fold_convert (long_integer_type_node
, tmp
));
3247 /* Multiply the index by the stride. */
3248 stride
= gfc_conv_array_stride (se
->expr
, n
);
3249 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3250 indexse
.expr
, stride
);
3252 /* And add it to the total. */
3253 add_to_offset (&cst_offset
, &offset
, tmp
);
3256 if (!integer_zerop (cst_offset
))
3257 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3258 gfc_array_index_type
, offset
, cst_offset
);
3260 se
->expr
= build_array_ref (se
->expr
, offset
, sym
->backend_decl
);
3264 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3265 LOOP_DIM dimension (if any) to array's offset. */
3268 add_array_offset (stmtblock_t
*pblock
, gfc_loopinfo
*loop
, gfc_ss
*ss
,
3269 gfc_array_ref
*ar
, int array_dim
, int loop_dim
)
3272 gfc_array_info
*info
;
3275 info
= &ss
->info
->data
.array
;
3277 gfc_init_se (&se
, NULL
);
3279 se
.expr
= info
->descriptor
;
3280 stride
= gfc_conv_array_stride (info
->descriptor
, array_dim
);
3281 index
= conv_array_index_offset (&se
, ss
, array_dim
, loop_dim
, ar
, stride
);
3282 gfc_add_block_to_block (pblock
, &se
.pre
);
3284 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3285 gfc_array_index_type
,
3286 info
->offset
, index
);
3287 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
3291 /* Generate the code to be executed immediately before entering a
3292 scalarization loop. */
3295 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
3296 stmtblock_t
* pblock
)
3299 gfc_ss_info
*ss_info
;
3300 gfc_array_info
*info
;
3301 gfc_ss_type ss_type
;
3303 gfc_loopinfo
*ploop
;
3307 /* This code will be executed before entering the scalarization loop
3308 for this dimension. */
3309 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3313 if ((ss_info
->useflags
& flag
) == 0)
3316 ss_type
= ss_info
->type
;
3317 if (ss_type
!= GFC_SS_SECTION
3318 && ss_type
!= GFC_SS_FUNCTION
3319 && ss_type
!= GFC_SS_CONSTRUCTOR
3320 && ss_type
!= GFC_SS_COMPONENT
)
3323 info
= &ss_info
->data
.array
;
3325 gcc_assert (dim
< ss
->dimen
);
3326 gcc_assert (ss
->dimen
== loop
->dimen
);
3329 ar
= &info
->ref
->u
.ar
;
3333 if (dim
== loop
->dimen
- 1 && loop
->parent
!= NULL
)
3335 /* If we are in the outermost dimension of this loop, the previous
3336 dimension shall be in the parent loop. */
3337 gcc_assert (ss
->parent
!= NULL
);
3340 ploop
= loop
->parent
;
3342 /* ss and ss->parent are about the same array. */
3343 gcc_assert (ss_info
== pss
->info
);
3351 if (dim
== loop
->dimen
- 1)
3356 /* For the time being, there is no loop reordering. */
3357 gcc_assert (i
== ploop
->order
[i
]);
3358 i
= ploop
->order
[i
];
3360 if (dim
== loop
->dimen
- 1 && loop
->parent
== NULL
)
3362 stride
= gfc_conv_array_stride (info
->descriptor
,
3363 innermost_ss (ss
)->dim
[i
]);
3365 /* Calculate the stride of the innermost loop. Hopefully this will
3366 allow the backend optimizers to do their stuff more effectively.
3368 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
3370 /* For the outermost loop calculate the offset due to any
3371 elemental dimensions. It will have been initialized with the
3372 base offset of the array. */
3375 for (i
= 0; i
< ar
->dimen
; i
++)
3377 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
3380 add_array_offset (pblock
, loop
, ss
, ar
, i
, /* unused */ -1);
3385 /* Add the offset for the previous loop dimension. */
3386 add_array_offset (pblock
, ploop
, ss
, ar
, pss
->dim
[i
], i
);
3388 /* Remember this offset for the second loop. */
3389 if (dim
== loop
->temp_dim
- 1 && loop
->parent
== NULL
)
3390 info
->saved_offset
= info
->offset
;
3395 /* Start a scalarized expression. Creates a scope and declares loop
3399 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
3405 gcc_assert (!loop
->array_parameter
);
3407 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
3409 n
= loop
->order
[dim
];
3411 gfc_start_block (&loop
->code
[n
]);
3413 /* Create the loop variable. */
3414 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
3416 if (dim
< loop
->temp_dim
)
3420 /* Calculate values that will be constant within this loop. */
3421 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
3423 gfc_start_block (pbody
);
3427 /* Generates the actual loop code for a scalarization loop. */
3430 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
3431 stmtblock_t
* pbody
)
3442 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
3443 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
3444 && n
== loop
->dimen
- 1)
3446 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3447 init
= make_tree_vec (1);
3448 cond
= make_tree_vec (1);
3449 incr
= make_tree_vec (1);
3451 /* Cycle statement is implemented with a goto. Exit statement must not
3452 be present for this loop. */
3453 exit_label
= gfc_build_label_decl (NULL_TREE
);
3454 TREE_USED (exit_label
) = 1;
3456 /* Label for cycle statements (if needed). */
3457 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3458 gfc_add_expr_to_block (pbody
, tmp
);
3460 stmt
= make_node (OMP_FOR
);
3462 TREE_TYPE (stmt
) = void_type_node
;
3463 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
3465 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
3466 OMP_CLAUSE_SCHEDULE
);
3467 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
3468 = OMP_CLAUSE_SCHEDULE_STATIC
;
3469 if (ompws_flags
& OMPWS_NOWAIT
)
3470 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
3471 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
3473 /* Initialize the loopvar. */
3474 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
3476 OMP_FOR_INIT (stmt
) = init
;
3477 /* The exit condition. */
3478 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
3480 loop
->loopvar
[n
], loop
->to
[n
]);
3481 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
3482 OMP_FOR_COND (stmt
) = cond
;
3483 /* Increment the loopvar. */
3484 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3485 loop
->loopvar
[n
], gfc_index_one_node
);
3486 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
3487 void_type_node
, loop
->loopvar
[n
], tmp
);
3488 OMP_FOR_INCR (stmt
) = incr
;
3490 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
3491 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
3495 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
3496 && (loop
->temp_ss
== NULL
);
3498 loopbody
= gfc_finish_block (pbody
);
3502 tmp
= loop
->from
[n
];
3503 loop
->from
[n
] = loop
->to
[n
];
3507 /* Initialize the loopvar. */
3508 if (loop
->loopvar
[n
] != loop
->from
[n
])
3509 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
3511 exit_label
= gfc_build_label_decl (NULL_TREE
);
3513 /* Generate the loop body. */
3514 gfc_init_block (&block
);
3516 /* The exit condition. */
3517 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
3518 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
3519 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3520 TREE_USED (exit_label
) = 1;
3521 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3522 gfc_add_expr_to_block (&block
, tmp
);
3524 /* The main body. */
3525 gfc_add_expr_to_block (&block
, loopbody
);
3527 /* Increment the loopvar. */
3528 tmp
= fold_build2_loc (input_location
,
3529 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
3530 gfc_array_index_type
, loop
->loopvar
[n
],
3531 gfc_index_one_node
);
3533 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
3535 /* Build the loop. */
3536 tmp
= gfc_finish_block (&block
);
3537 tmp
= build1_v (LOOP_EXPR
, tmp
);
3538 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3540 /* Add the exit label. */
3541 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3542 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
3548 /* Finishes and generates the loops for a scalarized expression. */
3551 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3556 stmtblock_t
*pblock
;
3560 /* Generate the loops. */
3561 for (dim
= 0; dim
< loop
->dimen
; dim
++)
3563 n
= loop
->order
[dim
];
3564 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3565 loop
->loopvar
[n
] = NULL_TREE
;
3566 pblock
= &loop
->code
[n
];
3569 tmp
= gfc_finish_block (pblock
);
3570 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3572 /* Clear all the used flags. */
3573 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3574 if (ss
->parent
== NULL
)
3575 ss
->info
->useflags
= 0;
3579 /* Finish the main body of a scalarized expression, and start the secondary
3583 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
3587 stmtblock_t
*pblock
;
3591 /* We finish as many loops as are used by the temporary. */
3592 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
3594 n
= loop
->order
[dim
];
3595 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3596 loop
->loopvar
[n
] = NULL_TREE
;
3597 pblock
= &loop
->code
[n
];
3600 /* We don't want to finish the outermost loop entirely. */
3601 n
= loop
->order
[loop
->temp_dim
- 1];
3602 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3604 /* Restore the initial offsets. */
3605 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3607 gfc_ss_type ss_type
;
3608 gfc_ss_info
*ss_info
;
3612 if ((ss_info
->useflags
& 2) == 0)
3615 ss_type
= ss_info
->type
;
3616 if (ss_type
!= GFC_SS_SECTION
3617 && ss_type
!= GFC_SS_FUNCTION
3618 && ss_type
!= GFC_SS_CONSTRUCTOR
3619 && ss_type
!= GFC_SS_COMPONENT
)
3622 ss_info
->data
.array
.offset
= ss_info
->data
.array
.saved_offset
;
3625 /* Restart all the inner loops we just finished. */
3626 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3628 n
= loop
->order
[dim
];
3630 gfc_start_block (&loop
->code
[n
]);
3632 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3634 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3637 /* Start a block for the secondary copying code. */
3638 gfc_start_block (body
);
3642 /* Precalculate (either lower or upper) bound of an array section.
3643 BLOCK: Block in which the (pre)calculation code will go.
3644 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3645 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3646 DESC: Array descriptor from which the bound will be picked if unspecified
3647 (either lower or upper bound according to LBOUND). */
3650 evaluate_bound (stmtblock_t
*block
, tree
*bounds
, gfc_expr
** values
,
3651 tree desc
, int dim
, bool lbound
)
3654 gfc_expr
* input_val
= values
[dim
];
3655 tree
*output
= &bounds
[dim
];
3660 /* Specified section bound. */
3661 gfc_init_se (&se
, NULL
);
3662 gfc_conv_expr_type (&se
, input_val
, gfc_array_index_type
);
3663 gfc_add_block_to_block (block
, &se
.pre
);
3668 /* No specific bound specified so use the bound of the array. */
3669 *output
= lbound
? gfc_conv_array_lbound (desc
, dim
) :
3670 gfc_conv_array_ubound (desc
, dim
);
3672 *output
= gfc_evaluate_now (*output
, block
);
3676 /* Calculate the lower bound of an array section. */
3679 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
3681 gfc_expr
*stride
= NULL
;
3684 gfc_array_info
*info
;
3687 gcc_assert (ss
->info
->type
== GFC_SS_SECTION
);
3689 info
= &ss
->info
->data
.array
;
3690 ar
= &info
->ref
->u
.ar
;
3692 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
3694 /* We use a zero-based index to access the vector. */
3695 info
->start
[dim
] = gfc_index_zero_node
;
3696 info
->end
[dim
] = NULL
;
3697 info
->stride
[dim
] = gfc_index_one_node
;
3701 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
3702 || ar
->dimen_type
[dim
] == DIMEN_THIS_IMAGE
);
3703 desc
= info
->descriptor
;
3704 stride
= ar
->stride
[dim
];
3706 /* Calculate the start of the range. For vector subscripts this will
3707 be the range of the vector. */
3708 evaluate_bound (&loop
->pre
, info
->start
, ar
->start
, desc
, dim
, true);
3710 /* Similarly calculate the end. Although this is not used in the
3711 scalarizer, it is needed when checking bounds and where the end
3712 is an expression with side-effects. */
3713 evaluate_bound (&loop
->pre
, info
->end
, ar
->end
, desc
, dim
, false);
3715 /* Calculate the stride. */
3717 info
->stride
[dim
] = gfc_index_one_node
;
3720 gfc_init_se (&se
, NULL
);
3721 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3722 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3723 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3728 /* Calculates the range start and stride for a SS chain. Also gets the
3729 descriptor and data pointer. The range of vector subscripts is the size
3730 of the vector. Array bounds are also checked. */
3733 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3741 /* Determine the rank of the loop. */
3742 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3744 switch (ss
->info
->type
)
3746 case GFC_SS_SECTION
:
3747 case GFC_SS_CONSTRUCTOR
:
3748 case GFC_SS_FUNCTION
:
3749 case GFC_SS_COMPONENT
:
3750 loop
->dimen
= ss
->dimen
;
3753 /* As usual, lbound and ubound are exceptions!. */
3754 case GFC_SS_INTRINSIC
:
3755 switch (ss
->info
->expr
->value
.function
.isym
->id
)
3757 case GFC_ISYM_LBOUND
:
3758 case GFC_ISYM_UBOUND
:
3759 case GFC_ISYM_LCOBOUND
:
3760 case GFC_ISYM_UCOBOUND
:
3761 case GFC_ISYM_THIS_IMAGE
:
3762 loop
->dimen
= ss
->dimen
;
3774 /* We should have determined the rank of the expression by now. If
3775 not, that's bad news. */
3779 /* Loop over all the SS in the chain. */
3780 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3782 gfc_ss_info
*ss_info
;
3783 gfc_array_info
*info
;
3787 expr
= ss_info
->expr
;
3788 info
= &ss_info
->data
.array
;
3790 if (expr
&& expr
->shape
&& !info
->shape
)
3791 info
->shape
= expr
->shape
;
3793 switch (ss_info
->type
)
3795 case GFC_SS_SECTION
:
3796 /* Get the descriptor for the array. If it is a cross loops array,
3797 we got the descriptor already in the outermost loop. */
3798 if (ss
->parent
== NULL
)
3799 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3801 for (n
= 0; n
< ss
->dimen
; n
++)
3802 gfc_conv_section_startstride (loop
, ss
, ss
->dim
[n
]);
3805 case GFC_SS_INTRINSIC
:
3806 switch (expr
->value
.function
.isym
->id
)
3808 /* Fall through to supply start and stride. */
3809 case GFC_ISYM_LBOUND
:
3810 case GFC_ISYM_UBOUND
:
3814 /* This is the variant without DIM=... */
3815 gcc_assert (expr
->value
.function
.actual
->next
->expr
== NULL
);
3817 arg
= expr
->value
.function
.actual
->expr
;
3818 if (arg
->rank
== -1)
3823 /* The rank (hence the return value's shape) is unknown,
3824 we have to retrieve it. */
3825 gfc_init_se (&se
, NULL
);
3826 se
.descriptor_only
= 1;
3827 gfc_conv_expr (&se
, arg
);
3828 /* This is a bare variable, so there is no preliminary
3830 gcc_assert (se
.pre
.head
== NULL_TREE
3831 && se
.post
.head
== NULL_TREE
);
3832 rank
= gfc_conv_descriptor_rank (se
.expr
);
3833 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3834 gfc_array_index_type
,
3835 fold_convert (gfc_array_index_type
,
3837 gfc_index_one_node
);
3838 info
->end
[0] = gfc_evaluate_now (tmp
, &loop
->pre
);
3839 info
->start
[0] = gfc_index_zero_node
;
3840 info
->stride
[0] = gfc_index_one_node
;
3843 /* Otherwise fall through GFC_SS_FUNCTION. */
3845 case GFC_ISYM_LCOBOUND
:
3846 case GFC_ISYM_UCOBOUND
:
3847 case GFC_ISYM_THIS_IMAGE
:
3854 case GFC_SS_CONSTRUCTOR
:
3855 case GFC_SS_FUNCTION
:
3856 for (n
= 0; n
< ss
->dimen
; n
++)
3858 int dim
= ss
->dim
[n
];
3860 info
->start
[dim
] = gfc_index_zero_node
;
3861 info
->end
[dim
] = gfc_index_zero_node
;
3862 info
->stride
[dim
] = gfc_index_one_node
;
3871 /* The rest is just runtime bound checking. */
3872 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3875 tree lbound
, ubound
;
3877 tree size
[GFC_MAX_DIMENSIONS
];
3878 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3879 gfc_array_info
*info
;
3883 gfc_start_block (&block
);
3885 for (n
= 0; n
< loop
->dimen
; n
++)
3886 size
[n
] = NULL_TREE
;
3888 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3891 gfc_ss_info
*ss_info
;
3894 const char *expr_name
;
3897 if (ss_info
->type
!= GFC_SS_SECTION
)
3900 /* Catch allocatable lhs in f2003. */
3901 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3904 expr
= ss_info
->expr
;
3905 expr_loc
= &expr
->where
;
3906 expr_name
= expr
->symtree
->name
;
3908 gfc_start_block (&inner
);
3910 /* TODO: range checking for mapped dimensions. */
3911 info
= &ss_info
->data
.array
;
3913 /* This code only checks ranges. Elemental and vector
3914 dimensions are checked later. */
3915 for (n
= 0; n
< loop
->dimen
; n
++)
3920 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3923 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3924 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3925 check_upper
= false;
3929 /* Zero stride is not allowed. */
3930 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3931 info
->stride
[dim
], gfc_index_zero_node
);
3932 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3933 "of array '%s'", dim
+ 1, expr_name
);
3934 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3938 desc
= info
->descriptor
;
3940 /* This is the run-time equivalent of resolve.c's
3941 check_dimension(). The logical is more readable there
3942 than it is here, with all the trees. */
3943 lbound
= gfc_conv_array_lbound (desc
, dim
);
3944 end
= info
->end
[dim
];
3946 ubound
= gfc_conv_array_ubound (desc
, dim
);
3950 /* non_zerosized is true when the selected range is not
3952 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
3953 boolean_type_node
, info
->stride
[dim
],
3954 gfc_index_zero_node
);
3955 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3956 info
->start
[dim
], end
);
3957 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3958 boolean_type_node
, stride_pos
, tmp
);
3960 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
3962 info
->stride
[dim
], gfc_index_zero_node
);
3963 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3964 info
->start
[dim
], end
);
3965 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3968 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3970 stride_pos
, stride_neg
);
3972 /* Check the start of the range against the lower and upper
3973 bounds of the array, if the range is not empty.
3974 If upper bound is present, include both bounds in the
3978 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3980 info
->start
[dim
], lbound
);
3981 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3983 non_zerosized
, tmp
);
3984 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
3986 info
->start
[dim
], ubound
);
3987 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3989 non_zerosized
, tmp2
);
3990 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3991 "outside of expected range (%%ld:%%ld)",
3992 dim
+ 1, expr_name
);
3993 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3995 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3996 fold_convert (long_integer_type_node
, lbound
),
3997 fold_convert (long_integer_type_node
, ubound
));
3998 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4000 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4001 fold_convert (long_integer_type_node
, lbound
),
4002 fold_convert (long_integer_type_node
, ubound
));
4007 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
4009 info
->start
[dim
], lbound
);
4010 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4011 boolean_type_node
, non_zerosized
, tmp
);
4012 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4013 "below lower bound of %%ld",
4014 dim
+ 1, expr_name
);
4015 gfc_trans_runtime_check (true, false, tmp
, &inner
,
4017 fold_convert (long_integer_type_node
, info
->start
[dim
]),
4018 fold_convert (long_integer_type_node
, lbound
));
4022 /* Compute the last element of the range, which is not
4023 necessarily "end" (think 0:5:3, which doesn't contain 5)
4024 and check it against both lower and upper bounds. */
4026 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4027 gfc_array_index_type
, end
,
4029 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
4030 gfc_array_index_type
, tmp
,
4032 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4033 gfc_array_index_type
, end
, tmp
);
4034 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
4035 boolean_type_node
, tmp
, lbound
);
4036 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4037 boolean_type_node
, non_zerosized
, tmp2
);
4040 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
4041 boolean_type_node
, tmp
, ubound
);
4042 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4043 boolean_type_node
, non_zerosized
, tmp3
);
4044 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4045 "outside of expected range (%%ld:%%ld)",
4046 dim
+ 1, expr_name
);
4047 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4049 fold_convert (long_integer_type_node
, tmp
),
4050 fold_convert (long_integer_type_node
, ubound
),
4051 fold_convert (long_integer_type_node
, lbound
));
4052 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4054 fold_convert (long_integer_type_node
, tmp
),
4055 fold_convert (long_integer_type_node
, ubound
),
4056 fold_convert (long_integer_type_node
, lbound
));
4061 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
4062 "below lower bound of %%ld",
4063 dim
+ 1, expr_name
);
4064 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
4066 fold_convert (long_integer_type_node
, tmp
),
4067 fold_convert (long_integer_type_node
, lbound
));
4071 /* Check the section sizes match. */
4072 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4073 gfc_array_index_type
, end
,
4075 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4076 gfc_array_index_type
, tmp
,
4078 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4079 gfc_array_index_type
,
4080 gfc_index_one_node
, tmp
);
4081 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4082 gfc_array_index_type
, tmp
,
4083 build_int_cst (gfc_array_index_type
, 0));
4084 /* We remember the size of the first section, and check all the
4085 others against this. */
4088 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
4089 boolean_type_node
, tmp
, size
[n
]);
4090 asprintf (&msg
, "Array bound mismatch for dimension %d "
4091 "of array '%s' (%%ld/%%ld)",
4092 dim
+ 1, expr_name
);
4094 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
4096 fold_convert (long_integer_type_node
, tmp
),
4097 fold_convert (long_integer_type_node
, size
[n
]));
4102 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
4105 tmp
= gfc_finish_block (&inner
);
4107 /* For optional arguments, only check bounds if the argument is
4109 if (expr
->symtree
->n
.sym
->attr
.optional
4110 || expr
->symtree
->n
.sym
->attr
.not_always_present
)
4111 tmp
= build3_v (COND_EXPR
,
4112 gfc_conv_expr_present (expr
->symtree
->n
.sym
),
4113 tmp
, build_empty_stmt (input_location
));
4115 gfc_add_expr_to_block (&block
, tmp
);
4119 tmp
= gfc_finish_block (&block
);
4120 gfc_add_expr_to_block (&loop
->pre
, tmp
);
4123 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4124 gfc_conv_ss_startstride (loop
);
4127 /* Return true if both symbols could refer to the same data object. Does
4128 not take account of aliasing due to equivalence statements. */
4131 symbols_could_alias (gfc_symbol
*lsym
, gfc_symbol
*rsym
, bool lsym_pointer
,
4132 bool lsym_target
, bool rsym_pointer
, bool rsym_target
)
4134 /* Aliasing isn't possible if the symbols have different base types. */
4135 if (gfc_compare_types (&lsym
->ts
, &rsym
->ts
) == 0)
4138 /* Pointers can point to other pointers and target objects. */
4140 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4141 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4144 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4145 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4147 if (lsym_target
&& rsym_target
4148 && ((lsym
->attr
.dummy
&& !lsym
->attr
.contiguous
4149 && (!lsym
->attr
.dimension
|| lsym
->as
->type
== AS_ASSUMED_SHAPE
))
4150 || (rsym
->attr
.dummy
&& !rsym
->attr
.contiguous
4151 && (!rsym
->attr
.dimension
4152 || rsym
->as
->type
== AS_ASSUMED_SHAPE
))))
4159 /* Return true if the two SS could be aliased, i.e. both point to the same data
4161 /* TODO: resolve aliases based on frontend expressions. */
4164 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
4168 gfc_expr
*lexpr
, *rexpr
;
4171 bool lsym_pointer
, lsym_target
, rsym_pointer
, rsym_target
;
4173 lexpr
= lss
->info
->expr
;
4174 rexpr
= rss
->info
->expr
;
4176 lsym
= lexpr
->symtree
->n
.sym
;
4177 rsym
= rexpr
->symtree
->n
.sym
;
4179 lsym_pointer
= lsym
->attr
.pointer
;
4180 lsym_target
= lsym
->attr
.target
;
4181 rsym_pointer
= rsym
->attr
.pointer
;
4182 rsym_target
= rsym
->attr
.target
;
4184 if (symbols_could_alias (lsym
, rsym
, lsym_pointer
, lsym_target
,
4185 rsym_pointer
, rsym_target
))
4188 if (rsym
->ts
.type
!= BT_DERIVED
&& rsym
->ts
.type
!= BT_CLASS
4189 && lsym
->ts
.type
!= BT_DERIVED
&& lsym
->ts
.type
!= BT_CLASS
)
4192 /* For derived types we must check all the component types. We can ignore
4193 array references as these will have the same base type as the previous
4195 for (lref
= lexpr
->ref
; lref
!= lss
->info
->data
.array
.ref
; lref
= lref
->next
)
4197 if (lref
->type
!= REF_COMPONENT
)
4200 lsym_pointer
= lsym_pointer
|| lref
->u
.c
.sym
->attr
.pointer
;
4201 lsym_target
= lsym_target
|| lref
->u
.c
.sym
->attr
.target
;
4203 if (symbols_could_alias (lref
->u
.c
.sym
, rsym
, lsym_pointer
, lsym_target
,
4204 rsym_pointer
, rsym_target
))
4207 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4208 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4210 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4215 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
;
4218 if (rref
->type
!= REF_COMPONENT
)
4221 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4222 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4224 if (symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
,
4225 lsym_pointer
, lsym_target
,
4226 rsym_pointer
, rsym_target
))
4229 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4230 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4232 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4233 &rref
->u
.c
.sym
->ts
))
4235 if (gfc_compare_types (&lref
->u
.c
.sym
->ts
,
4236 &rref
->u
.c
.component
->ts
))
4238 if (gfc_compare_types (&lref
->u
.c
.component
->ts
,
4239 &rref
->u
.c
.component
->ts
))
4245 lsym_pointer
= lsym
->attr
.pointer
;
4246 lsym_target
= lsym
->attr
.target
;
4247 lsym_pointer
= lsym
->attr
.pointer
;
4248 lsym_target
= lsym
->attr
.target
;
4250 for (rref
= rexpr
->ref
; rref
!= rss
->info
->data
.array
.ref
; rref
= rref
->next
)
4252 if (rref
->type
!= REF_COMPONENT
)
4255 rsym_pointer
= rsym_pointer
|| rref
->u
.c
.sym
->attr
.pointer
;
4256 rsym_target
= lsym_target
|| rref
->u
.c
.sym
->attr
.target
;
4258 if (symbols_could_alias (rref
->u
.c
.sym
, lsym
,
4259 lsym_pointer
, lsym_target
,
4260 rsym_pointer
, rsym_target
))
4263 if ((lsym_pointer
&& (rsym_pointer
|| rsym_target
))
4264 || (rsym_pointer
&& (lsym_pointer
|| lsym_target
)))
4266 if (gfc_compare_types (&lsym
->ts
, &rref
->u
.c
.component
->ts
))
4275 /* Resolve array data dependencies. Creates a temporary if required. */
4276 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4280 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
4286 gfc_expr
*dest_expr
;
4291 loop
->temp_ss
= NULL
;
4292 dest_expr
= dest
->info
->expr
;
4294 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
4296 if (ss
->info
->type
!= GFC_SS_SECTION
)
4299 ss_expr
= ss
->info
->expr
;
4301 if (dest_expr
->symtree
->n
.sym
!= ss_expr
->symtree
->n
.sym
)
4303 if (gfc_could_be_alias (dest
, ss
)
4304 || gfc_are_equivalenced_arrays (dest_expr
, ss_expr
))
4312 lref
= dest_expr
->ref
;
4313 rref
= ss_expr
->ref
;
4315 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
4320 for (i
= 0; i
< dest
->dimen
; i
++)
4321 for (j
= 0; j
< ss
->dimen
; j
++)
4323 && dest
->dim
[i
] == ss
->dim
[j
])
4325 /* If we don't access array elements in the same order,
4326 there is a dependency. */
4331 /* TODO : loop shifting. */
4334 /* Mark the dimensions for LOOP SHIFTING */
4335 for (n
= 0; n
< loop
->dimen
; n
++)
4337 int dim
= dest
->data
.info
.dim
[n
];
4339 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
4341 else if (! gfc_is_same_range (&lref
->u
.ar
,
4342 &rref
->u
.ar
, dim
, 0))
4346 /* Put all the dimensions with dependencies in the
4349 for (n
= 0; n
< loop
->dimen
; n
++)
4351 gcc_assert (loop
->order
[n
] == n
);
4353 loop
->order
[dim
++] = n
;
4355 for (n
= 0; n
< loop
->dimen
; n
++)
4358 loop
->order
[dim
++] = n
;
4361 gcc_assert (dim
== loop
->dimen
);
4372 tree base_type
= gfc_typenode_for_spec (&dest_expr
->ts
);
4373 if (GFC_ARRAY_TYPE_P (base_type
)
4374 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4375 base_type
= gfc_get_element_type (base_type
);
4376 loop
->temp_ss
= gfc_get_temp_ss (base_type
, dest
->info
->string_length
,
4378 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
4381 loop
->temp_ss
= NULL
;
4385 /* Browse through each array's information from the scalarizer and set the loop
4386 bounds according to the "best" one (per dimension), i.e. the one which
4387 provides the most information (constant bounds, shape, etc.). */
4390 set_loop_bounds (gfc_loopinfo
*loop
)
4392 int n
, dim
, spec_dim
;
4393 gfc_array_info
*info
;
4394 gfc_array_info
*specinfo
;
4398 bool dynamic
[GFC_MAX_DIMENSIONS
];
4401 bool nonoptional_arr
;
4403 loopspec
= loop
->specloop
;
4406 for (n
= 0; n
< loop
->dimen
; n
++)
4411 /* If there are both optional and nonoptional array arguments, scalarize
4412 over the nonoptional; otherwise, it does not matter as then all
4413 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4415 nonoptional_arr
= false;
4417 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4418 if (ss
->info
->type
!= GFC_SS_SCALAR
&& ss
->info
->type
!= GFC_SS_TEMP
4419 && ss
->info
->type
!= GFC_SS_REFERENCE
&& !ss
->info
->can_be_null_ref
)
4420 nonoptional_arr
= true;
4422 /* We use one SS term, and use that to determine the bounds of the
4423 loop for this dimension. We try to pick the simplest term. */
4424 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4426 gfc_ss_type ss_type
;
4428 ss_type
= ss
->info
->type
;
4429 if (ss_type
== GFC_SS_SCALAR
4430 || ss_type
== GFC_SS_TEMP
4431 || ss_type
== GFC_SS_REFERENCE
4432 || (ss
->info
->can_be_null_ref
&& nonoptional_arr
))
4435 info
= &ss
->info
->data
.array
;
4438 if (loopspec
[n
] != NULL
)
4440 specinfo
= &loopspec
[n
]->info
->data
.array
;
4441 spec_dim
= loopspec
[n
]->dim
[n
];
4445 /* Silence uninitialized warnings. */
4452 gcc_assert (info
->shape
[dim
]);
4453 /* The frontend has worked out the size for us. */
4456 || !integer_zerop (specinfo
->start
[spec_dim
]))
4457 /* Prefer zero-based descriptors if possible. */
4462 if (ss_type
== GFC_SS_CONSTRUCTOR
)
4464 gfc_constructor_base base
;
4465 /* An unknown size constructor will always be rank one.
4466 Higher rank constructors will either have known shape,
4467 or still be wrapped in a call to reshape. */
4468 gcc_assert (loop
->dimen
== 1);
4470 /* Always prefer to use the constructor bounds if the size
4471 can be determined at compile time. Prefer not to otherwise,
4472 since the general case involves realloc, and it's better to
4473 avoid that overhead if possible. */
4474 base
= ss
->info
->expr
->value
.constructor
;
4475 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
4476 if (!dynamic
[n
] || !loopspec
[n
])
4481 /* Avoid using an allocatable lhs in an assignment, since
4482 there might be a reallocation coming. */
4483 if (loopspec
[n
] && ss
->is_alloc_lhs
)
4488 /* Criteria for choosing a loop specifier (most important first):
4489 doesn't need realloc
4495 else if (loopspec
[n
]->info
->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
4497 else if (integer_onep (info
->stride
[dim
])
4498 && !integer_onep (specinfo
->stride
[spec_dim
]))
4500 else if (INTEGER_CST_P (info
->stride
[dim
])
4501 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4503 else if (INTEGER_CST_P (info
->start
[dim
])
4504 && !INTEGER_CST_P (specinfo
->start
[spec_dim
])
4505 && integer_onep (info
->stride
[dim
])
4506 == integer_onep (specinfo
->stride
[spec_dim
])
4507 && INTEGER_CST_P (info
->stride
[dim
])
4508 == INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
4510 /* We don't work out the upper bound.
4511 else if (INTEGER_CST_P (info->finish[n])
4512 && ! INTEGER_CST_P (specinfo->finish[n]))
4513 loopspec[n] = ss; */
4516 /* We should have found the scalarization loop specifier. If not,
4518 gcc_assert (loopspec
[n
]);
4520 info
= &loopspec
[n
]->info
->data
.array
;
4521 dim
= loopspec
[n
]->dim
[n
];
4523 /* Set the extents of this range. */
4524 cshape
= info
->shape
;
4525 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
4526 && INTEGER_CST_P (info
->stride
[dim
]))
4528 loop
->from
[n
] = info
->start
[dim
];
4529 mpz_set (i
, cshape
[get_array_ref_dim_for_loop_dim (loopspec
[n
], n
)]);
4530 mpz_sub_ui (i
, i
, 1);
4531 /* To = from + (size - 1) * stride. */
4532 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
4533 if (!integer_onep (info
->stride
[dim
]))
4534 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4535 gfc_array_index_type
, tmp
,
4537 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
4538 gfc_array_index_type
,
4539 loop
->from
[n
], tmp
);
4543 loop
->from
[n
] = info
->start
[dim
];
4544 switch (loopspec
[n
]->info
->type
)
4546 case GFC_SS_CONSTRUCTOR
:
4547 /* The upper bound is calculated when we expand the
4549 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4552 case GFC_SS_SECTION
:
4553 /* Use the end expression if it exists and is not constant,
4554 so that it is only evaluated once. */
4555 loop
->to
[n
] = info
->end
[dim
];
4558 case GFC_SS_FUNCTION
:
4559 /* The loop bound will be set when we generate the call. */
4560 gcc_assert (loop
->to
[n
] == NULL_TREE
);
4563 case GFC_SS_INTRINSIC
:
4565 gfc_expr
*expr
= loopspec
[n
]->info
->expr
;
4567 /* The {l,u}bound of an assumed rank. */
4568 gcc_assert ((expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
4569 || expr
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
)
4570 && expr
->value
.function
.actual
->next
->expr
== NULL
4571 && expr
->value
.function
.actual
->expr
->rank
== -1);
4573 loop
->to
[n
] = info
->end
[dim
];
4582 /* Transform everything so we have a simple incrementing variable. */
4583 if (integer_onep (info
->stride
[dim
]))
4584 info
->delta
[dim
] = gfc_index_zero_node
;
4587 /* Set the delta for this section. */
4588 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
4589 /* Number of iterations is (end - start + step) / step.
4590 with start = 0, this simplifies to
4592 for (i = 0; i<=last; i++){...}; */
4593 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4594 gfc_array_index_type
, loop
->to
[n
],
4596 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
4597 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
4598 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
4599 tmp
, build_int_cst (gfc_array_index_type
, -1));
4600 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4601 /* Make the loop variable start at 0. */
4602 loop
->from
[n
] = gfc_index_zero_node
;
4607 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4608 set_loop_bounds (loop
);
4612 /* Initialize the scalarization loop. Creates the loop variables. Determines
4613 the range of the loop variables. Creates a temporary if required.
4614 Also generates code for scalar expressions which have been
4615 moved outside the loop. */
4618 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
4623 set_loop_bounds (loop
);
4625 /* Add all the scalar code that can be taken out of the loops.
4626 This may include calculating the loop bounds, so do it before
4627 allocating the temporary. */
4628 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
4630 tmp_ss
= loop
->temp_ss
;
4631 /* If we want a temporary then create it. */
4634 gfc_ss_info
*tmp_ss_info
;
4636 tmp_ss_info
= tmp_ss
->info
;
4637 gcc_assert (tmp_ss_info
->type
== GFC_SS_TEMP
);
4638 gcc_assert (loop
->parent
== NULL
);
4640 /* Make absolutely sure that this is a complete type. */
4641 if (tmp_ss_info
->string_length
)
4642 tmp_ss_info
->data
.temp
.type
4643 = gfc_get_character_type_len_for_eltype
4644 (TREE_TYPE (tmp_ss_info
->data
.temp
.type
),
4645 tmp_ss_info
->string_length
);
4647 tmp
= tmp_ss_info
->data
.temp
.type
;
4648 memset (&tmp_ss_info
->data
.array
, 0, sizeof (gfc_array_info
));
4649 tmp_ss_info
->type
= GFC_SS_SECTION
;
4651 gcc_assert (tmp_ss
->dimen
!= 0);
4653 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, tmp_ss
, tmp
,
4654 NULL_TREE
, false, true, false, where
);
4657 /* For array parameters we don't have loop variables, so don't calculate the
4659 if (!loop
->array_parameter
)
4660 gfc_set_delta (loop
);
4664 /* Calculates how to transform from loop variables to array indices for each
4665 array: once loop bounds are chosen, sets the difference (DELTA field) between
4666 loop bounds and array reference bounds, for each array info. */
4669 gfc_set_delta (gfc_loopinfo
*loop
)
4671 gfc_ss
*ss
, **loopspec
;
4672 gfc_array_info
*info
;
4676 loopspec
= loop
->specloop
;
4678 /* Calculate the translation from loop variables to array indices. */
4679 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
4681 gfc_ss_type ss_type
;
4683 ss_type
= ss
->info
->type
;
4684 if (ss_type
!= GFC_SS_SECTION
4685 && ss_type
!= GFC_SS_COMPONENT
4686 && ss_type
!= GFC_SS_CONSTRUCTOR
)
4689 info
= &ss
->info
->data
.array
;
4691 for (n
= 0; n
< ss
->dimen
; n
++)
4693 /* If we are specifying the range the delta is already set. */
4694 if (loopspec
[n
] != ss
)
4698 /* Calculate the offset relative to the loop variable.
4699 First multiply by the stride. */
4700 tmp
= loop
->from
[n
];
4701 if (!integer_onep (info
->stride
[dim
]))
4702 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4703 gfc_array_index_type
,
4704 tmp
, info
->stride
[dim
]);
4706 /* Then subtract this from our starting value. */
4707 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4708 gfc_array_index_type
,
4709 info
->start
[dim
], tmp
);
4711 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
4716 for (loop
= loop
->nested
; loop
; loop
= loop
->next
)
4717 gfc_set_delta (loop
);
4721 /* Calculate the size of a given array dimension from the bounds. This
4722 is simply (ubound - lbound + 1) if this expression is positive
4723 or 0 if it is negative (pick either one if it is zero). Optionally
4724 (if or_expr is present) OR the (expression != 0) condition to it. */
4727 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
4732 /* Calculate (ubound - lbound + 1). */
4733 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4735 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
4736 gfc_index_one_node
);
4738 /* Check whether the size for this dimension is negative. */
4739 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
4740 gfc_index_zero_node
);
4741 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
4742 gfc_index_zero_node
, res
);
4744 /* Build OR expression. */
4746 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4747 boolean_type_node
, *or_expr
, cond
);
4753 /* For an array descriptor, get the total number of elements. This is just
4754 the product of the extents along from_dim to to_dim. */
4757 gfc_conv_descriptor_size_1 (tree desc
, int from_dim
, int to_dim
)
4762 res
= gfc_index_one_node
;
4764 for (dim
= from_dim
; dim
< to_dim
; ++dim
)
4770 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
4771 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
4773 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
4774 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4782 /* Full size of an array. */
4785 gfc_conv_descriptor_size (tree desc
, int rank
)
4787 return gfc_conv_descriptor_size_1 (desc
, 0, rank
);
4791 /* Size of a coarray for all dimensions but the last. */
4794 gfc_conv_descriptor_cosize (tree desc
, int rank
, int corank
)
4796 return gfc_conv_descriptor_size_1 (desc
, rank
, rank
+ corank
- 1);
4800 /* Fills in an array descriptor, and returns the size of the array.
4801 The size will be a simple_val, ie a variable or a constant. Also
4802 calculates the offset of the base. The pointer argument overflow,
4803 which should be of integer type, will increase in value if overflow
4804 occurs during the size calculation. Returns the size of the array.
4808 for (n = 0; n < rank; n++)
4810 a.lbound[n] = specified_lower_bound;
4811 offset = offset + a.lbond[n] * stride;
4813 a.ubound[n] = specified_upper_bound;
4814 a.stride[n] = stride;
4815 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4816 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4817 stride = stride * size;
4819 for (n = rank; n < rank+corank; n++)
4820 (Set lcobound/ucobound as above.)
4821 element_size = sizeof (array element);
4824 stride = (size_t) stride;
4825 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4826 stride = stride * element_size;
4832 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
4833 gfc_expr
** lower
, gfc_expr
** upper
, stmtblock_t
* pblock
,
4834 stmtblock_t
* descriptor_block
, tree
* overflow
,
4835 tree expr3_elem_size
, tree
*nelems
, gfc_expr
*expr3
)
4848 stmtblock_t thenblock
;
4849 stmtblock_t elseblock
;
4854 type
= TREE_TYPE (descriptor
);
4856 stride
= gfc_index_one_node
;
4857 offset
= gfc_index_zero_node
;
4859 /* Set the dtype. */
4860 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4861 gfc_add_modify (descriptor_block
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4863 or_expr
= boolean_false_node
;
4865 for (n
= 0; n
< rank
; n
++)
4870 /* We have 3 possibilities for determining the size of the array:
4871 lower == NULL => lbound = 1, ubound = upper[n]
4872 upper[n] = NULL => lbound = 1, ubound = lower[n]
4873 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4876 /* Set lower bound. */
4877 gfc_init_se (&se
, NULL
);
4879 se
.expr
= gfc_index_one_node
;
4882 gcc_assert (lower
[n
]);
4885 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4886 gfc_add_block_to_block (pblock
, &se
.pre
);
4890 se
.expr
= gfc_index_one_node
;
4894 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4895 gfc_rank_cst
[n
], se
.expr
);
4896 conv_lbound
= se
.expr
;
4898 /* Work out the offset for this component. */
4899 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4901 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4902 gfc_array_index_type
, offset
, tmp
);
4904 /* Set upper bound. */
4905 gfc_init_se (&se
, NULL
);
4906 gcc_assert (ubound
);
4907 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4908 gfc_add_block_to_block (pblock
, &se
.pre
);
4910 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4911 gfc_rank_cst
[n
], se
.expr
);
4912 conv_ubound
= se
.expr
;
4914 /* Store the stride. */
4915 gfc_conv_descriptor_stride_set (descriptor_block
, descriptor
,
4916 gfc_rank_cst
[n
], stride
);
4918 /* Calculate size and check whether extent is negative. */
4919 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4920 size
= gfc_evaluate_now (size
, pblock
);
4922 /* Check whether multiplying the stride by the number of
4923 elements in this dimension would overflow. We must also check
4924 whether the current dimension has zero size in order to avoid
4927 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
4928 gfc_array_index_type
,
4929 fold_convert (gfc_array_index_type
,
4930 TYPE_MAX_VALUE (gfc_array_index_type
)),
4932 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
4933 boolean_type_node
, tmp
, stride
));
4934 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4935 integer_one_node
, integer_zero_node
);
4936 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
4937 boolean_type_node
, size
,
4938 gfc_index_zero_node
));
4939 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
4940 integer_zero_node
, tmp
);
4941 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
4943 *overflow
= gfc_evaluate_now (tmp
, pblock
);
4945 /* Multiply the stride by the number of elements in this dimension. */
4946 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
4947 gfc_array_index_type
, stride
, size
);
4948 stride
= gfc_evaluate_now (stride
, pblock
);
4951 for (n
= rank
; n
< rank
+ corank
; n
++)
4955 /* Set lower bound. */
4956 gfc_init_se (&se
, NULL
);
4957 if (lower
== NULL
|| lower
[n
] == NULL
)
4959 gcc_assert (n
== rank
+ corank
- 1);
4960 se
.expr
= gfc_index_one_node
;
4964 if (ubound
|| n
== rank
+ corank
- 1)
4966 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4967 gfc_add_block_to_block (pblock
, &se
.pre
);
4971 se
.expr
= gfc_index_one_node
;
4975 gfc_conv_descriptor_lbound_set (descriptor_block
, descriptor
,
4976 gfc_rank_cst
[n
], se
.expr
);
4978 if (n
< rank
+ corank
- 1)
4980 gfc_init_se (&se
, NULL
);
4981 gcc_assert (ubound
);
4982 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4983 gfc_add_block_to_block (pblock
, &se
.pre
);
4984 gfc_conv_descriptor_ubound_set (descriptor_block
, descriptor
,
4985 gfc_rank_cst
[n
], se
.expr
);
4989 /* The stride is the number of elements in the array, so multiply by the
4990 size of an element to get the total size. Obviously, if there is a
4991 SOURCE expression (expr3) we must use its element size. */
4992 if (expr3_elem_size
!= NULL_TREE
)
4993 tmp
= expr3_elem_size
;
4994 else if (expr3
!= NULL
)
4996 if (expr3
->ts
.type
== BT_CLASS
)
4999 gfc_expr
*sz
= gfc_copy_expr (expr3
);
5000 gfc_add_vptr_component (sz
);
5001 gfc_add_size_component (sz
);
5002 gfc_init_se (&se_sz
, NULL
);
5003 gfc_conv_expr (&se_sz
, sz
);
5009 tmp
= gfc_typenode_for_spec (&expr3
->ts
);
5010 tmp
= TYPE_SIZE_UNIT (tmp
);
5014 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5016 /* Convert to size_t. */
5017 element_size
= fold_convert (size_type_node
, tmp
);
5020 return element_size
;
5022 *nelems
= gfc_evaluate_now (stride
, pblock
);
5023 stride
= fold_convert (size_type_node
, stride
);
5025 /* First check for overflow. Since an array of type character can
5026 have zero element_size, we must check for that before
5028 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5030 TYPE_MAX_VALUE (size_type_node
), element_size
);
5031 cond
= gfc_unlikely (fold_build2_loc (input_location
, LT_EXPR
,
5032 boolean_type_node
, tmp
, stride
));
5033 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5034 integer_one_node
, integer_zero_node
);
5035 cond
= gfc_unlikely (fold_build2_loc (input_location
, EQ_EXPR
,
5036 boolean_type_node
, element_size
,
5037 build_int_cst (size_type_node
, 0)));
5038 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
, cond
,
5039 integer_zero_node
, tmp
);
5040 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
5042 *overflow
= gfc_evaluate_now (tmp
, pblock
);
5044 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5045 stride
, element_size
);
5047 if (poffset
!= NULL
)
5049 offset
= gfc_evaluate_now (offset
, pblock
);
5053 if (integer_zerop (or_expr
))
5055 if (integer_onep (or_expr
))
5056 return build_int_cst (size_type_node
, 0);
5058 var
= gfc_create_var (TREE_TYPE (size
), "size");
5059 gfc_start_block (&thenblock
);
5060 gfc_add_modify (&thenblock
, var
, build_int_cst (size_type_node
, 0));
5061 thencase
= gfc_finish_block (&thenblock
);
5063 gfc_start_block (&elseblock
);
5064 gfc_add_modify (&elseblock
, var
, size
);
5065 elsecase
= gfc_finish_block (&elseblock
);
5067 tmp
= gfc_evaluate_now (or_expr
, pblock
);
5068 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
5069 gfc_add_expr_to_block (pblock
, tmp
);
5075 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5076 the work for an ALLOCATE statement. */
5080 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree status
, tree errmsg
,
5081 tree errlen
, tree label_finish
, tree expr3_elem_size
,
5082 tree
*nelems
, gfc_expr
*expr3
)
5086 tree offset
= NULL_TREE
;
5087 tree token
= NULL_TREE
;
5090 tree error
= NULL_TREE
;
5091 tree overflow
; /* Boolean storing whether size calculation overflows. */
5092 tree var_overflow
= NULL_TREE
;
5094 tree set_descriptor
;
5095 stmtblock_t set_descriptor_block
;
5096 stmtblock_t elseblock
;
5099 gfc_ref
*ref
, *prev_ref
= NULL
;
5100 bool allocatable
, coarray
, dimension
;
5104 /* Find the last reference in the chain. */
5105 while (ref
&& ref
->next
!= NULL
)
5107 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
5108 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
5113 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
5118 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
5119 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
5120 dimension
= expr
->symtree
->n
.sym
->attr
.dimension
;
5124 allocatable
= prev_ref
->u
.c
.component
->attr
.allocatable
;
5125 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
5126 dimension
= prev_ref
->u
.c
.component
->attr
.dimension
;
5130 gcc_assert (coarray
);
5132 /* Figure out the size of the array. */
5133 switch (ref
->u
.ar
.type
)
5139 upper
= ref
->u
.ar
.start
;
5145 lower
= ref
->u
.ar
.start
;
5146 upper
= ref
->u
.ar
.end
;
5150 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
5152 lower
= ref
->u
.ar
.as
->lower
;
5153 upper
= ref
->u
.ar
.as
->upper
;
5161 overflow
= integer_zero_node
;
5163 gfc_init_block (&set_descriptor_block
);
5164 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
5165 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
5166 &se
->pre
, &set_descriptor_block
, &overflow
,
5167 expr3_elem_size
, nelems
, expr3
);
5172 var_overflow
= gfc_create_var (integer_type_node
, "overflow");
5173 gfc_add_modify (&se
->pre
, var_overflow
, overflow
);
5175 /* Generate the block of code handling overflow. */
5176 msg
= gfc_build_addr_expr (pchar_type_node
,
5177 gfc_build_localized_cstring_const
5178 ("Integer overflow when calculating the amount of "
5179 "memory to allocate"));
5180 error
= build_call_expr_loc (input_location
, gfor_fndecl_runtime_error
,
5184 if (status
!= NULL_TREE
)
5186 tree status_type
= TREE_TYPE (status
);
5187 stmtblock_t set_status_block
;
5189 gfc_start_block (&set_status_block
);
5190 gfc_add_modify (&set_status_block
, status
,
5191 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
5192 error
= gfc_finish_block (&set_status_block
);
5195 gfc_start_block (&elseblock
);
5197 /* Allocate memory to store the data. */
5198 if (POINTER_TYPE_P (TREE_TYPE (se
->expr
)))
5199 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5201 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
5202 STRIP_NOPS (pointer
);
5204 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5205 token
= gfc_build_addr_expr (NULL_TREE
,
5206 gfc_conv_descriptor_token (se
->expr
));
5208 /* The allocatable variant takes the old pointer as first argument. */
5210 gfc_allocate_allocatable (&elseblock
, pointer
, size
, token
,
5211 status
, errmsg
, errlen
, label_finish
, expr
);
5213 gfc_allocate_using_malloc (&elseblock
, pointer
, size
, status
);
5217 cond
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
5218 boolean_type_node
, var_overflow
, integer_zero_node
));
5219 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5220 error
, gfc_finish_block (&elseblock
));
5223 tmp
= gfc_finish_block (&elseblock
);
5225 gfc_add_expr_to_block (&se
->pre
, tmp
);
5227 if (expr
->ts
.type
== BT_CLASS
)
5229 tmp
= build_int_cst (unsigned_char_type_node
, 0);
5230 /* With class objects, it is best to play safe and null the
5231 memory because we cannot know if dynamic types have allocatable
5232 components or not. */
5233 tmp
= build_call_expr_loc (input_location
,
5234 builtin_decl_explicit (BUILT_IN_MEMSET
),
5235 3, pointer
, tmp
, size
);
5236 gfc_add_expr_to_block (&se
->pre
, tmp
);
5239 /* Update the array descriptors. */
5241 gfc_conv_descriptor_offset_set (&set_descriptor_block
, se
->expr
, offset
);
5243 set_descriptor
= gfc_finish_block (&set_descriptor_block
);
5244 if (status
!= NULL_TREE
)
5246 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5247 boolean_type_node
, status
,
5248 build_int_cst (TREE_TYPE (status
), 0));
5249 gfc_add_expr_to_block (&se
->pre
,
5250 fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5251 gfc_likely (cond
), set_descriptor
,
5252 build_empty_stmt (input_location
)));
5255 gfc_add_expr_to_block (&se
->pre
, set_descriptor
);
5257 if ((expr
->ts
.type
== BT_DERIVED
)
5258 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5260 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
5261 ref
->u
.ar
.as
->rank
);
5262 gfc_add_expr_to_block (&se
->pre
, tmp
);
5269 /* Deallocate an array variable. Also used when an allocated variable goes
5274 gfc_array_deallocate (tree descriptor
, tree pstat
, tree errmsg
, tree errlen
,
5275 tree label_finish
, gfc_expr
* expr
)
5280 bool coarray
= gfc_is_coarray (expr
);
5282 gfc_start_block (&block
);
5284 /* Get a pointer to the data. */
5285 var
= gfc_conv_descriptor_data_get (descriptor
);
5288 /* Parameter is the address of the data component. */
5289 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, pstat
, errmsg
,
5290 errlen
, label_finish
, false, expr
, coarray
);
5291 gfc_add_expr_to_block (&block
, tmp
);
5293 /* Zero the data pointer; only for coarrays an error can occur and then
5294 the allocation status may not be changed. */
5295 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5296 var
, build_int_cst (TREE_TYPE (var
), 0));
5297 if (pstat
!= NULL_TREE
&& coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5300 tree stat
= build_fold_indirect_ref_loc (input_location
, pstat
);
5302 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5303 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5304 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5305 cond
, tmp
, build_empty_stmt (input_location
));
5308 gfc_add_expr_to_block (&block
, tmp
);
5310 return gfc_finish_block (&block
);
5314 /* Create an array constructor from an initialization expression.
5315 We assume the frontend already did any expansions and conversions. */
5318 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
5324 unsigned HOST_WIDE_INT lo
;
5326 VEC(constructor_elt
,gc
) *v
= NULL
;
5328 if (expr
->expr_type
== EXPR_VARIABLE
5329 && expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
5330 && expr
->symtree
->n
.sym
->value
)
5331 expr
= expr
->symtree
->n
.sym
->value
;
5333 switch (expr
->expr_type
)
5336 case EXPR_STRUCTURE
:
5337 /* A single scalar or derived type value. Create an array with all
5338 elements equal to that value. */
5339 gfc_init_se (&se
, NULL
);
5341 if (expr
->expr_type
== EXPR_CONSTANT
)
5342 gfc_conv_constant (&se
, expr
);
5344 gfc_conv_structure (&se
, expr
, 1);
5346 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5347 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
5348 hi
= TREE_INT_CST_HIGH (tmp
);
5349 lo
= TREE_INT_CST_LOW (tmp
);
5353 /* This will probably eat buckets of memory for large arrays. */
5354 while (hi
!= 0 || lo
!= 0)
5356 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
5364 /* Create a vector of all the elements. */
5365 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5366 c
; c
= gfc_constructor_next (c
))
5370 /* Problems occur when we get something like
5371 integer :: a(lots) = (/(i, i=1, lots)/) */
5372 gfc_fatal_error ("The number of elements in the array constructor "
5373 "at %L requires an increase of the allowed %d "
5374 "upper limit. See -fmax-array-constructor "
5375 "option", &expr
->where
,
5376 gfc_option
.flag_max_array_constructor
);
5379 if (mpz_cmp_si (c
->offset
, 0) != 0)
5380 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5384 if (mpz_cmp_si (c
->repeat
, 1) > 0)
5390 mpz_add (maxval
, c
->offset
, c
->repeat
);
5391 mpz_sub_ui (maxval
, maxval
, 1);
5392 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5393 if (mpz_cmp_si (c
->offset
, 0) != 0)
5395 mpz_add_ui (maxval
, c
->offset
, 1);
5396 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
5399 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
5401 range
= fold_build2 (RANGE_EXPR
, gfc_array_index_type
, tmp1
, tmp2
);
5407 gfc_init_se (&se
, NULL
);
5408 switch (c
->expr
->expr_type
)
5411 gfc_conv_constant (&se
, c
->expr
);
5414 case EXPR_STRUCTURE
:
5415 gfc_conv_structure (&se
, c
->expr
, 1);
5419 /* Catch those occasional beasts that do not simplify
5420 for one reason or another, assuming that if they are
5421 standard defying the frontend will catch them. */
5422 gfc_conv_expr (&se
, c
->expr
);
5426 if (range
== NULL_TREE
)
5427 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5430 if (index
!= NULL_TREE
)
5431 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
5432 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
5438 return gfc_build_null_descriptor (type
);
5444 /* Create a constructor from the list of elements. */
5445 tmp
= build_constructor (type
, v
);
5446 TREE_CONSTANT (tmp
) = 1;
5451 /* Generate code to evaluate non-constant coarray cobounds. */
5454 gfc_trans_array_cobounds (tree type
, stmtblock_t
* pblock
,
5455 const gfc_symbol
*sym
)
5465 for (dim
= as
->rank
; dim
< as
->rank
+ as
->corank
; dim
++)
5467 /* Evaluate non-constant array bound expressions. */
5468 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5469 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5471 gfc_init_se (&se
, NULL
);
5472 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5473 gfc_add_block_to_block (pblock
, &se
.pre
);
5474 gfc_add_modify (pblock
, lbound
, se
.expr
);
5476 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5477 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5479 gfc_init_se (&se
, NULL
);
5480 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5481 gfc_add_block_to_block (pblock
, &se
.pre
);
5482 gfc_add_modify (pblock
, ubound
, se
.expr
);
5488 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5489 returns the size (in elements) of the array. */
5492 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
5493 stmtblock_t
* pblock
)
5508 size
= gfc_index_one_node
;
5509 offset
= gfc_index_zero_node
;
5510 for (dim
= 0; dim
< as
->rank
; dim
++)
5512 /* Evaluate non-constant array bound expressions. */
5513 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
5514 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
5516 gfc_init_se (&se
, NULL
);
5517 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
5518 gfc_add_block_to_block (pblock
, &se
.pre
);
5519 gfc_add_modify (pblock
, lbound
, se
.expr
);
5521 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
5522 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
5524 gfc_init_se (&se
, NULL
);
5525 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
5526 gfc_add_block_to_block (pblock
, &se
.pre
);
5527 gfc_add_modify (pblock
, ubound
, se
.expr
);
5529 /* The offset of this dimension. offset = offset - lbound * stride. */
5530 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5532 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5535 /* The size of this dimension, and the stride of the next. */
5536 if (dim
+ 1 < as
->rank
)
5537 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
5539 stride
= GFC_TYPE_ARRAY_SIZE (type
);
5541 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
5543 /* Calculate stride = size * (ubound + 1 - lbound). */
5544 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5545 gfc_array_index_type
,
5546 gfc_index_one_node
, lbound
);
5547 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5548 gfc_array_index_type
, ubound
, tmp
);
5549 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5550 gfc_array_index_type
, size
, tmp
);
5552 gfc_add_modify (pblock
, stride
, tmp
);
5554 stride
= gfc_evaluate_now (tmp
, pblock
);
5556 /* Make sure that negative size arrays are translated
5557 to being zero size. */
5558 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5559 stride
, gfc_index_zero_node
);
5560 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5561 gfc_array_index_type
, tmp
,
5562 stride
, gfc_index_zero_node
);
5563 gfc_add_modify (pblock
, stride
, tmp
);
5569 gfc_trans_array_cobounds (type
, pblock
, sym
);
5570 gfc_trans_vla_type_sizes (sym
, pblock
);
5577 /* Generate code to initialize/allocate an array variable. */
5580 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
5581 gfc_wrapped_block
* block
)
5585 tree tmp
= NULL_TREE
;
5592 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
5594 /* Do nothing for USEd variables. */
5595 if (sym
->attr
.use_assoc
)
5598 type
= TREE_TYPE (decl
);
5599 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5600 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
5602 gfc_init_block (&init
);
5604 /* Evaluate character string length. */
5605 if (sym
->ts
.type
== BT_CHARACTER
5606 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5608 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5610 gfc_trans_vla_type_sizes (sym
, &init
);
5612 /* Emit a DECL_EXPR for this variable, which will cause the
5613 gimplifier to allocate storage, and all that good stuff. */
5614 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
5615 gfc_add_expr_to_block (&init
, tmp
);
5620 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5624 type
= TREE_TYPE (type
);
5626 gcc_assert (!sym
->attr
.use_assoc
);
5627 gcc_assert (!TREE_STATIC (decl
));
5628 gcc_assert (!sym
->module
);
5630 if (sym
->ts
.type
== BT_CHARACTER
5631 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
5632 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5634 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5636 /* Don't actually allocate space for Cray Pointees. */
5637 if (sym
->attr
.cray_pointee
)
5639 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5640 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5642 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5646 if (gfc_option
.flag_stack_arrays
)
5648 gcc_assert (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
);
5649 space
= build_decl (sym
->declared_at
.lb
->location
,
5650 VAR_DECL
, create_tmp_var_name ("A"),
5651 TREE_TYPE (TREE_TYPE (decl
)));
5652 gfc_trans_vla_type_sizes (sym
, &init
);
5656 /* The size is the number of elements in the array, so multiply by the
5657 size of an element to get the total size. */
5658 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5659 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5660 size
, fold_convert (gfc_array_index_type
, tmp
));
5662 /* Allocate memory to hold the data. */
5663 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
5664 gfc_add_modify (&init
, decl
, tmp
);
5666 /* Free the temporary. */
5667 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
5671 /* Set offset of the array. */
5672 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5673 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5675 /* Automatic arrays should not have initializers. */
5676 gcc_assert (!sym
->value
);
5678 inittree
= gfc_finish_block (&init
);
5685 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5686 where also space is located. */
5687 gfc_init_block (&init
);
5688 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
5689 TREE_TYPE (space
), space
);
5690 gfc_add_expr_to_block (&init
, tmp
);
5691 addr
= fold_build1_loc (sym
->declared_at
.lb
->location
,
5692 ADDR_EXPR
, TREE_TYPE (decl
), space
);
5693 gfc_add_modify (&init
, decl
, addr
);
5694 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
5697 gfc_add_init_cleanup (block
, inittree
, tmp
);
5701 /* Generate entry and exit code for g77 calling convention arrays. */
5704 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
5714 gfc_save_backend_locus (&loc
);
5715 gfc_set_backend_locus (&sym
->declared_at
);
5717 /* Descriptor type. */
5718 parm
= sym
->backend_decl
;
5719 type
= TREE_TYPE (parm
);
5720 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5722 gfc_start_block (&init
);
5724 if (sym
->ts
.type
== BT_CHARACTER
5725 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5726 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5728 /* Evaluate the bounds of the array. */
5729 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
5731 /* Set the offset. */
5732 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
5733 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
5735 /* Set the pointer itself if we aren't using the parameter directly. */
5736 if (TREE_CODE (parm
) != PARM_DECL
)
5738 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
5739 gfc_add_modify (&init
, parm
, tmp
);
5741 stmt
= gfc_finish_block (&init
);
5743 gfc_restore_backend_locus (&loc
);
5745 /* Add the initialization code to the start of the function. */
5747 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
5749 tmp
= gfc_conv_expr_present (sym
);
5750 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5753 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
5757 /* Modify the descriptor of an array parameter so that it has the
5758 correct lower bound. Also move the upper bound accordingly.
5759 If the array is not packed, it will be copied into a temporary.
5760 For each dimension we set the new lower and upper bounds. Then we copy the
5761 stride and calculate the offset for this dimension. We also work out
5762 what the stride of a packed array would be, and see it the two match.
5763 If the array need repacking, we set the stride to the values we just
5764 calculated, recalculate the offset and copy the array data.
5765 Code is also added to copy the data back at the end of the function.
5769 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
5770 gfc_wrapped_block
* block
)
5777 tree stmtInit
, stmtCleanup
;
5784 tree stride
, stride2
;
5794 /* Do nothing for pointer and allocatable arrays. */
5795 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
5798 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
5800 gfc_trans_g77_array (sym
, block
);
5804 gfc_save_backend_locus (&loc
);
5805 gfc_set_backend_locus (&sym
->declared_at
);
5807 /* Descriptor type. */
5808 type
= TREE_TYPE (tmpdesc
);
5809 gcc_assert (GFC_ARRAY_TYPE_P (type
));
5810 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5811 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
5812 gfc_start_block (&init
);
5814 if (sym
->ts
.type
== BT_CHARACTER
5815 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5816 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
5818 checkparm
= (sym
->as
->type
== AS_EXPLICIT
5819 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
5821 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
5822 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
5824 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
5826 /* For non-constant shape arrays we only check if the first dimension
5827 is contiguous. Repacking higher dimensions wouldn't gain us
5828 anything as we still don't know the array stride. */
5829 partial
= gfc_create_var (boolean_type_node
, "partial");
5830 TREE_USED (partial
) = 1;
5831 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5832 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5833 gfc_index_one_node
);
5834 gfc_add_modify (&init
, partial
, tmp
);
5837 partial
= NULL_TREE
;
5839 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5840 here, however I think it does the right thing. */
5843 /* Set the first stride. */
5844 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
5845 stride
= gfc_evaluate_now (stride
, &init
);
5847 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5848 stride
, gfc_index_zero_node
);
5849 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5850 tmp
, gfc_index_one_node
, stride
);
5851 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
5852 gfc_add_modify (&init
, stride
, tmp
);
5854 /* Allow the user to disable array repacking. */
5855 stmt_unpacked
= NULL_TREE
;
5859 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
5860 /* A library call to repack the array if necessary. */
5861 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
5862 stmt_unpacked
= build_call_expr_loc (input_location
,
5863 gfor_fndecl_in_pack
, 1, tmp
);
5865 stride
= gfc_index_one_node
;
5867 if (gfc_option
.warn_array_temp
)
5868 gfc_warning ("Creating array temporary at %L", &loc
);
5871 /* This is for the case where the array data is used directly without
5872 calling the repack function. */
5873 if (no_repack
|| partial
!= NULL_TREE
)
5874 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
5876 stmt_packed
= NULL_TREE
;
5878 /* Assign the data pointer. */
5879 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
5881 /* Don't repack unknown shape arrays when the first stride is 1. */
5882 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
5883 partial
, stmt_packed
, stmt_unpacked
);
5886 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
5887 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
5889 offset
= gfc_index_zero_node
;
5890 size
= gfc_index_one_node
;
5892 /* Evaluate the bounds of the array. */
5893 for (n
= 0; n
< sym
->as
->rank
; n
++)
5895 if (checkparm
|| !sym
->as
->upper
[n
])
5897 /* Get the bounds of the actual parameter. */
5898 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
5899 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
5903 dubound
= NULL_TREE
;
5904 dlbound
= NULL_TREE
;
5907 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
5908 if (!INTEGER_CST_P (lbound
))
5910 gfc_init_se (&se
, NULL
);
5911 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
5912 gfc_array_index_type
);
5913 gfc_add_block_to_block (&init
, &se
.pre
);
5914 gfc_add_modify (&init
, lbound
, se
.expr
);
5917 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
5918 /* Set the desired upper bound. */
5919 if (sym
->as
->upper
[n
])
5921 /* We know what we want the upper bound to be. */
5922 if (!INTEGER_CST_P (ubound
))
5924 gfc_init_se (&se
, NULL
);
5925 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
5926 gfc_array_index_type
);
5927 gfc_add_block_to_block (&init
, &se
.pre
);
5928 gfc_add_modify (&init
, ubound
, se
.expr
);
5931 /* Check the sizes match. */
5934 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5938 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5939 gfc_array_index_type
, ubound
, lbound
);
5940 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5941 gfc_array_index_type
,
5942 gfc_index_one_node
, temp
);
5943 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
5944 gfc_array_index_type
, dubound
,
5946 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
5947 gfc_array_index_type
,
5948 gfc_index_one_node
, stride2
);
5949 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5950 gfc_array_index_type
, temp
, stride2
);
5951 asprintf (&msg
, "Dimension %d of array '%s' has extent "
5952 "%%ld instead of %%ld", n
+1, sym
->name
);
5954 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
5955 fold_convert (long_integer_type_node
, temp
),
5956 fold_convert (long_integer_type_node
, stride2
));
5963 /* For assumed shape arrays move the upper bound by the same amount
5964 as the lower bound. */
5965 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5966 gfc_array_index_type
, dubound
, dlbound
);
5967 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5968 gfc_array_index_type
, tmp
, lbound
);
5969 gfc_add_modify (&init
, ubound
, tmp
);
5971 /* The offset of this dimension. offset = offset - lbound * stride. */
5972 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5974 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5975 gfc_array_index_type
, offset
, tmp
);
5977 /* The size of this dimension, and the stride of the next. */
5978 if (n
+ 1 < sym
->as
->rank
)
5980 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
5982 if (no_repack
|| partial
!= NULL_TREE
)
5984 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
5986 /* Figure out the stride if not a known constant. */
5987 if (!INTEGER_CST_P (stride
))
5990 stmt_packed
= NULL_TREE
;
5993 /* Calculate stride = size * (ubound + 1 - lbound). */
5994 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5995 gfc_array_index_type
,
5996 gfc_index_one_node
, lbound
);
5997 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5998 gfc_array_index_type
, ubound
, tmp
);
5999 size
= fold_build2_loc (input_location
, MULT_EXPR
,
6000 gfc_array_index_type
, size
, tmp
);
6004 /* Assign the stride. */
6005 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
6006 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6007 gfc_array_index_type
, partial
,
6008 stmt_unpacked
, stmt_packed
);
6010 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
6011 gfc_add_modify (&init
, stride
, tmp
);
6016 stride
= GFC_TYPE_ARRAY_SIZE (type
);
6018 if (stride
&& !INTEGER_CST_P (stride
))
6020 /* Calculate size = stride * (ubound + 1 - lbound). */
6021 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6022 gfc_array_index_type
,
6023 gfc_index_one_node
, lbound
);
6024 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6025 gfc_array_index_type
,
6027 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6028 gfc_array_index_type
,
6029 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
6030 gfc_add_modify (&init
, stride
, tmp
);
6035 gfc_trans_array_cobounds (type
, &init
, sym
);
6037 /* Set the offset. */
6038 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
6039 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
6041 gfc_trans_vla_type_sizes (sym
, &init
);
6043 stmtInit
= gfc_finish_block (&init
);
6045 /* Only do the entry/initialization code if the arg is present. */
6046 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
6047 optional_arg
= (sym
->attr
.optional
6048 || (sym
->ns
->proc_name
->attr
.entry_master
6049 && sym
->attr
.dummy
));
6052 tmp
= gfc_conv_expr_present (sym
);
6053 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
6054 build_empty_stmt (input_location
));
6059 stmtCleanup
= NULL_TREE
;
6062 stmtblock_t cleanup
;
6063 gfc_start_block (&cleanup
);
6065 if (sym
->attr
.intent
!= INTENT_IN
)
6067 /* Copy the data back. */
6068 tmp
= build_call_expr_loc (input_location
,
6069 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
6070 gfc_add_expr_to_block (&cleanup
, tmp
);
6073 /* Free the temporary. */
6074 tmp
= gfc_call_free (tmpdesc
);
6075 gfc_add_expr_to_block (&cleanup
, tmp
);
6077 stmtCleanup
= gfc_finish_block (&cleanup
);
6079 /* Only do the cleanup if the array was repacked. */
6080 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
6081 tmp
= gfc_conv_descriptor_data_get (tmp
);
6082 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6084 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6085 build_empty_stmt (input_location
));
6089 tmp
= gfc_conv_expr_present (sym
);
6090 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
6091 build_empty_stmt (input_location
));
6095 /* We don't need to free any memory allocated by internal_pack as it will
6096 be freed at the end of the function by pop_context. */
6097 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
6099 gfc_restore_backend_locus (&loc
);
6103 /* Calculate the overall offset, including subreferences. */
6105 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
6106 bool subref
, gfc_expr
*expr
)
6116 /* If offset is NULL and this is not a subreferenced array, there is
6118 if (offset
== NULL_TREE
)
6121 offset
= gfc_index_zero_node
;
6126 tmp
= build_array_ref (desc
, offset
, NULL
);
6128 /* Offset the data pointer for pointer assignments from arrays with
6129 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6132 /* Go past the array reference. */
6133 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6134 if (ref
->type
== REF_ARRAY
&&
6135 ref
->u
.ar
.type
!= AR_ELEMENT
)
6141 /* Calculate the offset for each subsequent subreference. */
6142 for (; ref
; ref
= ref
->next
)
6147 field
= ref
->u
.c
.component
->backend_decl
;
6148 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
6149 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6151 tmp
, field
, NULL_TREE
);
6155 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
6156 gfc_init_se (&start
, NULL
);
6157 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
6158 gfc_add_block_to_block (block
, &start
.pre
);
6159 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
6163 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
6164 && ref
->u
.ar
.type
== AR_ELEMENT
);
6166 /* TODO - Add bounds checking. */
6167 stride
= gfc_index_one_node
;
6168 index
= gfc_index_zero_node
;
6169 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6174 /* Update the index. */
6175 gfc_init_se (&start
, NULL
);
6176 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
6177 itmp
= gfc_evaluate_now (start
.expr
, block
);
6178 gfc_init_se (&start
, NULL
);
6179 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
6180 jtmp
= gfc_evaluate_now (start
.expr
, block
);
6181 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6182 gfc_array_index_type
, itmp
, jtmp
);
6183 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6184 gfc_array_index_type
, itmp
, stride
);
6185 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
6186 gfc_array_index_type
, itmp
, index
);
6187 index
= gfc_evaluate_now (index
, block
);
6189 /* Update the stride. */
6190 gfc_init_se (&start
, NULL
);
6191 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
6192 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6193 gfc_array_index_type
, start
.expr
,
6195 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6196 gfc_array_index_type
,
6197 gfc_index_one_node
, itmp
);
6198 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6199 gfc_array_index_type
, stride
, itmp
);
6200 stride
= gfc_evaluate_now (stride
, block
);
6203 /* Apply the index to obtain the array element. */
6204 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
6214 /* Set the target data pointer. */
6215 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
6216 gfc_conv_descriptor_data_set (block
, parm
, offset
);
6220 /* gfc_conv_expr_descriptor needs the string length an expression
6221 so that the size of the temporary can be obtained. This is done
6222 by adding up the string lengths of all the elements in the
6223 expression. Function with non-constant expressions have their
6224 string lengths mapped onto the actual arguments using the
6225 interface mapping machinery in trans-expr.c. */
6227 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
6229 gfc_interface_mapping mapping
;
6230 gfc_formal_arglist
*formal
;
6231 gfc_actual_arglist
*arg
;
6234 if (expr
->ts
.u
.cl
->length
6235 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
6237 if (!expr
->ts
.u
.cl
->backend_decl
)
6238 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6242 switch (expr
->expr_type
)
6245 get_array_charlen (expr
->value
.op
.op1
, se
);
6247 /* For parentheses the expression ts.u.cl is identical. */
6248 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
6251 expr
->ts
.u
.cl
->backend_decl
=
6252 gfc_create_var (gfc_charlen_type_node
, "sln");
6254 if (expr
->value
.op
.op2
)
6256 get_array_charlen (expr
->value
.op
.op2
, se
);
6258 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
6260 /* Add the string lengths and assign them to the expression
6261 string length backend declaration. */
6262 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6263 fold_build2_loc (input_location
, PLUS_EXPR
,
6264 gfc_charlen_type_node
,
6265 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
6266 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
6269 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
6270 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
6274 if (expr
->value
.function
.esym
== NULL
6275 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6277 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6281 /* Map expressions involving the dummy arguments onto the actual
6282 argument expressions. */
6283 gfc_init_interface_mapping (&mapping
);
6284 formal
= expr
->symtree
->n
.sym
->formal
;
6285 arg
= expr
->value
.function
.actual
;
6287 /* Set se = NULL in the calls to the interface mapping, to suppress any
6289 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
6294 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
6297 gfc_init_se (&tse
, NULL
);
6299 /* Build the expression for the character length and convert it. */
6300 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
6302 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
6303 gfc_add_block_to_block (&se
->post
, &tse
.post
);
6304 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
6305 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6306 gfc_charlen_type_node
, tse
.expr
,
6307 build_int_cst (gfc_charlen_type_node
, 0));
6308 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
6309 gfc_free_interface_mapping (&mapping
);
6313 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
6319 /* Helper function to check dimensions. */
6321 transposed_dims (gfc_ss
*ss
)
6325 for (n
= 0; n
< ss
->dimen
; n
++)
6326 if (ss
->dim
[n
] != n
)
6331 /* Convert an array for passing as an actual argument. Expressions and
6332 vector subscripts are evaluated and stored in a temporary, which is then
6333 passed. For whole arrays the descriptor is passed. For array sections
6334 a modified copy of the descriptor is passed, but using the original data.
6336 This function is also used for array pointer assignments, and there
6339 - se->want_pointer && !se->direct_byref
6340 EXPR is an actual argument. On exit, se->expr contains a
6341 pointer to the array descriptor.
6343 - !se->want_pointer && !se->direct_byref
6344 EXPR is an actual argument to an intrinsic function or the
6345 left-hand side of a pointer assignment. On exit, se->expr
6346 contains the descriptor for EXPR.
6348 - !se->want_pointer && se->direct_byref
6349 EXPR is the right-hand side of a pointer assignment and
6350 se->expr is the descriptor for the previously-evaluated
6351 left-hand side. The function creates an assignment from
6355 The se->force_tmp flag disables the non-copying descriptor optimization
6356 that is used for transpose. It may be used in cases where there is an
6357 alias between the transpose argument and another argument in the same
6361 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
6363 gfc_ss_type ss_type
;
6364 gfc_ss_info
*ss_info
;
6366 gfc_array_info
*info
;
6375 bool subref_array_target
= false;
6376 gfc_expr
*arg
, *ss_expr
;
6378 gcc_assert (ss
!= NULL
);
6379 gcc_assert (ss
!= gfc_ss_terminator
);
6382 ss_type
= ss_info
->type
;
6383 ss_expr
= ss_info
->expr
;
6385 /* Special case things we know we can pass easily. */
6386 switch (expr
->expr_type
)
6389 /* If we have a linear array section, we can pass it directly.
6390 Otherwise we need to copy it into a temporary. */
6392 gcc_assert (ss_type
== GFC_SS_SECTION
);
6393 gcc_assert (ss_expr
== expr
);
6394 info
= &ss_info
->data
.array
;
6396 /* Get the descriptor for the array. */
6397 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
6398 desc
= info
->descriptor
;
6400 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
6401 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
6402 && !subref_array_target
;
6409 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6411 /* Create a new descriptor if the array doesn't have one. */
6414 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
6416 else if (se
->direct_byref
)
6419 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
6421 if (full
&& !transposed_dims (ss
))
6423 if (se
->direct_byref
&& !se
->byref_noassign
)
6425 /* Copy the descriptor for pointer assignments. */
6426 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
6428 /* Add any offsets from subreferences. */
6429 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
6430 subref_array_target
, expr
);
6432 else if (se
->want_pointer
)
6434 /* We pass full arrays directly. This means that pointers and
6435 allocatable arrays should also work. */
6436 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6443 if (expr
->ts
.type
== BT_CHARACTER
)
6444 se
->string_length
= gfc_get_expr_charlen (expr
);
6452 /* We don't need to copy data in some cases. */
6453 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
6456 /* This is a call to transpose... */
6457 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6458 /* ... which has already been handled by the scalarizer, so
6459 that we just need to get its argument's descriptor. */
6460 gfc_conv_expr_descriptor (se
, expr
->value
.function
.actual
->expr
, ss
);
6464 /* A transformational function return value will be a temporary
6465 array descriptor. We still need to go through the scalarizer
6466 to create the descriptor. Elemental functions are handled as
6467 arbitrary expressions, i.e. copy to a temporary. */
6469 if (se
->direct_byref
)
6471 gcc_assert (ss_type
== GFC_SS_FUNCTION
&& ss_expr
== expr
);
6473 /* For pointer assignments pass the descriptor directly. */
6477 gcc_assert (se
->ss
== ss
);
6478 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6479 gfc_conv_expr (se
, expr
);
6483 if (ss_expr
!= expr
|| ss_type
!= GFC_SS_FUNCTION
)
6485 if (ss_expr
!= expr
)
6486 /* Elemental function. */
6487 gcc_assert ((expr
->value
.function
.esym
!= NULL
6488 && expr
->value
.function
.esym
->attr
.elemental
)
6489 || (expr
->value
.function
.isym
!= NULL
6490 && expr
->value
.function
.isym
->elemental
)
6491 || gfc_inline_intrinsic_function_p (expr
));
6493 gcc_assert (ss_type
== GFC_SS_INTRINSIC
);
6496 if (expr
->ts
.type
== BT_CHARACTER
6497 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6498 get_array_charlen (expr
, se
);
6504 /* Transformational function. */
6505 info
= &ss_info
->data
.array
;
6511 /* Constant array constructors don't need a temporary. */
6512 if (ss_type
== GFC_SS_CONSTRUCTOR
6513 && expr
->ts
.type
!= BT_CHARACTER
6514 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
6517 info
= &ss_info
->data
.array
;
6527 /* Something complicated. Copy it into a temporary. */
6533 /* If we are creating a temporary, we don't need to bother about aliases
6538 gfc_init_loopinfo (&loop
);
6540 /* Associate the SS with the loop. */
6541 gfc_add_ss_to_loop (&loop
, ss
);
6543 /* Tell the scalarizer not to bother creating loop variables, etc. */
6545 loop
.array_parameter
= 1;
6547 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6548 gcc_assert (!se
->direct_byref
);
6550 /* Setup the scalarizing loops and bounds. */
6551 gfc_conv_ss_startstride (&loop
);
6555 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
6556 get_array_charlen (expr
, se
);
6558 /* Tell the scalarizer to make a temporary. */
6559 loop
.temp_ss
= gfc_get_temp_ss (gfc_typenode_for_spec (&expr
->ts
),
6560 ((expr
->ts
.type
== BT_CHARACTER
)
6561 ? expr
->ts
.u
.cl
->backend_decl
6565 se
->string_length
= loop
.temp_ss
->info
->string_length
;
6566 gcc_assert (loop
.temp_ss
->dimen
== loop
.dimen
);
6567 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
6570 gfc_conv_loop_setup (&loop
, & expr
->where
);
6574 /* Copy into a temporary and pass that. We don't need to copy the data
6575 back because expressions and vector subscripts must be INTENT_IN. */
6576 /* TODO: Optimize passing function return values. */
6580 /* Start the copying loops. */
6581 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
6582 gfc_mark_ss_chain_used (ss
, 1);
6583 gfc_start_scalarized_body (&loop
, &block
);
6585 /* Copy each data element. */
6586 gfc_init_se (&lse
, NULL
);
6587 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6588 gfc_init_se (&rse
, NULL
);
6589 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6591 lse
.ss
= loop
.temp_ss
;
6594 gfc_conv_scalarized_array_ref (&lse
, NULL
);
6595 if (expr
->ts
.type
== BT_CHARACTER
)
6597 gfc_conv_expr (&rse
, expr
);
6598 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
6599 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6603 gfc_conv_expr_val (&rse
, expr
);
6605 gfc_add_block_to_block (&block
, &rse
.pre
);
6606 gfc_add_block_to_block (&block
, &lse
.pre
);
6608 lse
.string_length
= rse
.string_length
;
6609 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
6610 expr
->expr_type
== EXPR_VARIABLE
6611 || expr
->expr_type
== EXPR_ARRAY
, true);
6612 gfc_add_expr_to_block (&block
, tmp
);
6614 /* Finish the copying loops. */
6615 gfc_trans_scalarizing_loops (&loop
, &block
);
6617 desc
= loop
.temp_ss
->info
->data
.array
.descriptor
;
6619 else if (expr
->expr_type
== EXPR_FUNCTION
&& !transposed_dims (ss
))
6621 desc
= info
->descriptor
;
6622 se
->string_length
= ss_info
->string_length
;
6626 /* We pass sections without copying to a temporary. Make a new
6627 descriptor and point it at the section we want. The loop variable
6628 limits will be the limits of the section.
6629 A function may decide to repack the array to speed up access, but
6630 we're not bothered about that here. */
6631 int dim
, ndim
, codim
;
6639 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: ss
->dimen
;
6641 if (se
->want_coarray
)
6643 gfc_array_ref
*ar
= &info
->ref
->u
.ar
;
6645 codim
= gfc_get_corank (expr
);
6646 for (n
= 0; n
< codim
- 1; n
++)
6648 /* Make sure we are not lost somehow. */
6649 gcc_assert (ar
->dimen_type
[n
+ ndim
] == DIMEN_THIS_IMAGE
);
6651 /* Make sure the call to gfc_conv_section_startstride won't
6652 generate unnecessary code to calculate stride. */
6653 gcc_assert (ar
->stride
[n
+ ndim
] == NULL
);
6655 gfc_conv_section_startstride (&loop
, ss
, n
+ ndim
);
6656 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6657 loop
.to
[n
+ loop
.dimen
] = info
->end
[n
+ ndim
];
6660 gcc_assert (n
== codim
- 1);
6661 evaluate_bound (&loop
.pre
, info
->start
, ar
->start
,
6662 info
->descriptor
, n
+ ndim
, true);
6663 loop
.from
[n
+ loop
.dimen
] = info
->start
[n
+ ndim
];
6668 /* Set the string_length for a character array. */
6669 if (expr
->ts
.type
== BT_CHARACTER
)
6670 se
->string_length
= gfc_get_expr_charlen (expr
);
6672 desc
= info
->descriptor
;
6673 if (se
->direct_byref
&& !se
->byref_noassign
)
6675 /* For pointer assignments we fill in the destination. */
6677 parmtype
= TREE_TYPE (parm
);
6681 /* Otherwise make a new one. */
6682 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
6683 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, codim
,
6684 loop
.from
, loop
.to
, 0,
6685 GFC_ARRAY_UNKNOWN
, false);
6686 parm
= gfc_create_var (parmtype
, "parm");
6689 offset
= gfc_index_zero_node
;
6691 /* The following can be somewhat confusing. We have two
6692 descriptors, a new one and the original array.
6693 {parm, parmtype, dim} refer to the new one.
6694 {desc, type, n, loop} refer to the original, which maybe
6695 a descriptorless array.
6696 The bounds of the scalarization are the bounds of the section.
6697 We don't have to worry about numeric overflows when calculating
6698 the offsets because all elements are within the array data. */
6700 /* Set the dtype. */
6701 tmp
= gfc_conv_descriptor_dtype (parm
);
6702 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
6704 /* Set offset for assignments to pointer only to zero if it is not
6706 if (se
->direct_byref
6707 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
6708 base
= gfc_index_zero_node
;
6709 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6710 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
6714 for (n
= 0; n
< ndim
; n
++)
6716 stride
= gfc_conv_array_stride (desc
, n
);
6718 /* Work out the offset. */
6720 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6722 gcc_assert (info
->subscript
[n
]
6723 && info
->subscript
[n
]->info
->type
== GFC_SS_SCALAR
);
6724 start
= info
->subscript
[n
]->info
->data
.scalar
.value
;
6728 /* Evaluate and remember the start of the section. */
6729 start
= info
->start
[n
];
6730 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
6733 tmp
= gfc_conv_array_lbound (desc
, n
);
6734 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6736 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
6738 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
6742 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
6744 /* For elemental dimensions, we only need the offset. */
6748 /* Vector subscripts need copying and are handled elsewhere. */
6750 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
6752 /* look for the corresponding scalarizer dimension: dim. */
6753 for (dim
= 0; dim
< ndim
; dim
++)
6754 if (ss
->dim
[dim
] == n
)
6757 /* loop exited early: the DIM being looked for has been found. */
6758 gcc_assert (dim
< ndim
);
6760 /* Set the new lower bound. */
6761 from
= loop
.from
[dim
];
6764 /* If we have an array section or are assigning make sure that
6765 the lower bound is 1. References to the full
6766 array should otherwise keep the original bounds. */
6768 || info
->ref
->u
.ar
.type
!= AR_FULL
)
6769 && !integer_onep (from
))
6771 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6772 gfc_array_index_type
, gfc_index_one_node
,
6774 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
6775 gfc_array_index_type
, to
, tmp
);
6776 from
= gfc_index_one_node
;
6778 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6779 gfc_rank_cst
[dim
], from
);
6781 /* Set the new upper bound. */
6782 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6783 gfc_rank_cst
[dim
], to
);
6785 /* Multiply the stride by the section stride to get the
6787 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6788 gfc_array_index_type
,
6789 stride
, info
->stride
[n
]);
6791 if (se
->direct_byref
6793 && info
->ref
->u
.ar
.type
!= AR_FULL
)
6795 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
6796 TREE_TYPE (base
), base
, stride
);
6798 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6800 tmp
= gfc_conv_array_lbound (desc
, n
);
6801 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6802 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
6803 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6804 TREE_TYPE (base
), tmp
,
6805 gfc_conv_array_stride (desc
, n
));
6806 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
6807 TREE_TYPE (base
), tmp
, base
);
6810 /* Store the new stride. */
6811 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
6812 gfc_rank_cst
[dim
], stride
);
6815 for (n
= loop
.dimen
; n
< loop
.dimen
+ codim
; n
++)
6817 from
= loop
.from
[n
];
6819 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
6820 gfc_rank_cst
[n
], from
);
6821 if (n
< loop
.dimen
+ codim
- 1)
6822 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
6823 gfc_rank_cst
[n
], to
);
6826 if (se
->data_not_needed
)
6827 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
6828 gfc_index_zero_node
);
6830 /* Point the data pointer at the 1st element in the section. */
6831 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
6832 subref_array_target
, expr
);
6834 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6835 && !se
->data_not_needed
)
6837 /* Set the offset. */
6838 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
6842 /* Only the callee knows what the correct offset it, so just set
6844 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
6849 if (!se
->direct_byref
|| se
->byref_noassign
)
6851 /* Get a pointer to the new descriptor. */
6852 if (se
->want_pointer
)
6853 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
6858 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6859 gfc_add_block_to_block (&se
->post
, &loop
.post
);
6861 /* Cleanup the scalarizer. */
6862 gfc_cleanup_loop (&loop
);
6865 /* Helper function for gfc_conv_array_parameter if array size needs to be
6869 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
6872 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
6873 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
6874 else if (expr
->rank
> 1)
6875 *size
= build_call_expr_loc (input_location
,
6876 gfor_fndecl_size0
, 1,
6877 gfc_build_addr_expr (NULL
, desc
));
6880 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
6881 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
6883 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
6884 gfc_array_index_type
, ubound
, lbound
);
6885 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6886 *size
, gfc_index_one_node
);
6887 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6888 *size
, gfc_index_zero_node
);
6890 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
6891 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6892 *size
, fold_convert (gfc_array_index_type
, elem
));
6895 /* Convert an array for passing as an actual parameter. */
6896 /* TODO: Optimize passing g77 arrays. */
6899 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, bool g77
,
6900 const gfc_symbol
*fsym
, const char *proc_name
,
6905 tree tmp
= NULL_TREE
;
6907 tree parent
= DECL_CONTEXT (current_function_decl
);
6908 bool full_array_var
;
6909 bool this_array_result
;
6912 bool array_constructor
;
6913 bool good_allocatable
;
6914 bool ultimate_ptr_comp
;
6915 bool ultimate_alloc_comp
;
6920 ultimate_ptr_comp
= false;
6921 ultimate_alloc_comp
= false;
6923 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6925 if (ref
->next
== NULL
)
6928 if (ref
->type
== REF_COMPONENT
)
6930 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
6931 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
6935 full_array_var
= false;
6938 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
6939 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
6941 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
6943 /* The symbol should have an array specification. */
6944 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
6946 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
6948 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
6949 expr
->ts
.u
.cl
->backend_decl
= tmp
;
6950 se
->string_length
= tmp
;
6953 /* Is this the result of the enclosing procedure? */
6954 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
6955 if (this_array_result
6956 && (sym
->backend_decl
!= current_function_decl
)
6957 && (sym
->backend_decl
!= parent
))
6958 this_array_result
= false;
6960 /* Passing address of the array if it is not pointer or assumed-shape. */
6961 if (full_array_var
&& g77
&& !this_array_result
)
6963 tmp
= gfc_get_symbol_decl (sym
);
6965 if (sym
->ts
.type
== BT_CHARACTER
)
6966 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6968 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
6970 gfc_conv_expr_descriptor (se
, expr
, ss
);
6971 se
->expr
= gfc_conv_array_data (se
->expr
);
6975 if (!sym
->attr
.pointer
6977 && sym
->as
->type
!= AS_ASSUMED_SHAPE
6978 && sym
->as
->type
!= AS_ASSUMED_RANK
6979 && !sym
->attr
.allocatable
)
6981 /* Some variables are declared directly, others are declared as
6982 pointers and allocated on the heap. */
6983 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
6986 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6988 array_parameter_size (tmp
, expr
, size
);
6992 if (sym
->attr
.allocatable
)
6994 if (sym
->attr
.dummy
|| sym
->attr
.result
)
6996 gfc_conv_expr_descriptor (se
, expr
, ss
);
7000 array_parameter_size (tmp
, expr
, size
);
7001 se
->expr
= gfc_conv_array_data (tmp
);
7006 /* A convenient reduction in scope. */
7007 contiguous
= g77
&& !this_array_result
&& contiguous
;
7009 /* There is no need to pack and unpack the array, if it is contiguous
7010 and not a deferred- or assumed-shape array, or if it is simply
7012 no_pack
= ((sym
&& sym
->as
7013 && !sym
->attr
.pointer
7014 && sym
->as
->type
!= AS_DEFERRED
7015 && sym
->as
->type
!= AS_ASSUMED_RANK
7016 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
7018 (ref
&& ref
->u
.ar
.as
7019 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
7020 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_RANK
7021 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
7023 gfc_is_simply_contiguous (expr
, false));
7025 no_pack
= contiguous
&& no_pack
;
7027 /* Array constructors are always contiguous and do not need packing. */
7028 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
7030 /* Same is true of contiguous sections from allocatable variables. */
7031 good_allocatable
= contiguous
7033 && expr
->symtree
->n
.sym
->attr
.allocatable
;
7035 /* Or ultimate allocatable components. */
7036 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
7038 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
7040 gfc_conv_expr_descriptor (se
, expr
, ss
);
7041 if (expr
->ts
.type
== BT_CHARACTER
)
7042 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
7044 array_parameter_size (se
->expr
, expr
, size
);
7045 se
->expr
= gfc_conv_array_data (se
->expr
);
7049 if (this_array_result
)
7051 /* Result of the enclosing function. */
7052 gfc_conv_expr_descriptor (se
, expr
, ss
);
7054 array_parameter_size (se
->expr
, expr
, size
);
7055 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7057 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
7058 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
7059 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
7066 /* Every other type of array. */
7067 se
->want_pointer
= 1;
7068 gfc_conv_expr_descriptor (se
, expr
, ss
);
7070 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
7075 /* Deallocate the allocatable components of structures that are
7077 if ((expr
->ts
.type
== BT_DERIVED
|| expr
->ts
.type
== BT_CLASS
)
7078 && expr
->ts
.u
.derived
->attr
.alloc_comp
7079 && expr
->expr_type
!= EXPR_VARIABLE
)
7081 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7082 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7084 /* The components shall be deallocated before their containing entity. */
7085 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7088 if (g77
|| (fsym
&& fsym
->attr
.contiguous
7089 && !gfc_is_simply_contiguous (expr
, false)))
7091 tree origptr
= NULL_TREE
;
7095 /* For contiguous arrays, save the original value of the descriptor. */
7098 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
7099 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7100 tmp
= gfc_conv_array_data (tmp
);
7101 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7102 TREE_TYPE (origptr
), origptr
,
7103 fold_convert (TREE_TYPE (origptr
), tmp
));
7104 gfc_add_expr_to_block (&se
->pre
, tmp
);
7107 /* Repack the array. */
7108 if (gfc_option
.warn_array_temp
)
7111 gfc_warning ("Creating array temporary at %L for argument '%s'",
7112 &expr
->where
, fsym
->name
);
7114 gfc_warning ("Creating array temporary at %L", &expr
->where
);
7117 ptr
= build_call_expr_loc (input_location
,
7118 gfor_fndecl_in_pack
, 1, desc
);
7120 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7122 tmp
= gfc_conv_expr_present (sym
);
7123 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
7124 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
7125 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
7128 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
7130 /* Use the packed data for the actual argument, except for contiguous arrays,
7131 where the descriptor's data component is set. */
7136 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7137 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
7140 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
7144 if (fsym
&& proc_name
)
7145 asprintf (&msg
, "An array temporary was created for argument "
7146 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
7148 asprintf (&msg
, "An array temporary was created");
7150 tmp
= build_fold_indirect_ref_loc (input_location
,
7152 tmp
= gfc_conv_array_data (tmp
);
7153 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7154 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7156 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7157 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7159 gfc_conv_expr_present (sym
), tmp
);
7161 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
7166 gfc_start_block (&block
);
7168 /* Copy the data back. */
7169 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
7171 tmp
= build_call_expr_loc (input_location
,
7172 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
7173 gfc_add_expr_to_block (&block
, tmp
);
7176 /* Free the temporary. */
7177 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
7178 gfc_add_expr_to_block (&block
, tmp
);
7180 stmt
= gfc_finish_block (&block
);
7182 gfc_init_block (&block
);
7183 /* Only if it was repacked. This code needs to be executed before the
7184 loop cleanup code. */
7185 tmp
= build_fold_indirect_ref_loc (input_location
,
7187 tmp
= gfc_conv_array_data (tmp
);
7188 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7189 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
7191 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
7192 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7194 gfc_conv_expr_present (sym
), tmp
);
7196 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
7198 gfc_add_expr_to_block (&block
, tmp
);
7199 gfc_add_block_to_block (&block
, &se
->post
);
7201 gfc_init_block (&se
->post
);
7203 /* Reset the descriptor pointer. */
7206 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
7207 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
7210 gfc_add_block_to_block (&se
->post
, &block
);
7215 /* Generate code to deallocate an array, if it is allocated. */
7218 gfc_trans_dealloc_allocated (tree descriptor
, bool coarray
)
7224 gfc_start_block (&block
);
7226 var
= gfc_conv_descriptor_data_get (descriptor
);
7229 /* Call array_deallocate with an int * present in the second argument.
7230 Although it is ignored here, it's presence ensures that arrays that
7231 are already deallocated are ignored. */
7232 tmp
= gfc_deallocate_with_status (coarray
? descriptor
: var
, NULL_TREE
,
7233 NULL_TREE
, NULL_TREE
, NULL_TREE
, true,
7235 gfc_add_expr_to_block (&block
, tmp
);
7237 /* Zero the data pointer. */
7238 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7239 var
, build_int_cst (TREE_TYPE (var
), 0));
7240 gfc_add_expr_to_block (&block
, tmp
);
7242 return gfc_finish_block (&block
);
7246 /* This helper function calculates the size in words of a full array. */
7249 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
7254 idx
= gfc_rank_cst
[rank
- 1];
7255 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
7256 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
7257 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7259 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7260 tmp
, gfc_index_one_node
);
7261 tmp
= gfc_evaluate_now (tmp
, block
);
7263 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
7264 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7266 return gfc_evaluate_now (tmp
, block
);
7270 /* Allocate dest to the same size as src, and copy src -> dest.
7271 If no_malloc is set, only the copy is done. */
7274 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
7284 /* If the source is null, set the destination to null. Then,
7285 allocate memory to the destination. */
7286 gfc_init_block (&block
);
7290 tmp
= null_pointer_node
;
7291 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
7292 gfc_add_expr_to_block (&block
, tmp
);
7293 null_data
= gfc_finish_block (&block
);
7295 gfc_init_block (&block
);
7296 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
7299 tmp
= gfc_call_malloc (&block
, type
, size
);
7300 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7301 dest
, fold_convert (type
, tmp
));
7302 gfc_add_expr_to_block (&block
, tmp
);
7305 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7306 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
7311 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7312 null_data
= gfc_finish_block (&block
);
7314 gfc_init_block (&block
);
7315 nelems
= get_full_array_size (&block
, src
, rank
);
7316 tmp
= fold_convert (gfc_array_index_type
,
7317 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
7318 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7322 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
7323 tmp
= gfc_call_malloc (&block
, tmp
, size
);
7324 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
7327 /* We know the temporary and the value will be the same length,
7328 so can use memcpy. */
7329 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7330 tmp
= build_call_expr_loc (input_location
,
7331 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
7332 gfc_conv_descriptor_data_get (src
), size
);
7335 gfc_add_expr_to_block (&block
, tmp
);
7336 tmp
= gfc_finish_block (&block
);
7338 /* Null the destination if the source is null; otherwise do
7339 the allocate and copy. */
7343 null_cond
= gfc_conv_descriptor_data_get (src
);
7345 null_cond
= convert (pvoid_type_node
, null_cond
);
7346 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7347 null_cond
, null_pointer_node
);
7348 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
7352 /* Allocate dest to the same size as src, and copy data src -> dest. */
7355 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
7357 return duplicate_allocatable (dest
, src
, type
, rank
, false);
7361 /* Copy data src -> dest. */
7364 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
7366 return duplicate_allocatable (dest
, src
, type
, rank
, true);
7370 /* Recursively traverse an object of derived type, generating code to
7371 deallocate, nullify or copy allocatable components. This is the work horse
7372 function for the functions named in this enum. */
7374 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
7375 COPY_ONLY_ALLOC_COMP
};
7378 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
7379 tree dest
, int rank
, int purpose
)
7383 stmtblock_t fnblock
;
7384 stmtblock_t loopbody
;
7385 stmtblock_t tmpblock
;
7396 tree null_cond
= NULL_TREE
;
7397 bool called_dealloc_with_status
;
7399 gfc_init_block (&fnblock
);
7401 decl_type
= TREE_TYPE (decl
);
7403 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
7404 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
7405 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
7407 /* Just in case in gets dereferenced. */
7408 decl_type
= TREE_TYPE (decl
);
7410 /* If this an array of derived types with allocatable components
7411 build a loop and recursively call this function. */
7412 if (TREE_CODE (decl_type
) == ARRAY_TYPE
7413 || (GFC_DESCRIPTOR_TYPE_P (decl_type
) && rank
!= 0))
7415 tmp
= gfc_conv_array_data (decl
);
7416 var
= build_fold_indirect_ref_loc (input_location
,
7419 /* Get the number of elements - 1 and set the counter. */
7420 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
7422 /* Use the descriptor for an allocatable array. Since this
7423 is a full array reference, we only need the descriptor
7424 information from dimension = rank. */
7425 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
7426 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7427 gfc_array_index_type
, tmp
,
7428 gfc_index_one_node
);
7430 null_cond
= gfc_conv_descriptor_data_get (decl
);
7431 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7432 boolean_type_node
, null_cond
,
7433 build_int_cst (TREE_TYPE (null_cond
), 0));
7437 /* Otherwise use the TYPE_DOMAIN information. */
7438 tmp
= array_type_nelts (decl_type
);
7439 tmp
= fold_convert (gfc_array_index_type
, tmp
);
7442 /* Remember that this is, in fact, the no. of elements - 1. */
7443 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
7444 index
= gfc_create_var (gfc_array_index_type
, "S");
7446 /* Build the body of the loop. */
7447 gfc_init_block (&loopbody
);
7449 vref
= gfc_build_array_ref (var
, index
, NULL
);
7451 if (purpose
== COPY_ALLOC_COMP
)
7453 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
7455 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
7456 gfc_add_expr_to_block (&fnblock
, tmp
);
7458 tmp
= build_fold_indirect_ref_loc (input_location
,
7459 gfc_conv_array_data (dest
));
7460 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7461 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
7463 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
7465 tmp
= build_fold_indirect_ref_loc (input_location
,
7466 gfc_conv_array_data (dest
));
7467 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
7468 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
7472 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
7474 gfc_add_expr_to_block (&loopbody
, tmp
);
7476 /* Build the loop and return. */
7477 gfc_init_loopinfo (&loop
);
7479 loop
.from
[0] = gfc_index_zero_node
;
7480 loop
.loopvar
[0] = index
;
7481 loop
.to
[0] = nelems
;
7482 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
7483 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
7485 tmp
= gfc_finish_block (&fnblock
);
7486 if (null_cond
!= NULL_TREE
)
7487 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
7488 build_empty_stmt (input_location
));
7493 /* Otherwise, act on the components or recursively call self to
7494 act on a chain of components. */
7495 for (c
= der_type
->components
; c
; c
= c
->next
)
7497 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
7498 || c
->ts
.type
== BT_CLASS
)
7499 && c
->ts
.u
.derived
->attr
.alloc_comp
;
7500 cdecl = c
->backend_decl
;
7501 ctype
= TREE_TYPE (cdecl);
7505 case DEALLOCATE_ALLOC_COMP
:
7507 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7508 (i.e. this function) so generate all the calls and suppress the
7509 recursion from here, if necessary. */
7510 called_dealloc_with_status
= false;
7511 gfc_init_block (&tmpblock
);
7513 if (c
->attr
.allocatable
7514 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7516 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7517 decl
, cdecl, NULL_TREE
);
7518 tmp
= gfc_trans_dealloc_allocated (comp
, c
->attr
.codimension
);
7519 gfc_add_expr_to_block (&tmpblock
, tmp
);
7521 else if (c
->attr
.allocatable
)
7523 /* Allocatable scalar components. */
7524 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7525 decl
, cdecl, NULL_TREE
);
7527 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7529 gfc_add_expr_to_block (&tmpblock
, tmp
);
7530 called_dealloc_with_status
= true;
7532 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7533 void_type_node
, comp
,
7534 build_int_cst (TREE_TYPE (comp
), 0));
7535 gfc_add_expr_to_block (&tmpblock
, tmp
);
7537 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7539 /* Allocatable CLASS components. */
7540 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7541 decl
, cdecl, NULL_TREE
);
7543 /* Add reference to '_data' component. */
7544 tmp
= CLASS_DATA (c
)->backend_decl
;
7545 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7546 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7548 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp
)))
7549 tmp
= gfc_trans_dealloc_allocated (comp
,
7550 CLASS_DATA (c
)->attr
.codimension
);
7553 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
7554 CLASS_DATA (c
)->ts
);
7555 gfc_add_expr_to_block (&tmpblock
, tmp
);
7556 called_dealloc_with_status
= true;
7558 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7559 void_type_node
, comp
,
7560 build_int_cst (TREE_TYPE (comp
), 0));
7562 gfc_add_expr_to_block (&tmpblock
, tmp
);
7565 if (cmp_has_alloc_comps
7567 && !called_dealloc_with_status
)
7569 /* Do not deallocate the components of ultimate pointer
7570 components or iteratively call self if call has been made
7571 to gfc_trans_dealloc_allocated */
7572 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7573 decl
, cdecl, NULL_TREE
);
7574 rank
= c
->as
? c
->as
->rank
: 0;
7575 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7577 gfc_add_expr_to_block (&fnblock
, tmp
);
7580 /* Now add the deallocation of this component. */
7581 gfc_add_block_to_block (&fnblock
, &tmpblock
);
7584 case NULLIFY_ALLOC_COMP
:
7585 if (c
->attr
.pointer
)
7587 else if (c
->attr
.allocatable
7588 && (c
->attr
.dimension
|| c
->attr
.codimension
))
7590 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7591 decl
, cdecl, NULL_TREE
);
7592 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7594 else if (c
->attr
.allocatable
)
7596 /* Allocatable scalar components. */
7597 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7598 decl
, cdecl, NULL_TREE
);
7599 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7600 void_type_node
, comp
,
7601 build_int_cst (TREE_TYPE (comp
), 0));
7602 gfc_add_expr_to_block (&fnblock
, tmp
);
7604 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7606 /* Allocatable CLASS components. */
7607 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7608 decl
, cdecl, NULL_TREE
);
7609 /* Add reference to '_data' component. */
7610 tmp
= CLASS_DATA (c
)->backend_decl
;
7611 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7612 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
7613 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp
)))
7614 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
7617 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7618 void_type_node
, comp
,
7619 build_int_cst (TREE_TYPE (comp
), 0));
7620 gfc_add_expr_to_block (&fnblock
, tmp
);
7623 else if (cmp_has_alloc_comps
)
7625 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
7626 decl
, cdecl, NULL_TREE
);
7627 rank
= c
->as
? c
->as
->rank
: 0;
7628 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
7630 gfc_add_expr_to_block (&fnblock
, tmp
);
7634 case COPY_ALLOC_COMP
:
7635 if (c
->attr
.pointer
)
7638 /* We need source and destination components. */
7639 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
7641 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
7643 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
7645 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
7653 dst_data
= gfc_class_data_get (dcmp
);
7654 src_data
= gfc_class_data_get (comp
);
7655 size
= fold_convert (size_type_node
, gfc_vtable_size_get (comp
));
7657 if (CLASS_DATA (c
)->attr
.dimension
)
7659 nelems
= gfc_conv_descriptor_size (src_data
,
7660 CLASS_DATA (c
)->as
->rank
);
7661 src_data
= gfc_conv_descriptor_data_get (src_data
);
7662 dst_data
= gfc_conv_descriptor_data_get (dst_data
);
7665 nelems
= build_int_cst (size_type_node
, 1);
7667 gfc_init_block (&tmpblock
);
7669 /* We need to use CALLOC as _copy might try to free allocatable
7670 components of the destination. */
7671 ftn_tree
= builtin_decl_explicit (BUILT_IN_CALLOC
);
7672 tmp
= build_call_expr_loc (input_location
, ftn_tree
, 2, nelems
,
7674 gfc_add_modify (&tmpblock
, dst_data
,
7675 fold_convert (TREE_TYPE (dst_data
), tmp
));
7677 tmp
= gfc_copy_class_to_class (comp
, dcmp
, nelems
);
7678 gfc_add_expr_to_block (&tmpblock
, tmp
);
7679 tmp
= gfc_finish_block (&tmpblock
);
7681 gfc_init_block (&tmpblock
);
7682 gfc_add_modify (&tmpblock
, dst_data
,
7683 fold_convert (TREE_TYPE (dst_data
),
7684 null_pointer_node
));
7685 null_data
= gfc_finish_block (&tmpblock
);
7687 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
7688 boolean_type_node
, src_data
,
7691 gfc_add_expr_to_block (&fnblock
, build3_v (COND_EXPR
, null_cond
,
7696 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
7698 rank
= c
->as
? c
->as
->rank
: 0;
7699 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
7700 gfc_add_expr_to_block (&fnblock
, tmp
);
7703 if (cmp_has_alloc_comps
)
7705 rank
= c
->as
? c
->as
->rank
: 0;
7706 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
7707 gfc_add_modify (&fnblock
, dcmp
, tmp
);
7708 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
7710 gfc_add_expr_to_block (&fnblock
, tmp
);
7720 return gfc_finish_block (&fnblock
);
7723 /* Recursively traverse an object of derived type, generating code to
7724 nullify allocatable components. */
7727 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7729 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7730 NULLIFY_ALLOC_COMP
);
7734 /* Recursively traverse an object of derived type, generating code to
7735 deallocate allocatable components. */
7738 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
7740 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
7741 DEALLOCATE_ALLOC_COMP
);
7745 /* Recursively traverse an object of derived type, generating code to
7746 copy it and its allocatable components. */
7749 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7751 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
7755 /* Recursively traverse an object of derived type, generating code to
7756 copy only its allocatable components. */
7759 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
7761 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
7765 /* Returns the value of LBOUND for an expression. This could be broken out
7766 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7767 called by gfc_alloc_allocatable_for_assignment. */
7769 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
7774 tree cond
, cond1
, cond3
, cond4
;
7778 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
7780 tmp
= gfc_rank_cst
[dim
];
7781 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
7782 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
7783 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
7784 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7786 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
7787 stride
, gfc_index_zero_node
);
7788 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7789 boolean_type_node
, cond3
, cond1
);
7790 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7791 stride
, gfc_index_zero_node
);
7793 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7794 tmp
, build_int_cst (gfc_array_index_type
,
7797 cond
= boolean_false_node
;
7799 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7800 boolean_type_node
, cond3
, cond4
);
7801 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7802 boolean_type_node
, cond
, cond1
);
7804 return fold_build3_loc (input_location
, COND_EXPR
,
7805 gfc_array_index_type
, cond
,
7806 lbound
, gfc_index_one_node
);
7809 if (expr
->expr_type
== EXPR_FUNCTION
)
7811 /* A conversion function, so use the argument. */
7812 gcc_assert (expr
->value
.function
.isym
7813 && expr
->value
.function
.isym
->conversion
);
7814 expr
= expr
->value
.function
.actual
->expr
;
7817 if (expr
->expr_type
== EXPR_VARIABLE
)
7819 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
7820 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7822 if (ref
->type
== REF_COMPONENT
7823 && ref
->u
.c
.component
->as
7825 && ref
->next
->u
.ar
.type
== AR_FULL
)
7826 tmp
= TREE_TYPE (ref
->u
.c
.component
->backend_decl
);
7828 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
7831 return gfc_index_one_node
;
7835 /* Returns true if an expression represents an lhs that can be reallocated
7839 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
7846 /* An allocatable variable. */
7847 if (expr
->symtree
->n
.sym
->attr
.allocatable
7849 && expr
->ref
->type
== REF_ARRAY
7850 && expr
->ref
->u
.ar
.type
== AR_FULL
)
7853 /* All that can be left are allocatable components. */
7854 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7855 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7856 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7859 /* Find a component ref followed by an array reference. */
7860 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7862 && ref
->type
== REF_COMPONENT
7863 && ref
->next
->type
== REF_ARRAY
7864 && !ref
->next
->next
)
7870 /* Return true if valid reallocatable lhs. */
7871 if (ref
->u
.c
.component
->attr
.allocatable
7872 && ref
->next
->u
.ar
.type
== AR_FULL
)
7879 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7883 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
7887 stmtblock_t realloc_block
;
7888 stmtblock_t alloc_block
;
7892 gfc_array_info
*linfo
;
7912 gfc_array_spec
* as
;
7914 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7915 Find the lhs expression in the loop chain and set expr1 and
7916 expr2 accordingly. */
7917 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
7920 /* Find the ss for the lhs. */
7922 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7923 if (lss
->info
->expr
&& lss
->info
->expr
->expr_type
== EXPR_VARIABLE
)
7925 if (lss
== gfc_ss_terminator
)
7927 expr1
= lss
->info
->expr
;
7930 /* Bail out if this is not a valid allocate on assignment. */
7931 if (!gfc_is_reallocatable_lhs (expr1
)
7932 || (expr2
&& !expr2
->rank
))
7935 /* Find the ss for the lhs. */
7937 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
7938 if (lss
->info
->expr
== expr1
)
7941 if (lss
== gfc_ss_terminator
)
7944 linfo
= &lss
->info
->data
.array
;
7946 /* Find an ss for the rhs. For operator expressions, we see the
7947 ss's for the operands. Any one of these will do. */
7949 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
7950 if (rss
->info
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
7953 if (expr2
&& rss
== gfc_ss_terminator
)
7956 gfc_start_block (&fblock
);
7958 /* Since the lhs is allocatable, this must be a descriptor type.
7959 Get the data and array size. */
7960 desc
= linfo
->descriptor
;
7961 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
7962 array1
= gfc_conv_descriptor_data_get (desc
);
7964 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7965 deallocated if expr is an array of different shape or any of the
7966 corresponding length type parameter values of variable and expr
7967 differ." This assures F95 compatibility. */
7968 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7969 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7971 /* Allocate if data is NULL. */
7972 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7973 array1
, build_int_cst (TREE_TYPE (array1
), 0));
7974 tmp
= build3_v (COND_EXPR
, cond
,
7975 build1_v (GOTO_EXPR
, jump_label1
),
7976 build_empty_stmt (input_location
));
7977 gfc_add_expr_to_block (&fblock
, tmp
);
7979 /* Get arrayspec if expr is a full array. */
7980 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
7981 && expr2
->value
.function
.isym
7982 && expr2
->value
.function
.isym
->conversion
)
7984 /* For conversion functions, take the arg. */
7985 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
7986 as
= gfc_get_full_arrayspec_from_expr (arg
);
7989 as
= gfc_get_full_arrayspec_from_expr (expr2
);
7993 /* If the lhs shape is not the same as the rhs jump to setting the
7994 bounds and doing the reallocation....... */
7995 for (n
= 0; n
< expr1
->rank
; n
++)
7997 /* Check the shape. */
7998 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7999 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8000 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8001 gfc_array_index_type
,
8002 loop
->to
[n
], loop
->from
[n
]);
8003 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8004 gfc_array_index_type
,
8006 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8007 gfc_array_index_type
,
8009 cond
= fold_build2_loc (input_location
, NE_EXPR
,
8011 tmp
, gfc_index_zero_node
);
8012 tmp
= build3_v (COND_EXPR
, cond
,
8013 build1_v (GOTO_EXPR
, jump_label1
),
8014 build_empty_stmt (input_location
));
8015 gfc_add_expr_to_block (&fblock
, tmp
);
8018 /* ....else jump past the (re)alloc code. */
8019 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8020 gfc_add_expr_to_block (&fblock
, tmp
);
8022 /* Add the label to start automatic (re)allocation. */
8023 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8024 gfc_add_expr_to_block (&fblock
, tmp
);
8026 size1
= gfc_conv_descriptor_size (desc
, expr1
->rank
);
8028 /* Get the rhs size. Fix both sizes. */
8030 desc2
= rss
->info
->data
.array
.descriptor
;
8033 size2
= gfc_index_one_node
;
8034 for (n
= 0; n
< expr2
->rank
; n
++)
8036 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8037 gfc_array_index_type
,
8038 loop
->to
[n
], loop
->from
[n
]);
8039 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8040 gfc_array_index_type
,
8041 tmp
, gfc_index_one_node
);
8042 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8043 gfc_array_index_type
,
8047 size1
= gfc_evaluate_now (size1
, &fblock
);
8048 size2
= gfc_evaluate_now (size2
, &fblock
);
8050 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8052 neq_size
= gfc_evaluate_now (cond
, &fblock
);
8055 /* Now modify the lhs descriptor and the associated scalarizer
8056 variables. F2003 7.4.1.3: "If variable is or becomes an
8057 unallocated allocatable variable, then it is allocated with each
8058 deferred type parameter equal to the corresponding type parameters
8059 of expr , with the shape of expr , and with each lower bound equal
8060 to the corresponding element of LBOUND(expr)."
8061 Reuse size1 to keep a dimension-by-dimension track of the
8062 stride of the new array. */
8063 size1
= gfc_index_one_node
;
8064 offset
= gfc_index_zero_node
;
8066 for (n
= 0; n
< expr2
->rank
; n
++)
8068 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8069 gfc_array_index_type
,
8070 loop
->to
[n
], loop
->from
[n
]);
8071 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8072 gfc_array_index_type
,
8073 tmp
, gfc_index_one_node
);
8075 lbound
= gfc_index_one_node
;
8080 lbd
= get_std_lbound (expr2
, desc2
, n
,
8081 as
->type
== AS_ASSUMED_SIZE
);
8082 ubound
= fold_build2_loc (input_location
,
8084 gfc_array_index_type
,
8086 ubound
= fold_build2_loc (input_location
,
8088 gfc_array_index_type
,
8093 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
8096 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
8099 gfc_conv_descriptor_stride_set (&fblock
, desc
,
8102 lbound
= gfc_conv_descriptor_lbound_get (desc
,
8104 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
8105 gfc_array_index_type
,
8107 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8108 gfc_array_index_type
,
8110 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
8111 gfc_array_index_type
,
8115 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8116 the array offset is saved and the info.offset is used for a
8117 running offset. Use the saved_offset instead. */
8118 tmp
= gfc_conv_descriptor_offset (desc
);
8119 gfc_add_modify (&fblock
, tmp
, offset
);
8120 if (linfo
->saved_offset
8121 && TREE_CODE (linfo
->saved_offset
) == VAR_DECL
)
8122 gfc_add_modify (&fblock
, linfo
->saved_offset
, tmp
);
8124 /* Now set the deltas for the lhs. */
8125 for (n
= 0; n
< expr1
->rank
; n
++)
8127 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8129 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8130 gfc_array_index_type
, tmp
,
8132 if (linfo
->delta
[dim
]
8133 && TREE_CODE (linfo
->delta
[dim
]) == VAR_DECL
)
8134 gfc_add_modify (&fblock
, linfo
->delta
[dim
], tmp
);
8137 /* Get the new lhs size in bytes. */
8138 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8140 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
8141 gcc_assert (expr1
->ts
.u
.cl
->backend_decl
);
8142 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
8143 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
8145 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
8147 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
8148 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8149 gfc_array_index_type
, tmp
,
8150 expr1
->ts
.u
.cl
->backend_decl
);
8153 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8154 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8155 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
8156 gfc_array_index_type
,
8158 size2
= fold_convert (size_type_node
, size2
);
8159 size2
= gfc_evaluate_now (size2
, &fblock
);
8161 /* Realloc expression. Note that the scalarizer uses desc.data
8162 in the array reference - (*desc.data)[<element>]. */
8163 gfc_init_block (&realloc_block
);
8164 tmp
= build_call_expr_loc (input_location
,
8165 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
8166 fold_convert (pvoid_type_node
, array1
),
8168 gfc_conv_descriptor_data_set (&realloc_block
,
8170 realloc_expr
= gfc_finish_block (&realloc_block
);
8172 /* Only reallocate if sizes are different. */
8173 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
8174 build_empty_stmt (input_location
));
8178 /* Malloc expression. */
8179 gfc_init_block (&alloc_block
);
8180 tmp
= build_call_expr_loc (input_location
,
8181 builtin_decl_explicit (BUILT_IN_MALLOC
),
8183 gfc_conv_descriptor_data_set (&alloc_block
,
8185 tmp
= gfc_conv_descriptor_dtype (desc
);
8186 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8187 alloc_expr
= gfc_finish_block (&alloc_block
);
8189 /* Malloc if not allocated; realloc otherwise. */
8190 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
8191 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8194 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
8195 gfc_add_expr_to_block (&fblock
, tmp
);
8197 /* Make sure that the scalarizer data pointer is updated. */
8199 && TREE_CODE (linfo
->data
) == VAR_DECL
)
8201 tmp
= gfc_conv_descriptor_data_get (desc
);
8202 gfc_add_modify (&fblock
, linfo
->data
, tmp
);
8205 /* Add the exit label. */
8206 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8207 gfc_add_expr_to_block (&fblock
, tmp
);
8209 return gfc_finish_block (&fblock
);
8213 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8214 Do likewise, recursively if necessary, with the allocatable components of
8218 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
8224 stmtblock_t cleanup
;
8227 bool sym_has_alloc_comp
;
8229 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
8230 || sym
->ts
.type
== BT_CLASS
)
8231 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
8233 /* Make sure the frontend gets these right. */
8234 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
8235 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
8236 "allocatable attribute or derived type without allocatable "
8239 gfc_save_backend_locus (&loc
);
8240 gfc_set_backend_locus (&sym
->declared_at
);
8241 gfc_init_block (&init
);
8243 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
8244 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
8246 if (sym
->ts
.type
== BT_CHARACTER
8247 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
8249 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
8250 gfc_trans_vla_type_sizes (sym
, &init
);
8253 /* Dummy, use associated and result variables don't need anything special. */
8254 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
8256 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8257 gfc_restore_backend_locus (&loc
);
8261 descriptor
= sym
->backend_decl
;
8263 /* Although static, derived types with default initializers and
8264 allocatable components must not be nulled wholesale; instead they
8265 are treated component by component. */
8266 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
8268 /* SAVEd variables are not freed on exit. */
8269 gfc_trans_static_array_pointer (sym
);
8271 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
8272 gfc_restore_backend_locus (&loc
);
8276 /* Get the descriptor type. */
8277 type
= TREE_TYPE (sym
->backend_decl
);
8279 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
8282 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
8284 if (sym
->value
== NULL
8285 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
8287 rank
= sym
->as
? sym
->as
->rank
: 0;
8288 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
8290 gfc_add_expr_to_block (&init
, tmp
);
8293 gfc_init_default_dt (sym
, &init
, false);
8296 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
8298 /* If the backend_decl is not a descriptor, we must have a pointer
8300 descriptor
= build_fold_indirect_ref_loc (input_location
,
8302 type
= TREE_TYPE (descriptor
);
8305 /* NULLIFY the data pointer. */
8306 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
8307 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
8309 gfc_restore_backend_locus (&loc
);
8310 gfc_init_block (&cleanup
);
8312 /* Allocatable arrays need to be freed when they go out of scope.
8313 The allocatable components of pointers must not be touched. */
8314 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
8315 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
8318 rank
= sym
->as
? sym
->as
->rank
: 0;
8319 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
8320 gfc_add_expr_to_block (&cleanup
, tmp
);
8323 if (sym
->attr
.allocatable
&& (sym
->attr
.dimension
|| sym
->attr
.codimension
)
8324 && !sym
->attr
.save
&& !sym
->attr
.result
)
8326 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
,
8327 sym
->attr
.codimension
);
8328 gfc_add_expr_to_block (&cleanup
, tmp
);
8331 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
8332 gfc_finish_block (&cleanup
));
8335 /************ Expression Walking Functions ******************/
8337 /* Walk a variable reference.
8339 Possible extension - multiple component subscripts.
8340 x(:,:) = foo%a(:)%b(:)
8342 forall (i=..., j=...)
8343 x(i,j) = foo%a(j)%b(i)
8345 This adds a fair amount of complexity because you need to deal with more
8346 than one ref. Maybe handle in a similar manner to vector subscripts.
8347 Maybe not worth the effort. */
8351 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8355 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8356 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
8359 return gfc_walk_array_ref (ss
, expr
, ref
);
8364 gfc_walk_array_ref (gfc_ss
* ss
, gfc_expr
* expr
, gfc_ref
* ref
)
8370 for (; ref
; ref
= ref
->next
)
8372 if (ref
->type
== REF_SUBSTRING
)
8374 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.start
);
8375 ss
= gfc_get_scalar_ss (ss
, ref
->u
.ss
.end
);
8378 /* We're only interested in array sections from now on. */
8379 if (ref
->type
!= REF_ARRAY
)
8387 for (n
= ar
->dimen
- 1; n
>= 0; n
--)
8388 ss
= gfc_get_scalar_ss (ss
, ar
->start
[n
]);
8392 newss
= gfc_get_array_ss (ss
, expr
, ar
->as
->rank
, GFC_SS_SECTION
);
8393 newss
->info
->data
.array
.ref
= ref
;
8395 /* Make sure array is the same as array(:,:), this way
8396 we don't need to special case all the time. */
8397 ar
->dimen
= ar
->as
->rank
;
8398 for (n
= 0; n
< ar
->dimen
; n
++)
8400 ar
->dimen_type
[n
] = DIMEN_RANGE
;
8402 gcc_assert (ar
->start
[n
] == NULL
);
8403 gcc_assert (ar
->end
[n
] == NULL
);
8404 gcc_assert (ar
->stride
[n
] == NULL
);
8410 newss
= gfc_get_array_ss (ss
, expr
, 0, GFC_SS_SECTION
);
8411 newss
->info
->data
.array
.ref
= ref
;
8413 /* We add SS chains for all the subscripts in the section. */
8414 for (n
= 0; n
< ar
->dimen
; n
++)
8418 switch (ar
->dimen_type
[n
])
8421 /* Add SS for elemental (scalar) subscripts. */
8422 gcc_assert (ar
->start
[n
]);
8423 indexss
= gfc_get_scalar_ss (gfc_ss_terminator
, ar
->start
[n
]);
8424 indexss
->loop_chain
= gfc_ss_terminator
;
8425 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8429 /* We don't add anything for sections, just remember this
8430 dimension for later. */
8431 newss
->dim
[newss
->dimen
] = n
;
8436 /* Create a GFC_SS_VECTOR index in which we can store
8437 the vector's descriptor. */
8438 indexss
= gfc_get_array_ss (gfc_ss_terminator
, ar
->start
[n
],
8440 indexss
->loop_chain
= gfc_ss_terminator
;
8441 newss
->info
->data
.array
.subscript
[n
] = indexss
;
8442 newss
->dim
[newss
->dimen
] = n
;
8447 /* We should know what sort of section it is by now. */
8451 /* We should have at least one non-elemental dimension,
8452 unless we are creating a descriptor for a (scalar) coarray. */
8453 gcc_assert (newss
->dimen
> 0
8454 || newss
->info
->data
.array
.ref
->u
.ar
.as
->corank
> 0);
8459 /* We should know what sort of section it is by now. */
8468 /* Walk an expression operator. If only one operand of a binary expression is
8469 scalar, we must also add the scalar term to the SS chain. */
8472 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8477 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
8478 if (expr
->value
.op
.op2
== NULL
)
8481 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
8483 /* All operands are scalar. Pass back and let the caller deal with it. */
8487 /* All operands require scalarization. */
8488 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
8491 /* One of the operands needs scalarization, the other is scalar.
8492 Create a gfc_ss for the scalar expression. */
8495 /* First operand is scalar. We build the chain in reverse order, so
8496 add the scalar SS after the second operand. */
8498 while (head
&& head
->next
!= ss
)
8500 /* Check we haven't somehow broken the chain. */
8502 head
->next
= gfc_get_scalar_ss (ss
, expr
->value
.op
.op1
);
8504 else /* head2 == head */
8506 gcc_assert (head2
== head
);
8507 /* Second operand is scalar. */
8508 head2
= gfc_get_scalar_ss (head2
, expr
->value
.op
.op2
);
8515 /* Reverse a SS chain. */
8518 gfc_reverse_ss (gfc_ss
* ss
)
8523 gcc_assert (ss
!= NULL
);
8525 head
= gfc_ss_terminator
;
8526 while (ss
!= gfc_ss_terminator
)
8529 /* Check we didn't somehow break the chain. */
8530 gcc_assert (next
!= NULL
);
8540 /* Given an expression referring to a procedure, return the symbol of its
8541 interface. We can't get the procedure symbol directly as we have to handle
8542 the case of (deferred) type-bound procedures. */
8545 gfc_get_proc_ifc_for_expr (gfc_expr
*procedure_ref
)
8550 if (procedure_ref
== NULL
)
8553 /* Normal procedure case. */
8554 sym
= procedure_ref
->symtree
->n
.sym
;
8556 /* Typebound procedure case. */
8557 for (ref
= procedure_ref
->ref
; ref
; ref
= ref
->next
)
8559 if (ref
->type
== REF_COMPONENT
8560 && ref
->u
.c
.component
->attr
.proc_pointer
)
8561 sym
= ref
->u
.c
.component
->ts
.interface
;
8570 /* Walk the arguments of an elemental function.
8571 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8572 it is NULL, we don't do the check and the argument is assumed to be present.
8576 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
8577 gfc_symbol
*proc_ifc
, gfc_ss_type type
)
8579 gfc_formal_arglist
*dummy_arg
;
8585 head
= gfc_ss_terminator
;
8589 dummy_arg
= proc_ifc
->formal
;
8594 for (; arg
; arg
= arg
->next
)
8596 if (!arg
->expr
|| arg
->expr
->expr_type
== EXPR_NULL
)
8599 newss
= gfc_walk_subexpr (head
, arg
->expr
);
8602 /* Scalar argument. */
8603 gcc_assert (type
== GFC_SS_SCALAR
|| type
== GFC_SS_REFERENCE
);
8604 newss
= gfc_get_scalar_ss (head
, arg
->expr
);
8605 newss
->info
->type
= type
;
8611 if (dummy_arg
!= NULL
8612 && dummy_arg
->sym
->attr
.optional
8613 && arg
->expr
->expr_type
== EXPR_VARIABLE
8614 && (gfc_expr_attr (arg
->expr
).optional
8615 || gfc_expr_attr (arg
->expr
).allocatable
8616 || gfc_expr_attr (arg
->expr
).pointer
))
8617 newss
->info
->can_be_null_ref
= true;
8623 while (tail
->next
!= gfc_ss_terminator
)
8627 if (dummy_arg
!= NULL
)
8628 dummy_arg
= dummy_arg
->next
;
8633 /* If all the arguments are scalar we don't need the argument SS. */
8634 gfc_free_ss_chain (head
);
8639 /* Add it onto the existing chain. */
8645 /* Walk a function call. Scalar functions are passed back, and taken out of
8646 scalarization loops. For elemental functions we walk their arguments.
8647 The result of functions returning arrays is stored in a temporary outside
8648 the loop, so that the function is only called once. Hence we do not need
8649 to walk their arguments. */
8652 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
8654 gfc_intrinsic_sym
*isym
;
8656 gfc_component
*comp
= NULL
;
8658 isym
= expr
->value
.function
.isym
;
8660 /* Handle intrinsic functions separately. */
8662 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
8664 sym
= expr
->value
.function
.esym
;
8666 sym
= expr
->symtree
->n
.sym
;
8668 /* A function that returns arrays. */
8669 comp
= gfc_get_proc_ptr_comp (expr
);
8670 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
8671 || (comp
&& comp
->attr
.dimension
))
8672 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8674 /* Walk the parameters of an elemental function. For now we always pass
8676 if (sym
->attr
.elemental
|| (comp
&& comp
->attr
.elemental
))
8677 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8678 gfc_get_proc_ifc_for_expr (expr
),
8681 /* Scalar functions are OK as these are evaluated outside the scalarization
8682 loop. Pass back and let the caller deal with it. */
8687 /* An array temporary is constructed for array constructors. */
8690 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
8692 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_CONSTRUCTOR
);
8696 /* Walk an expression. Add walked expressions to the head of the SS chain.
8697 A wholly scalar expression will not be added. */
8700 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
8704 switch (expr
->expr_type
)
8707 head
= gfc_walk_variable_expr (ss
, expr
);
8711 head
= gfc_walk_op_expr (ss
, expr
);
8715 head
= gfc_walk_function_expr (ss
, expr
);
8720 case EXPR_STRUCTURE
:
8721 /* Pass back and let the caller deal with it. */
8725 head
= gfc_walk_array_constructor (ss
, expr
);
8728 case EXPR_SUBSTRING
:
8729 /* Pass back and let the caller deal with it. */
8733 internal_error ("bad expression type during walk (%d)",
8740 /* Entry point for expression walking.
8741 A return value equal to the passed chain means this is
8742 a scalar expression. It is up to the caller to take whatever action is
8743 necessary to translate these. */
8746 gfc_walk_expr (gfc_expr
* expr
)
8750 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
8751 return gfc_reverse_ss (res
);