1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.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 gfc_ss
*gfc_walk_subexpr (gfc_ss
*, gfc_expr
*);
97 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor
*);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var
;
101 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
105 gfc_array_dataptr_type (tree desc
)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
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
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
153 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set_tuples. */
167 gfc_conv_descriptor_data_set_internal (stmtblock_t
*block
,
168 tree desc
, tree value
,
173 type
= TREE_TYPE (desc
);
174 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
176 field
= TYPE_FIELDS (type
);
177 gcc_assert (DATA_FIELD
== 0);
179 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
180 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
), tuples_p
);
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
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
199 return build_fold_addr_expr (t
);
203 gfc_conv_descriptor_offset (tree desc
)
208 type
= TREE_TYPE (desc
);
209 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
211 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
212 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
214 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
218 gfc_conv_descriptor_dtype (tree desc
)
223 type
= TREE_TYPE (desc
);
224 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
226 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
227 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
229 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
233 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
239 type
= TREE_TYPE (desc
);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
242 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
243 gcc_assert (field
!= NULL_TREE
244 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
245 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
247 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
248 tmp
= gfc_build_array_ref (tmp
, dim
, NULL
);
253 gfc_conv_descriptor_stride (tree desc
, tree dim
)
258 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
259 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
260 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
261 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
263 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
268 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
273 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
274 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
275 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
276 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
278 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
283 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
288 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
289 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
290 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
291 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
293 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
298 /* Build a null array descriptor constructor. */
301 gfc_build_null_descriptor (tree type
)
306 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
307 gcc_assert (DATA_FIELD
== 0);
308 field
= TYPE_FIELDS (type
);
310 /* Set a NULL data pointer. */
311 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
312 TREE_CONSTANT (tmp
) = 1;
313 TREE_INVARIANT (tmp
) = 1;
314 /* All other fields are ignored. */
320 /* Cleanup those #defines. */
325 #undef DIMENSION_FIELD
326 #undef STRIDE_SUBFIELD
327 #undef LBOUND_SUBFIELD
328 #undef UBOUND_SUBFIELD
331 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
332 flags & 1 = Main loop body.
333 flags & 2 = temp copy loop. */
336 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
338 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
339 ss
->useflags
= flags
;
342 static void gfc_free_ss (gfc_ss
*);
345 /* Free a gfc_ss chain. */
348 gfc_free_ss_chain (gfc_ss
* ss
)
352 while (ss
!= gfc_ss_terminator
)
354 gcc_assert (ss
!= NULL
);
365 gfc_free_ss (gfc_ss
* ss
)
372 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
374 if (ss
->data
.info
.subscript
[n
])
375 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
387 /* Free all the SS associated with a loop. */
390 gfc_cleanup_loop (gfc_loopinfo
* loop
)
396 while (ss
!= gfc_ss_terminator
)
398 gcc_assert (ss
!= NULL
);
399 next
= ss
->loop_chain
;
406 /* Associate a SS chain with a loop. */
409 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
413 if (head
== gfc_ss_terminator
)
417 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
419 if (ss
->next
== gfc_ss_terminator
)
420 ss
->loop_chain
= loop
->ss
;
422 ss
->loop_chain
= ss
->next
;
424 gcc_assert (ss
== gfc_ss_terminator
);
429 /* Generate an initializer for a static pointer or allocatable array. */
432 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
436 gcc_assert (TREE_STATIC (sym
->backend_decl
));
437 /* Just zero the data member. */
438 type
= TREE_TYPE (sym
->backend_decl
);
439 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
443 /* If the bounds of SE's loop have not yet been set, see if they can be
444 determined from array spec AS, which is the array spec of a called
445 function. MAPPING maps the callee's dummy arguments to the values
446 that the caller is passing. Add any initialization and finalization
450 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
451 gfc_se
* se
, gfc_array_spec
* as
)
459 if (as
&& as
->type
== AS_EXPLICIT
)
460 for (dim
= 0; dim
< se
->loop
->dimen
; dim
++)
462 n
= se
->loop
->order
[dim
];
463 if (se
->loop
->to
[n
] == NULL_TREE
)
465 /* Evaluate the lower bound. */
466 gfc_init_se (&tmpse
, NULL
);
467 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
468 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
469 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
472 /* ...and the upper bound. */
473 gfc_init_se (&tmpse
, NULL
);
474 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
475 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
476 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
479 /* Set the upper bound of the loop to UPPER - LOWER. */
480 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
481 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
482 se
->loop
->to
[n
] = tmp
;
488 /* Generate code to allocate an array temporary, or create a variable to
489 hold the data. If size is NULL, zero the descriptor so that the
490 callee will allocate the array. If DEALLOC is true, also generate code to
491 free the array afterwards.
493 Initialization code is added to PRE and finalization code to POST.
494 DYNAMIC is true if the caller may want to extend the array later
495 using realloc. This prevents us from putting the array on the stack. */
498 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
499 gfc_ss_info
* info
, tree size
, tree nelem
,
500 bool dynamic
, bool dealloc
)
506 desc
= info
->descriptor
;
507 info
->offset
= gfc_index_zero_node
;
508 if (size
== NULL_TREE
|| integer_zerop (size
))
510 /* A callee allocated array. */
511 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
516 /* Allocate the temporary. */
517 onstack
= !dynamic
&& gfc_can_put_var_on_stack (size
);
521 /* Make a temporary variable to hold the data. */
522 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
524 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
526 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
528 tmp
= gfc_create_var (tmp
, "A");
529 tmp
= build_fold_addr_expr (tmp
);
530 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
534 /* Allocate memory to hold the data. */
535 tmp
= gfc_call_malloc (pre
, NULL
, size
);
536 tmp
= gfc_evaluate_now (tmp
, pre
);
537 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
540 info
->data
= gfc_conv_descriptor_data_get (desc
);
542 /* The offset is zero because we create temporaries with a zero
544 tmp
= gfc_conv_descriptor_offset (desc
);
545 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
547 if (dealloc
&& !onstack
)
549 /* Free the temporary. */
550 tmp
= gfc_conv_descriptor_data_get (desc
);
551 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
552 gfc_add_expr_to_block (post
, tmp
);
557 /* Generate code to create and initialize the descriptor for a temporary
558 array. This is used for both temporaries needed by the scalarizer, and
559 functions returning arrays. Adjusts the loop variables to be
560 zero-based, and calculates the loop bounds for callee allocated arrays.
561 Allocate the array unless it's callee allocated (we have a callee
562 allocated array if 'callee_alloc' is true, or if loop->to[n] is
563 NULL_TREE for any n). Also fills in the descriptor, data and offset
564 fields of info if known. Returns the size of the array, or NULL for a
565 callee allocated array.
567 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
571 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
572 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
573 tree eltype
, bool dynamic
, bool dealloc
,
586 gcc_assert (info
->dimen
> 0);
587 /* Set the lower bound to zero. */
588 for (dim
= 0; dim
< info
->dimen
; dim
++)
590 n
= loop
->order
[dim
];
591 if (n
< loop
->temp_dim
)
592 gcc_assert (integer_zerop (loop
->from
[n
]));
595 /* Callee allocated arrays may not have a known bound yet. */
597 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
598 loop
->to
[n
], loop
->from
[n
]);
599 loop
->from
[n
] = gfc_index_zero_node
;
602 info
->delta
[dim
] = gfc_index_zero_node
;
603 info
->start
[dim
] = gfc_index_zero_node
;
604 info
->end
[dim
] = gfc_index_zero_node
;
605 info
->stride
[dim
] = gfc_index_one_node
;
606 info
->dim
[dim
] = dim
;
609 /* Initialize the descriptor. */
611 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
612 desc
= gfc_create_var (type
, "atmp");
613 GFC_DECL_PACKED_ARRAY (desc
) = 1;
615 info
->descriptor
= desc
;
616 size
= gfc_index_one_node
;
618 /* Fill in the array dtype. */
619 tmp
= gfc_conv_descriptor_dtype (desc
);
620 gfc_add_modify_expr (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
623 Fill in the bounds and stride. This is a packed array, so:
626 for (n = 0; n < rank; n++)
629 delta = ubound[n] + 1 - lbound[n];
632 size = size * sizeof(element);
637 for (n
= 0; n
< info
->dimen
; n
++)
639 if (loop
->to
[n
] == NULL_TREE
)
641 /* For a callee allocated array express the loop bounds in terms
642 of the descriptor fields. */
643 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
644 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
645 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
651 /* Store the stride and bound components in the descriptor. */
652 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
653 gfc_add_modify_expr (pre
, tmp
, size
);
655 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
656 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
658 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
659 gfc_add_modify_expr (pre
, tmp
, loop
->to
[n
]);
661 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
662 loop
->to
[n
], gfc_index_one_node
);
664 /* Check whether the size for this dimension is negative. */
665 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
666 gfc_index_zero_node
);
667 cond
= gfc_evaluate_now (cond
, pre
);
672 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
674 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
675 size
= gfc_evaluate_now (size
, pre
);
678 /* Get the size of the array. */
680 if (size
&& !callee_alloc
)
682 /* If or_expr is true, then the extent in at least one
683 dimension is zero and the size is set to zero. */
684 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
,
685 or_expr
, gfc_index_zero_node
, size
);
688 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
689 fold_convert (gfc_array_index_type
,
690 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
698 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, dynamic
,
701 if (info
->dimen
> loop
->temp_dim
)
702 loop
->temp_dim
= info
->dimen
;
708 /* Generate code to transpose array EXPR by creating a new descriptor
709 in which the dimension specifications have been reversed. */
712 gfc_conv_array_transpose (gfc_se
* se
, gfc_expr
* expr
)
714 tree dest
, src
, dest_index
, src_index
;
716 gfc_ss_info
*dest_info
, *src_info
;
717 gfc_ss
*dest_ss
, *src_ss
;
723 src_ss
= gfc_walk_expr (expr
);
726 src_info
= &src_ss
->data
.info
;
727 dest_info
= &dest_ss
->data
.info
;
728 gcc_assert (dest_info
->dimen
== 2);
729 gcc_assert (src_info
->dimen
== 2);
731 /* Get a descriptor for EXPR. */
732 gfc_init_se (&src_se
, NULL
);
733 gfc_conv_expr_descriptor (&src_se
, expr
, src_ss
);
734 gfc_add_block_to_block (&se
->pre
, &src_se
.pre
);
735 gfc_add_block_to_block (&se
->post
, &src_se
.post
);
738 /* Allocate a new descriptor for the return value. */
739 dest
= gfc_create_var (TREE_TYPE (src
), "atmp");
740 dest_info
->descriptor
= dest
;
743 /* Copy across the dtype field. */
744 gfc_add_modify_expr (&se
->pre
,
745 gfc_conv_descriptor_dtype (dest
),
746 gfc_conv_descriptor_dtype (src
));
748 /* Copy the dimension information, renumbering dimension 1 to 0 and
750 for (n
= 0; n
< 2; n
++)
752 dest_info
->delta
[n
] = gfc_index_zero_node
;
753 dest_info
->start
[n
] = gfc_index_zero_node
;
754 dest_info
->end
[n
] = gfc_index_zero_node
;
755 dest_info
->stride
[n
] = gfc_index_one_node
;
756 dest_info
->dim
[n
] = n
;
758 dest_index
= gfc_rank_cst
[n
];
759 src_index
= gfc_rank_cst
[1 - n
];
761 gfc_add_modify_expr (&se
->pre
,
762 gfc_conv_descriptor_stride (dest
, dest_index
),
763 gfc_conv_descriptor_stride (src
, src_index
));
765 gfc_add_modify_expr (&se
->pre
,
766 gfc_conv_descriptor_lbound (dest
, dest_index
),
767 gfc_conv_descriptor_lbound (src
, src_index
));
769 gfc_add_modify_expr (&se
->pre
,
770 gfc_conv_descriptor_ubound (dest
, dest_index
),
771 gfc_conv_descriptor_ubound (src
, src_index
));
775 gcc_assert (integer_zerop (loop
->from
[n
]));
776 loop
->to
[n
] = build2 (MINUS_EXPR
, gfc_array_index_type
,
777 gfc_conv_descriptor_ubound (dest
, dest_index
),
778 gfc_conv_descriptor_lbound (dest
, dest_index
));
782 /* Copy the data pointer. */
783 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
784 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
786 /* Copy the offset. This is not changed by transposition; the top-left
787 element is still at the same offset as before, except where the loop
789 if (!integer_zerop (loop
->from
[0]))
790 dest_info
->offset
= gfc_conv_descriptor_offset (src
);
792 dest_info
->offset
= gfc_index_zero_node
;
794 gfc_add_modify_expr (&se
->pre
,
795 gfc_conv_descriptor_offset (dest
),
798 if (dest_info
->dimen
> loop
->temp_dim
)
799 loop
->temp_dim
= dest_info
->dimen
;
803 /* Return the number of iterations in a loop that starts at START,
804 ends at END, and has step STEP. */
807 gfc_get_iteration_count (tree start
, tree end
, tree step
)
812 type
= TREE_TYPE (step
);
813 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
814 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
815 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
816 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
817 return fold_convert (gfc_array_index_type
, tmp
);
821 /* Extend the data in array DESC by EXTRA elements. */
824 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
831 if (integer_zerop (extra
))
834 ubound
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
836 /* Add EXTRA to the upper bound. */
837 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
838 gfc_add_modify_expr (pblock
, ubound
, tmp
);
840 /* Get the value of the current data pointer. */
841 arg0
= gfc_conv_descriptor_data_get (desc
);
843 /* Calculate the new array size. */
844 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
845 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, gfc_index_one_node
);
846 arg1
= build2 (MULT_EXPR
, size_type_node
, fold_convert (size_type_node
, tmp
),
847 fold_convert (size_type_node
, size
));
849 /* Call the realloc() function. */
850 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
851 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
855 /* Return true if the bounds of iterator I can only be determined
859 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
861 return (i
->start
->expr_type
!= EXPR_CONSTANT
862 || i
->end
->expr_type
!= EXPR_CONSTANT
863 || i
->step
->expr_type
!= EXPR_CONSTANT
);
867 /* Split the size of constructor element EXPR into the sum of two terms,
868 one of which can be determined at compile time and one of which must
869 be calculated at run time. Set *SIZE to the former and return true
870 if the latter might be nonzero. */
873 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
875 if (expr
->expr_type
== EXPR_ARRAY
)
876 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
877 else if (expr
->rank
> 0)
879 /* Calculate everything at run time. */
880 mpz_set_ui (*size
, 0);
885 /* A single element. */
886 mpz_set_ui (*size
, 1);
892 /* Like gfc_get_array_constructor_element_size, but applied to the whole
893 of array constructor C. */
896 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor
* c
)
903 mpz_set_ui (*size
, 0);
908 for (; c
; c
= c
->next
)
911 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
915 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
918 /* Multiply the static part of the element size by the
919 number of iterations. */
920 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
921 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
922 mpz_add_ui (val
, val
, 1);
923 if (mpz_sgn (val
) > 0)
924 mpz_mul (len
, len
, val
);
928 mpz_add (*size
, *size
, len
);
937 /* Make sure offset is a variable. */
940 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
943 /* We should have already created the offset variable. We cannot
944 create it here because we may be in an inner scope. */
945 gcc_assert (*offsetvar
!= NULL_TREE
);
946 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
947 *poffset
= *offsetvar
;
948 TREE_USED (*offsetvar
) = 1;
952 /* Assign an element of an array constructor. */
955 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
956 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
960 gfc_conv_expr (se
, expr
);
962 /* Store the value. */
963 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc
));
964 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
965 if (expr
->ts
.type
== BT_CHARACTER
)
967 gfc_conv_string_parameter (se
);
968 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
970 /* The temporary is an array of pointers. */
971 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
972 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
976 /* The temporary is an array of string values. */
977 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
978 /* We know the temporary and the value will be the same length,
979 so can use memcpy. */
980 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
981 tmp
, se
->expr
, se
->string_length
);
982 gfc_add_expr_to_block (&se
->pre
, tmp
);
987 /* TODO: Should the frontend already have done this conversion? */
988 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
989 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
992 gfc_add_block_to_block (pblock
, &se
->pre
);
993 gfc_add_block_to_block (pblock
, &se
->post
);
997 /* Add the contents of an array to the constructor. DYNAMIC is as for
998 gfc_trans_array_constructor_value. */
1001 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1002 tree type ATTRIBUTE_UNUSED
,
1003 tree desc
, gfc_expr
* expr
,
1004 tree
* poffset
, tree
* offsetvar
,
1015 /* We need this to be a variable so we can increment it. */
1016 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1018 gfc_init_se (&se
, NULL
);
1020 /* Walk the array expression. */
1021 ss
= gfc_walk_expr (expr
);
1022 gcc_assert (ss
!= gfc_ss_terminator
);
1024 /* Initialize the scalarizer. */
1025 gfc_init_loopinfo (&loop
);
1026 gfc_add_ss_to_loop (&loop
, ss
);
1028 /* Initialize the loop. */
1029 gfc_conv_ss_startstride (&loop
);
1030 gfc_conv_loop_setup (&loop
);
1032 /* Make sure the constructed array has room for the new data. */
1035 /* Set SIZE to the total number of elements in the subarray. */
1036 size
= gfc_index_one_node
;
1037 for (n
= 0; n
< loop
.dimen
; n
++)
1039 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1040 gfc_index_one_node
);
1041 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1044 /* Grow the constructed array by SIZE elements. */
1045 gfc_grow_array (&loop
.pre
, desc
, size
);
1048 /* Make the loop body. */
1049 gfc_mark_ss_chain_used (ss
, 1);
1050 gfc_start_scalarized_body (&loop
, &body
);
1051 gfc_copy_loopinfo_to_se (&se
, &loop
);
1054 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1055 gcc_assert (se
.ss
== gfc_ss_terminator
);
1057 /* Increment the offset. */
1058 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
1059 gfc_add_modify_expr (&body
, *poffset
, tmp
);
1061 /* Finish the loop. */
1062 gfc_trans_scalarizing_loops (&loop
, &body
);
1063 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1064 tmp
= gfc_finish_block (&loop
.pre
);
1065 gfc_add_expr_to_block (pblock
, tmp
);
1067 gfc_cleanup_loop (&loop
);
1071 /* Assign the values to the elements of an array constructor. DYNAMIC
1072 is true if descriptor DESC only contains enough data for the static
1073 size calculated by gfc_get_array_constructor_size. When true, memory
1074 for the dynamic parts must be allocated using realloc. */
1077 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1078 tree desc
, gfc_constructor
* c
,
1079 tree
* poffset
, tree
* offsetvar
,
1088 for (; c
; c
= c
->next
)
1090 /* If this is an iterator or an array, the offset must be a variable. */
1091 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1092 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1094 gfc_start_block (&body
);
1096 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1098 /* Array constructors can be nested. */
1099 gfc_trans_array_constructor_value (&body
, type
, desc
,
1100 c
->expr
->value
.constructor
,
1101 poffset
, offsetvar
, dynamic
);
1103 else if (c
->expr
->rank
> 0)
1105 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1106 poffset
, offsetvar
, dynamic
);
1110 /* This code really upsets the gimplifier so don't bother for now. */
1117 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1124 /* Scalar values. */
1125 gfc_init_se (&se
, NULL
);
1126 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1129 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1130 *poffset
, gfc_index_one_node
);
1134 /* Collect multiple scalar constants into a constructor. */
1142 /* Count the number of consecutive scalar constants. */
1143 while (p
&& !(p
->iterator
1144 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1146 gfc_init_se (&se
, NULL
);
1147 gfc_conv_constant (&se
, p
->expr
);
1148 if (p
->expr
->ts
.type
== BT_CHARACTER
1149 && POINTER_TYPE_P (type
))
1151 /* For constant character array constructors we build
1152 an array of pointers. */
1153 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
1157 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1162 bound
= build_int_cst (NULL_TREE
, n
- 1);
1163 /* Create an array type to hold them. */
1164 tmptype
= build_range_type (gfc_array_index_type
,
1165 gfc_index_zero_node
, bound
);
1166 tmptype
= build_array_type (type
, tmptype
);
1168 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1169 TREE_CONSTANT (init
) = 1;
1170 TREE_INVARIANT (init
) = 1;
1171 TREE_STATIC (init
) = 1;
1172 /* Create a static variable to hold the data. */
1173 tmp
= gfc_create_var (tmptype
, "data");
1174 TREE_STATIC (tmp
) = 1;
1175 TREE_CONSTANT (tmp
) = 1;
1176 TREE_INVARIANT (tmp
) = 1;
1177 TREE_READONLY (tmp
) = 1;
1178 DECL_INITIAL (tmp
) = init
;
1181 /* Use BUILTIN_MEMCPY to assign the values. */
1182 tmp
= gfc_conv_descriptor_data_get (desc
);
1183 tmp
= build_fold_indirect_ref (tmp
);
1184 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1185 tmp
= build_fold_addr_expr (tmp
);
1186 init
= build_fold_addr_expr (init
);
1188 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1189 bound
= build_int_cst (NULL_TREE
, n
* size
);
1190 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
1192 gfc_add_expr_to_block (&body
, tmp
);
1194 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1196 build_int_cst (gfc_array_index_type
, n
));
1198 if (!INTEGER_CST_P (*poffset
))
1200 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
1201 *poffset
= *offsetvar
;
1205 /* The frontend should already have done any expansions possible
1209 /* Pass the code as is. */
1210 tmp
= gfc_finish_block (&body
);
1211 gfc_add_expr_to_block (pblock
, tmp
);
1215 /* Build the implied do-loop. */
1225 loopbody
= gfc_finish_block (&body
);
1227 gfc_init_se (&se
, NULL
);
1228 gfc_conv_expr (&se
, c
->iterator
->var
);
1229 gfc_add_block_to_block (pblock
, &se
.pre
);
1232 /* Make a temporary, store the current value in that
1233 and return it, once the loop is done. */
1234 tmp_loopvar
= gfc_create_var (TREE_TYPE (loopvar
), "loopvar");
1235 gfc_add_modify_expr (pblock
, tmp_loopvar
, loopvar
);
1237 /* Initialize the loop. */
1238 gfc_init_se (&se
, NULL
);
1239 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1240 gfc_add_block_to_block (pblock
, &se
.pre
);
1241 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
1243 gfc_init_se (&se
, NULL
);
1244 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1245 gfc_add_block_to_block (pblock
, &se
.pre
);
1246 end
= gfc_evaluate_now (se
.expr
, pblock
);
1248 gfc_init_se (&se
, NULL
);
1249 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1250 gfc_add_block_to_block (pblock
, &se
.pre
);
1251 step
= gfc_evaluate_now (se
.expr
, pblock
);
1253 /* If this array expands dynamically, and the number of iterations
1254 is not constant, we won't have allocated space for the static
1255 part of C->EXPR's size. Do that now. */
1256 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1258 /* Get the number of iterations. */
1259 tmp
= gfc_get_iteration_count (loopvar
, end
, step
);
1261 /* Get the static part of C->EXPR's size. */
1262 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1263 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1265 /* Grow the array by TMP * TMP2 elements. */
1266 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1267 gfc_grow_array (pblock
, desc
, tmp
);
1270 /* Generate the loop body. */
1271 exit_label
= gfc_build_label_decl (NULL_TREE
);
1272 gfc_start_block (&body
);
1274 /* Generate the exit condition. Depending on the sign of
1275 the step variable we have to generate the correct
1277 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1278 build_int_cst (TREE_TYPE (step
), 0));
1279 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1280 build2 (GT_EXPR
, boolean_type_node
,
1282 build2 (LT_EXPR
, boolean_type_node
,
1284 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1285 TREE_USED (exit_label
) = 1;
1286 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1287 gfc_add_expr_to_block (&body
, tmp
);
1289 /* The main loop body. */
1290 gfc_add_expr_to_block (&body
, loopbody
);
1292 /* Increase loop variable by step. */
1293 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
1294 gfc_add_modify_expr (&body
, loopvar
, tmp
);
1296 /* Finish the loop. */
1297 tmp
= gfc_finish_block (&body
);
1298 tmp
= build1_v (LOOP_EXPR
, tmp
);
1299 gfc_add_expr_to_block (pblock
, tmp
);
1301 /* Add the exit label. */
1302 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1303 gfc_add_expr_to_block (pblock
, tmp
);
1305 /* Restore the original value of the loop counter. */
1306 gfc_add_modify_expr (pblock
, loopvar
, tmp_loopvar
);
1313 /* Figure out the string length of a variable reference expression.
1314 Used by get_array_ctor_strlen. */
1317 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1323 /* Don't bother if we already know the length is a constant. */
1324 if (*len
&& INTEGER_CST_P (*len
))
1327 ts
= &expr
->symtree
->n
.sym
->ts
;
1328 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1333 /* Array references don't change the string length. */
1337 /* Use the length of the component. */
1338 ts
= &ref
->u
.c
.component
->ts
;
1342 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1343 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
)
1345 mpz_init_set_ui (char_len
, 1);
1346 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1347 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1348 *len
= gfc_conv_mpz_to_tree (char_len
,
1349 gfc_default_character_kind
);
1350 *len
= convert (gfc_charlen_type_node
, *len
);
1351 mpz_clear (char_len
);
1355 /* TODO: Substrings are tricky because we can't evaluate the
1356 expression more than once. For now we just give up, and hope
1357 we can figure it out elsewhere. */
1362 *len
= ts
->cl
->backend_decl
;
1366 /* A catch-all to obtain the string length for anything that is not a
1367 constant, array or variable. */
1369 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1374 /* Don't bother if we already know the length is a constant. */
1375 if (*len
&& INTEGER_CST_P (*len
))
1378 if (!e
->ref
&& e
->ts
.cl
&& e
->ts
.cl
->length
1379 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1382 gfc_conv_const_charlen (e
->ts
.cl
);
1383 *len
= e
->ts
.cl
->backend_decl
;
1387 /* Otherwise, be brutal even if inefficient. */
1388 ss
= gfc_walk_expr (e
);
1389 gfc_init_se (&se
, NULL
);
1391 /* No function call, in case of side effects. */
1392 se
.no_function_call
= 1;
1393 if (ss
== gfc_ss_terminator
)
1394 gfc_conv_expr (&se
, e
);
1396 gfc_conv_expr_descriptor (&se
, e
, ss
);
1398 /* Fix the value. */
1399 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1401 gfc_add_block_to_block (block
, &se
.pre
);
1402 gfc_add_block_to_block (block
, &se
.post
);
1404 e
->ts
.cl
->backend_decl
= *len
;
1409 /* Figure out the string length of a character array constructor.
1410 Returns TRUE if all elements are character constants. */
1413 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor
* c
, tree
* len
)
1421 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1425 for (; c
; c
= c
->next
)
1427 switch (c
->expr
->expr_type
)
1430 if (!(*len
&& INTEGER_CST_P (*len
)))
1431 *len
= build_int_cstu (gfc_charlen_type_node
,
1432 c
->expr
->value
.character
.length
);
1436 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1442 get_array_ctor_var_strlen (c
->expr
, len
);
1447 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1455 /* Check whether the array constructor C consists entirely of constant
1456 elements, and if so returns the number of those elements, otherwise
1457 return zero. Note, an empty or NULL array constructor returns zero. */
1459 unsigned HOST_WIDE_INT
1460 gfc_constant_array_constructor_p (gfc_constructor
* c
)
1462 unsigned HOST_WIDE_INT nelem
= 0;
1467 || c
->expr
->rank
> 0
1468 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1477 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1478 and the tree type of it's elements, TYPE, return a static constant
1479 variable that is compile-time initialized. */
1482 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1484 tree tmptype
, list
, init
, tmp
;
1485 HOST_WIDE_INT nelem
;
1491 /* First traverse the constructor list, converting the constants
1492 to tree to build an initializer. */
1495 c
= expr
->value
.constructor
;
1498 gfc_init_se (&se
, NULL
);
1499 gfc_conv_constant (&se
, c
->expr
);
1500 if (c
->expr
->ts
.type
== BT_CHARACTER
1501 && POINTER_TYPE_P (type
))
1502 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
1503 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1508 /* Next determine the tree type for the array. We use the gfortran
1509 front-end's gfc_get_nodesc_array_type in order to create a suitable
1510 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1512 memset (&as
, 0, sizeof (gfc_array_spec
));
1514 as
.rank
= expr
->rank
;
1515 as
.type
= AS_EXPLICIT
;
1518 as
.lower
[0] = gfc_int_expr (0);
1519 as
.upper
[0] = gfc_int_expr (nelem
- 1);
1522 for (i
= 0; i
< expr
->rank
; i
++)
1524 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1525 as
.lower
[i
] = gfc_int_expr (0);
1526 as
.upper
[i
] = gfc_int_expr (tmp
- 1);
1529 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
);
1531 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1533 TREE_CONSTANT (init
) = 1;
1534 TREE_INVARIANT (init
) = 1;
1535 TREE_STATIC (init
) = 1;
1537 tmp
= gfc_create_var (tmptype
, "A");
1538 TREE_STATIC (tmp
) = 1;
1539 TREE_CONSTANT (tmp
) = 1;
1540 TREE_INVARIANT (tmp
) = 1;
1541 TREE_READONLY (tmp
) = 1;
1542 DECL_INITIAL (tmp
) = init
;
1548 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1549 This mostly initializes the scalarizer state info structure with the
1550 appropriate values to directly use the array created by the function
1551 gfc_build_constant_array_constructor. */
1554 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1555 gfc_ss
* ss
, tree type
)
1561 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1563 info
= &ss
->data
.info
;
1565 info
->descriptor
= tmp
;
1566 info
->data
= build_fold_addr_expr (tmp
);
1567 info
->offset
= fold_build1 (NEGATE_EXPR
, gfc_array_index_type
,
1570 for (i
= 0; i
< info
->dimen
; i
++)
1572 info
->delta
[i
] = gfc_index_zero_node
;
1573 info
->start
[i
] = gfc_index_zero_node
;
1574 info
->end
[i
] = gfc_index_zero_node
;
1575 info
->stride
[i
] = gfc_index_one_node
;
1579 if (info
->dimen
> loop
->temp_dim
)
1580 loop
->temp_dim
= info
->dimen
;
1583 /* Helper routine of gfc_trans_array_constructor to determine if the
1584 bounds of the loop specified by LOOP are constant and simple enough
1585 to use with gfc_trans_constant_array_constructor. Returns the
1586 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1589 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1591 tree size
= gfc_index_one_node
;
1595 for (i
= 0; i
< loop
->dimen
; i
++)
1597 /* If the bounds aren't constant, return NULL_TREE. */
1598 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1600 if (!integer_zerop (loop
->from
[i
]))
1602 /* Only allow nonzero "from" in one-dimensional arrays. */
1603 if (loop
->dimen
!= 1)
1605 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1606 loop
->to
[i
], loop
->from
[i
]);
1610 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1611 tmp
, gfc_index_one_node
);
1612 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1619 /* Array constructors are handled by constructing a temporary, then using that
1620 within the scalarization loop. This is not optimal, but seems by far the
1624 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1633 ss
->data
.info
.dimen
= loop
->dimen
;
1635 c
= ss
->expr
->value
.constructor
;
1636 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1638 bool const_string
= get_array_ctor_strlen (&loop
->pre
, c
, &ss
->string_length
);
1639 if (!ss
->string_length
)
1640 gfc_todo_error ("complex character array constructors");
1642 ss
->expr
->ts
.cl
->backend_decl
= ss
->string_length
;
1644 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1646 type
= build_pointer_type (type
);
1649 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1651 /* See if the constructor determines the loop bounds. */
1654 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1656 /* We have a multidimensional parameter. */
1658 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1660 loop
->from
[n
] = gfc_index_zero_node
;
1661 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1662 gfc_index_integer_kind
);
1663 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1664 loop
->to
[n
], gfc_index_one_node
);
1668 if (loop
->to
[0] == NULL_TREE
)
1672 /* We should have a 1-dimensional, zero-based loop. */
1673 gcc_assert (loop
->dimen
== 1);
1674 gcc_assert (integer_zerop (loop
->from
[0]));
1676 /* Split the constructor size into a static part and a dynamic part.
1677 Allocate the static size up-front and record whether the dynamic
1678 size might be nonzero. */
1680 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1681 mpz_sub_ui (size
, size
, 1);
1682 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1686 /* Special case constant array constructors. */
1689 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1692 tree size
= constant_array_constructor_loop_size (loop
);
1693 if (size
&& compare_tree_int (size
, nelem
) == 0)
1695 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1701 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1702 type
, dynamic
, true, false);
1704 desc
= ss
->data
.info
.descriptor
;
1705 offset
= gfc_index_zero_node
;
1706 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1707 TREE_NO_WARNING (offsetvar
) = 1;
1708 TREE_USED (offsetvar
) = 0;
1709 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1710 &offset
, &offsetvar
, dynamic
);
1712 /* If the array grows dynamically, the upper bound of the loop variable
1713 is determined by the array's final upper bound. */
1715 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1717 if (TREE_USED (offsetvar
))
1718 pushdecl (offsetvar
);
1720 gcc_assert (INTEGER_CST_P (offset
));
1722 /* Disable bound checking for now because it's probably broken. */
1723 if (flag_bounds_check
)
1731 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1732 called after evaluating all of INFO's vector dimensions. Go through
1733 each such vector dimension and see if we can now fill in any missing
1737 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1746 for (n
= 0; n
< loop
->dimen
; n
++)
1749 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1750 && loop
->to
[n
] == NULL
)
1752 /* Loop variable N indexes vector dimension DIM, and we don't
1753 yet know the upper bound of loop variable N. Set it to the
1754 difference between the vector's upper and lower bounds. */
1755 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1756 gcc_assert (info
->subscript
[dim
]
1757 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1759 gfc_init_se (&se
, NULL
);
1760 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1761 zero
= gfc_rank_cst
[0];
1762 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1763 gfc_conv_descriptor_ubound (desc
, zero
),
1764 gfc_conv_descriptor_lbound (desc
, zero
));
1765 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1772 /* Add the pre and post chains for all the scalar expressions in a SS chain
1773 to loop. This is called after the loop parameters have been calculated,
1774 but before the actual scalarizing loops. */
1777 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1782 /* TODO: This can generate bad code if there are ordering dependencies.
1783 eg. a callee allocated function and an unknown size constructor. */
1784 gcc_assert (ss
!= NULL
);
1786 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1793 /* Scalar expression. Evaluate this now. This includes elemental
1794 dimension indices, but not array section bounds. */
1795 gfc_init_se (&se
, NULL
);
1796 gfc_conv_expr (&se
, ss
->expr
);
1797 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1799 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1801 /* Move the evaluation of scalar expressions outside the
1802 scalarization loop. */
1804 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1805 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1806 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1809 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1811 ss
->data
.scalar
.expr
= se
.expr
;
1812 ss
->string_length
= se
.string_length
;
1815 case GFC_SS_REFERENCE
:
1816 /* Scalar reference. Evaluate this now. */
1817 gfc_init_se (&se
, NULL
);
1818 gfc_conv_expr_reference (&se
, ss
->expr
);
1819 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1820 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1822 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1823 ss
->string_length
= se
.string_length
;
1826 case GFC_SS_SECTION
:
1827 /* Add the expressions for scalar and vector subscripts. */
1828 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1829 if (ss
->data
.info
.subscript
[n
])
1830 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1832 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1836 /* Get the vector's descriptor and store it in SS. */
1837 gfc_init_se (&se
, NULL
);
1838 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1839 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1840 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1841 ss
->data
.info
.descriptor
= se
.expr
;
1844 case GFC_SS_INTRINSIC
:
1845 gfc_add_intrinsic_ss_code (loop
, ss
);
1848 case GFC_SS_FUNCTION
:
1849 /* Array function return value. We call the function and save its
1850 result in a temporary for use inside the loop. */
1851 gfc_init_se (&se
, NULL
);
1854 gfc_conv_expr (&se
, ss
->expr
);
1855 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1856 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1857 ss
->string_length
= se
.string_length
;
1860 case GFC_SS_CONSTRUCTOR
:
1861 gfc_trans_array_constructor (loop
, ss
);
1865 case GFC_SS_COMPONENT
:
1866 /* Do nothing. These are handled elsewhere. */
1876 /* Translate expressions for the descriptor and data pointer of a SS. */
1880 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1885 /* Get the descriptor for the array to be scalarized. */
1886 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1887 gfc_init_se (&se
, NULL
);
1888 se
.descriptor_only
= 1;
1889 gfc_conv_expr_lhs (&se
, ss
->expr
);
1890 gfc_add_block_to_block (block
, &se
.pre
);
1891 ss
->data
.info
.descriptor
= se
.expr
;
1892 ss
->string_length
= se
.string_length
;
1896 /* Also the data pointer. */
1897 tmp
= gfc_conv_array_data (se
.expr
);
1898 /* If this is a variable or address of a variable we use it directly.
1899 Otherwise we must evaluate it now to avoid breaking dependency
1900 analysis by pulling the expressions for elemental array indices
1903 || (TREE_CODE (tmp
) == ADDR_EXPR
1904 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1905 tmp
= gfc_evaluate_now (tmp
, block
);
1906 ss
->data
.info
.data
= tmp
;
1908 tmp
= gfc_conv_array_offset (se
.expr
);
1909 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1914 /* Initialize a gfc_loopinfo structure. */
1917 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1921 memset (loop
, 0, sizeof (gfc_loopinfo
));
1922 gfc_init_block (&loop
->pre
);
1923 gfc_init_block (&loop
->post
);
1925 /* Initially scalarize in order. */
1926 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1929 loop
->ss
= gfc_ss_terminator
;
1933 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1937 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1943 /* Return an expression for the data pointer of an array. */
1946 gfc_conv_array_data (tree descriptor
)
1950 type
= TREE_TYPE (descriptor
);
1951 if (GFC_ARRAY_TYPE_P (type
))
1953 if (TREE_CODE (type
) == POINTER_TYPE
)
1957 /* Descriptorless arrays. */
1958 return build_fold_addr_expr (descriptor
);
1962 return gfc_conv_descriptor_data_get (descriptor
);
1966 /* Return an expression for the base offset of an array. */
1969 gfc_conv_array_offset (tree descriptor
)
1973 type
= TREE_TYPE (descriptor
);
1974 if (GFC_ARRAY_TYPE_P (type
))
1975 return GFC_TYPE_ARRAY_OFFSET (type
);
1977 return gfc_conv_descriptor_offset (descriptor
);
1981 /* Get an expression for the array stride. */
1984 gfc_conv_array_stride (tree descriptor
, int dim
)
1989 type
= TREE_TYPE (descriptor
);
1991 /* For descriptorless arrays use the array size. */
1992 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1993 if (tmp
!= NULL_TREE
)
1996 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
2001 /* Like gfc_conv_array_stride, but for the lower bound. */
2004 gfc_conv_array_lbound (tree descriptor
, int dim
)
2009 type
= TREE_TYPE (descriptor
);
2011 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2012 if (tmp
!= NULL_TREE
)
2015 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
2020 /* Like gfc_conv_array_stride, but for the upper bound. */
2023 gfc_conv_array_ubound (tree descriptor
, int dim
)
2028 type
= TREE_TYPE (descriptor
);
2030 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2031 if (tmp
!= NULL_TREE
)
2034 /* This should only ever happen when passing an assumed shape array
2035 as an actual parameter. The value will never be used. */
2036 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2037 return gfc_index_zero_node
;
2039 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
2044 /* Generate code to perform an array index bound check. */
2047 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2048 locus
* where
, bool check_upper
)
2053 const char * name
= NULL
;
2055 if (!flag_bounds_check
)
2058 index
= gfc_evaluate_now (index
, &se
->pre
);
2060 /* We find a name for the error message. */
2062 name
= se
->ss
->expr
->symtree
->name
;
2064 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2065 && se
->loop
->ss
->expr
->symtree
)
2066 name
= se
->loop
->ss
->expr
->symtree
->name
;
2068 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2069 && se
->loop
->ss
->loop_chain
->expr
2070 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2071 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2073 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2074 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2075 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2077 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2079 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2080 && se
->loop
->ss
->expr
->value
.function
.name
)
2081 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2083 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2084 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2085 name
= "unnamed constant";
2088 /* Check lower bound. */
2089 tmp
= gfc_conv_array_lbound (descriptor
, n
);
2090 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
2092 asprintf (&msg
, "%s for array '%s', lower bound of dimension %d exceeded",
2093 gfc_msg_fault
, name
, n
+1);
2095 asprintf (&msg
, "%s, lower bound of dimension %d exceeded, %%ld is "
2096 "smaller than %%ld", gfc_msg_fault
, n
+1);
2097 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
2098 fold_convert (long_integer_type_node
, index
),
2099 fold_convert (long_integer_type_node
, tmp
));
2102 /* Check upper bound. */
2105 tmp
= gfc_conv_array_ubound (descriptor
, n
);
2106 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
2108 asprintf (&msg
, "%s for array '%s', upper bound of dimension %d "
2109 " exceeded", gfc_msg_fault
, name
, n
+1);
2111 asprintf (&msg
, "%s, upper bound of dimension %d exceeded, %%ld is "
2112 "larger than %%ld", gfc_msg_fault
, n
+1);
2113 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
2114 fold_convert (long_integer_type_node
, index
),
2115 fold_convert (long_integer_type_node
, tmp
));
2123 /* Return the offset for an index. Performs bound checking for elemental
2124 dimensions. Single element references are processed separately. */
2127 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2128 gfc_array_ref
* ar
, tree stride
)
2134 /* Get the index into the array for this dimension. */
2137 gcc_assert (ar
->type
!= AR_ELEMENT
);
2138 switch (ar
->dimen_type
[dim
])
2141 gcc_assert (i
== -1);
2142 /* Elemental dimension. */
2143 gcc_assert (info
->subscript
[dim
]
2144 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2145 /* We've already translated this value outside the loop. */
2146 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2148 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2149 index
, dim
, &ar
->where
,
2150 (ar
->as
->type
!= AS_ASSUMED_SIZE
2151 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2155 gcc_assert (info
&& se
->loop
);
2156 gcc_assert (info
->subscript
[dim
]
2157 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2158 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2160 /* Get a zero-based index into the vector. */
2161 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2162 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2164 /* Multiply the index by the stride. */
2165 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2166 index
, gfc_conv_array_stride (desc
, 0));
2168 /* Read the vector to get an index into info->descriptor. */
2169 data
= build_fold_indirect_ref (gfc_conv_array_data (desc
));
2170 index
= gfc_build_array_ref (data
, index
, NULL
);
2171 index
= gfc_evaluate_now (index
, &se
->pre
);
2173 /* Do any bounds checking on the final info->descriptor index. */
2174 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2175 index
, dim
, &ar
->where
,
2176 (ar
->as
->type
!= AS_ASSUMED_SIZE
2177 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2181 /* Scalarized dimension. */
2182 gcc_assert (info
&& se
->loop
);
2184 /* Multiply the loop variable by the stride and delta. */
2185 index
= se
->loop
->loopvar
[i
];
2186 if (!integer_onep (info
->stride
[i
]))
2187 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2189 if (!integer_zerop (info
->delta
[i
]))
2190 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2200 /* Temporary array or derived type component. */
2201 gcc_assert (se
->loop
);
2202 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2203 if (!integer_zerop (info
->delta
[i
]))
2204 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2205 index
, info
->delta
[i
]);
2208 /* Multiply by the stride. */
2209 if (!integer_onep (stride
))
2210 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2216 /* Build a scalarized reference to an array. */
2219 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2222 tree decl
= NULL_TREE
;
2227 info
= &se
->ss
->data
.info
;
2229 n
= se
->loop
->order
[0];
2233 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2235 /* Add the offset for this dimension to the stored offset for all other
2237 if (!integer_zerop (info
->offset
))
2238 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2240 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2241 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2243 tmp
= build_fold_indirect_ref (info
->data
);
2244 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2248 /* Translate access of temporary array. */
2251 gfc_conv_tmp_array_ref (gfc_se
* se
)
2253 se
->string_length
= se
->ss
->string_length
;
2254 gfc_conv_scalarized_array_ref (se
, NULL
);
2258 /* Build an array reference. se->expr already holds the array descriptor.
2259 This should be either a variable, indirect variable reference or component
2260 reference. For arrays which do not have a descriptor, se->expr will be
2262 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2265 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2274 /* Handle scalarized references separately. */
2275 if (ar
->type
!= AR_ELEMENT
)
2277 gfc_conv_scalarized_array_ref (se
, ar
);
2278 gfc_advance_se_ss_chain (se
);
2282 index
= gfc_index_zero_node
;
2284 /* Calculate the offsets from all the dimensions. */
2285 for (n
= 0; n
< ar
->dimen
; n
++)
2287 /* Calculate the index for this dimension. */
2288 gfc_init_se (&indexse
, se
);
2289 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2290 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2292 if (flag_bounds_check
)
2294 /* Check array bounds. */
2298 /* Evaluate the indexse.expr only once. */
2299 indexse
.expr
= save_expr (indexse
.expr
);
2302 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2303 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2305 asprintf (&msg
, "%s for array '%s', "
2306 "lower bound of dimension %d exceeded, %%ld is smaller "
2307 "than %%ld", gfc_msg_fault
, sym
->name
, n
+1);
2308 gfc_trans_runtime_check (cond
, &se
->pre
, where
, msg
,
2309 fold_convert (long_integer_type_node
,
2311 fold_convert (long_integer_type_node
, tmp
));
2314 /* Upper bound, but not for the last dimension of assumed-size
2316 if (n
< ar
->dimen
- 1
2317 || (ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
))
2319 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2320 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2322 asprintf (&msg
, "%s for array '%s', "
2323 "upper bound of dimension %d exceeded, %%ld is "
2324 "greater than %%ld", gfc_msg_fault
, sym
->name
, n
+1);
2325 gfc_trans_runtime_check (cond
, &se
->pre
, where
, msg
,
2326 fold_convert (long_integer_type_node
,
2328 fold_convert (long_integer_type_node
, tmp
));
2333 /* Multiply the index by the stride. */
2334 stride
= gfc_conv_array_stride (se
->expr
, n
);
2335 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2338 /* And add it to the total. */
2339 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2342 tmp
= gfc_conv_array_offset (se
->expr
);
2343 if (!integer_zerop (tmp
))
2344 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2346 /* Access the calculated element. */
2347 tmp
= gfc_conv_array_data (se
->expr
);
2348 tmp
= build_fold_indirect_ref (tmp
);
2349 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2353 /* Generate the code to be executed immediately before entering a
2354 scalarization loop. */
2357 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2358 stmtblock_t
* pblock
)
2367 /* This code will be executed before entering the scalarization loop
2368 for this dimension. */
2369 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2371 if ((ss
->useflags
& flag
) == 0)
2374 if (ss
->type
!= GFC_SS_SECTION
2375 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2376 && ss
->type
!= GFC_SS_COMPONENT
)
2379 info
= &ss
->data
.info
;
2381 if (dim
>= info
->dimen
)
2384 if (dim
== info
->dimen
- 1)
2386 /* For the outermost loop calculate the offset due to any
2387 elemental dimensions. It will have been initialized with the
2388 base offset of the array. */
2391 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2393 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2396 gfc_init_se (&se
, NULL
);
2398 se
.expr
= info
->descriptor
;
2399 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2400 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2403 gfc_add_block_to_block (pblock
, &se
.pre
);
2405 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2406 info
->offset
, index
);
2407 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2411 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2414 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2416 /* Calculate the stride of the innermost loop. Hopefully this will
2417 allow the backend optimizers to do their stuff more effectively.
2419 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2423 /* Add the offset for the previous loop dimension. */
2428 ar
= &info
->ref
->u
.ar
;
2429 i
= loop
->order
[dim
+ 1];
2437 gfc_init_se (&se
, NULL
);
2439 se
.expr
= info
->descriptor
;
2440 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2441 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2443 gfc_add_block_to_block (pblock
, &se
.pre
);
2444 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2445 info
->offset
, index
);
2446 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2449 /* Remember this offset for the second loop. */
2450 if (dim
== loop
->temp_dim
- 1)
2451 info
->saved_offset
= info
->offset
;
2456 /* Start a scalarized expression. Creates a scope and declares loop
2460 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2466 gcc_assert (!loop
->array_parameter
);
2468 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2470 n
= loop
->order
[dim
];
2472 gfc_start_block (&loop
->code
[n
]);
2474 /* Create the loop variable. */
2475 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2477 if (dim
< loop
->temp_dim
)
2481 /* Calculate values that will be constant within this loop. */
2482 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2484 gfc_start_block (pbody
);
2488 /* Generates the actual loop code for a scalarization loop. */
2491 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2492 stmtblock_t
* pbody
)
2500 loopbody
= gfc_finish_block (pbody
);
2502 /* Initialize the loopvar. */
2503 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2505 exit_label
= gfc_build_label_decl (NULL_TREE
);
2507 /* Generate the loop body. */
2508 gfc_init_block (&block
);
2510 /* The exit condition. */
2511 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2512 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2513 TREE_USED (exit_label
) = 1;
2514 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2515 gfc_add_expr_to_block (&block
, tmp
);
2517 /* The main body. */
2518 gfc_add_expr_to_block (&block
, loopbody
);
2520 /* Increment the loopvar. */
2521 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2522 loop
->loopvar
[n
], gfc_index_one_node
);
2523 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2525 /* Build the loop. */
2526 tmp
= gfc_finish_block (&block
);
2527 tmp
= build1_v (LOOP_EXPR
, tmp
);
2528 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2530 /* Add the exit label. */
2531 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2532 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2536 /* Finishes and generates the loops for a scalarized expression. */
2539 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2544 stmtblock_t
*pblock
;
2548 /* Generate the loops. */
2549 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2551 n
= loop
->order
[dim
];
2552 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2553 loop
->loopvar
[n
] = NULL_TREE
;
2554 pblock
= &loop
->code
[n
];
2557 tmp
= gfc_finish_block (pblock
);
2558 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2560 /* Clear all the used flags. */
2561 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2566 /* Finish the main body of a scalarized expression, and start the secondary
2570 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2574 stmtblock_t
*pblock
;
2578 /* We finish as many loops as are used by the temporary. */
2579 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2581 n
= loop
->order
[dim
];
2582 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2583 loop
->loopvar
[n
] = NULL_TREE
;
2584 pblock
= &loop
->code
[n
];
2587 /* We don't want to finish the outermost loop entirely. */
2588 n
= loop
->order
[loop
->temp_dim
- 1];
2589 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2591 /* Restore the initial offsets. */
2592 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2594 if ((ss
->useflags
& 2) == 0)
2597 if (ss
->type
!= GFC_SS_SECTION
2598 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2599 && ss
->type
!= GFC_SS_COMPONENT
)
2602 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2605 /* Restart all the inner loops we just finished. */
2606 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2608 n
= loop
->order
[dim
];
2610 gfc_start_block (&loop
->code
[n
]);
2612 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2614 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2617 /* Start a block for the secondary copying code. */
2618 gfc_start_block (body
);
2622 /* Calculate the upper bound of an array section. */
2625 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2634 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2636 info
= &ss
->data
.info
;
2639 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2640 /* We'll calculate the upper bound once we have access to the
2641 vector's descriptor. */
2644 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2645 desc
= info
->descriptor
;
2646 end
= info
->ref
->u
.ar
.end
[dim
];
2650 /* The upper bound was specified. */
2651 gfc_init_se (&se
, NULL
);
2652 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2653 gfc_add_block_to_block (pblock
, &se
.pre
);
2658 /* No upper bound was specified, so use the bound of the array. */
2659 bound
= gfc_conv_array_ubound (desc
, dim
);
2666 /* Calculate the lower bound of an array section. */
2669 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2679 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2681 info
= &ss
->data
.info
;
2684 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2686 /* We use a zero-based index to access the vector. */
2687 info
->start
[n
] = gfc_index_zero_node
;
2688 info
->end
[n
] = gfc_index_zero_node
;
2689 info
->stride
[n
] = gfc_index_one_node
;
2693 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2694 desc
= info
->descriptor
;
2695 start
= info
->ref
->u
.ar
.start
[dim
];
2696 end
= info
->ref
->u
.ar
.end
[dim
];
2697 stride
= info
->ref
->u
.ar
.stride
[dim
];
2699 /* Calculate the start of the range. For vector subscripts this will
2700 be the range of the vector. */
2703 /* Specified section start. */
2704 gfc_init_se (&se
, NULL
);
2705 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2706 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2707 info
->start
[n
] = se
.expr
;
2711 /* No lower bound specified so use the bound of the array. */
2712 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2714 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2716 /* Similarly calculate the end. Although this is not used in the
2717 scalarizer, it is needed when checking bounds and where the end
2718 is an expression with side-effects. */
2721 /* Specified section start. */
2722 gfc_init_se (&se
, NULL
);
2723 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2724 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2725 info
->end
[n
] = se
.expr
;
2729 /* No upper bound specified so use the bound of the array. */
2730 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
2732 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
2734 /* Calculate the stride. */
2736 info
->stride
[n
] = gfc_index_one_node
;
2739 gfc_init_se (&se
, NULL
);
2740 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2741 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2742 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2747 /* Calculates the range start and stride for a SS chain. Also gets the
2748 descriptor and data pointer. The range of vector subscripts is the size
2749 of the vector. Array bounds are also checked. */
2752 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2760 /* Determine the rank of the loop. */
2762 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2766 case GFC_SS_SECTION
:
2767 case GFC_SS_CONSTRUCTOR
:
2768 case GFC_SS_FUNCTION
:
2769 case GFC_SS_COMPONENT
:
2770 loop
->dimen
= ss
->data
.info
.dimen
;
2773 /* As usual, lbound and ubound are exceptions!. */
2774 case GFC_SS_INTRINSIC
:
2775 switch (ss
->expr
->value
.function
.isym
->id
)
2777 case GFC_ISYM_LBOUND
:
2778 case GFC_ISYM_UBOUND
:
2779 loop
->dimen
= ss
->data
.info
.dimen
;
2790 if (loop
->dimen
== 0)
2791 gfc_todo_error ("Unable to determine rank of expression");
2794 /* Loop over all the SS in the chain. */
2795 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2797 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2798 ss
->shape
= ss
->expr
->shape
;
2802 case GFC_SS_SECTION
:
2803 /* Get the descriptor for the array. */
2804 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2806 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2807 gfc_conv_section_startstride (loop
, ss
, n
);
2810 case GFC_SS_INTRINSIC
:
2811 switch (ss
->expr
->value
.function
.isym
->id
)
2813 /* Fall through to supply start and stride. */
2814 case GFC_ISYM_LBOUND
:
2815 case GFC_ISYM_UBOUND
:
2821 case GFC_SS_CONSTRUCTOR
:
2822 case GFC_SS_FUNCTION
:
2823 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2825 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2826 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
2827 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2836 /* The rest is just runtime bound checking. */
2837 if (flag_bounds_check
)
2840 tree lbound
, ubound
;
2842 tree size
[GFC_MAX_DIMENSIONS
];
2843 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
;
2848 gfc_start_block (&block
);
2850 for (n
= 0; n
< loop
->dimen
; n
++)
2851 size
[n
] = NULL_TREE
;
2853 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2855 if (ss
->type
!= GFC_SS_SECTION
)
2858 /* TODO: range checking for mapped dimensions. */
2859 info
= &ss
->data
.info
;
2861 /* This code only checks ranges. Elemental and vector
2862 dimensions are checked later. */
2863 for (n
= 0; n
< loop
->dimen
; n
++)
2868 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
2871 if (n
== info
->ref
->u
.ar
.dimen
- 1
2872 && (info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
2873 || info
->ref
->u
.ar
.as
->cp_was_assumed
))
2874 check_upper
= false;
2878 /* Zero stride is not allowed. */
2879 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
2880 gfc_index_zero_node
);
2881 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
2882 "of array '%s'", info
->dim
[n
]+1,
2883 ss
->expr
->symtree
->name
);
2884 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
);
2887 desc
= ss
->data
.info
.descriptor
;
2889 /* This is the run-time equivalent of resolve.c's
2890 check_dimension(). The logical is more readable there
2891 than it is here, with all the trees. */
2892 lbound
= gfc_conv_array_lbound (desc
, dim
);
2895 ubound
= gfc_conv_array_ubound (desc
, dim
);
2899 /* non_zerosized is true when the selected range is not
2901 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
2902 info
->stride
[n
], gfc_index_zero_node
);
2903 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
2905 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2908 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
2909 info
->stride
[n
], gfc_index_zero_node
);
2910 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
2912 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2914 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2915 stride_pos
, stride_neg
);
2917 /* Check the start of the range against the lower and upper
2918 bounds of the array, if the range is not empty. */
2919 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, info
->start
[n
],
2921 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2922 non_zerosized
, tmp
);
2923 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2924 " exceeded, %%ld is smaller than %%ld", gfc_msg_fault
,
2925 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
2926 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
,
2927 fold_convert (long_integer_type_node
,
2929 fold_convert (long_integer_type_node
,
2935 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
,
2936 info
->start
[n
], ubound
);
2937 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2938 non_zerosized
, tmp
);
2939 asprintf (&msg
, "%s, upper bound of dimension %d of array "
2940 "'%s' exceeded, %%ld is greater than %%ld",
2941 gfc_msg_fault
, info
->dim
[n
]+1,
2942 ss
->expr
->symtree
->name
);
2943 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
,
2944 fold_convert (long_integer_type_node
, info
->start
[n
]),
2945 fold_convert (long_integer_type_node
, ubound
));
2949 /* Compute the last element of the range, which is not
2950 necessarily "end" (think 0:5:3, which doesn't contain 5)
2951 and check it against both lower and upper bounds. */
2952 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2954 tmp2
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp2
,
2956 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2959 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp2
, lbound
);
2960 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2961 non_zerosized
, tmp
);
2962 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2963 " exceeded, %%ld is smaller than %%ld", gfc_msg_fault
,
2964 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
2965 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
,
2966 fold_convert (long_integer_type_node
,
2968 fold_convert (long_integer_type_node
,
2974 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp2
, ubound
);
2975 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2976 non_zerosized
, tmp
);
2977 asprintf (&msg
, "%s, upper bound of dimension %d of array "
2978 "'%s' exceeded, %%ld is greater than %%ld",
2979 gfc_msg_fault
, info
->dim
[n
]+1,
2980 ss
->expr
->symtree
->name
);
2981 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
,
2982 fold_convert (long_integer_type_node
, tmp2
),
2983 fold_convert (long_integer_type_node
, ubound
));
2987 /* Check the section sizes match. */
2988 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2990 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2992 /* We remember the size of the first section, and check all the
2993 others against this. */
2998 tmp3
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
3000 /* For optional arguments, only check bounds if the
3001 argument is present. */
3002 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3003 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3007 cond
= gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
);
3008 tmp3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3012 asprintf (&msg
, "%s, size mismatch for dimension %d "
3013 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds
,
3014 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3015 gfc_trans_runtime_check (tmp3
, &block
, &ss
->expr
->where
, msg
,
3016 fold_convert (long_integer_type_node
, tmp
),
3017 fold_convert (long_integer_type_node
, size
[n
]));
3021 size
[n
] = gfc_evaluate_now (tmp
, &block
);
3025 tmp
= gfc_finish_block (&block
);
3026 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3031 /* Return true if the two SS could be aliased, i.e. both point to the same data
3033 /* TODO: resolve aliases based on frontend expressions. */
3036 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3043 lsym
= lss
->expr
->symtree
->n
.sym
;
3044 rsym
= rss
->expr
->symtree
->n
.sym
;
3045 if (gfc_symbols_could_alias (lsym
, rsym
))
3048 if (rsym
->ts
.type
!= BT_DERIVED
3049 && lsym
->ts
.type
!= BT_DERIVED
)
3052 /* For derived types we must check all the component types. We can ignore
3053 array references as these will have the same base type as the previous
3055 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3057 if (lref
->type
!= REF_COMPONENT
)
3060 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3063 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3066 if (rref
->type
!= REF_COMPONENT
)
3069 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3074 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3076 if (rref
->type
!= REF_COMPONENT
)
3079 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3087 /* Resolve array data dependencies. Creates a temporary if required. */
3088 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3092 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3102 loop
->temp_ss
= NULL
;
3103 aref
= dest
->data
.info
.ref
;
3106 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3108 if (ss
->type
!= GFC_SS_SECTION
)
3111 if (gfc_could_be_alias (dest
, ss
)
3112 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3118 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
3120 lref
= dest
->expr
->ref
;
3121 rref
= ss
->expr
->ref
;
3123 nDepend
= gfc_dep_resolver (lref
, rref
);
3127 /* TODO : loop shifting. */
3130 /* Mark the dimensions for LOOP SHIFTING */
3131 for (n
= 0; n
< loop
->dimen
; n
++)
3133 int dim
= dest
->data
.info
.dim
[n
];
3135 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3137 else if (! gfc_is_same_range (&lref
->u
.ar
,
3138 &rref
->u
.ar
, dim
, 0))
3142 /* Put all the dimensions with dependencies in the
3145 for (n
= 0; n
< loop
->dimen
; n
++)
3147 gcc_assert (loop
->order
[n
] == n
);
3149 loop
->order
[dim
++] = n
;
3152 for (n
= 0; n
< loop
->dimen
; n
++)
3155 loop
->order
[dim
++] = n
;
3158 gcc_assert (dim
== loop
->dimen
);
3167 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3168 if (GFC_ARRAY_TYPE_P (base_type
)
3169 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3170 base_type
= gfc_get_element_type (base_type
);
3171 loop
->temp_ss
= gfc_get_ss ();
3172 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3173 loop
->temp_ss
->data
.temp
.type
= base_type
;
3174 loop
->temp_ss
->string_length
= dest
->string_length
;
3175 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3176 loop
->temp_ss
->next
= gfc_ss_terminator
;
3177 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3180 loop
->temp_ss
= NULL
;
3184 /* Initialize the scalarization loop. Creates the loop variables. Determines
3185 the range of the loop variables. Creates a temporary if required.
3186 Calculates how to transform from loop variables to array indices for each
3187 expression. Also generates code for scalar expressions which have been
3188 moved outside the loop. */
3191 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
3196 gfc_ss_info
*specinfo
;
3200 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3201 bool dynamic
[GFC_MAX_DIMENSIONS
];
3207 for (n
= 0; n
< loop
->dimen
; n
++)
3211 /* We use one SS term, and use that to determine the bounds of the
3212 loop for this dimension. We try to pick the simplest term. */
3213 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3217 /* The frontend has worked out the size for us. */
3222 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3224 /* An unknown size constructor will always be rank one.
3225 Higher rank constructors will either have known shape,
3226 or still be wrapped in a call to reshape. */
3227 gcc_assert (loop
->dimen
== 1);
3229 /* Always prefer to use the constructor bounds if the size
3230 can be determined at compile time. Prefer not to otherwise,
3231 since the general case involves realloc, and it's better to
3232 avoid that overhead if possible. */
3233 c
= ss
->expr
->value
.constructor
;
3234 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
3235 if (!dynamic
[n
] || !loopspec
[n
])
3240 /* TODO: Pick the best bound if we have a choice between a
3241 function and something else. */
3242 if (ss
->type
== GFC_SS_FUNCTION
)
3248 if (ss
->type
!= GFC_SS_SECTION
)
3252 specinfo
= &loopspec
[n
]->data
.info
;
3255 info
= &ss
->data
.info
;
3259 /* Criteria for choosing a loop specifier (most important first):
3260 doesn't need realloc
3266 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3268 else if (integer_onep (info
->stride
[n
])
3269 && !integer_onep (specinfo
->stride
[n
]))
3271 else if (INTEGER_CST_P (info
->stride
[n
])
3272 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3274 else if (INTEGER_CST_P (info
->start
[n
])
3275 && !INTEGER_CST_P (specinfo
->start
[n
]))
3277 /* We don't work out the upper bound.
3278 else if (INTEGER_CST_P (info->finish[n])
3279 && ! INTEGER_CST_P (specinfo->finish[n]))
3280 loopspec[n] = ss; */
3284 gfc_todo_error ("Unable to find scalarization loop specifier");
3286 info
= &loopspec
[n
]->data
.info
;
3288 /* Set the extents of this range. */
3289 cshape
= loopspec
[n
]->shape
;
3290 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3291 && INTEGER_CST_P (info
->stride
[n
]))
3293 loop
->from
[n
] = info
->start
[n
];
3294 mpz_set (i
, cshape
[n
]);
3295 mpz_sub_ui (i
, i
, 1);
3296 /* To = from + (size - 1) * stride. */
3297 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3298 if (!integer_onep (info
->stride
[n
]))
3299 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3300 tmp
, info
->stride
[n
]);
3301 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3302 loop
->from
[n
], tmp
);
3306 loop
->from
[n
] = info
->start
[n
];
3307 switch (loopspec
[n
]->type
)
3309 case GFC_SS_CONSTRUCTOR
:
3310 /* The upper bound is calculated when we expand the
3312 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3315 case GFC_SS_SECTION
:
3316 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3320 case GFC_SS_FUNCTION
:
3321 /* The loop bound will be set when we generate the call. */
3322 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3330 /* Transform everything so we have a simple incrementing variable. */
3331 if (integer_onep (info
->stride
[n
]))
3332 info
->delta
[n
] = gfc_index_zero_node
;
3335 /* Set the delta for this section. */
3336 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3337 /* Number of iterations is (end - start + step) / step.
3338 with start = 0, this simplifies to
3340 for (i = 0; i<=last; i++){...}; */
3341 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3342 loop
->to
[n
], loop
->from
[n
]);
3343 tmp
= fold_build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
3344 tmp
, info
->stride
[n
]);
3345 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3346 /* Make the loop variable start at 0. */
3347 loop
->from
[n
] = gfc_index_zero_node
;
3351 /* Add all the scalar code that can be taken out of the loops.
3352 This may include calculating the loop bounds, so do it before
3353 allocating the temporary. */
3354 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
3356 /* If we want a temporary then create it. */
3357 if (loop
->temp_ss
!= NULL
)
3359 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3360 tmp
= loop
->temp_ss
->data
.temp
.type
;
3361 len
= loop
->temp_ss
->string_length
;
3362 n
= loop
->temp_ss
->data
.temp
.dimen
;
3363 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3364 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3365 loop
->temp_ss
->data
.info
.dimen
= n
;
3366 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3367 &loop
->temp_ss
->data
.info
, tmp
, false, true,
3371 for (n
= 0; n
< loop
->temp_dim
; n
++)
3372 loopspec
[loop
->order
[n
]] = NULL
;
3376 /* For array parameters we don't have loop variables, so don't calculate the
3378 if (loop
->array_parameter
)
3381 /* Calculate the translation from loop variables to array indices. */
3382 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3384 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
3387 info
= &ss
->data
.info
;
3389 for (n
= 0; n
< info
->dimen
; n
++)
3393 /* If we are specifying the range the delta is already set. */
3394 if (loopspec
[n
] != ss
)
3396 /* Calculate the offset relative to the loop variable.
3397 First multiply by the stride. */
3398 tmp
= loop
->from
[n
];
3399 if (!integer_onep (info
->stride
[n
]))
3400 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3401 tmp
, info
->stride
[n
]);
3403 /* Then subtract this from our starting value. */
3404 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3405 info
->start
[n
], tmp
);
3407 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3414 /* Fills in an array descriptor, and returns the size of the array. The size
3415 will be a simple_val, ie a variable or a constant. Also calculates the
3416 offset of the base. Returns the size of the array.
3420 for (n = 0; n < rank; n++)
3422 a.lbound[n] = specified_lower_bound;
3423 offset = offset + a.lbond[n] * stride;
3425 a.ubound[n] = specified_upper_bound;
3426 a.stride[n] = stride;
3427 size = ubound + size; //size = ubound + 1 - lbound
3428 stride = stride * size;
3435 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3436 gfc_expr
** lower
, gfc_expr
** upper
,
3437 stmtblock_t
* pblock
)
3449 stmtblock_t thenblock
;
3450 stmtblock_t elseblock
;
3455 type
= TREE_TYPE (descriptor
);
3457 stride
= gfc_index_one_node
;
3458 offset
= gfc_index_zero_node
;
3460 /* Set the dtype. */
3461 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3462 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3464 or_expr
= NULL_TREE
;
3466 for (n
= 0; n
< rank
; n
++)
3468 /* We have 3 possibilities for determining the size of the array:
3469 lower == NULL => lbound = 1, ubound = upper[n]
3470 upper[n] = NULL => lbound = 1, ubound = lower[n]
3471 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3474 /* Set lower bound. */
3475 gfc_init_se (&se
, NULL
);
3477 se
.expr
= gfc_index_one_node
;
3480 gcc_assert (lower
[n
]);
3483 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3484 gfc_add_block_to_block (pblock
, &se
.pre
);
3488 se
.expr
= gfc_index_one_node
;
3492 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
3493 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3495 /* Work out the offset for this component. */
3496 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3497 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3499 /* Start the calculation for the size of this dimension. */
3500 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3501 gfc_index_one_node
, se
.expr
);
3503 /* Set upper bound. */
3504 gfc_init_se (&se
, NULL
);
3505 gcc_assert (ubound
);
3506 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3507 gfc_add_block_to_block (pblock
, &se
.pre
);
3509 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
3510 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3512 /* Store the stride. */
3513 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
3514 gfc_add_modify_expr (pblock
, tmp
, stride
);
3516 /* Calculate the size of this dimension. */
3517 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3519 /* Check whether the size for this dimension is negative. */
3520 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3521 gfc_index_zero_node
);
3525 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3527 /* Multiply the stride by the number of elements in this dimension. */
3528 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3529 stride
= gfc_evaluate_now (stride
, pblock
);
3532 /* The stride is the number of elements in the array, so multiply by the
3533 size of an element to get the total size. */
3534 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3535 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3536 fold_convert (gfc_array_index_type
, tmp
));
3538 if (poffset
!= NULL
)
3540 offset
= gfc_evaluate_now (offset
, pblock
);
3544 if (integer_zerop (or_expr
))
3546 if (integer_onep (or_expr
))
3547 return gfc_index_zero_node
;
3549 var
= gfc_create_var (TREE_TYPE (size
), "size");
3550 gfc_start_block (&thenblock
);
3551 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
3552 thencase
= gfc_finish_block (&thenblock
);
3554 gfc_start_block (&elseblock
);
3555 gfc_add_modify_expr (&elseblock
, var
, size
);
3556 elsecase
= gfc_finish_block (&elseblock
);
3558 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3559 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3560 gfc_add_expr_to_block (pblock
, tmp
);
3566 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3567 the work for an ALLOCATE statement. */
3571 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3579 gfc_ref
*ref
, *prev_ref
= NULL
;
3580 bool allocatable_array
;
3584 /* Find the last reference in the chain. */
3585 while (ref
&& ref
->next
!= NULL
)
3587 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3592 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3596 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3598 allocatable_array
= prev_ref
->u
.c
.component
->allocatable
;
3600 /* Figure out the size of the array. */
3601 switch (ref
->u
.ar
.type
)
3605 upper
= ref
->u
.ar
.start
;
3609 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
3611 lower
= ref
->u
.ar
.as
->lower
;
3612 upper
= ref
->u
.ar
.as
->upper
;
3616 lower
= ref
->u
.ar
.start
;
3617 upper
= ref
->u
.ar
.end
;
3625 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
3626 lower
, upper
, &se
->pre
);
3628 /* Allocate memory to store the data. */
3629 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
3630 STRIP_NOPS (pointer
);
3632 /* The allocate_array variants take the old pointer as first argument. */
3633 if (allocatable_array
)
3634 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
);
3636 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
3637 tmp
= build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
3638 gfc_add_expr_to_block (&se
->pre
, tmp
);
3640 tmp
= gfc_conv_descriptor_offset (se
->expr
);
3641 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
3643 if (expr
->ts
.type
== BT_DERIVED
3644 && expr
->ts
.derived
->attr
.alloc_comp
)
3646 tmp
= gfc_nullify_alloc_comp (expr
->ts
.derived
, se
->expr
,
3647 ref
->u
.ar
.as
->rank
);
3648 gfc_add_expr_to_block (&se
->pre
, tmp
);
3655 /* Deallocate an array variable. Also used when an allocated variable goes
3660 gfc_array_deallocate (tree descriptor
, tree pstat
)
3666 gfc_start_block (&block
);
3667 /* Get a pointer to the data. */
3668 var
= gfc_conv_descriptor_data_get (descriptor
);
3671 /* Parameter is the address of the data component. */
3672 tmp
= gfc_deallocate_with_status (var
, pstat
, false);
3673 gfc_add_expr_to_block (&block
, tmp
);
3675 /* Zero the data pointer. */
3676 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
3677 var
, build_int_cst (TREE_TYPE (var
), 0));
3678 gfc_add_expr_to_block (&block
, tmp
);
3680 return gfc_finish_block (&block
);
3684 /* Create an array constructor from an initialization expression.
3685 We assume the frontend already did any expansions and conversions. */
3688 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3695 unsigned HOST_WIDE_INT lo
;
3697 VEC(constructor_elt
,gc
) *v
= NULL
;
3699 switch (expr
->expr_type
)
3702 case EXPR_STRUCTURE
:
3703 /* A single scalar or derived type value. Create an array with all
3704 elements equal to that value. */
3705 gfc_init_se (&se
, NULL
);
3707 if (expr
->expr_type
== EXPR_CONSTANT
)
3708 gfc_conv_constant (&se
, expr
);
3710 gfc_conv_structure (&se
, expr
, 1);
3712 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3713 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3714 hi
= TREE_INT_CST_HIGH (tmp
);
3715 lo
= TREE_INT_CST_LOW (tmp
);
3719 /* This will probably eat buckets of memory for large arrays. */
3720 while (hi
!= 0 || lo
!= 0)
3722 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3730 /* Create a vector of all the elements. */
3731 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3735 /* Problems occur when we get something like
3736 integer :: a(lots) = (/(i, i=1,lots)/) */
3737 /* TODO: Unexpanded array initializers. */
3739 ("Possible frontend bug: array constructor not expanded");
3741 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3742 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3746 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3750 mpz_set (maxval
, c
->repeat
);
3751 mpz_add (maxval
, c
->n
.offset
, maxval
);
3752 mpz_sub_ui (maxval
, maxval
, 1);
3753 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3754 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3756 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3757 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3760 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3762 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3768 gfc_init_se (&se
, NULL
);
3769 switch (c
->expr
->expr_type
)
3772 gfc_conv_constant (&se
, c
->expr
);
3773 if (range
== NULL_TREE
)
3774 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3777 if (index
!= NULL_TREE
)
3778 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3779 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3783 case EXPR_STRUCTURE
:
3784 gfc_conv_structure (&se
, c
->expr
, 1);
3785 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3795 return gfc_build_null_descriptor (type
);
3801 /* Create a constructor from the list of elements. */
3802 tmp
= build_constructor (type
, v
);
3803 TREE_CONSTANT (tmp
) = 1;
3804 TREE_INVARIANT (tmp
) = 1;
3809 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3810 returns the size (in elements) of the array. */
3813 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3814 stmtblock_t
* pblock
)
3829 size
= gfc_index_one_node
;
3830 offset
= gfc_index_zero_node
;
3831 for (dim
= 0; dim
< as
->rank
; dim
++)
3833 /* Evaluate non-constant array bound expressions. */
3834 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3835 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3837 gfc_init_se (&se
, NULL
);
3838 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3839 gfc_add_block_to_block (pblock
, &se
.pre
);
3840 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3842 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3843 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3845 gfc_init_se (&se
, NULL
);
3846 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3847 gfc_add_block_to_block (pblock
, &se
.pre
);
3848 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
3850 /* The offset of this dimension. offset = offset - lbound * stride. */
3851 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
3852 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3854 /* The size of this dimension, and the stride of the next. */
3855 if (dim
+ 1 < as
->rank
)
3856 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3858 stride
= GFC_TYPE_ARRAY_SIZE (type
);
3860 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3862 /* Calculate stride = size * (ubound + 1 - lbound). */
3863 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3864 gfc_index_one_node
, lbound
);
3865 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
3866 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3868 gfc_add_modify_expr (pblock
, stride
, tmp
);
3870 stride
= gfc_evaluate_now (tmp
, pblock
);
3872 /* Make sure that negative size arrays are translated
3873 to being zero size. */
3874 tmp
= build2 (GE_EXPR
, boolean_type_node
,
3875 stride
, gfc_index_zero_node
);
3876 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3877 stride
, gfc_index_zero_node
);
3878 gfc_add_modify_expr (pblock
, stride
, tmp
);
3884 gfc_trans_vla_type_sizes (sym
, pblock
);
3891 /* Generate code to initialize/allocate an array variable. */
3894 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3903 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3905 /* Do nothing for USEd variables. */
3906 if (sym
->attr
.use_assoc
)
3909 type
= TREE_TYPE (decl
);
3910 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3911 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3913 gfc_start_block (&block
);
3915 /* Evaluate character string length. */
3916 if (sym
->ts
.type
== BT_CHARACTER
3917 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3919 gfc_conv_string_length (sym
->ts
.cl
, &block
);
3921 gfc_trans_vla_type_sizes (sym
, &block
);
3923 /* Emit a DECL_EXPR for this variable, which will cause the
3924 gimplifier to allocate storage, and all that good stuff. */
3925 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3926 gfc_add_expr_to_block (&block
, tmp
);
3931 gfc_add_expr_to_block (&block
, fnbody
);
3932 return gfc_finish_block (&block
);
3935 type
= TREE_TYPE (type
);
3937 gcc_assert (!sym
->attr
.use_assoc
);
3938 gcc_assert (!TREE_STATIC (decl
));
3939 gcc_assert (!sym
->module
);
3941 if (sym
->ts
.type
== BT_CHARACTER
3942 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3943 gfc_conv_string_length (sym
->ts
.cl
, &block
);
3945 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3947 /* Don't actually allocate space for Cray Pointees. */
3948 if (sym
->attr
.cray_pointee
)
3950 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3951 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3952 gfc_add_expr_to_block (&block
, fnbody
);
3953 return gfc_finish_block (&block
);
3956 /* The size is the number of elements in the array, so multiply by the
3957 size of an element to get the total size. */
3958 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3959 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
3960 fold_convert (gfc_array_index_type
, tmp
));
3962 /* Allocate memory to hold the data. */
3963 tmp
= gfc_call_malloc (&block
, TREE_TYPE (decl
), size
);
3964 gfc_add_modify_expr (&block
, decl
, tmp
);
3966 /* Set offset of the array. */
3967 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3968 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3971 /* Automatic arrays should not have initializers. */
3972 gcc_assert (!sym
->value
);
3974 gfc_add_expr_to_block (&block
, fnbody
);
3976 /* Free the temporary. */
3977 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
3978 gfc_add_expr_to_block (&block
, tmp
);
3980 return gfc_finish_block (&block
);
3984 /* Generate entry and exit code for g77 calling convention arrays. */
3987 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3997 gfc_get_backend_locus (&loc
);
3998 gfc_set_backend_locus (&sym
->declared_at
);
4000 /* Descriptor type. */
4001 parm
= sym
->backend_decl
;
4002 type
= TREE_TYPE (parm
);
4003 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4005 gfc_start_block (&block
);
4007 if (sym
->ts
.type
== BT_CHARACTER
4008 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4009 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4011 /* Evaluate the bounds of the array. */
4012 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4014 /* Set the offset. */
4015 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4016 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4018 /* Set the pointer itself if we aren't using the parameter directly. */
4019 if (TREE_CODE (parm
) != PARM_DECL
)
4021 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4022 gfc_add_modify_expr (&block
, parm
, tmp
);
4024 stmt
= gfc_finish_block (&block
);
4026 gfc_set_backend_locus (&loc
);
4028 gfc_start_block (&block
);
4030 /* Add the initialization code to the start of the function. */
4032 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4034 tmp
= gfc_conv_expr_present (sym
);
4035 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4038 gfc_add_expr_to_block (&block
, stmt
);
4039 gfc_add_expr_to_block (&block
, body
);
4041 return gfc_finish_block (&block
);
4045 /* Modify the descriptor of an array parameter so that it has the
4046 correct lower bound. Also move the upper bound accordingly.
4047 If the array is not packed, it will be copied into a temporary.
4048 For each dimension we set the new lower and upper bounds. Then we copy the
4049 stride and calculate the offset for this dimension. We also work out
4050 what the stride of a packed array would be, and see it the two match.
4051 If the array need repacking, we set the stride to the values we just
4052 calculated, recalculate the offset and copy the array data.
4053 Code is also added to copy the data back at the end of the function.
4057 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
4064 stmtblock_t cleanup
;
4072 tree stride
, stride2
;
4082 /* Do nothing for pointer and allocatable arrays. */
4083 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4086 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4087 return gfc_trans_g77_array (sym
, body
);
4089 gfc_get_backend_locus (&loc
);
4090 gfc_set_backend_locus (&sym
->declared_at
);
4092 /* Descriptor type. */
4093 type
= TREE_TYPE (tmpdesc
);
4094 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4095 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4096 dumdesc
= build_fold_indirect_ref (dumdesc
);
4097 gfc_start_block (&block
);
4099 if (sym
->ts
.type
== BT_CHARACTER
4100 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4101 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4103 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
4105 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4106 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4108 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4110 /* For non-constant shape arrays we only check if the first dimension
4111 is contiguous. Repacking higher dimensions wouldn't gain us
4112 anything as we still don't know the array stride. */
4113 partial
= gfc_create_var (boolean_type_node
, "partial");
4114 TREE_USED (partial
) = 1;
4115 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4116 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4117 gfc_add_modify_expr (&block
, partial
, tmp
);
4121 partial
= NULL_TREE
;
4124 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4125 here, however I think it does the right thing. */
4128 /* Set the first stride. */
4129 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4130 stride
= gfc_evaluate_now (stride
, &block
);
4132 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, gfc_index_zero_node
);
4133 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4134 gfc_index_one_node
, stride
);
4135 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4136 gfc_add_modify_expr (&block
, stride
, tmp
);
4138 /* Allow the user to disable array repacking. */
4139 stmt_unpacked
= NULL_TREE
;
4143 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4144 /* A library call to repack the array if necessary. */
4145 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4146 stmt_unpacked
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
4148 stride
= gfc_index_one_node
;
4151 /* This is for the case where the array data is used directly without
4152 calling the repack function. */
4153 if (no_repack
|| partial
!= NULL_TREE
)
4154 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4156 stmt_packed
= NULL_TREE
;
4158 /* Assign the data pointer. */
4159 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4161 /* Don't repack unknown shape arrays when the first stride is 1. */
4162 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
4163 stmt_packed
, stmt_unpacked
);
4166 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4167 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
4169 offset
= gfc_index_zero_node
;
4170 size
= gfc_index_one_node
;
4172 /* Evaluate the bounds of the array. */
4173 for (n
= 0; n
< sym
->as
->rank
; n
++)
4175 if (checkparm
|| !sym
->as
->upper
[n
])
4177 /* Get the bounds of the actual parameter. */
4178 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
4179 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
4183 dubound
= NULL_TREE
;
4184 dlbound
= NULL_TREE
;
4187 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4188 if (!INTEGER_CST_P (lbound
))
4190 gfc_init_se (&se
, NULL
);
4191 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4192 gfc_array_index_type
);
4193 gfc_add_block_to_block (&block
, &se
.pre
);
4194 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
4197 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4198 /* Set the desired upper bound. */
4199 if (sym
->as
->upper
[n
])
4201 /* We know what we want the upper bound to be. */
4202 if (!INTEGER_CST_P (ubound
))
4204 gfc_init_se (&se
, NULL
);
4205 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4206 gfc_array_index_type
);
4207 gfc_add_block_to_block (&block
, &se
.pre
);
4208 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
4211 /* Check the sizes match. */
4214 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4217 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4219 stride2
= build2 (MINUS_EXPR
, gfc_array_index_type
,
4221 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
4222 asprintf (&msg
, "%s for dimension %d of array '%s'",
4223 gfc_msg_bounds
, n
+1, sym
->name
);
4224 gfc_trans_runtime_check (tmp
, &block
, &loc
, msg
);
4230 /* For assumed shape arrays move the upper bound by the same amount
4231 as the lower bound. */
4232 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
4233 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4234 gfc_add_modify_expr (&block
, ubound
, tmp
);
4236 /* The offset of this dimension. offset = offset - lbound * stride. */
4237 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4238 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4240 /* The size of this dimension, and the stride of the next. */
4241 if (n
+ 1 < sym
->as
->rank
)
4243 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4245 if (no_repack
|| partial
!= NULL_TREE
)
4248 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
4251 /* Figure out the stride if not a known constant. */
4252 if (!INTEGER_CST_P (stride
))
4255 stmt_packed
= NULL_TREE
;
4258 /* Calculate stride = size * (ubound + 1 - lbound). */
4259 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4260 gfc_index_one_node
, lbound
);
4261 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4263 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4268 /* Assign the stride. */
4269 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4270 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4271 stmt_unpacked
, stmt_packed
);
4273 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4274 gfc_add_modify_expr (&block
, stride
, tmp
);
4279 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4281 if (stride
&& !INTEGER_CST_P (stride
))
4283 /* Calculate size = stride * (ubound + 1 - lbound). */
4284 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4285 gfc_index_one_node
, lbound
);
4286 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4288 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4289 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4290 gfc_add_modify_expr (&block
, stride
, tmp
);
4295 /* Set the offset. */
4296 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4297 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4299 gfc_trans_vla_type_sizes (sym
, &block
);
4301 stmt
= gfc_finish_block (&block
);
4303 gfc_start_block (&block
);
4305 /* Only do the entry/initialization code if the arg is present. */
4306 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4307 optional_arg
= (sym
->attr
.optional
4308 || (sym
->ns
->proc_name
->attr
.entry_master
4309 && sym
->attr
.dummy
));
4312 tmp
= gfc_conv_expr_present (sym
);
4313 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4315 gfc_add_expr_to_block (&block
, stmt
);
4317 /* Add the main function body. */
4318 gfc_add_expr_to_block (&block
, body
);
4323 gfc_start_block (&cleanup
);
4325 if (sym
->attr
.intent
!= INTENT_IN
)
4327 /* Copy the data back. */
4328 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4329 gfc_add_expr_to_block (&cleanup
, tmp
);
4332 /* Free the temporary. */
4333 tmp
= gfc_call_free (tmpdesc
);
4334 gfc_add_expr_to_block (&cleanup
, tmp
);
4336 stmt
= gfc_finish_block (&cleanup
);
4338 /* Only do the cleanup if the array was repacked. */
4339 tmp
= build_fold_indirect_ref (dumdesc
);
4340 tmp
= gfc_conv_descriptor_data_get (tmp
);
4341 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4342 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4346 tmp
= gfc_conv_expr_present (sym
);
4347 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4349 gfc_add_expr_to_block (&block
, stmt
);
4351 /* We don't need to free any memory allocated by internal_pack as it will
4352 be freed at the end of the function by pop_context. */
4353 return gfc_finish_block (&block
);
4357 /* Calculate the overall offset, including subreferences. */
4359 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4360 bool subref
, gfc_expr
*expr
)
4370 /* If offset is NULL and this is not a subreferenced array, there is
4372 if (offset
== NULL_TREE
)
4375 offset
= gfc_index_zero_node
;
4380 tmp
= gfc_conv_array_data (desc
);
4381 tmp
= build_fold_indirect_ref (tmp
);
4382 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4384 /* Offset the data pointer for pointer assignments from arrays with
4385 subreferences; eg. my_integer => my_type(:)%integer_component. */
4388 /* Go past the array reference. */
4389 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4390 if (ref
->type
== REF_ARRAY
&&
4391 ref
->u
.ar
.type
!= AR_ELEMENT
)
4397 /* Calculate the offset for each subsequent subreference. */
4398 for (; ref
; ref
= ref
->next
)
4403 field
= ref
->u
.c
.component
->backend_decl
;
4404 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
4405 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
4409 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
4410 gfc_init_se (&start
, NULL
);
4411 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
4412 gfc_add_block_to_block (block
, &start
.pre
);
4413 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
4417 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
4418 && ref
->u
.ar
.type
== AR_ELEMENT
);
4420 /* TODO - Add bounds checking. */
4421 stride
= gfc_index_one_node
;
4422 index
= gfc_index_zero_node
;
4423 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4428 /* Update the index. */
4429 gfc_init_se (&start
, NULL
);
4430 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
4431 itmp
= gfc_evaluate_now (start
.expr
, block
);
4432 gfc_init_se (&start
, NULL
);
4433 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
4434 jtmp
= gfc_evaluate_now (start
.expr
, block
);
4435 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, itmp
, jtmp
);
4436 itmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, itmp
, stride
);
4437 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, itmp
, index
);
4438 index
= gfc_evaluate_now (index
, block
);
4440 /* Update the stride. */
4441 gfc_init_se (&start
, NULL
);
4442 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
4443 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, start
.expr
, jtmp
);
4444 itmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4445 gfc_index_one_node
, itmp
);
4446 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, itmp
);
4447 stride
= gfc_evaluate_now (stride
, block
);
4450 /* Apply the index to obtain the array element. */
4451 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
4461 /* Set the target data pointer. */
4462 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4463 gfc_conv_descriptor_data_set (block
, parm
, offset
);
4467 /* Convert an array for passing as an actual argument. Expressions and
4468 vector subscripts are evaluated and stored in a temporary, which is then
4469 passed. For whole arrays the descriptor is passed. For array sections
4470 a modified copy of the descriptor is passed, but using the original data.
4472 This function is also used for array pointer assignments, and there
4475 - se->want_pointer && !se->direct_byref
4476 EXPR is an actual argument. On exit, se->expr contains a
4477 pointer to the array descriptor.
4479 - !se->want_pointer && !se->direct_byref
4480 EXPR is an actual argument to an intrinsic function or the
4481 left-hand side of a pointer assignment. On exit, se->expr
4482 contains the descriptor for EXPR.
4484 - !se->want_pointer && se->direct_byref
4485 EXPR is the right-hand side of a pointer assignment and
4486 se->expr is the descriptor for the previously-evaluated
4487 left-hand side. The function creates an assignment from
4488 EXPR to se->expr. */
4491 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
4504 bool subref_array_target
= false;
4506 gcc_assert (ss
!= gfc_ss_terminator
);
4508 /* Special case things we know we can pass easily. */
4509 switch (expr
->expr_type
)
4512 /* If we have a linear array section, we can pass it directly.
4513 Otherwise we need to copy it into a temporary. */
4515 /* Find the SS for the array section. */
4517 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
4518 secss
= secss
->next
;
4520 gcc_assert (secss
!= gfc_ss_terminator
);
4521 info
= &secss
->data
.info
;
4523 /* Get the descriptor for the array. */
4524 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
4525 desc
= info
->descriptor
;
4527 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
4528 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
4529 && !subref_array_target
;
4533 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4535 /* Create a new descriptor if the array doesn't have one. */
4538 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
4540 else if (se
->direct_byref
)
4543 full
= gfc_full_array_ref_p (info
->ref
);
4547 if (se
->direct_byref
)
4549 /* Copy the descriptor for pointer assignments. */
4550 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
4552 /* Add any offsets from subreferences. */
4553 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
4554 subref_array_target
, expr
);
4556 else if (se
->want_pointer
)
4558 /* We pass full arrays directly. This means that pointers and
4559 allocatable arrays should also work. */
4560 se
->expr
= build_fold_addr_expr (desc
);
4567 if (expr
->ts
.type
== BT_CHARACTER
)
4568 se
->string_length
= gfc_get_expr_charlen (expr
);
4575 /* A transformational function return value will be a temporary
4576 array descriptor. We still need to go through the scalarizer
4577 to create the descriptor. Elemental functions ar handled as
4578 arbitrary expressions, i.e. copy to a temporary. */
4580 /* Look for the SS for this function. */
4581 while (secss
!= gfc_ss_terminator
4582 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
4583 secss
= secss
->next
;
4585 if (se
->direct_byref
)
4587 gcc_assert (secss
!= gfc_ss_terminator
);
4589 /* For pointer assignments pass the descriptor directly. */
4591 se
->expr
= build_fold_addr_expr (se
->expr
);
4592 gfc_conv_expr (se
, expr
);
4596 if (secss
== gfc_ss_terminator
)
4598 /* Elemental function. */
4604 /* Transformational function. */
4605 info
= &secss
->data
.info
;
4611 /* Constant array constructors don't need a temporary. */
4612 if (ss
->type
== GFC_SS_CONSTRUCTOR
4613 && expr
->ts
.type
!= BT_CHARACTER
4614 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
4617 info
= &ss
->data
.info
;
4629 /* Something complicated. Copy it into a temporary. */
4637 gfc_init_loopinfo (&loop
);
4639 /* Associate the SS with the loop. */
4640 gfc_add_ss_to_loop (&loop
, ss
);
4642 /* Tell the scalarizer not to bother creating loop variables, etc. */
4644 loop
.array_parameter
= 1;
4646 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4647 gcc_assert (!se
->direct_byref
);
4649 /* Setup the scalarizing loops and bounds. */
4650 gfc_conv_ss_startstride (&loop
);
4654 /* Tell the scalarizer to make a temporary. */
4655 loop
.temp_ss
= gfc_get_ss ();
4656 loop
.temp_ss
->type
= GFC_SS_TEMP
;
4657 loop
.temp_ss
->next
= gfc_ss_terminator
;
4659 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
4660 gfc_conv_string_length (expr
->ts
.cl
, &se
->pre
);
4662 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
4664 if (expr
->ts
.type
== BT_CHARACTER
)
4665 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4667 loop
.temp_ss
->string_length
= NULL
;
4669 se
->string_length
= loop
.temp_ss
->string_length
;
4670 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
4671 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4674 gfc_conv_loop_setup (&loop
);
4678 /* Copy into a temporary and pass that. We don't need to copy the data
4679 back because expressions and vector subscripts must be INTENT_IN. */
4680 /* TODO: Optimize passing function return values. */
4684 /* Start the copying loops. */
4685 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4686 gfc_mark_ss_chain_used (ss
, 1);
4687 gfc_start_scalarized_body (&loop
, &block
);
4689 /* Copy each data element. */
4690 gfc_init_se (&lse
, NULL
);
4691 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4692 gfc_init_se (&rse
, NULL
);
4693 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4695 lse
.ss
= loop
.temp_ss
;
4698 gfc_conv_scalarized_array_ref (&lse
, NULL
);
4699 if (expr
->ts
.type
== BT_CHARACTER
)
4701 gfc_conv_expr (&rse
, expr
);
4702 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
4703 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4706 gfc_conv_expr_val (&rse
, expr
);
4708 gfc_add_block_to_block (&block
, &rse
.pre
);
4709 gfc_add_block_to_block (&block
, &lse
.pre
);
4711 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
4713 /* Finish the copying loops. */
4714 gfc_trans_scalarizing_loops (&loop
, &block
);
4716 desc
= loop
.temp_ss
->data
.info
.descriptor
;
4718 gcc_assert (is_gimple_lvalue (desc
));
4720 else if (expr
->expr_type
== EXPR_FUNCTION
)
4722 desc
= info
->descriptor
;
4723 se
->string_length
= ss
->string_length
;
4727 /* We pass sections without copying to a temporary. Make a new
4728 descriptor and point it at the section we want. The loop variable
4729 limits will be the limits of the section.
4730 A function may decide to repack the array to speed up access, but
4731 we're not bothered about that here. */
4740 /* Set the string_length for a character array. */
4741 if (expr
->ts
.type
== BT_CHARACTER
)
4742 se
->string_length
= gfc_get_expr_charlen (expr
);
4744 desc
= info
->descriptor
;
4745 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
4746 if (se
->direct_byref
)
4748 /* For pointer assignments we fill in the destination. */
4750 parmtype
= TREE_TYPE (parm
);
4754 /* Otherwise make a new one. */
4755 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4756 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
4757 loop
.from
, loop
.to
, 0);
4758 parm
= gfc_create_var (parmtype
, "parm");
4761 offset
= gfc_index_zero_node
;
4764 /* The following can be somewhat confusing. We have two
4765 descriptors, a new one and the original array.
4766 {parm, parmtype, dim} refer to the new one.
4767 {desc, type, n, secss, loop} refer to the original, which maybe
4768 a descriptorless array.
4769 The bounds of the scalarization are the bounds of the section.
4770 We don't have to worry about numeric overflows when calculating
4771 the offsets because all elements are within the array data. */
4773 /* Set the dtype. */
4774 tmp
= gfc_conv_descriptor_dtype (parm
);
4775 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
4777 /* Set offset for assignments to pointer only to zero if it is not
4779 if (se
->direct_byref
4780 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
4781 base
= gfc_index_zero_node
;
4782 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4783 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
4787 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
4788 for (n
= 0; n
< ndim
; n
++)
4790 stride
= gfc_conv_array_stride (desc
, n
);
4792 /* Work out the offset. */
4794 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4796 gcc_assert (info
->subscript
[n
]
4797 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
4798 start
= info
->subscript
[n
]->data
.scalar
.expr
;
4802 /* Check we haven't somehow got out of sync. */
4803 gcc_assert (info
->dim
[dim
] == n
);
4805 /* Evaluate and remember the start of the section. */
4806 start
= info
->start
[dim
];
4807 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
4810 tmp
= gfc_conv_array_lbound (desc
, n
);
4811 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
4813 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
4814 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
4817 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4819 /* For elemental dimensions, we only need the offset. */
4823 /* Vector subscripts need copying and are handled elsewhere. */
4825 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
4827 /* Set the new lower bound. */
4828 from
= loop
.from
[dim
];
4831 /* If we have an array section or are assigning make sure that
4832 the lower bound is 1. References to the full
4833 array should otherwise keep the original bounds. */
4835 || info
->ref
->u
.ar
.type
!= AR_FULL
)
4836 && !integer_onep (from
))
4838 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4839 gfc_index_one_node
, from
);
4840 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
4841 from
= gfc_index_one_node
;
4843 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
4844 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
4846 /* Set the new upper bound. */
4847 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
4848 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
4850 /* Multiply the stride by the section stride to get the
4852 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4853 stride
, info
->stride
[dim
]);
4855 if (se
->direct_byref
&& info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
4857 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4860 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4862 tmp
= gfc_conv_array_lbound (desc
, n
);
4863 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4864 tmp
, loop
.from
[dim
]);
4865 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
4866 tmp
, gfc_conv_array_stride (desc
, n
));
4867 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
4871 /* Store the new stride. */
4872 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
4873 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
4878 if (se
->data_not_needed
)
4879 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, gfc_index_zero_node
);
4881 /* Point the data pointer at the first element in the section. */
4882 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
4883 subref_array_target
, expr
);
4885 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4886 && !se
->data_not_needed
)
4888 /* Set the offset. */
4889 tmp
= gfc_conv_descriptor_offset (parm
);
4890 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
4894 /* Only the callee knows what the correct offset it, so just set
4896 tmp
= gfc_conv_descriptor_offset (parm
);
4897 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
4902 if (!se
->direct_byref
)
4904 /* Get a pointer to the new descriptor. */
4905 if (se
->want_pointer
)
4906 se
->expr
= build_fold_addr_expr (desc
);
4911 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4912 gfc_add_block_to_block (&se
->post
, &loop
.post
);
4914 /* Cleanup the scalarizer. */
4915 gfc_cleanup_loop (&loop
);
4919 /* Convert an array for passing as an actual parameter. */
4920 /* TODO: Optimize passing g77 arrays. */
4923 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
4927 tree tmp
= NULL_TREE
;
4929 tree parent
= DECL_CONTEXT (current_function_decl
);
4930 bool full_array_var
, this_array_result
;
4934 full_array_var
= (expr
->expr_type
== EXPR_VARIABLE
4935 && expr
->ref
->u
.ar
.type
== AR_FULL
);
4936 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
4938 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
4940 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
4941 expr
->ts
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &se
->pre
);
4942 se
->string_length
= expr
->ts
.cl
->backend_decl
;
4945 /* Is this the result of the enclosing procedure? */
4946 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
4947 if (this_array_result
4948 && (sym
->backend_decl
!= current_function_decl
)
4949 && (sym
->backend_decl
!= parent
))
4950 this_array_result
= false;
4952 /* Passing address of the array if it is not pointer or assumed-shape. */
4953 if (full_array_var
&& g77
&& !this_array_result
)
4955 tmp
= gfc_get_symbol_decl (sym
);
4957 if (sym
->ts
.type
== BT_CHARACTER
)
4958 se
->string_length
= sym
->ts
.cl
->backend_decl
;
4959 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
4960 && !sym
->attr
.allocatable
)
4962 /* Some variables are declared directly, others are declared as
4963 pointers and allocated on the heap. */
4964 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
4967 se
->expr
= build_fold_addr_expr (tmp
);
4970 if (sym
->attr
.allocatable
)
4972 if (sym
->attr
.dummy
)
4974 gfc_conv_expr_descriptor (se
, expr
, ss
);
4975 se
->expr
= gfc_conv_array_data (se
->expr
);
4978 se
->expr
= gfc_conv_array_data (tmp
);
4983 if (this_array_result
)
4985 /* Result of the enclosing function. */
4986 gfc_conv_expr_descriptor (se
, expr
, ss
);
4987 se
->expr
= build_fold_addr_expr (se
->expr
);
4989 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
4990 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4991 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref (se
->expr
));
4997 /* Every other type of array. */
4998 se
->want_pointer
= 1;
4999 gfc_conv_expr_descriptor (se
, expr
, ss
);
5003 /* Deallocate the allocatable components of structures that are
5005 if (expr
->ts
.type
== BT_DERIVED
5006 && expr
->ts
.derived
->attr
.alloc_comp
5007 && expr
->expr_type
!= EXPR_VARIABLE
)
5009 tmp
= build_fold_indirect_ref (se
->expr
);
5010 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.derived
, tmp
, expr
->rank
);
5011 gfc_add_expr_to_block (&se
->post
, tmp
);
5017 /* Repack the array. */
5018 ptr
= build_call_expr (gfor_fndecl_in_pack
, 1, desc
);
5019 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5022 gfc_start_block (&block
);
5024 /* Copy the data back. */
5025 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5026 gfc_add_expr_to_block (&block
, tmp
);
5028 /* Free the temporary. */
5029 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5030 gfc_add_expr_to_block (&block
, tmp
);
5032 stmt
= gfc_finish_block (&block
);
5034 gfc_init_block (&block
);
5035 /* Only if it was repacked. This code needs to be executed before the
5036 loop cleanup code. */
5037 tmp
= build_fold_indirect_ref (desc
);
5038 tmp
= gfc_conv_array_data (tmp
);
5039 tmp
= build2 (NE_EXPR
, boolean_type_node
,
5040 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5041 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
5043 gfc_add_expr_to_block (&block
, tmp
);
5044 gfc_add_block_to_block (&block
, &se
->post
);
5046 gfc_init_block (&se
->post
);
5047 gfc_add_block_to_block (&se
->post
, &block
);
5052 /* Generate code to deallocate an array, if it is allocated. */
5055 gfc_trans_dealloc_allocated (tree descriptor
)
5061 gfc_start_block (&block
);
5063 var
= gfc_conv_descriptor_data_get (descriptor
);
5066 /* Call array_deallocate with an int * present in the second argument.
5067 Although it is ignored here, it's presence ensures that arrays that
5068 are already deallocated are ignored. */
5069 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true);
5070 gfc_add_expr_to_block (&block
, tmp
);
5072 /* Zero the data pointer. */
5073 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
5074 var
, build_int_cst (TREE_TYPE (var
), 0));
5075 gfc_add_expr_to_block (&block
, tmp
);
5077 return gfc_finish_block (&block
);
5081 /* This helper function calculates the size in words of a full array. */
5084 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
5089 idx
= gfc_rank_cst
[rank
- 1];
5090 nelems
= gfc_conv_descriptor_ubound (decl
, idx
);
5091 tmp
= gfc_conv_descriptor_lbound (decl
, idx
);
5092 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5093 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
5094 tmp
, gfc_index_one_node
);
5095 tmp
= gfc_evaluate_now (tmp
, block
);
5097 nelems
= gfc_conv_descriptor_stride (decl
, idx
);
5098 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5099 return gfc_evaluate_now (tmp
, block
);
5103 /* Allocate dest to the same size as src, and copy src -> dest. */
5106 gfc_duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
)
5115 /* If the source is null, set the destination to null. */
5116 gfc_init_block (&block
);
5117 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5118 null_data
= gfc_finish_block (&block
);
5120 gfc_init_block (&block
);
5122 nelems
= get_full_array_size (&block
, src
, rank
);
5123 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
,
5124 fold_convert (gfc_array_index_type
,
5125 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
5127 /* Allocate memory to the destination. */
5128 tmp
= gfc_call_malloc (&block
, TREE_TYPE (gfc_conv_descriptor_data_get (src
)),
5130 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5132 /* We know the temporary and the value will be the same length,
5133 so can use memcpy. */
5134 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5135 tmp
= build_call_expr (tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5136 gfc_conv_descriptor_data_get (src
), size
);
5137 gfc_add_expr_to_block (&block
, tmp
);
5138 tmp
= gfc_finish_block (&block
);
5140 /* Null the destination if the source is null; otherwise do
5141 the allocate and copy. */
5142 null_cond
= gfc_conv_descriptor_data_get (src
);
5143 null_cond
= convert (pvoid_type_node
, null_cond
);
5144 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5146 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5150 /* Recursively traverse an object of derived type, generating code to
5151 deallocate, nullify or copy allocatable components. This is the work horse
5152 function for the functions named in this enum. */
5154 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
};
5157 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5158 tree dest
, int rank
, int purpose
)
5162 stmtblock_t fnblock
;
5163 stmtblock_t loopbody
;
5173 tree null_cond
= NULL_TREE
;
5175 gfc_init_block (&fnblock
);
5177 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
5178 decl
= build_fold_indirect_ref (decl
);
5180 /* If this an array of derived types with allocatable components
5181 build a loop and recursively call this function. */
5182 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
5183 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5185 tmp
= gfc_conv_array_data (decl
);
5186 var
= build_fold_indirect_ref (tmp
);
5188 /* Get the number of elements - 1 and set the counter. */
5189 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5191 /* Use the descriptor for an allocatable array. Since this
5192 is a full array reference, we only need the descriptor
5193 information from dimension = rank. */
5194 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
5195 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
5196 tmp
, gfc_index_one_node
);
5198 null_cond
= gfc_conv_descriptor_data_get (decl
);
5199 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5200 build_int_cst (TREE_TYPE (null_cond
), 0));
5204 /* Otherwise use the TYPE_DOMAIN information. */
5205 tmp
= array_type_nelts (TREE_TYPE (decl
));
5206 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5209 /* Remember that this is, in fact, the no. of elements - 1. */
5210 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5211 index
= gfc_create_var (gfc_array_index_type
, "S");
5213 /* Build the body of the loop. */
5214 gfc_init_block (&loopbody
);
5216 vref
= gfc_build_array_ref (var
, index
, NULL
);
5218 if (purpose
== COPY_ALLOC_COMP
)
5220 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
5221 gfc_add_expr_to_block (&fnblock
, tmp
);
5223 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest
));
5224 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
5225 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
5228 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
5230 gfc_add_expr_to_block (&loopbody
, tmp
);
5232 /* Build the loop and return. */
5233 gfc_init_loopinfo (&loop
);
5235 loop
.from
[0] = gfc_index_zero_node
;
5236 loop
.loopvar
[0] = index
;
5237 loop
.to
[0] = nelems
;
5238 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
5239 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
5241 tmp
= gfc_finish_block (&fnblock
);
5242 if (null_cond
!= NULL_TREE
)
5243 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
, build_empty_stmt ());
5248 /* Otherwise, act on the components or recursively call self to
5249 act on a chain of components. */
5250 for (c
= der_type
->components
; c
; c
= c
->next
)
5252 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
5253 && c
->ts
.derived
->attr
.alloc_comp
;
5254 cdecl = c
->backend_decl
;
5255 ctype
= TREE_TYPE (cdecl);
5259 case DEALLOCATE_ALLOC_COMP
:
5260 /* Do not deallocate the components of ultimate pointer
5262 if (cmp_has_alloc_comps
&& !c
->pointer
)
5264 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5265 rank
= c
->as
? c
->as
->rank
: 0;
5266 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5268 gfc_add_expr_to_block (&fnblock
, tmp
);
5273 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5274 tmp
= gfc_trans_dealloc_allocated (comp
);
5275 gfc_add_expr_to_block (&fnblock
, tmp
);
5279 case NULLIFY_ALLOC_COMP
:
5282 else if (c
->allocatable
)
5284 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5285 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
5287 else if (cmp_has_alloc_comps
)
5289 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5290 rank
= c
->as
? c
->as
->rank
: 0;
5291 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5293 gfc_add_expr_to_block (&fnblock
, tmp
);
5297 case COPY_ALLOC_COMP
:
5301 /* We need source and destination components. */
5302 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5303 dcmp
= build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
5304 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
5306 if (c
->allocatable
&& !cmp_has_alloc_comps
)
5308 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, c
->as
->rank
);
5309 gfc_add_expr_to_block (&fnblock
, tmp
);
5312 if (cmp_has_alloc_comps
)
5314 rank
= c
->as
? c
->as
->rank
: 0;
5315 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
5316 gfc_add_modify_expr (&fnblock
, dcmp
, tmp
);
5317 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, dcmp
,
5319 gfc_add_expr_to_block (&fnblock
, tmp
);
5329 return gfc_finish_block (&fnblock
);
5332 /* Recursively traverse an object of derived type, generating code to
5333 nullify allocatable components. */
5336 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5338 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5339 NULLIFY_ALLOC_COMP
);
5343 /* Recursively traverse an object of derived type, generating code to
5344 deallocate allocatable components. */
5347 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5349 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5350 DEALLOCATE_ALLOC_COMP
);
5354 /* Recursively traverse an object of derived type, generating code to
5355 copy its allocatable components. */
5358 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
5360 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
5364 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5365 Do likewise, recursively if necessary, with the allocatable components of
5369 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
5374 stmtblock_t fnblock
;
5377 bool sym_has_alloc_comp
;
5379 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
5380 && sym
->ts
.derived
->attr
.alloc_comp
;
5382 /* Make sure the frontend gets these right. */
5383 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
5384 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5385 "allocatable attribute or derived type without allocatable "
5388 gfc_init_block (&fnblock
);
5390 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
5391 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
5393 if (sym
->ts
.type
== BT_CHARACTER
5394 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
5396 gfc_conv_string_length (sym
->ts
.cl
, &fnblock
);
5397 gfc_trans_vla_type_sizes (sym
, &fnblock
);
5400 /* Dummy and use associated variables don't need anything special. */
5401 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
5403 gfc_add_expr_to_block (&fnblock
, body
);
5405 return gfc_finish_block (&fnblock
);
5408 gfc_get_backend_locus (&loc
);
5409 gfc_set_backend_locus (&sym
->declared_at
);
5410 descriptor
= sym
->backend_decl
;
5412 /* Although static, derived types with default initializers and
5413 allocatable components must not be nulled wholesale; instead they
5414 are treated component by component. */
5415 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
5417 /* SAVEd variables are not freed on exit. */
5418 gfc_trans_static_array_pointer (sym
);
5422 /* Get the descriptor type. */
5423 type
= TREE_TYPE (sym
->backend_decl
);
5425 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5427 if (!sym
->attr
.save
)
5429 rank
= sym
->as
? sym
->as
->rank
: 0;
5430 tmp
= gfc_nullify_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5431 gfc_add_expr_to_block (&fnblock
, tmp
);
5434 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
5436 /* If the backend_decl is not a descriptor, we must have a pointer
5438 descriptor
= build_fold_indirect_ref (sym
->backend_decl
);
5439 type
= TREE_TYPE (descriptor
);
5442 /* NULLIFY the data pointer. */
5443 if (GFC_DESCRIPTOR_TYPE_P (type
))
5444 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
5446 gfc_add_expr_to_block (&fnblock
, body
);
5448 gfc_set_backend_locus (&loc
);
5450 /* Allocatable arrays need to be freed when they go out of scope.
5451 The allocatable components of pointers must not be touched. */
5452 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
5453 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
5456 rank
= sym
->as
? sym
->as
->rank
: 0;
5457 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5458 gfc_add_expr_to_block (&fnblock
, tmp
);
5461 if (sym
->attr
.allocatable
)
5463 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
5464 gfc_add_expr_to_block (&fnblock
, tmp
);
5467 return gfc_finish_block (&fnblock
);
5470 /************ Expression Walking Functions ******************/
5472 /* Walk a variable reference.
5474 Possible extension - multiple component subscripts.
5475 x(:,:) = foo%a(:)%b(:)
5477 forall (i=..., j=...)
5478 x(i,j) = foo%a(j)%b(i)
5480 This adds a fair amount of complexity because you need to deal with more
5481 than one ref. Maybe handle in a similar manner to vector subscripts.
5482 Maybe not worth the effort. */
5486 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5494 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5495 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
5498 for (; ref
; ref
= ref
->next
)
5500 if (ref
->type
== REF_SUBSTRING
)
5502 newss
= gfc_get_ss ();
5503 newss
->type
= GFC_SS_SCALAR
;
5504 newss
->expr
= ref
->u
.ss
.start
;
5508 newss
= gfc_get_ss ();
5509 newss
->type
= GFC_SS_SCALAR
;
5510 newss
->expr
= ref
->u
.ss
.end
;
5515 /* We're only interested in array sections from now on. */
5516 if (ref
->type
!= REF_ARRAY
)
5523 for (n
= 0; n
< ar
->dimen
; n
++)
5525 newss
= gfc_get_ss ();
5526 newss
->type
= GFC_SS_SCALAR
;
5527 newss
->expr
= ar
->start
[n
];
5534 newss
= gfc_get_ss ();
5535 newss
->type
= GFC_SS_SECTION
;
5538 newss
->data
.info
.dimen
= ar
->as
->rank
;
5539 newss
->data
.info
.ref
= ref
;
5541 /* Make sure array is the same as array(:,:), this way
5542 we don't need to special case all the time. */
5543 ar
->dimen
= ar
->as
->rank
;
5544 for (n
= 0; n
< ar
->dimen
; n
++)
5546 newss
->data
.info
.dim
[n
] = n
;
5547 ar
->dimen_type
[n
] = DIMEN_RANGE
;
5549 gcc_assert (ar
->start
[n
] == NULL
);
5550 gcc_assert (ar
->end
[n
] == NULL
);
5551 gcc_assert (ar
->stride
[n
] == NULL
);
5557 newss
= gfc_get_ss ();
5558 newss
->type
= GFC_SS_SECTION
;
5561 newss
->data
.info
.dimen
= 0;
5562 newss
->data
.info
.ref
= ref
;
5566 /* We add SS chains for all the subscripts in the section. */
5567 for (n
= 0; n
< ar
->dimen
; n
++)
5571 switch (ar
->dimen_type
[n
])
5574 /* Add SS for elemental (scalar) subscripts. */
5575 gcc_assert (ar
->start
[n
]);
5576 indexss
= gfc_get_ss ();
5577 indexss
->type
= GFC_SS_SCALAR
;
5578 indexss
->expr
= ar
->start
[n
];
5579 indexss
->next
= gfc_ss_terminator
;
5580 indexss
->loop_chain
= gfc_ss_terminator
;
5581 newss
->data
.info
.subscript
[n
] = indexss
;
5585 /* We don't add anything for sections, just remember this
5586 dimension for later. */
5587 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5588 newss
->data
.info
.dimen
++;
5592 /* Create a GFC_SS_VECTOR index in which we can store
5593 the vector's descriptor. */
5594 indexss
= gfc_get_ss ();
5595 indexss
->type
= GFC_SS_VECTOR
;
5596 indexss
->expr
= ar
->start
[n
];
5597 indexss
->next
= gfc_ss_terminator
;
5598 indexss
->loop_chain
= gfc_ss_terminator
;
5599 newss
->data
.info
.subscript
[n
] = indexss
;
5600 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5601 newss
->data
.info
.dimen
++;
5605 /* We should know what sort of section it is by now. */
5609 /* We should have at least one non-elemental dimension. */
5610 gcc_assert (newss
->data
.info
.dimen
> 0);
5615 /* We should know what sort of section it is by now. */
5624 /* Walk an expression operator. If only one operand of a binary expression is
5625 scalar, we must also add the scalar term to the SS chain. */
5628 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5634 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
5635 if (expr
->value
.op
.op2
== NULL
)
5638 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
5640 /* All operands are scalar. Pass back and let the caller deal with it. */
5644 /* All operands require scalarization. */
5645 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
5648 /* One of the operands needs scalarization, the other is scalar.
5649 Create a gfc_ss for the scalar expression. */
5650 newss
= gfc_get_ss ();
5651 newss
->type
= GFC_SS_SCALAR
;
5654 /* First operand is scalar. We build the chain in reverse order, so
5655 add the scarar SS after the second operand. */
5657 while (head
&& head
->next
!= ss
)
5659 /* Check we haven't somehow broken the chain. */
5663 newss
->expr
= expr
->value
.op
.op1
;
5665 else /* head2 == head */
5667 gcc_assert (head2
== head
);
5668 /* Second operand is scalar. */
5669 newss
->next
= head2
;
5671 newss
->expr
= expr
->value
.op
.op2
;
5678 /* Reverse a SS chain. */
5681 gfc_reverse_ss (gfc_ss
* ss
)
5686 gcc_assert (ss
!= NULL
);
5688 head
= gfc_ss_terminator
;
5689 while (ss
!= gfc_ss_terminator
)
5692 /* Check we didn't somehow break the chain. */
5693 gcc_assert (next
!= NULL
);
5703 /* Walk the arguments of an elemental function. */
5706 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
5714 head
= gfc_ss_terminator
;
5717 for (; arg
; arg
= arg
->next
)
5722 newss
= gfc_walk_subexpr (head
, arg
->expr
);
5725 /* Scalar argument. */
5726 newss
= gfc_get_ss ();
5728 newss
->expr
= arg
->expr
;
5738 while (tail
->next
!= gfc_ss_terminator
)
5745 /* If all the arguments are scalar we don't need the argument SS. */
5746 gfc_free_ss_chain (head
);
5751 /* Add it onto the existing chain. */
5757 /* Walk a function call. Scalar functions are passed back, and taken out of
5758 scalarization loops. For elemental functions we walk their arguments.
5759 The result of functions returning arrays is stored in a temporary outside
5760 the loop, so that the function is only called once. Hence we do not need
5761 to walk their arguments. */
5764 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5767 gfc_intrinsic_sym
*isym
;
5770 isym
= expr
->value
.function
.isym
;
5772 /* Handle intrinsic functions separately. */
5774 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
5776 sym
= expr
->value
.function
.esym
;
5778 sym
= expr
->symtree
->n
.sym
;
5780 /* A function that returns arrays. */
5781 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
5783 newss
= gfc_get_ss ();
5784 newss
->type
= GFC_SS_FUNCTION
;
5787 newss
->data
.info
.dimen
= expr
->rank
;
5791 /* Walk the parameters of an elemental function. For now we always pass
5793 if (sym
->attr
.elemental
)
5794 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
5797 /* Scalar functions are OK as these are evaluated outside the scalarization
5798 loop. Pass back and let the caller deal with it. */
5803 /* An array temporary is constructed for array constructors. */
5806 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
5811 newss
= gfc_get_ss ();
5812 newss
->type
= GFC_SS_CONSTRUCTOR
;
5815 newss
->data
.info
.dimen
= expr
->rank
;
5816 for (n
= 0; n
< expr
->rank
; n
++)
5817 newss
->data
.info
.dim
[n
] = n
;
5823 /* Walk an expression. Add walked expressions to the head of the SS chain.
5824 A wholly scalar expression will not be added. */
5827 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
5831 switch (expr
->expr_type
)
5834 head
= gfc_walk_variable_expr (ss
, expr
);
5838 head
= gfc_walk_op_expr (ss
, expr
);
5842 head
= gfc_walk_function_expr (ss
, expr
);
5847 case EXPR_STRUCTURE
:
5848 /* Pass back and let the caller deal with it. */
5852 head
= gfc_walk_array_constructor (ss
, expr
);
5855 case EXPR_SUBSTRING
:
5856 /* Pass back and let the caller deal with it. */
5860 internal_error ("bad expression type during walk (%d)",
5867 /* Entry point for expression walking.
5868 A return value equal to the passed chain means this is
5869 a scalar expression. It is up to the caller to take whatever action is
5870 necessary to translate these. */
5873 gfc_walk_expr (gfc_expr
* expr
)
5877 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
5878 return gfc_reverse_ss (res
);