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,
613 desc
= gfc_create_var (type
, "atmp");
614 GFC_DECL_PACKED_ARRAY (desc
) = 1;
616 info
->descriptor
= desc
;
617 size
= gfc_index_one_node
;
619 /* Fill in the array dtype. */
620 tmp
= gfc_conv_descriptor_dtype (desc
);
621 gfc_add_modify_expr (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
624 Fill in the bounds and stride. This is a packed array, so:
627 for (n = 0; n < rank; n++)
630 delta = ubound[n] + 1 - lbound[n];
633 size = size * sizeof(element);
638 for (n
= 0; n
< info
->dimen
; n
++)
640 if (loop
->to
[n
] == NULL_TREE
)
642 /* For a callee allocated array express the loop bounds in terms
643 of the descriptor fields. */
644 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
645 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
646 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
652 /* Store the stride and bound components in the descriptor. */
653 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
654 gfc_add_modify_expr (pre
, tmp
, size
);
656 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
657 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
659 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
660 gfc_add_modify_expr (pre
, tmp
, loop
->to
[n
]);
662 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
663 loop
->to
[n
], gfc_index_one_node
);
665 /* Check whether the size for this dimension is negative. */
666 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
667 gfc_index_zero_node
);
668 cond
= gfc_evaluate_now (cond
, pre
);
673 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
675 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
676 size
= gfc_evaluate_now (size
, pre
);
679 /* Get the size of the array. */
681 if (size
&& !callee_alloc
)
683 /* If or_expr is true, then the extent in at least one
684 dimension is zero and the size is set to zero. */
685 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
,
686 or_expr
, gfc_index_zero_node
, size
);
689 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
690 fold_convert (gfc_array_index_type
,
691 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
699 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, dynamic
,
702 if (info
->dimen
> loop
->temp_dim
)
703 loop
->temp_dim
= info
->dimen
;
709 /* Generate code to transpose array EXPR by creating a new descriptor
710 in which the dimension specifications have been reversed. */
713 gfc_conv_array_transpose (gfc_se
* se
, gfc_expr
* expr
)
715 tree dest
, src
, dest_index
, src_index
;
717 gfc_ss_info
*dest_info
, *src_info
;
718 gfc_ss
*dest_ss
, *src_ss
;
724 src_ss
= gfc_walk_expr (expr
);
727 src_info
= &src_ss
->data
.info
;
728 dest_info
= &dest_ss
->data
.info
;
729 gcc_assert (dest_info
->dimen
== 2);
730 gcc_assert (src_info
->dimen
== 2);
732 /* Get a descriptor for EXPR. */
733 gfc_init_se (&src_se
, NULL
);
734 gfc_conv_expr_descriptor (&src_se
, expr
, src_ss
);
735 gfc_add_block_to_block (&se
->pre
, &src_se
.pre
);
736 gfc_add_block_to_block (&se
->post
, &src_se
.post
);
739 /* Allocate a new descriptor for the return value. */
740 dest
= gfc_create_var (TREE_TYPE (src
), "atmp");
741 dest_info
->descriptor
= dest
;
744 /* Copy across the dtype field. */
745 gfc_add_modify_expr (&se
->pre
,
746 gfc_conv_descriptor_dtype (dest
),
747 gfc_conv_descriptor_dtype (src
));
749 /* Copy the dimension information, renumbering dimension 1 to 0 and
751 for (n
= 0; n
< 2; n
++)
753 dest_info
->delta
[n
] = gfc_index_zero_node
;
754 dest_info
->start
[n
] = gfc_index_zero_node
;
755 dest_info
->end
[n
] = gfc_index_zero_node
;
756 dest_info
->stride
[n
] = gfc_index_one_node
;
757 dest_info
->dim
[n
] = n
;
759 dest_index
= gfc_rank_cst
[n
];
760 src_index
= gfc_rank_cst
[1 - n
];
762 gfc_add_modify_expr (&se
->pre
,
763 gfc_conv_descriptor_stride (dest
, dest_index
),
764 gfc_conv_descriptor_stride (src
, src_index
));
766 gfc_add_modify_expr (&se
->pre
,
767 gfc_conv_descriptor_lbound (dest
, dest_index
),
768 gfc_conv_descriptor_lbound (src
, src_index
));
770 gfc_add_modify_expr (&se
->pre
,
771 gfc_conv_descriptor_ubound (dest
, dest_index
),
772 gfc_conv_descriptor_ubound (src
, src_index
));
776 gcc_assert (integer_zerop (loop
->from
[n
]));
777 loop
->to
[n
] = build2 (MINUS_EXPR
, gfc_array_index_type
,
778 gfc_conv_descriptor_ubound (dest
, dest_index
),
779 gfc_conv_descriptor_lbound (dest
, dest_index
));
783 /* Copy the data pointer. */
784 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
785 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
787 /* Copy the offset. This is not changed by transposition; the top-left
788 element is still at the same offset as before, except where the loop
790 if (!integer_zerop (loop
->from
[0]))
791 dest_info
->offset
= gfc_conv_descriptor_offset (src
);
793 dest_info
->offset
= gfc_index_zero_node
;
795 gfc_add_modify_expr (&se
->pre
,
796 gfc_conv_descriptor_offset (dest
),
799 if (dest_info
->dimen
> loop
->temp_dim
)
800 loop
->temp_dim
= dest_info
->dimen
;
804 /* Return the number of iterations in a loop that starts at START,
805 ends at END, and has step STEP. */
808 gfc_get_iteration_count (tree start
, tree end
, tree step
)
813 type
= TREE_TYPE (step
);
814 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
815 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
816 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
817 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
818 return fold_convert (gfc_array_index_type
, tmp
);
822 /* Extend the data in array DESC by EXTRA elements. */
825 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
832 if (integer_zerop (extra
))
835 ubound
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
837 /* Add EXTRA to the upper bound. */
838 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
839 gfc_add_modify_expr (pblock
, ubound
, tmp
);
841 /* Get the value of the current data pointer. */
842 arg0
= gfc_conv_descriptor_data_get (desc
);
844 /* Calculate the new array size. */
845 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
846 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, gfc_index_one_node
);
847 arg1
= build2 (MULT_EXPR
, size_type_node
, fold_convert (size_type_node
, tmp
),
848 fold_convert (size_type_node
, size
));
850 /* Call the realloc() function. */
851 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
852 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
856 /* Return true if the bounds of iterator I can only be determined
860 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
862 return (i
->start
->expr_type
!= EXPR_CONSTANT
863 || i
->end
->expr_type
!= EXPR_CONSTANT
864 || i
->step
->expr_type
!= EXPR_CONSTANT
);
868 /* Split the size of constructor element EXPR into the sum of two terms,
869 one of which can be determined at compile time and one of which must
870 be calculated at run time. Set *SIZE to the former and return true
871 if the latter might be nonzero. */
874 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
876 if (expr
->expr_type
== EXPR_ARRAY
)
877 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
878 else if (expr
->rank
> 0)
880 /* Calculate everything at run time. */
881 mpz_set_ui (*size
, 0);
886 /* A single element. */
887 mpz_set_ui (*size
, 1);
893 /* Like gfc_get_array_constructor_element_size, but applied to the whole
894 of array constructor C. */
897 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor
* c
)
904 mpz_set_ui (*size
, 0);
909 for (; c
; c
= c
->next
)
912 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
916 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
919 /* Multiply the static part of the element size by the
920 number of iterations. */
921 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
922 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
923 mpz_add_ui (val
, val
, 1);
924 if (mpz_sgn (val
) > 0)
925 mpz_mul (len
, len
, val
);
929 mpz_add (*size
, *size
, len
);
938 /* Make sure offset is a variable. */
941 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
944 /* We should have already created the offset variable. We cannot
945 create it here because we may be in an inner scope. */
946 gcc_assert (*offsetvar
!= NULL_TREE
);
947 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
948 *poffset
= *offsetvar
;
949 TREE_USED (*offsetvar
) = 1;
953 /* Assign an element of an array constructor. */
956 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
957 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
961 gfc_conv_expr (se
, expr
);
963 /* Store the value. */
964 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc
));
965 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
966 if (expr
->ts
.type
== BT_CHARACTER
)
968 gfc_conv_string_parameter (se
);
969 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
971 /* The temporary is an array of pointers. */
972 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
973 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
977 /* The temporary is an array of string values. */
978 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
979 /* We know the temporary and the value will be the same length,
980 so can use memcpy. */
981 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
982 tmp
, se
->expr
, se
->string_length
);
983 gfc_add_expr_to_block (&se
->pre
, tmp
);
988 /* TODO: Should the frontend already have done this conversion? */
989 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
990 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
993 gfc_add_block_to_block (pblock
, &se
->pre
);
994 gfc_add_block_to_block (pblock
, &se
->post
);
998 /* Add the contents of an array to the constructor. DYNAMIC is as for
999 gfc_trans_array_constructor_value. */
1002 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1003 tree type ATTRIBUTE_UNUSED
,
1004 tree desc
, gfc_expr
* expr
,
1005 tree
* poffset
, tree
* offsetvar
,
1016 /* We need this to be a variable so we can increment it. */
1017 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1019 gfc_init_se (&se
, NULL
);
1021 /* Walk the array expression. */
1022 ss
= gfc_walk_expr (expr
);
1023 gcc_assert (ss
!= gfc_ss_terminator
);
1025 /* Initialize the scalarizer. */
1026 gfc_init_loopinfo (&loop
);
1027 gfc_add_ss_to_loop (&loop
, ss
);
1029 /* Initialize the loop. */
1030 gfc_conv_ss_startstride (&loop
);
1031 gfc_conv_loop_setup (&loop
);
1033 /* Make sure the constructed array has room for the new data. */
1036 /* Set SIZE to the total number of elements in the subarray. */
1037 size
= gfc_index_one_node
;
1038 for (n
= 0; n
< loop
.dimen
; n
++)
1040 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1041 gfc_index_one_node
);
1042 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1045 /* Grow the constructed array by SIZE elements. */
1046 gfc_grow_array (&loop
.pre
, desc
, size
);
1049 /* Make the loop body. */
1050 gfc_mark_ss_chain_used (ss
, 1);
1051 gfc_start_scalarized_body (&loop
, &body
);
1052 gfc_copy_loopinfo_to_se (&se
, &loop
);
1055 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1056 gcc_assert (se
.ss
== gfc_ss_terminator
);
1058 /* Increment the offset. */
1059 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
1060 gfc_add_modify_expr (&body
, *poffset
, tmp
);
1062 /* Finish the loop. */
1063 gfc_trans_scalarizing_loops (&loop
, &body
);
1064 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1065 tmp
= gfc_finish_block (&loop
.pre
);
1066 gfc_add_expr_to_block (pblock
, tmp
);
1068 gfc_cleanup_loop (&loop
);
1072 /* Assign the values to the elements of an array constructor. DYNAMIC
1073 is true if descriptor DESC only contains enough data for the static
1074 size calculated by gfc_get_array_constructor_size. When true, memory
1075 for the dynamic parts must be allocated using realloc. */
1078 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1079 tree desc
, gfc_constructor
* c
,
1080 tree
* poffset
, tree
* offsetvar
,
1089 for (; c
; c
= c
->next
)
1091 /* If this is an iterator or an array, the offset must be a variable. */
1092 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1093 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1095 gfc_start_block (&body
);
1097 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1099 /* Array constructors can be nested. */
1100 gfc_trans_array_constructor_value (&body
, type
, desc
,
1101 c
->expr
->value
.constructor
,
1102 poffset
, offsetvar
, dynamic
);
1104 else if (c
->expr
->rank
> 0)
1106 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1107 poffset
, offsetvar
, dynamic
);
1111 /* This code really upsets the gimplifier so don't bother for now. */
1118 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1125 /* Scalar values. */
1126 gfc_init_se (&se
, NULL
);
1127 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1130 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1131 *poffset
, gfc_index_one_node
);
1135 /* Collect multiple scalar constants into a constructor. */
1143 /* Count the number of consecutive scalar constants. */
1144 while (p
&& !(p
->iterator
1145 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1147 gfc_init_se (&se
, NULL
);
1148 gfc_conv_constant (&se
, p
->expr
);
1149 if (p
->expr
->ts
.type
== BT_CHARACTER
1150 && POINTER_TYPE_P (type
))
1152 /* For constant character array constructors we build
1153 an array of pointers. */
1154 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
1158 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1163 bound
= build_int_cst (NULL_TREE
, n
- 1);
1164 /* Create an array type to hold them. */
1165 tmptype
= build_range_type (gfc_array_index_type
,
1166 gfc_index_zero_node
, bound
);
1167 tmptype
= build_array_type (type
, tmptype
);
1169 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1170 TREE_CONSTANT (init
) = 1;
1171 TREE_INVARIANT (init
) = 1;
1172 TREE_STATIC (init
) = 1;
1173 /* Create a static variable to hold the data. */
1174 tmp
= gfc_create_var (tmptype
, "data");
1175 TREE_STATIC (tmp
) = 1;
1176 TREE_CONSTANT (tmp
) = 1;
1177 TREE_INVARIANT (tmp
) = 1;
1178 TREE_READONLY (tmp
) = 1;
1179 DECL_INITIAL (tmp
) = init
;
1182 /* Use BUILTIN_MEMCPY to assign the values. */
1183 tmp
= gfc_conv_descriptor_data_get (desc
);
1184 tmp
= build_fold_indirect_ref (tmp
);
1185 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1186 tmp
= build_fold_addr_expr (tmp
);
1187 init
= build_fold_addr_expr (init
);
1189 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1190 bound
= build_int_cst (NULL_TREE
, n
* size
);
1191 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
1193 gfc_add_expr_to_block (&body
, tmp
);
1195 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1197 build_int_cst (gfc_array_index_type
, n
));
1199 if (!INTEGER_CST_P (*poffset
))
1201 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
1202 *poffset
= *offsetvar
;
1206 /* The frontend should already have done any expansions possible
1210 /* Pass the code as is. */
1211 tmp
= gfc_finish_block (&body
);
1212 gfc_add_expr_to_block (pblock
, tmp
);
1216 /* Build the implied do-loop. */
1226 loopbody
= gfc_finish_block (&body
);
1228 gfc_init_se (&se
, NULL
);
1229 gfc_conv_expr (&se
, c
->iterator
->var
);
1230 gfc_add_block_to_block (pblock
, &se
.pre
);
1233 /* Make a temporary, store the current value in that
1234 and return it, once the loop is done. */
1235 tmp_loopvar
= gfc_create_var (TREE_TYPE (loopvar
), "loopvar");
1236 gfc_add_modify_expr (pblock
, tmp_loopvar
, loopvar
);
1238 /* Initialize the loop. */
1239 gfc_init_se (&se
, NULL
);
1240 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1241 gfc_add_block_to_block (pblock
, &se
.pre
);
1242 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
1244 gfc_init_se (&se
, NULL
);
1245 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1246 gfc_add_block_to_block (pblock
, &se
.pre
);
1247 end
= gfc_evaluate_now (se
.expr
, pblock
);
1249 gfc_init_se (&se
, NULL
);
1250 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1251 gfc_add_block_to_block (pblock
, &se
.pre
);
1252 step
= gfc_evaluate_now (se
.expr
, pblock
);
1254 /* If this array expands dynamically, and the number of iterations
1255 is not constant, we won't have allocated space for the static
1256 part of C->EXPR's size. Do that now. */
1257 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1259 /* Get the number of iterations. */
1260 tmp
= gfc_get_iteration_count (loopvar
, end
, step
);
1262 /* Get the static part of C->EXPR's size. */
1263 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1264 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1266 /* Grow the array by TMP * TMP2 elements. */
1267 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1268 gfc_grow_array (pblock
, desc
, tmp
);
1271 /* Generate the loop body. */
1272 exit_label
= gfc_build_label_decl (NULL_TREE
);
1273 gfc_start_block (&body
);
1275 /* Generate the exit condition. Depending on the sign of
1276 the step variable we have to generate the correct
1278 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1279 build_int_cst (TREE_TYPE (step
), 0));
1280 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1281 build2 (GT_EXPR
, boolean_type_node
,
1283 build2 (LT_EXPR
, boolean_type_node
,
1285 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1286 TREE_USED (exit_label
) = 1;
1287 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1288 gfc_add_expr_to_block (&body
, tmp
);
1290 /* The main loop body. */
1291 gfc_add_expr_to_block (&body
, loopbody
);
1293 /* Increase loop variable by step. */
1294 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
1295 gfc_add_modify_expr (&body
, loopvar
, tmp
);
1297 /* Finish the loop. */
1298 tmp
= gfc_finish_block (&body
);
1299 tmp
= build1_v (LOOP_EXPR
, tmp
);
1300 gfc_add_expr_to_block (pblock
, tmp
);
1302 /* Add the exit label. */
1303 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1304 gfc_add_expr_to_block (pblock
, tmp
);
1306 /* Restore the original value of the loop counter. */
1307 gfc_add_modify_expr (pblock
, loopvar
, tmp_loopvar
);
1314 /* Figure out the string length of a variable reference expression.
1315 Used by get_array_ctor_strlen. */
1318 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1324 /* Don't bother if we already know the length is a constant. */
1325 if (*len
&& INTEGER_CST_P (*len
))
1328 ts
= &expr
->symtree
->n
.sym
->ts
;
1329 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1334 /* Array references don't change the string length. */
1338 /* Use the length of the component. */
1339 ts
= &ref
->u
.c
.component
->ts
;
1343 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1344 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1346 mpz_init_set_ui (char_len
, 1);
1347 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1348 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1349 *len
= gfc_conv_mpz_to_tree (char_len
,
1350 gfc_default_character_kind
);
1351 *len
= convert (gfc_charlen_type_node
, *len
);
1352 mpz_clear (char_len
);
1356 /* TODO: Substrings are tricky because we can't evaluate the
1357 expression more than once. For now we just give up, and hope
1358 we can figure it out elsewhere. */
1363 *len
= ts
->cl
->backend_decl
;
1367 /* A catch-all to obtain the string length for anything that is not a
1368 constant, array or variable. */
1370 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1375 /* Don't bother if we already know the length is a constant. */
1376 if (*len
&& INTEGER_CST_P (*len
))
1379 if (!e
->ref
&& e
->ts
.cl
&& e
->ts
.cl
->length
1380 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1383 gfc_conv_const_charlen (e
->ts
.cl
);
1384 *len
= e
->ts
.cl
->backend_decl
;
1388 /* Otherwise, be brutal even if inefficient. */
1389 ss
= gfc_walk_expr (e
);
1390 gfc_init_se (&se
, NULL
);
1392 /* No function call, in case of side effects. */
1393 se
.no_function_call
= 1;
1394 if (ss
== gfc_ss_terminator
)
1395 gfc_conv_expr (&se
, e
);
1397 gfc_conv_expr_descriptor (&se
, e
, ss
);
1399 /* Fix the value. */
1400 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1402 gfc_add_block_to_block (block
, &se
.pre
);
1403 gfc_add_block_to_block (block
, &se
.post
);
1405 e
->ts
.cl
->backend_decl
= *len
;
1410 /* Figure out the string length of a character array constructor.
1411 Returns TRUE if all elements are character constants. */
1414 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor
* c
, tree
* len
)
1417 tree first_len
= NULL_TREE
;
1423 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1427 for (; c
; c
= c
->next
)
1429 switch (c
->expr
->expr_type
)
1432 if (!(*len
&& INTEGER_CST_P (*len
)))
1433 *len
= build_int_cstu (gfc_charlen_type_node
,
1434 c
->expr
->value
.character
.length
);
1438 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1444 get_array_ctor_var_strlen (c
->expr
, len
);
1449 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1452 if (flag_bounds_check
)
1458 /* Verify that all constructor elements are of the same
1460 tree cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
1462 gfc_trans_runtime_check
1463 (cond
, block
, &c
->expr
->where
,
1464 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1465 fold_convert (long_integer_type_node
, first_len
),
1466 fold_convert (long_integer_type_node
, *len
));
1474 /* Check whether the array constructor C consists entirely of constant
1475 elements, and if so returns the number of those elements, otherwise
1476 return zero. Note, an empty or NULL array constructor returns zero. */
1478 unsigned HOST_WIDE_INT
1479 gfc_constant_array_constructor_p (gfc_constructor
* c
)
1481 unsigned HOST_WIDE_INT nelem
= 0;
1486 || c
->expr
->rank
> 0
1487 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1496 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1497 and the tree type of it's elements, TYPE, return a static constant
1498 variable that is compile-time initialized. */
1501 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1503 tree tmptype
, list
, init
, tmp
;
1504 HOST_WIDE_INT nelem
;
1510 /* First traverse the constructor list, converting the constants
1511 to tree to build an initializer. */
1514 c
= expr
->value
.constructor
;
1517 gfc_init_se (&se
, NULL
);
1518 gfc_conv_constant (&se
, c
->expr
);
1519 if (c
->expr
->ts
.type
== BT_CHARACTER
1520 && POINTER_TYPE_P (type
))
1521 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
1522 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1527 /* Next determine the tree type for the array. We use the gfortran
1528 front-end's gfc_get_nodesc_array_type in order to create a suitable
1529 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1531 memset (&as
, 0, sizeof (gfc_array_spec
));
1533 as
.rank
= expr
->rank
;
1534 as
.type
= AS_EXPLICIT
;
1537 as
.lower
[0] = gfc_int_expr (0);
1538 as
.upper
[0] = gfc_int_expr (nelem
- 1);
1541 for (i
= 0; i
< expr
->rank
; i
++)
1543 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1544 as
.lower
[i
] = gfc_int_expr (0);
1545 as
.upper
[i
] = gfc_int_expr (tmp
- 1);
1548 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
);
1550 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1552 TREE_CONSTANT (init
) = 1;
1553 TREE_INVARIANT (init
) = 1;
1554 TREE_STATIC (init
) = 1;
1556 tmp
= gfc_create_var (tmptype
, "A");
1557 TREE_STATIC (tmp
) = 1;
1558 TREE_CONSTANT (tmp
) = 1;
1559 TREE_INVARIANT (tmp
) = 1;
1560 TREE_READONLY (tmp
) = 1;
1561 DECL_INITIAL (tmp
) = init
;
1567 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1568 This mostly initializes the scalarizer state info structure with the
1569 appropriate values to directly use the array created by the function
1570 gfc_build_constant_array_constructor. */
1573 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1574 gfc_ss
* ss
, tree type
)
1580 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1582 info
= &ss
->data
.info
;
1584 info
->descriptor
= tmp
;
1585 info
->data
= build_fold_addr_expr (tmp
);
1586 info
->offset
= fold_build1 (NEGATE_EXPR
, gfc_array_index_type
,
1589 for (i
= 0; i
< info
->dimen
; i
++)
1591 info
->delta
[i
] = gfc_index_zero_node
;
1592 info
->start
[i
] = gfc_index_zero_node
;
1593 info
->end
[i
] = gfc_index_zero_node
;
1594 info
->stride
[i
] = gfc_index_one_node
;
1598 if (info
->dimen
> loop
->temp_dim
)
1599 loop
->temp_dim
= info
->dimen
;
1602 /* Helper routine of gfc_trans_array_constructor to determine if the
1603 bounds of the loop specified by LOOP are constant and simple enough
1604 to use with gfc_trans_constant_array_constructor. Returns the
1605 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1608 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1610 tree size
= gfc_index_one_node
;
1614 for (i
= 0; i
< loop
->dimen
; i
++)
1616 /* If the bounds aren't constant, return NULL_TREE. */
1617 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1619 if (!integer_zerop (loop
->from
[i
]))
1621 /* Only allow nonzero "from" in one-dimensional arrays. */
1622 if (loop
->dimen
!= 1)
1624 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1625 loop
->to
[i
], loop
->from
[i
]);
1629 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1630 tmp
, gfc_index_one_node
);
1631 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1638 /* Array constructors are handled by constructing a temporary, then using that
1639 within the scalarization loop. This is not optimal, but seems by far the
1643 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1652 ss
->data
.info
.dimen
= loop
->dimen
;
1654 c
= ss
->expr
->value
.constructor
;
1655 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1657 bool const_string
= get_array_ctor_strlen (&loop
->pre
, c
, &ss
->string_length
);
1659 /* Complex character array constructors should have been taken care of
1660 and not end up here. */
1661 gcc_assert (ss
->string_length
);
1663 ss
->expr
->ts
.cl
->backend_decl
= ss
->string_length
;
1665 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1667 type
= build_pointer_type (type
);
1670 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1672 /* See if the constructor determines the loop bounds. */
1675 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1677 /* We have a multidimensional parameter. */
1679 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1681 loop
->from
[n
] = gfc_index_zero_node
;
1682 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1683 gfc_index_integer_kind
);
1684 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1685 loop
->to
[n
], gfc_index_one_node
);
1689 if (loop
->to
[0] == NULL_TREE
)
1693 /* We should have a 1-dimensional, zero-based loop. */
1694 gcc_assert (loop
->dimen
== 1);
1695 gcc_assert (integer_zerop (loop
->from
[0]));
1697 /* Split the constructor size into a static part and a dynamic part.
1698 Allocate the static size up-front and record whether the dynamic
1699 size might be nonzero. */
1701 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1702 mpz_sub_ui (size
, size
, 1);
1703 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1707 /* Special case constant array constructors. */
1710 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1713 tree size
= constant_array_constructor_loop_size (loop
);
1714 if (size
&& compare_tree_int (size
, nelem
) == 0)
1716 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1722 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1723 type
, dynamic
, true, false);
1725 desc
= ss
->data
.info
.descriptor
;
1726 offset
= gfc_index_zero_node
;
1727 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1728 TREE_NO_WARNING (offsetvar
) = 1;
1729 TREE_USED (offsetvar
) = 0;
1730 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1731 &offset
, &offsetvar
, dynamic
);
1733 /* If the array grows dynamically, the upper bound of the loop variable
1734 is determined by the array's final upper bound. */
1736 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1738 if (TREE_USED (offsetvar
))
1739 pushdecl (offsetvar
);
1741 gcc_assert (INTEGER_CST_P (offset
));
1743 /* Disable bound checking for now because it's probably broken. */
1744 if (flag_bounds_check
)
1752 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1753 called after evaluating all of INFO's vector dimensions. Go through
1754 each such vector dimension and see if we can now fill in any missing
1758 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1767 for (n
= 0; n
< loop
->dimen
; n
++)
1770 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1771 && loop
->to
[n
] == NULL
)
1773 /* Loop variable N indexes vector dimension DIM, and we don't
1774 yet know the upper bound of loop variable N. Set it to the
1775 difference between the vector's upper and lower bounds. */
1776 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1777 gcc_assert (info
->subscript
[dim
]
1778 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1780 gfc_init_se (&se
, NULL
);
1781 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1782 zero
= gfc_rank_cst
[0];
1783 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1784 gfc_conv_descriptor_ubound (desc
, zero
),
1785 gfc_conv_descriptor_lbound (desc
, zero
));
1786 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1793 /* Add the pre and post chains for all the scalar expressions in a SS chain
1794 to loop. This is called after the loop parameters have been calculated,
1795 but before the actual scalarizing loops. */
1798 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1803 /* TODO: This can generate bad code if there are ordering dependencies.
1804 eg. a callee allocated function and an unknown size constructor. */
1805 gcc_assert (ss
!= NULL
);
1807 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1814 /* Scalar expression. Evaluate this now. This includes elemental
1815 dimension indices, but not array section bounds. */
1816 gfc_init_se (&se
, NULL
);
1817 gfc_conv_expr (&se
, ss
->expr
);
1818 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1820 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1822 /* Move the evaluation of scalar expressions outside the
1823 scalarization loop. */
1825 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1826 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1827 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1830 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1832 ss
->data
.scalar
.expr
= se
.expr
;
1833 ss
->string_length
= se
.string_length
;
1836 case GFC_SS_REFERENCE
:
1837 /* Scalar reference. Evaluate this now. */
1838 gfc_init_se (&se
, NULL
);
1839 gfc_conv_expr_reference (&se
, ss
->expr
);
1840 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1841 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1843 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1844 ss
->string_length
= se
.string_length
;
1847 case GFC_SS_SECTION
:
1848 /* Add the expressions for scalar and vector subscripts. */
1849 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1850 if (ss
->data
.info
.subscript
[n
])
1851 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1853 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1857 /* Get the vector's descriptor and store it in SS. */
1858 gfc_init_se (&se
, NULL
);
1859 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1860 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1861 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1862 ss
->data
.info
.descriptor
= se
.expr
;
1865 case GFC_SS_INTRINSIC
:
1866 gfc_add_intrinsic_ss_code (loop
, ss
);
1869 case GFC_SS_FUNCTION
:
1870 /* Array function return value. We call the function and save its
1871 result in a temporary for use inside the loop. */
1872 gfc_init_se (&se
, NULL
);
1875 gfc_conv_expr (&se
, ss
->expr
);
1876 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1877 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1878 ss
->string_length
= se
.string_length
;
1881 case GFC_SS_CONSTRUCTOR
:
1882 gfc_trans_array_constructor (loop
, ss
);
1886 case GFC_SS_COMPONENT
:
1887 /* Do nothing. These are handled elsewhere. */
1897 /* Translate expressions for the descriptor and data pointer of a SS. */
1901 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1906 /* Get the descriptor for the array to be scalarized. */
1907 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1908 gfc_init_se (&se
, NULL
);
1909 se
.descriptor_only
= 1;
1910 gfc_conv_expr_lhs (&se
, ss
->expr
);
1911 gfc_add_block_to_block (block
, &se
.pre
);
1912 ss
->data
.info
.descriptor
= se
.expr
;
1913 ss
->string_length
= se
.string_length
;
1917 /* Also the data pointer. */
1918 tmp
= gfc_conv_array_data (se
.expr
);
1919 /* If this is a variable or address of a variable we use it directly.
1920 Otherwise we must evaluate it now to avoid breaking dependency
1921 analysis by pulling the expressions for elemental array indices
1924 || (TREE_CODE (tmp
) == ADDR_EXPR
1925 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1926 tmp
= gfc_evaluate_now (tmp
, block
);
1927 ss
->data
.info
.data
= tmp
;
1929 tmp
= gfc_conv_array_offset (se
.expr
);
1930 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1935 /* Initialize a gfc_loopinfo structure. */
1938 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1942 memset (loop
, 0, sizeof (gfc_loopinfo
));
1943 gfc_init_block (&loop
->pre
);
1944 gfc_init_block (&loop
->post
);
1946 /* Initially scalarize in order. */
1947 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1950 loop
->ss
= gfc_ss_terminator
;
1954 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1958 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1964 /* Return an expression for the data pointer of an array. */
1967 gfc_conv_array_data (tree descriptor
)
1971 type
= TREE_TYPE (descriptor
);
1972 if (GFC_ARRAY_TYPE_P (type
))
1974 if (TREE_CODE (type
) == POINTER_TYPE
)
1978 /* Descriptorless arrays. */
1979 return build_fold_addr_expr (descriptor
);
1983 return gfc_conv_descriptor_data_get (descriptor
);
1987 /* Return an expression for the base offset of an array. */
1990 gfc_conv_array_offset (tree descriptor
)
1994 type
= TREE_TYPE (descriptor
);
1995 if (GFC_ARRAY_TYPE_P (type
))
1996 return GFC_TYPE_ARRAY_OFFSET (type
);
1998 return gfc_conv_descriptor_offset (descriptor
);
2002 /* Get an expression for the array stride. */
2005 gfc_conv_array_stride (tree descriptor
, int dim
)
2010 type
= TREE_TYPE (descriptor
);
2012 /* For descriptorless arrays use the array size. */
2013 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2014 if (tmp
!= NULL_TREE
)
2017 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
2022 /* Like gfc_conv_array_stride, but for the lower bound. */
2025 gfc_conv_array_lbound (tree descriptor
, int dim
)
2030 type
= TREE_TYPE (descriptor
);
2032 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2033 if (tmp
!= NULL_TREE
)
2036 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
2041 /* Like gfc_conv_array_stride, but for the upper bound. */
2044 gfc_conv_array_ubound (tree descriptor
, int dim
)
2049 type
= TREE_TYPE (descriptor
);
2051 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2052 if (tmp
!= NULL_TREE
)
2055 /* This should only ever happen when passing an assumed shape array
2056 as an actual parameter. The value will never be used. */
2057 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2058 return gfc_index_zero_node
;
2060 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
2065 /* Generate code to perform an array index bound check. */
2068 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2069 locus
* where
, bool check_upper
)
2074 const char * name
= NULL
;
2076 if (!flag_bounds_check
)
2079 index
= gfc_evaluate_now (index
, &se
->pre
);
2081 /* We find a name for the error message. */
2083 name
= se
->ss
->expr
->symtree
->name
;
2085 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2086 && se
->loop
->ss
->expr
->symtree
)
2087 name
= se
->loop
->ss
->expr
->symtree
->name
;
2089 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2090 && se
->loop
->ss
->loop_chain
->expr
2091 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2092 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2094 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2095 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2096 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2098 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2100 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2101 && se
->loop
->ss
->expr
->value
.function
.name
)
2102 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2104 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2105 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2106 name
= "unnamed constant";
2109 /* Check lower bound. */
2110 tmp
= gfc_conv_array_lbound (descriptor
, n
);
2111 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
2113 asprintf (&msg
, "%s for array '%s', lower bound of dimension %d exceeded"
2114 "(%%ld < %%ld)", gfc_msg_fault
, name
, n
+1);
2116 asprintf (&msg
, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2117 gfc_msg_fault
, n
+1);
2118 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
2119 fold_convert (long_integer_type_node
, index
),
2120 fold_convert (long_integer_type_node
, tmp
));
2123 /* Check upper bound. */
2126 tmp
= gfc_conv_array_ubound (descriptor
, n
);
2127 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
2129 asprintf (&msg
, "%s for array '%s', upper bound of dimension %d "
2130 " exceeded (%%ld > %%ld)", gfc_msg_fault
, name
, n
+1);
2132 asprintf (&msg
, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2133 gfc_msg_fault
, n
+1);
2134 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
2135 fold_convert (long_integer_type_node
, index
),
2136 fold_convert (long_integer_type_node
, tmp
));
2144 /* Return the offset for an index. Performs bound checking for elemental
2145 dimensions. Single element references are processed separately. */
2148 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2149 gfc_array_ref
* ar
, tree stride
)
2155 /* Get the index into the array for this dimension. */
2158 gcc_assert (ar
->type
!= AR_ELEMENT
);
2159 switch (ar
->dimen_type
[dim
])
2162 gcc_assert (i
== -1);
2163 /* Elemental dimension. */
2164 gcc_assert (info
->subscript
[dim
]
2165 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2166 /* We've already translated this value outside the loop. */
2167 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2169 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2170 index
, dim
, &ar
->where
,
2171 (ar
->as
->type
!= AS_ASSUMED_SIZE
2172 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2176 gcc_assert (info
&& se
->loop
);
2177 gcc_assert (info
->subscript
[dim
]
2178 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2179 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2181 /* Get a zero-based index into the vector. */
2182 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2183 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2185 /* Multiply the index by the stride. */
2186 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2187 index
, gfc_conv_array_stride (desc
, 0));
2189 /* Read the vector to get an index into info->descriptor. */
2190 data
= build_fold_indirect_ref (gfc_conv_array_data (desc
));
2191 index
= gfc_build_array_ref (data
, index
, NULL
);
2192 index
= gfc_evaluate_now (index
, &se
->pre
);
2194 /* Do any bounds checking on the final info->descriptor index. */
2195 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2196 index
, dim
, &ar
->where
,
2197 (ar
->as
->type
!= AS_ASSUMED_SIZE
2198 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2202 /* Scalarized dimension. */
2203 gcc_assert (info
&& se
->loop
);
2205 /* Multiply the loop variable by the stride and delta. */
2206 index
= se
->loop
->loopvar
[i
];
2207 if (!integer_onep (info
->stride
[i
]))
2208 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2210 if (!integer_zerop (info
->delta
[i
]))
2211 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2221 /* Temporary array or derived type component. */
2222 gcc_assert (se
->loop
);
2223 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2224 if (!integer_zerop (info
->delta
[i
]))
2225 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2226 index
, info
->delta
[i
]);
2229 /* Multiply by the stride. */
2230 if (!integer_onep (stride
))
2231 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2237 /* Build a scalarized reference to an array. */
2240 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2243 tree decl
= NULL_TREE
;
2248 info
= &se
->ss
->data
.info
;
2250 n
= se
->loop
->order
[0];
2254 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2256 /* Add the offset for this dimension to the stored offset for all other
2258 if (!integer_zerop (info
->offset
))
2259 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2261 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2262 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2264 tmp
= build_fold_indirect_ref (info
->data
);
2265 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2269 /* Translate access of temporary array. */
2272 gfc_conv_tmp_array_ref (gfc_se
* se
)
2274 se
->string_length
= se
->ss
->string_length
;
2275 gfc_conv_scalarized_array_ref (se
, NULL
);
2279 /* Build an array reference. se->expr already holds the array descriptor.
2280 This should be either a variable, indirect variable reference or component
2281 reference. For arrays which do not have a descriptor, se->expr will be
2283 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2286 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2295 /* Handle scalarized references separately. */
2296 if (ar
->type
!= AR_ELEMENT
)
2298 gfc_conv_scalarized_array_ref (se
, ar
);
2299 gfc_advance_se_ss_chain (se
);
2303 index
= gfc_index_zero_node
;
2305 /* Calculate the offsets from all the dimensions. */
2306 for (n
= 0; n
< ar
->dimen
; n
++)
2308 /* Calculate the index for this dimension. */
2309 gfc_init_se (&indexse
, se
);
2310 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2311 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2313 if (flag_bounds_check
)
2315 /* Check array bounds. */
2319 /* Evaluate the indexse.expr only once. */
2320 indexse
.expr
= save_expr (indexse
.expr
);
2323 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2324 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2326 asprintf (&msg
, "%s for array '%s', "
2327 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2328 gfc_msg_fault
, sym
->name
, n
+1);
2329 gfc_trans_runtime_check (cond
, &se
->pre
, where
, msg
,
2330 fold_convert (long_integer_type_node
,
2332 fold_convert (long_integer_type_node
, tmp
));
2335 /* Upper bound, but not for the last dimension of assumed-size
2337 if (n
< ar
->dimen
- 1
2338 || (ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
))
2340 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2341 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2343 asprintf (&msg
, "%s for array '%s', "
2344 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2345 gfc_msg_fault
, sym
->name
, n
+1);
2346 gfc_trans_runtime_check (cond
, &se
->pre
, where
, msg
,
2347 fold_convert (long_integer_type_node
,
2349 fold_convert (long_integer_type_node
, tmp
));
2354 /* Multiply the index by the stride. */
2355 stride
= gfc_conv_array_stride (se
->expr
, n
);
2356 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2359 /* And add it to the total. */
2360 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2363 tmp
= gfc_conv_array_offset (se
->expr
);
2364 if (!integer_zerop (tmp
))
2365 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2367 /* Access the calculated element. */
2368 tmp
= gfc_conv_array_data (se
->expr
);
2369 tmp
= build_fold_indirect_ref (tmp
);
2370 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2374 /* Generate the code to be executed immediately before entering a
2375 scalarization loop. */
2378 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2379 stmtblock_t
* pblock
)
2388 /* This code will be executed before entering the scalarization loop
2389 for this dimension. */
2390 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2392 if ((ss
->useflags
& flag
) == 0)
2395 if (ss
->type
!= GFC_SS_SECTION
2396 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2397 && ss
->type
!= GFC_SS_COMPONENT
)
2400 info
= &ss
->data
.info
;
2402 if (dim
>= info
->dimen
)
2405 if (dim
== info
->dimen
- 1)
2407 /* For the outermost loop calculate the offset due to any
2408 elemental dimensions. It will have been initialized with the
2409 base offset of the array. */
2412 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2414 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2417 gfc_init_se (&se
, NULL
);
2419 se
.expr
= info
->descriptor
;
2420 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2421 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2424 gfc_add_block_to_block (pblock
, &se
.pre
);
2426 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2427 info
->offset
, index
);
2428 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2432 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2435 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2437 /* Calculate the stride of the innermost loop. Hopefully this will
2438 allow the backend optimizers to do their stuff more effectively.
2440 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2444 /* Add the offset for the previous loop dimension. */
2449 ar
= &info
->ref
->u
.ar
;
2450 i
= loop
->order
[dim
+ 1];
2458 gfc_init_se (&se
, NULL
);
2460 se
.expr
= info
->descriptor
;
2461 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2462 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2464 gfc_add_block_to_block (pblock
, &se
.pre
);
2465 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2466 info
->offset
, index
);
2467 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2470 /* Remember this offset for the second loop. */
2471 if (dim
== loop
->temp_dim
- 1)
2472 info
->saved_offset
= info
->offset
;
2477 /* Start a scalarized expression. Creates a scope and declares loop
2481 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2487 gcc_assert (!loop
->array_parameter
);
2489 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2491 n
= loop
->order
[dim
];
2493 gfc_start_block (&loop
->code
[n
]);
2495 /* Create the loop variable. */
2496 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2498 if (dim
< loop
->temp_dim
)
2502 /* Calculate values that will be constant within this loop. */
2503 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2505 gfc_start_block (pbody
);
2509 /* Generates the actual loop code for a scalarization loop. */
2512 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2513 stmtblock_t
* pbody
)
2521 loopbody
= gfc_finish_block (pbody
);
2523 /* Initialize the loopvar. */
2524 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2526 exit_label
= gfc_build_label_decl (NULL_TREE
);
2528 /* Generate the loop body. */
2529 gfc_init_block (&block
);
2531 /* The exit condition. */
2532 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2533 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2534 TREE_USED (exit_label
) = 1;
2535 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2536 gfc_add_expr_to_block (&block
, tmp
);
2538 /* The main body. */
2539 gfc_add_expr_to_block (&block
, loopbody
);
2541 /* Increment the loopvar. */
2542 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2543 loop
->loopvar
[n
], gfc_index_one_node
);
2544 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2546 /* Build the loop. */
2547 tmp
= gfc_finish_block (&block
);
2548 tmp
= build1_v (LOOP_EXPR
, tmp
);
2549 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2551 /* Add the exit label. */
2552 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2553 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2557 /* Finishes and generates the loops for a scalarized expression. */
2560 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2565 stmtblock_t
*pblock
;
2569 /* Generate the loops. */
2570 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2572 n
= loop
->order
[dim
];
2573 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2574 loop
->loopvar
[n
] = NULL_TREE
;
2575 pblock
= &loop
->code
[n
];
2578 tmp
= gfc_finish_block (pblock
);
2579 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2581 /* Clear all the used flags. */
2582 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2587 /* Finish the main body of a scalarized expression, and start the secondary
2591 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2595 stmtblock_t
*pblock
;
2599 /* We finish as many loops as are used by the temporary. */
2600 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2602 n
= loop
->order
[dim
];
2603 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2604 loop
->loopvar
[n
] = NULL_TREE
;
2605 pblock
= &loop
->code
[n
];
2608 /* We don't want to finish the outermost loop entirely. */
2609 n
= loop
->order
[loop
->temp_dim
- 1];
2610 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2612 /* Restore the initial offsets. */
2613 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2615 if ((ss
->useflags
& 2) == 0)
2618 if (ss
->type
!= GFC_SS_SECTION
2619 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2620 && ss
->type
!= GFC_SS_COMPONENT
)
2623 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2626 /* Restart all the inner loops we just finished. */
2627 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2629 n
= loop
->order
[dim
];
2631 gfc_start_block (&loop
->code
[n
]);
2633 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2635 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2638 /* Start a block for the secondary copying code. */
2639 gfc_start_block (body
);
2643 /* Calculate the upper bound of an array section. */
2646 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2655 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2657 info
= &ss
->data
.info
;
2660 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2661 /* We'll calculate the upper bound once we have access to the
2662 vector's descriptor. */
2665 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2666 desc
= info
->descriptor
;
2667 end
= info
->ref
->u
.ar
.end
[dim
];
2671 /* The upper bound was specified. */
2672 gfc_init_se (&se
, NULL
);
2673 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2674 gfc_add_block_to_block (pblock
, &se
.pre
);
2679 /* No upper bound was specified, so use the bound of the array. */
2680 bound
= gfc_conv_array_ubound (desc
, dim
);
2687 /* Calculate the lower bound of an array section. */
2690 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2700 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2702 info
= &ss
->data
.info
;
2705 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2707 /* We use a zero-based index to access the vector. */
2708 info
->start
[n
] = gfc_index_zero_node
;
2709 info
->end
[n
] = gfc_index_zero_node
;
2710 info
->stride
[n
] = gfc_index_one_node
;
2714 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2715 desc
= info
->descriptor
;
2716 start
= info
->ref
->u
.ar
.start
[dim
];
2717 end
= info
->ref
->u
.ar
.end
[dim
];
2718 stride
= info
->ref
->u
.ar
.stride
[dim
];
2720 /* Calculate the start of the range. For vector subscripts this will
2721 be the range of the vector. */
2724 /* Specified section start. */
2725 gfc_init_se (&se
, NULL
);
2726 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2727 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2728 info
->start
[n
] = se
.expr
;
2732 /* No lower bound specified so use the bound of the array. */
2733 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2735 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2737 /* Similarly calculate the end. Although this is not used in the
2738 scalarizer, it is needed when checking bounds and where the end
2739 is an expression with side-effects. */
2742 /* Specified section start. */
2743 gfc_init_se (&se
, NULL
);
2744 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2745 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2746 info
->end
[n
] = se
.expr
;
2750 /* No upper bound specified so use the bound of the array. */
2751 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
2753 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
2755 /* Calculate the stride. */
2757 info
->stride
[n
] = gfc_index_one_node
;
2760 gfc_init_se (&se
, NULL
);
2761 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2762 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2763 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2768 /* Calculates the range start and stride for a SS chain. Also gets the
2769 descriptor and data pointer. The range of vector subscripts is the size
2770 of the vector. Array bounds are also checked. */
2773 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2781 /* Determine the rank of the loop. */
2783 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2787 case GFC_SS_SECTION
:
2788 case GFC_SS_CONSTRUCTOR
:
2789 case GFC_SS_FUNCTION
:
2790 case GFC_SS_COMPONENT
:
2791 loop
->dimen
= ss
->data
.info
.dimen
;
2794 /* As usual, lbound and ubound are exceptions!. */
2795 case GFC_SS_INTRINSIC
:
2796 switch (ss
->expr
->value
.function
.isym
->id
)
2798 case GFC_ISYM_LBOUND
:
2799 case GFC_ISYM_UBOUND
:
2800 loop
->dimen
= ss
->data
.info
.dimen
;
2811 /* We should have determined the rank of the expression by now. If
2812 not, that's bad news. */
2813 gcc_assert (loop
->dimen
!= 0);
2815 /* Loop over all the SS in the chain. */
2816 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2818 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2819 ss
->shape
= ss
->expr
->shape
;
2823 case GFC_SS_SECTION
:
2824 /* Get the descriptor for the array. */
2825 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2827 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2828 gfc_conv_section_startstride (loop
, ss
, n
);
2831 case GFC_SS_INTRINSIC
:
2832 switch (ss
->expr
->value
.function
.isym
->id
)
2834 /* Fall through to supply start and stride. */
2835 case GFC_ISYM_LBOUND
:
2836 case GFC_ISYM_UBOUND
:
2842 case GFC_SS_CONSTRUCTOR
:
2843 case GFC_SS_FUNCTION
:
2844 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2846 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2847 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
2848 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2857 /* The rest is just runtime bound checking. */
2858 if (flag_bounds_check
)
2861 tree lbound
, ubound
;
2863 tree size
[GFC_MAX_DIMENSIONS
];
2864 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
;
2869 gfc_start_block (&block
);
2871 for (n
= 0; n
< loop
->dimen
; n
++)
2872 size
[n
] = NULL_TREE
;
2874 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2876 if (ss
->type
!= GFC_SS_SECTION
)
2879 /* TODO: range checking for mapped dimensions. */
2880 info
= &ss
->data
.info
;
2882 /* This code only checks ranges. Elemental and vector
2883 dimensions are checked later. */
2884 for (n
= 0; n
< loop
->dimen
; n
++)
2889 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
2892 if (dim
== info
->ref
->u
.ar
.dimen
- 1
2893 && (info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
2894 || info
->ref
->u
.ar
.as
->cp_was_assumed
))
2895 check_upper
= false;
2899 /* Zero stride is not allowed. */
2900 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
2901 gfc_index_zero_node
);
2902 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
2903 "of array '%s'", info
->dim
[n
]+1,
2904 ss
->expr
->symtree
->name
);
2905 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
);
2908 desc
= ss
->data
.info
.descriptor
;
2910 /* This is the run-time equivalent of resolve.c's
2911 check_dimension(). The logical is more readable there
2912 than it is here, with all the trees. */
2913 lbound
= gfc_conv_array_lbound (desc
, dim
);
2916 ubound
= gfc_conv_array_ubound (desc
, dim
);
2920 /* non_zerosized is true when the selected range is not
2922 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
2923 info
->stride
[n
], gfc_index_zero_node
);
2924 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
2926 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2929 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
2930 info
->stride
[n
], gfc_index_zero_node
);
2931 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
2933 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2935 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2936 stride_pos
, stride_neg
);
2938 /* Check the start of the range against the lower and upper
2939 bounds of the array, if the range is not empty. */
2940 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, info
->start
[n
],
2942 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2943 non_zerosized
, tmp
);
2944 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2945 " exceeded (%%ld < %%ld)", gfc_msg_fault
,
2946 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
2947 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
,
2948 fold_convert (long_integer_type_node
,
2950 fold_convert (long_integer_type_node
,
2956 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
,
2957 info
->start
[n
], ubound
);
2958 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2959 non_zerosized
, tmp
);
2960 asprintf (&msg
, "%s, upper bound of dimension %d of array "
2961 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault
,
2962 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
2963 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
,
2964 fold_convert (long_integer_type_node
, info
->start
[n
]),
2965 fold_convert (long_integer_type_node
, ubound
));
2969 /* Compute the last element of the range, which is not
2970 necessarily "end" (think 0:5:3, which doesn't contain 5)
2971 and check it against both lower and upper bounds. */
2972 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2974 tmp2
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp2
,
2976 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2979 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp2
, lbound
);
2980 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2981 non_zerosized
, tmp
);
2982 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2983 " exceeded (%%ld < %%ld)", gfc_msg_fault
,
2984 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
2985 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
,
2986 fold_convert (long_integer_type_node
,
2988 fold_convert (long_integer_type_node
,
2994 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp2
, ubound
);
2995 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2996 non_zerosized
, tmp
);
2997 asprintf (&msg
, "%s, upper bound of dimension %d of array "
2998 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault
,
2999 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3000 gfc_trans_runtime_check (tmp
, &block
, &ss
->expr
->where
, msg
,
3001 fold_convert (long_integer_type_node
, tmp2
),
3002 fold_convert (long_integer_type_node
, ubound
));
3006 /* Check the section sizes match. */
3007 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3009 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
3011 /* We remember the size of the first section, and check all the
3012 others against this. */
3017 tmp3
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
3019 /* For optional arguments, only check bounds if the
3020 argument is present. */
3021 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3022 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3026 cond
= gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
);
3027 tmp3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3031 asprintf (&msg
, "%s, size mismatch for dimension %d "
3032 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds
,
3033 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3034 gfc_trans_runtime_check (tmp3
, &block
, &ss
->expr
->where
, msg
,
3035 fold_convert (long_integer_type_node
, tmp
),
3036 fold_convert (long_integer_type_node
, size
[n
]));
3040 size
[n
] = gfc_evaluate_now (tmp
, &block
);
3044 tmp
= gfc_finish_block (&block
);
3045 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3050 /* Return true if the two SS could be aliased, i.e. both point to the same data
3052 /* TODO: resolve aliases based on frontend expressions. */
3055 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3062 lsym
= lss
->expr
->symtree
->n
.sym
;
3063 rsym
= rss
->expr
->symtree
->n
.sym
;
3064 if (gfc_symbols_could_alias (lsym
, rsym
))
3067 if (rsym
->ts
.type
!= BT_DERIVED
3068 && lsym
->ts
.type
!= BT_DERIVED
)
3071 /* For derived types we must check all the component types. We can ignore
3072 array references as these will have the same base type as the previous
3074 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3076 if (lref
->type
!= REF_COMPONENT
)
3079 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3082 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3085 if (rref
->type
!= REF_COMPONENT
)
3088 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3093 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3095 if (rref
->type
!= REF_COMPONENT
)
3098 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3106 /* Resolve array data dependencies. Creates a temporary if required. */
3107 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3111 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3121 loop
->temp_ss
= NULL
;
3122 aref
= dest
->data
.info
.ref
;
3125 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3127 if (ss
->type
!= GFC_SS_SECTION
)
3130 if (gfc_could_be_alias (dest
, ss
)
3131 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3137 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
3139 lref
= dest
->expr
->ref
;
3140 rref
= ss
->expr
->ref
;
3142 nDepend
= gfc_dep_resolver (lref
, rref
);
3146 /* TODO : loop shifting. */
3149 /* Mark the dimensions for LOOP SHIFTING */
3150 for (n
= 0; n
< loop
->dimen
; n
++)
3152 int dim
= dest
->data
.info
.dim
[n
];
3154 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3156 else if (! gfc_is_same_range (&lref
->u
.ar
,
3157 &rref
->u
.ar
, dim
, 0))
3161 /* Put all the dimensions with dependencies in the
3164 for (n
= 0; n
< loop
->dimen
; n
++)
3166 gcc_assert (loop
->order
[n
] == n
);
3168 loop
->order
[dim
++] = n
;
3171 for (n
= 0; n
< loop
->dimen
; n
++)
3174 loop
->order
[dim
++] = n
;
3177 gcc_assert (dim
== loop
->dimen
);
3186 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3187 if (GFC_ARRAY_TYPE_P (base_type
)
3188 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3189 base_type
= gfc_get_element_type (base_type
);
3190 loop
->temp_ss
= gfc_get_ss ();
3191 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3192 loop
->temp_ss
->data
.temp
.type
= base_type
;
3193 loop
->temp_ss
->string_length
= dest
->string_length
;
3194 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3195 loop
->temp_ss
->next
= gfc_ss_terminator
;
3196 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3199 loop
->temp_ss
= NULL
;
3203 /* Initialize the scalarization loop. Creates the loop variables. Determines
3204 the range of the loop variables. Creates a temporary if required.
3205 Calculates how to transform from loop variables to array indices for each
3206 expression. Also generates code for scalar expressions which have been
3207 moved outside the loop. */
3210 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
3215 gfc_ss_info
*specinfo
;
3219 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3220 bool dynamic
[GFC_MAX_DIMENSIONS
];
3226 for (n
= 0; n
< loop
->dimen
; n
++)
3230 /* We use one SS term, and use that to determine the bounds of the
3231 loop for this dimension. We try to pick the simplest term. */
3232 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3236 /* The frontend has worked out the size for us. */
3241 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3243 /* An unknown size constructor will always be rank one.
3244 Higher rank constructors will either have known shape,
3245 or still be wrapped in a call to reshape. */
3246 gcc_assert (loop
->dimen
== 1);
3248 /* Always prefer to use the constructor bounds if the size
3249 can be determined at compile time. Prefer not to otherwise,
3250 since the general case involves realloc, and it's better to
3251 avoid that overhead if possible. */
3252 c
= ss
->expr
->value
.constructor
;
3253 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
3254 if (!dynamic
[n
] || !loopspec
[n
])
3259 /* TODO: Pick the best bound if we have a choice between a
3260 function and something else. */
3261 if (ss
->type
== GFC_SS_FUNCTION
)
3267 if (ss
->type
!= GFC_SS_SECTION
)
3271 specinfo
= &loopspec
[n
]->data
.info
;
3274 info
= &ss
->data
.info
;
3278 /* Criteria for choosing a loop specifier (most important first):
3279 doesn't need realloc
3285 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3287 else if (integer_onep (info
->stride
[n
])
3288 && !integer_onep (specinfo
->stride
[n
]))
3290 else if (INTEGER_CST_P (info
->stride
[n
])
3291 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3293 else if (INTEGER_CST_P (info
->start
[n
])
3294 && !INTEGER_CST_P (specinfo
->start
[n
]))
3296 /* We don't work out the upper bound.
3297 else if (INTEGER_CST_P (info->finish[n])
3298 && ! INTEGER_CST_P (specinfo->finish[n]))
3299 loopspec[n] = ss; */
3302 /* We should have found the scalarization loop specifier. If not,
3304 gcc_assert (loopspec
[n
]);
3306 info
= &loopspec
[n
]->data
.info
;
3308 /* Set the extents of this range. */
3309 cshape
= loopspec
[n
]->shape
;
3310 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3311 && INTEGER_CST_P (info
->stride
[n
]))
3313 loop
->from
[n
] = info
->start
[n
];
3314 mpz_set (i
, cshape
[n
]);
3315 mpz_sub_ui (i
, i
, 1);
3316 /* To = from + (size - 1) * stride. */
3317 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3318 if (!integer_onep (info
->stride
[n
]))
3319 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3320 tmp
, info
->stride
[n
]);
3321 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3322 loop
->from
[n
], tmp
);
3326 loop
->from
[n
] = info
->start
[n
];
3327 switch (loopspec
[n
]->type
)
3329 case GFC_SS_CONSTRUCTOR
:
3330 /* The upper bound is calculated when we expand the
3332 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3335 case GFC_SS_SECTION
:
3336 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3340 case GFC_SS_FUNCTION
:
3341 /* The loop bound will be set when we generate the call. */
3342 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3350 /* Transform everything so we have a simple incrementing variable. */
3351 if (integer_onep (info
->stride
[n
]))
3352 info
->delta
[n
] = gfc_index_zero_node
;
3355 /* Set the delta for this section. */
3356 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3357 /* Number of iterations is (end - start + step) / step.
3358 with start = 0, this simplifies to
3360 for (i = 0; i<=last; i++){...}; */
3361 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3362 loop
->to
[n
], loop
->from
[n
]);
3363 tmp
= fold_build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
3364 tmp
, info
->stride
[n
]);
3365 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3366 /* Make the loop variable start at 0. */
3367 loop
->from
[n
] = gfc_index_zero_node
;
3371 /* Add all the scalar code that can be taken out of the loops.
3372 This may include calculating the loop bounds, so do it before
3373 allocating the temporary. */
3374 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
3376 /* If we want a temporary then create it. */
3377 if (loop
->temp_ss
!= NULL
)
3379 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3381 /* Make absolutely sure that this is a complete type. */
3382 if (loop
->temp_ss
->string_length
)
3383 loop
->temp_ss
->data
.temp
.type
3384 = gfc_get_character_type_len (gfc_default_character_kind
,
3385 loop
->temp_ss
->string_length
);
3387 tmp
= loop
->temp_ss
->data
.temp
.type
;
3388 len
= loop
->temp_ss
->string_length
;
3389 n
= loop
->temp_ss
->data
.temp
.dimen
;
3390 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3391 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3392 loop
->temp_ss
->data
.info
.dimen
= n
;
3393 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3394 &loop
->temp_ss
->data
.info
, tmp
, false, true,
3398 for (n
= 0; n
< loop
->temp_dim
; n
++)
3399 loopspec
[loop
->order
[n
]] = NULL
;
3403 /* For array parameters we don't have loop variables, so don't calculate the
3405 if (loop
->array_parameter
)
3408 /* Calculate the translation from loop variables to array indices. */
3409 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3411 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
3414 info
= &ss
->data
.info
;
3416 for (n
= 0; n
< info
->dimen
; n
++)
3420 /* If we are specifying the range the delta is already set. */
3421 if (loopspec
[n
] != ss
)
3423 /* Calculate the offset relative to the loop variable.
3424 First multiply by the stride. */
3425 tmp
= loop
->from
[n
];
3426 if (!integer_onep (info
->stride
[n
]))
3427 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3428 tmp
, info
->stride
[n
]);
3430 /* Then subtract this from our starting value. */
3431 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3432 info
->start
[n
], tmp
);
3434 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3441 /* Fills in an array descriptor, and returns the size of the array. The size
3442 will be a simple_val, ie a variable or a constant. Also calculates the
3443 offset of the base. Returns the size of the array.
3447 for (n = 0; n < rank; n++)
3449 a.lbound[n] = specified_lower_bound;
3450 offset = offset + a.lbond[n] * stride;
3452 a.ubound[n] = specified_upper_bound;
3453 a.stride[n] = stride;
3454 size = ubound + size; //size = ubound + 1 - lbound
3455 stride = stride * size;
3462 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3463 gfc_expr
** lower
, gfc_expr
** upper
,
3464 stmtblock_t
* pblock
)
3476 stmtblock_t thenblock
;
3477 stmtblock_t elseblock
;
3482 type
= TREE_TYPE (descriptor
);
3484 stride
= gfc_index_one_node
;
3485 offset
= gfc_index_zero_node
;
3487 /* Set the dtype. */
3488 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3489 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3491 or_expr
= NULL_TREE
;
3493 for (n
= 0; n
< rank
; n
++)
3495 /* We have 3 possibilities for determining the size of the array:
3496 lower == NULL => lbound = 1, ubound = upper[n]
3497 upper[n] = NULL => lbound = 1, ubound = lower[n]
3498 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3501 /* Set lower bound. */
3502 gfc_init_se (&se
, NULL
);
3504 se
.expr
= gfc_index_one_node
;
3507 gcc_assert (lower
[n
]);
3510 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3511 gfc_add_block_to_block (pblock
, &se
.pre
);
3515 se
.expr
= gfc_index_one_node
;
3519 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
3520 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3522 /* Work out the offset for this component. */
3523 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3524 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3526 /* Start the calculation for the size of this dimension. */
3527 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3528 gfc_index_one_node
, se
.expr
);
3530 /* Set upper bound. */
3531 gfc_init_se (&se
, NULL
);
3532 gcc_assert (ubound
);
3533 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3534 gfc_add_block_to_block (pblock
, &se
.pre
);
3536 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
3537 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3539 /* Store the stride. */
3540 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
3541 gfc_add_modify_expr (pblock
, tmp
, stride
);
3543 /* Calculate the size of this dimension. */
3544 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3546 /* Check whether the size for this dimension is negative. */
3547 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3548 gfc_index_zero_node
);
3552 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3554 /* Multiply the stride by the number of elements in this dimension. */
3555 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3556 stride
= gfc_evaluate_now (stride
, pblock
);
3559 /* The stride is the number of elements in the array, so multiply by the
3560 size of an element to get the total size. */
3561 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3562 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3563 fold_convert (gfc_array_index_type
, tmp
));
3565 if (poffset
!= NULL
)
3567 offset
= gfc_evaluate_now (offset
, pblock
);
3571 if (integer_zerop (or_expr
))
3573 if (integer_onep (or_expr
))
3574 return gfc_index_zero_node
;
3576 var
= gfc_create_var (TREE_TYPE (size
), "size");
3577 gfc_start_block (&thenblock
);
3578 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
3579 thencase
= gfc_finish_block (&thenblock
);
3581 gfc_start_block (&elseblock
);
3582 gfc_add_modify_expr (&elseblock
, var
, size
);
3583 elsecase
= gfc_finish_block (&elseblock
);
3585 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3586 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3587 gfc_add_expr_to_block (pblock
, tmp
);
3593 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3594 the work for an ALLOCATE statement. */
3598 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3606 gfc_ref
*ref
, *prev_ref
= NULL
;
3607 bool allocatable_array
;
3611 /* Find the last reference in the chain. */
3612 while (ref
&& ref
->next
!= NULL
)
3614 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3619 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3623 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3625 allocatable_array
= prev_ref
->u
.c
.component
->allocatable
;
3627 /* Figure out the size of the array. */
3628 switch (ref
->u
.ar
.type
)
3632 upper
= ref
->u
.ar
.start
;
3636 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
3638 lower
= ref
->u
.ar
.as
->lower
;
3639 upper
= ref
->u
.ar
.as
->upper
;
3643 lower
= ref
->u
.ar
.start
;
3644 upper
= ref
->u
.ar
.end
;
3652 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
3653 lower
, upper
, &se
->pre
);
3655 /* Allocate memory to store the data. */
3656 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
3657 STRIP_NOPS (pointer
);
3659 /* The allocate_array variants take the old pointer as first argument. */
3660 if (allocatable_array
)
3661 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
);
3663 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
3664 tmp
= build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
3665 gfc_add_expr_to_block (&se
->pre
, tmp
);
3667 tmp
= gfc_conv_descriptor_offset (se
->expr
);
3668 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
3670 if (expr
->ts
.type
== BT_DERIVED
3671 && expr
->ts
.derived
->attr
.alloc_comp
)
3673 tmp
= gfc_nullify_alloc_comp (expr
->ts
.derived
, se
->expr
,
3674 ref
->u
.ar
.as
->rank
);
3675 gfc_add_expr_to_block (&se
->pre
, tmp
);
3682 /* Deallocate an array variable. Also used when an allocated variable goes
3687 gfc_array_deallocate (tree descriptor
, tree pstat
)
3693 gfc_start_block (&block
);
3694 /* Get a pointer to the data. */
3695 var
= gfc_conv_descriptor_data_get (descriptor
);
3698 /* Parameter is the address of the data component. */
3699 tmp
= gfc_deallocate_with_status (var
, pstat
, false);
3700 gfc_add_expr_to_block (&block
, tmp
);
3702 /* Zero the data pointer. */
3703 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
3704 var
, build_int_cst (TREE_TYPE (var
), 0));
3705 gfc_add_expr_to_block (&block
, tmp
);
3707 return gfc_finish_block (&block
);
3711 /* Create an array constructor from an initialization expression.
3712 We assume the frontend already did any expansions and conversions. */
3715 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3722 unsigned HOST_WIDE_INT lo
;
3724 VEC(constructor_elt
,gc
) *v
= NULL
;
3726 switch (expr
->expr_type
)
3729 case EXPR_STRUCTURE
:
3730 /* A single scalar or derived type value. Create an array with all
3731 elements equal to that value. */
3732 gfc_init_se (&se
, NULL
);
3734 if (expr
->expr_type
== EXPR_CONSTANT
)
3735 gfc_conv_constant (&se
, expr
);
3737 gfc_conv_structure (&se
, expr
, 1);
3739 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3740 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3741 hi
= TREE_INT_CST_HIGH (tmp
);
3742 lo
= TREE_INT_CST_LOW (tmp
);
3746 /* This will probably eat buckets of memory for large arrays. */
3747 while (hi
!= 0 || lo
!= 0)
3749 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3757 /* Create a vector of all the elements. */
3758 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3762 /* Problems occur when we get something like
3763 integer :: a(lots) = (/(i, i=1,lots)/) */
3764 /* TODO: Unexpanded array initializers. */
3766 ("Possible frontend bug: array constructor not expanded");
3768 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3769 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3773 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3777 mpz_set (maxval
, c
->repeat
);
3778 mpz_add (maxval
, c
->n
.offset
, maxval
);
3779 mpz_sub_ui (maxval
, maxval
, 1);
3780 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3781 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3783 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3784 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3787 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3789 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3795 gfc_init_se (&se
, NULL
);
3796 switch (c
->expr
->expr_type
)
3799 gfc_conv_constant (&se
, c
->expr
);
3800 if (range
== NULL_TREE
)
3801 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3804 if (index
!= NULL_TREE
)
3805 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3806 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3810 case EXPR_STRUCTURE
:
3811 gfc_conv_structure (&se
, c
->expr
, 1);
3812 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3822 return gfc_build_null_descriptor (type
);
3828 /* Create a constructor from the list of elements. */
3829 tmp
= build_constructor (type
, v
);
3830 TREE_CONSTANT (tmp
) = 1;
3831 TREE_INVARIANT (tmp
) = 1;
3836 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3837 returns the size (in elements) of the array. */
3840 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3841 stmtblock_t
* pblock
)
3856 size
= gfc_index_one_node
;
3857 offset
= gfc_index_zero_node
;
3858 for (dim
= 0; dim
< as
->rank
; dim
++)
3860 /* Evaluate non-constant array bound expressions. */
3861 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3862 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3864 gfc_init_se (&se
, NULL
);
3865 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3866 gfc_add_block_to_block (pblock
, &se
.pre
);
3867 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3869 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3870 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3872 gfc_init_se (&se
, NULL
);
3873 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3874 gfc_add_block_to_block (pblock
, &se
.pre
);
3875 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
3877 /* The offset of this dimension. offset = offset - lbound * stride. */
3878 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
3879 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3881 /* The size of this dimension, and the stride of the next. */
3882 if (dim
+ 1 < as
->rank
)
3883 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3885 stride
= GFC_TYPE_ARRAY_SIZE (type
);
3887 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3889 /* Calculate stride = size * (ubound + 1 - lbound). */
3890 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3891 gfc_index_one_node
, lbound
);
3892 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
3893 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3895 gfc_add_modify_expr (pblock
, stride
, tmp
);
3897 stride
= gfc_evaluate_now (tmp
, pblock
);
3899 /* Make sure that negative size arrays are translated
3900 to being zero size. */
3901 tmp
= build2 (GE_EXPR
, boolean_type_node
,
3902 stride
, gfc_index_zero_node
);
3903 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3904 stride
, gfc_index_zero_node
);
3905 gfc_add_modify_expr (pblock
, stride
, tmp
);
3911 gfc_trans_vla_type_sizes (sym
, pblock
);
3918 /* Generate code to initialize/allocate an array variable. */
3921 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3930 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3932 /* Do nothing for USEd variables. */
3933 if (sym
->attr
.use_assoc
)
3936 type
= TREE_TYPE (decl
);
3937 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3938 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3940 gfc_start_block (&block
);
3942 /* Evaluate character string length. */
3943 if (sym
->ts
.type
== BT_CHARACTER
3944 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3946 gfc_conv_string_length (sym
->ts
.cl
, &block
);
3948 gfc_trans_vla_type_sizes (sym
, &block
);
3950 /* Emit a DECL_EXPR for this variable, which will cause the
3951 gimplifier to allocate storage, and all that good stuff. */
3952 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3953 gfc_add_expr_to_block (&block
, tmp
);
3958 gfc_add_expr_to_block (&block
, fnbody
);
3959 return gfc_finish_block (&block
);
3962 type
= TREE_TYPE (type
);
3964 gcc_assert (!sym
->attr
.use_assoc
);
3965 gcc_assert (!TREE_STATIC (decl
));
3966 gcc_assert (!sym
->module
);
3968 if (sym
->ts
.type
== BT_CHARACTER
3969 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3970 gfc_conv_string_length (sym
->ts
.cl
, &block
);
3972 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3974 /* Don't actually allocate space for Cray Pointees. */
3975 if (sym
->attr
.cray_pointee
)
3977 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3978 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3979 gfc_add_expr_to_block (&block
, fnbody
);
3980 return gfc_finish_block (&block
);
3983 /* The size is the number of elements in the array, so multiply by the
3984 size of an element to get the total size. */
3985 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3986 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
3987 fold_convert (gfc_array_index_type
, tmp
));
3989 /* Allocate memory to hold the data. */
3990 tmp
= gfc_call_malloc (&block
, TREE_TYPE (decl
), size
);
3991 gfc_add_modify_expr (&block
, decl
, tmp
);
3993 /* Set offset of the array. */
3994 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3995 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3998 /* Automatic arrays should not have initializers. */
3999 gcc_assert (!sym
->value
);
4001 gfc_add_expr_to_block (&block
, fnbody
);
4003 /* Free the temporary. */
4004 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
4005 gfc_add_expr_to_block (&block
, tmp
);
4007 return gfc_finish_block (&block
);
4011 /* Generate entry and exit code for g77 calling convention arrays. */
4014 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
4024 gfc_get_backend_locus (&loc
);
4025 gfc_set_backend_locus (&sym
->declared_at
);
4027 /* Descriptor type. */
4028 parm
= sym
->backend_decl
;
4029 type
= TREE_TYPE (parm
);
4030 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4032 gfc_start_block (&block
);
4034 if (sym
->ts
.type
== BT_CHARACTER
4035 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4036 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4038 /* Evaluate the bounds of the array. */
4039 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4041 /* Set the offset. */
4042 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4043 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4045 /* Set the pointer itself if we aren't using the parameter directly. */
4046 if (TREE_CODE (parm
) != PARM_DECL
)
4048 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4049 gfc_add_modify_expr (&block
, parm
, tmp
);
4051 stmt
= gfc_finish_block (&block
);
4053 gfc_set_backend_locus (&loc
);
4055 gfc_start_block (&block
);
4057 /* Add the initialization code to the start of the function. */
4059 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4061 tmp
= gfc_conv_expr_present (sym
);
4062 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4065 gfc_add_expr_to_block (&block
, stmt
);
4066 gfc_add_expr_to_block (&block
, body
);
4068 return gfc_finish_block (&block
);
4072 /* Modify the descriptor of an array parameter so that it has the
4073 correct lower bound. Also move the upper bound accordingly.
4074 If the array is not packed, it will be copied into a temporary.
4075 For each dimension we set the new lower and upper bounds. Then we copy the
4076 stride and calculate the offset for this dimension. We also work out
4077 what the stride of a packed array would be, and see it the two match.
4078 If the array need repacking, we set the stride to the values we just
4079 calculated, recalculate the offset and copy the array data.
4080 Code is also added to copy the data back at the end of the function.
4084 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
4091 stmtblock_t cleanup
;
4099 tree stride
, stride2
;
4109 /* Do nothing for pointer and allocatable arrays. */
4110 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4113 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4114 return gfc_trans_g77_array (sym
, body
);
4116 gfc_get_backend_locus (&loc
);
4117 gfc_set_backend_locus (&sym
->declared_at
);
4119 /* Descriptor type. */
4120 type
= TREE_TYPE (tmpdesc
);
4121 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4122 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4123 dumdesc
= build_fold_indirect_ref (dumdesc
);
4124 gfc_start_block (&block
);
4126 if (sym
->ts
.type
== BT_CHARACTER
4127 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4128 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4130 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
4132 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4133 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4135 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4137 /* For non-constant shape arrays we only check if the first dimension
4138 is contiguous. Repacking higher dimensions wouldn't gain us
4139 anything as we still don't know the array stride. */
4140 partial
= gfc_create_var (boolean_type_node
, "partial");
4141 TREE_USED (partial
) = 1;
4142 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4143 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4144 gfc_add_modify_expr (&block
, partial
, tmp
);
4148 partial
= NULL_TREE
;
4151 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4152 here, however I think it does the right thing. */
4155 /* Set the first stride. */
4156 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4157 stride
= gfc_evaluate_now (stride
, &block
);
4159 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, gfc_index_zero_node
);
4160 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4161 gfc_index_one_node
, stride
);
4162 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4163 gfc_add_modify_expr (&block
, stride
, tmp
);
4165 /* Allow the user to disable array repacking. */
4166 stmt_unpacked
= NULL_TREE
;
4170 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4171 /* A library call to repack the array if necessary. */
4172 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4173 stmt_unpacked
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
4175 stride
= gfc_index_one_node
;
4178 /* This is for the case where the array data is used directly without
4179 calling the repack function. */
4180 if (no_repack
|| partial
!= NULL_TREE
)
4181 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4183 stmt_packed
= NULL_TREE
;
4185 /* Assign the data pointer. */
4186 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4188 /* Don't repack unknown shape arrays when the first stride is 1. */
4189 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
4190 stmt_packed
, stmt_unpacked
);
4193 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4194 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
4196 offset
= gfc_index_zero_node
;
4197 size
= gfc_index_one_node
;
4199 /* Evaluate the bounds of the array. */
4200 for (n
= 0; n
< sym
->as
->rank
; n
++)
4202 if (checkparm
|| !sym
->as
->upper
[n
])
4204 /* Get the bounds of the actual parameter. */
4205 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
4206 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
4210 dubound
= NULL_TREE
;
4211 dlbound
= NULL_TREE
;
4214 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4215 if (!INTEGER_CST_P (lbound
))
4217 gfc_init_se (&se
, NULL
);
4218 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4219 gfc_array_index_type
);
4220 gfc_add_block_to_block (&block
, &se
.pre
);
4221 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
4224 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4225 /* Set the desired upper bound. */
4226 if (sym
->as
->upper
[n
])
4228 /* We know what we want the upper bound to be. */
4229 if (!INTEGER_CST_P (ubound
))
4231 gfc_init_se (&se
, NULL
);
4232 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4233 gfc_array_index_type
);
4234 gfc_add_block_to_block (&block
, &se
.pre
);
4235 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
4238 /* Check the sizes match. */
4241 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4244 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4246 stride2
= build2 (MINUS_EXPR
, gfc_array_index_type
,
4248 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
4249 asprintf (&msg
, "%s for dimension %d of array '%s'",
4250 gfc_msg_bounds
, n
+1, sym
->name
);
4251 gfc_trans_runtime_check (tmp
, &block
, &loc
, msg
);
4257 /* For assumed shape arrays move the upper bound by the same amount
4258 as the lower bound. */
4259 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
4260 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4261 gfc_add_modify_expr (&block
, ubound
, tmp
);
4263 /* The offset of this dimension. offset = offset - lbound * stride. */
4264 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4265 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4267 /* The size of this dimension, and the stride of the next. */
4268 if (n
+ 1 < sym
->as
->rank
)
4270 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4272 if (no_repack
|| partial
!= NULL_TREE
)
4275 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
4278 /* Figure out the stride if not a known constant. */
4279 if (!INTEGER_CST_P (stride
))
4282 stmt_packed
= NULL_TREE
;
4285 /* Calculate stride = size * (ubound + 1 - lbound). */
4286 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4287 gfc_index_one_node
, lbound
);
4288 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4290 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4295 /* Assign the stride. */
4296 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4297 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4298 stmt_unpacked
, stmt_packed
);
4300 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4301 gfc_add_modify_expr (&block
, stride
, tmp
);
4306 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4308 if (stride
&& !INTEGER_CST_P (stride
))
4310 /* Calculate size = stride * (ubound + 1 - lbound). */
4311 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4312 gfc_index_one_node
, lbound
);
4313 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4315 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4316 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4317 gfc_add_modify_expr (&block
, stride
, tmp
);
4322 /* Set the offset. */
4323 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4324 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4326 gfc_trans_vla_type_sizes (sym
, &block
);
4328 stmt
= gfc_finish_block (&block
);
4330 gfc_start_block (&block
);
4332 /* Only do the entry/initialization code if the arg is present. */
4333 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4334 optional_arg
= (sym
->attr
.optional
4335 || (sym
->ns
->proc_name
->attr
.entry_master
4336 && sym
->attr
.dummy
));
4339 tmp
= gfc_conv_expr_present (sym
);
4340 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4342 gfc_add_expr_to_block (&block
, stmt
);
4344 /* Add the main function body. */
4345 gfc_add_expr_to_block (&block
, body
);
4350 gfc_start_block (&cleanup
);
4352 if (sym
->attr
.intent
!= INTENT_IN
)
4354 /* Copy the data back. */
4355 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4356 gfc_add_expr_to_block (&cleanup
, tmp
);
4359 /* Free the temporary. */
4360 tmp
= gfc_call_free (tmpdesc
);
4361 gfc_add_expr_to_block (&cleanup
, tmp
);
4363 stmt
= gfc_finish_block (&cleanup
);
4365 /* Only do the cleanup if the array was repacked. */
4366 tmp
= build_fold_indirect_ref (dumdesc
);
4367 tmp
= gfc_conv_descriptor_data_get (tmp
);
4368 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4369 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4373 tmp
= gfc_conv_expr_present (sym
);
4374 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4376 gfc_add_expr_to_block (&block
, stmt
);
4378 /* We don't need to free any memory allocated by internal_pack as it will
4379 be freed at the end of the function by pop_context. */
4380 return gfc_finish_block (&block
);
4384 /* Calculate the overall offset, including subreferences. */
4386 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4387 bool subref
, gfc_expr
*expr
)
4397 /* If offset is NULL and this is not a subreferenced array, there is
4399 if (offset
== NULL_TREE
)
4402 offset
= gfc_index_zero_node
;
4407 tmp
= gfc_conv_array_data (desc
);
4408 tmp
= build_fold_indirect_ref (tmp
);
4409 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4411 /* Offset the data pointer for pointer assignments from arrays with
4412 subreferences; eg. my_integer => my_type(:)%integer_component. */
4415 /* Go past the array reference. */
4416 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4417 if (ref
->type
== REF_ARRAY
&&
4418 ref
->u
.ar
.type
!= AR_ELEMENT
)
4424 /* Calculate the offset for each subsequent subreference. */
4425 for (; ref
; ref
= ref
->next
)
4430 field
= ref
->u
.c
.component
->backend_decl
;
4431 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
4432 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
4436 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
4437 gfc_init_se (&start
, NULL
);
4438 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
4439 gfc_add_block_to_block (block
, &start
.pre
);
4440 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
4444 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
4445 && ref
->u
.ar
.type
== AR_ELEMENT
);
4447 /* TODO - Add bounds checking. */
4448 stride
= gfc_index_one_node
;
4449 index
= gfc_index_zero_node
;
4450 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4455 /* Update the index. */
4456 gfc_init_se (&start
, NULL
);
4457 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
4458 itmp
= gfc_evaluate_now (start
.expr
, block
);
4459 gfc_init_se (&start
, NULL
);
4460 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
4461 jtmp
= gfc_evaluate_now (start
.expr
, block
);
4462 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, itmp
, jtmp
);
4463 itmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, itmp
, stride
);
4464 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, itmp
, index
);
4465 index
= gfc_evaluate_now (index
, block
);
4467 /* Update the stride. */
4468 gfc_init_se (&start
, NULL
);
4469 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
4470 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, start
.expr
, jtmp
);
4471 itmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4472 gfc_index_one_node
, itmp
);
4473 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, itmp
);
4474 stride
= gfc_evaluate_now (stride
, block
);
4477 /* Apply the index to obtain the array element. */
4478 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
4488 /* Set the target data pointer. */
4489 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4490 gfc_conv_descriptor_data_set (block
, parm
, offset
);
4494 /* Convert an array for passing as an actual argument. Expressions and
4495 vector subscripts are evaluated and stored in a temporary, which is then
4496 passed. For whole arrays the descriptor is passed. For array sections
4497 a modified copy of the descriptor is passed, but using the original data.
4499 This function is also used for array pointer assignments, and there
4502 - se->want_pointer && !se->direct_byref
4503 EXPR is an actual argument. On exit, se->expr contains a
4504 pointer to the array descriptor.
4506 - !se->want_pointer && !se->direct_byref
4507 EXPR is an actual argument to an intrinsic function or the
4508 left-hand side of a pointer assignment. On exit, se->expr
4509 contains the descriptor for EXPR.
4511 - !se->want_pointer && se->direct_byref
4512 EXPR is the right-hand side of a pointer assignment and
4513 se->expr is the descriptor for the previously-evaluated
4514 left-hand side. The function creates an assignment from
4515 EXPR to se->expr. */
4518 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
4531 bool subref_array_target
= false;
4533 gcc_assert (ss
!= gfc_ss_terminator
);
4535 /* Special case things we know we can pass easily. */
4536 switch (expr
->expr_type
)
4539 /* If we have a linear array section, we can pass it directly.
4540 Otherwise we need to copy it into a temporary. */
4542 /* Find the SS for the array section. */
4544 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
4545 secss
= secss
->next
;
4547 gcc_assert (secss
!= gfc_ss_terminator
);
4548 info
= &secss
->data
.info
;
4550 /* Get the descriptor for the array. */
4551 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
4552 desc
= info
->descriptor
;
4554 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
4555 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
4556 && !subref_array_target
;
4560 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4562 /* Create a new descriptor if the array doesn't have one. */
4565 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
4567 else if (se
->direct_byref
)
4570 full
= gfc_full_array_ref_p (info
->ref
);
4574 if (se
->direct_byref
)
4576 /* Copy the descriptor for pointer assignments. */
4577 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
4579 /* Add any offsets from subreferences. */
4580 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
4581 subref_array_target
, expr
);
4583 else if (se
->want_pointer
)
4585 /* We pass full arrays directly. This means that pointers and
4586 allocatable arrays should also work. */
4587 se
->expr
= build_fold_addr_expr (desc
);
4594 if (expr
->ts
.type
== BT_CHARACTER
)
4595 se
->string_length
= gfc_get_expr_charlen (expr
);
4602 /* A transformational function return value will be a temporary
4603 array descriptor. We still need to go through the scalarizer
4604 to create the descriptor. Elemental functions ar handled as
4605 arbitrary expressions, i.e. copy to a temporary. */
4607 /* Look for the SS for this function. */
4608 while (secss
!= gfc_ss_terminator
4609 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
4610 secss
= secss
->next
;
4612 if (se
->direct_byref
)
4614 gcc_assert (secss
!= gfc_ss_terminator
);
4616 /* For pointer assignments pass the descriptor directly. */
4618 se
->expr
= build_fold_addr_expr (se
->expr
);
4619 gfc_conv_expr (se
, expr
);
4623 if (secss
== gfc_ss_terminator
)
4625 /* Elemental function. */
4631 /* Transformational function. */
4632 info
= &secss
->data
.info
;
4638 /* Constant array constructors don't need a temporary. */
4639 if (ss
->type
== GFC_SS_CONSTRUCTOR
4640 && expr
->ts
.type
!= BT_CHARACTER
4641 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
4644 info
= &ss
->data
.info
;
4656 /* Something complicated. Copy it into a temporary. */
4664 gfc_init_loopinfo (&loop
);
4666 /* Associate the SS with the loop. */
4667 gfc_add_ss_to_loop (&loop
, ss
);
4669 /* Tell the scalarizer not to bother creating loop variables, etc. */
4671 loop
.array_parameter
= 1;
4673 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4674 gcc_assert (!se
->direct_byref
);
4676 /* Setup the scalarizing loops and bounds. */
4677 gfc_conv_ss_startstride (&loop
);
4681 /* Tell the scalarizer to make a temporary. */
4682 loop
.temp_ss
= gfc_get_ss ();
4683 loop
.temp_ss
->type
= GFC_SS_TEMP
;
4684 loop
.temp_ss
->next
= gfc_ss_terminator
;
4686 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
4687 gfc_conv_string_length (expr
->ts
.cl
, &se
->pre
);
4689 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
4691 if (expr
->ts
.type
== BT_CHARACTER
)
4692 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4694 loop
.temp_ss
->string_length
= NULL
;
4696 se
->string_length
= loop
.temp_ss
->string_length
;
4697 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
4698 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4701 gfc_conv_loop_setup (&loop
);
4705 /* Copy into a temporary and pass that. We don't need to copy the data
4706 back because expressions and vector subscripts must be INTENT_IN. */
4707 /* TODO: Optimize passing function return values. */
4711 /* Start the copying loops. */
4712 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4713 gfc_mark_ss_chain_used (ss
, 1);
4714 gfc_start_scalarized_body (&loop
, &block
);
4716 /* Copy each data element. */
4717 gfc_init_se (&lse
, NULL
);
4718 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4719 gfc_init_se (&rse
, NULL
);
4720 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4722 lse
.ss
= loop
.temp_ss
;
4725 gfc_conv_scalarized_array_ref (&lse
, NULL
);
4726 if (expr
->ts
.type
== BT_CHARACTER
)
4728 gfc_conv_expr (&rse
, expr
);
4729 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
4730 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4733 gfc_conv_expr_val (&rse
, expr
);
4735 gfc_add_block_to_block (&block
, &rse
.pre
);
4736 gfc_add_block_to_block (&block
, &lse
.pre
);
4738 lse
.string_length
= rse
.string_length
;
4739 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
4740 expr
->expr_type
== EXPR_VARIABLE
);
4741 gfc_add_expr_to_block (&block
, tmp
);
4743 /* Finish the copying loops. */
4744 gfc_trans_scalarizing_loops (&loop
, &block
);
4746 desc
= loop
.temp_ss
->data
.info
.descriptor
;
4748 gcc_assert (is_gimple_lvalue (desc
));
4750 else if (expr
->expr_type
== EXPR_FUNCTION
)
4752 desc
= info
->descriptor
;
4753 se
->string_length
= ss
->string_length
;
4757 /* We pass sections without copying to a temporary. Make a new
4758 descriptor and point it at the section we want. The loop variable
4759 limits will be the limits of the section.
4760 A function may decide to repack the array to speed up access, but
4761 we're not bothered about that here. */
4770 /* Set the string_length for a character array. */
4771 if (expr
->ts
.type
== BT_CHARACTER
)
4772 se
->string_length
= gfc_get_expr_charlen (expr
);
4774 desc
= info
->descriptor
;
4775 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
4776 if (se
->direct_byref
)
4778 /* For pointer assignments we fill in the destination. */
4780 parmtype
= TREE_TYPE (parm
);
4784 /* Otherwise make a new one. */
4785 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4786 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
4787 loop
.from
, loop
.to
, 0,
4789 parm
= gfc_create_var (parmtype
, "parm");
4792 offset
= gfc_index_zero_node
;
4795 /* The following can be somewhat confusing. We have two
4796 descriptors, a new one and the original array.
4797 {parm, parmtype, dim} refer to the new one.
4798 {desc, type, n, secss, loop} refer to the original, which maybe
4799 a descriptorless array.
4800 The bounds of the scalarization are the bounds of the section.
4801 We don't have to worry about numeric overflows when calculating
4802 the offsets because all elements are within the array data. */
4804 /* Set the dtype. */
4805 tmp
= gfc_conv_descriptor_dtype (parm
);
4806 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
4808 /* Set offset for assignments to pointer only to zero if it is not
4810 if (se
->direct_byref
4811 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
4812 base
= gfc_index_zero_node
;
4813 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4814 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
4818 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
4819 for (n
= 0; n
< ndim
; n
++)
4821 stride
= gfc_conv_array_stride (desc
, n
);
4823 /* Work out the offset. */
4825 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4827 gcc_assert (info
->subscript
[n
]
4828 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
4829 start
= info
->subscript
[n
]->data
.scalar
.expr
;
4833 /* Check we haven't somehow got out of sync. */
4834 gcc_assert (info
->dim
[dim
] == n
);
4836 /* Evaluate and remember the start of the section. */
4837 start
= info
->start
[dim
];
4838 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
4841 tmp
= gfc_conv_array_lbound (desc
, n
);
4842 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
4844 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
4845 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
4848 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4850 /* For elemental dimensions, we only need the offset. */
4854 /* Vector subscripts need copying and are handled elsewhere. */
4856 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
4858 /* Set the new lower bound. */
4859 from
= loop
.from
[dim
];
4862 /* If we have an array section or are assigning make sure that
4863 the lower bound is 1. References to the full
4864 array should otherwise keep the original bounds. */
4866 || info
->ref
->u
.ar
.type
!= AR_FULL
)
4867 && !integer_onep (from
))
4869 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4870 gfc_index_one_node
, from
);
4871 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
4872 from
= gfc_index_one_node
;
4874 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
4875 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
4877 /* Set the new upper bound. */
4878 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
4879 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
4881 /* Multiply the stride by the section stride to get the
4883 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4884 stride
, info
->stride
[dim
]);
4886 if (se
->direct_byref
&& info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
4888 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4891 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4893 tmp
= gfc_conv_array_lbound (desc
, n
);
4894 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4895 tmp
, loop
.from
[dim
]);
4896 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
4897 tmp
, gfc_conv_array_stride (desc
, n
));
4898 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
4902 /* Store the new stride. */
4903 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
4904 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
4909 if (se
->data_not_needed
)
4910 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, gfc_index_zero_node
);
4912 /* Point the data pointer at the first element in the section. */
4913 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
4914 subref_array_target
, expr
);
4916 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4917 && !se
->data_not_needed
)
4919 /* Set the offset. */
4920 tmp
= gfc_conv_descriptor_offset (parm
);
4921 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
4925 /* Only the callee knows what the correct offset it, so just set
4927 tmp
= gfc_conv_descriptor_offset (parm
);
4928 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
4933 if (!se
->direct_byref
)
4935 /* Get a pointer to the new descriptor. */
4936 if (se
->want_pointer
)
4937 se
->expr
= build_fold_addr_expr (desc
);
4942 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4943 gfc_add_block_to_block (&se
->post
, &loop
.post
);
4945 /* Cleanup the scalarizer. */
4946 gfc_cleanup_loop (&loop
);
4950 /* Convert an array for passing as an actual parameter. */
4951 /* TODO: Optimize passing g77 arrays. */
4954 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
4958 tree tmp
= NULL_TREE
;
4960 tree parent
= DECL_CONTEXT (current_function_decl
);
4961 bool full_array_var
, this_array_result
;
4965 full_array_var
= (expr
->expr_type
== EXPR_VARIABLE
4966 && expr
->ref
->u
.ar
.type
== AR_FULL
);
4967 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
4969 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
4971 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
4972 expr
->ts
.cl
->backend_decl
= tmp
;
4973 se
->string_length
= gfc_evaluate_now (tmp
, &se
->pre
);
4976 /* Is this the result of the enclosing procedure? */
4977 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
4978 if (this_array_result
4979 && (sym
->backend_decl
!= current_function_decl
)
4980 && (sym
->backend_decl
!= parent
))
4981 this_array_result
= false;
4983 /* Passing address of the array if it is not pointer or assumed-shape. */
4984 if (full_array_var
&& g77
&& !this_array_result
)
4986 tmp
= gfc_get_symbol_decl (sym
);
4988 if (sym
->ts
.type
== BT_CHARACTER
)
4989 se
->string_length
= sym
->ts
.cl
->backend_decl
;
4990 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
4991 && !sym
->attr
.allocatable
)
4993 /* Some variables are declared directly, others are declared as
4994 pointers and allocated on the heap. */
4995 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
4998 se
->expr
= build_fold_addr_expr (tmp
);
5001 if (sym
->attr
.allocatable
)
5003 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5005 gfc_conv_expr_descriptor (se
, expr
, ss
);
5006 se
->expr
= gfc_conv_array_data (se
->expr
);
5009 se
->expr
= gfc_conv_array_data (tmp
);
5014 if (this_array_result
)
5016 /* Result of the enclosing function. */
5017 gfc_conv_expr_descriptor (se
, expr
, ss
);
5018 se
->expr
= build_fold_addr_expr (se
->expr
);
5020 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
5021 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
5022 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref (se
->expr
));
5028 /* Every other type of array. */
5029 se
->want_pointer
= 1;
5030 gfc_conv_expr_descriptor (se
, expr
, ss
);
5034 /* Deallocate the allocatable components of structures that are
5036 if (expr
->ts
.type
== BT_DERIVED
5037 && expr
->ts
.derived
->attr
.alloc_comp
5038 && expr
->expr_type
!= EXPR_VARIABLE
)
5040 tmp
= build_fold_indirect_ref (se
->expr
);
5041 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.derived
, tmp
, expr
->rank
);
5042 gfc_add_expr_to_block (&se
->post
, tmp
);
5048 /* Repack the array. */
5049 ptr
= build_call_expr (gfor_fndecl_in_pack
, 1, desc
);
5050 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5053 gfc_start_block (&block
);
5055 /* Copy the data back. */
5056 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5057 gfc_add_expr_to_block (&block
, tmp
);
5059 /* Free the temporary. */
5060 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5061 gfc_add_expr_to_block (&block
, tmp
);
5063 stmt
= gfc_finish_block (&block
);
5065 gfc_init_block (&block
);
5066 /* Only if it was repacked. This code needs to be executed before the
5067 loop cleanup code. */
5068 tmp
= build_fold_indirect_ref (desc
);
5069 tmp
= gfc_conv_array_data (tmp
);
5070 tmp
= build2 (NE_EXPR
, boolean_type_node
,
5071 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5072 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
5074 gfc_add_expr_to_block (&block
, tmp
);
5075 gfc_add_block_to_block (&block
, &se
->post
);
5077 gfc_init_block (&se
->post
);
5078 gfc_add_block_to_block (&se
->post
, &block
);
5083 /* Generate code to deallocate an array, if it is allocated. */
5086 gfc_trans_dealloc_allocated (tree descriptor
)
5092 gfc_start_block (&block
);
5094 var
= gfc_conv_descriptor_data_get (descriptor
);
5097 /* Call array_deallocate with an int * present in the second argument.
5098 Although it is ignored here, it's presence ensures that arrays that
5099 are already deallocated are ignored. */
5100 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true);
5101 gfc_add_expr_to_block (&block
, tmp
);
5103 /* Zero the data pointer. */
5104 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
5105 var
, build_int_cst (TREE_TYPE (var
), 0));
5106 gfc_add_expr_to_block (&block
, tmp
);
5108 return gfc_finish_block (&block
);
5112 /* This helper function calculates the size in words of a full array. */
5115 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
5120 idx
= gfc_rank_cst
[rank
- 1];
5121 nelems
= gfc_conv_descriptor_ubound (decl
, idx
);
5122 tmp
= gfc_conv_descriptor_lbound (decl
, idx
);
5123 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5124 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
5125 tmp
, gfc_index_one_node
);
5126 tmp
= gfc_evaluate_now (tmp
, block
);
5128 nelems
= gfc_conv_descriptor_stride (decl
, idx
);
5129 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5130 return gfc_evaluate_now (tmp
, block
);
5134 /* Allocate dest to the same size as src, and copy src -> dest. */
5137 gfc_duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
)
5146 /* If the source is null, set the destination to null. */
5147 gfc_init_block (&block
);
5148 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5149 null_data
= gfc_finish_block (&block
);
5151 gfc_init_block (&block
);
5153 nelems
= get_full_array_size (&block
, src
, rank
);
5154 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
,
5155 fold_convert (gfc_array_index_type
,
5156 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
5158 /* Allocate memory to the destination. */
5159 tmp
= gfc_call_malloc (&block
, TREE_TYPE (gfc_conv_descriptor_data_get (src
)),
5161 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5163 /* We know the temporary and the value will be the same length,
5164 so can use memcpy. */
5165 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5166 tmp
= build_call_expr (tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5167 gfc_conv_descriptor_data_get (src
), size
);
5168 gfc_add_expr_to_block (&block
, tmp
);
5169 tmp
= gfc_finish_block (&block
);
5171 /* Null the destination if the source is null; otherwise do
5172 the allocate and copy. */
5173 null_cond
= gfc_conv_descriptor_data_get (src
);
5174 null_cond
= convert (pvoid_type_node
, null_cond
);
5175 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5177 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5181 /* Recursively traverse an object of derived type, generating code to
5182 deallocate, nullify or copy allocatable components. This is the work horse
5183 function for the functions named in this enum. */
5185 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
};
5188 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5189 tree dest
, int rank
, int purpose
)
5193 stmtblock_t fnblock
;
5194 stmtblock_t loopbody
;
5204 tree null_cond
= NULL_TREE
;
5206 gfc_init_block (&fnblock
);
5208 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
5209 decl
= build_fold_indirect_ref (decl
);
5211 /* If this an array of derived types with allocatable components
5212 build a loop and recursively call this function. */
5213 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
5214 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5216 tmp
= gfc_conv_array_data (decl
);
5217 var
= build_fold_indirect_ref (tmp
);
5219 /* Get the number of elements - 1 and set the counter. */
5220 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5222 /* Use the descriptor for an allocatable array. Since this
5223 is a full array reference, we only need the descriptor
5224 information from dimension = rank. */
5225 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
5226 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
5227 tmp
, gfc_index_one_node
);
5229 null_cond
= gfc_conv_descriptor_data_get (decl
);
5230 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5231 build_int_cst (TREE_TYPE (null_cond
), 0));
5235 /* Otherwise use the TYPE_DOMAIN information. */
5236 tmp
= array_type_nelts (TREE_TYPE (decl
));
5237 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5240 /* Remember that this is, in fact, the no. of elements - 1. */
5241 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5242 index
= gfc_create_var (gfc_array_index_type
, "S");
5244 /* Build the body of the loop. */
5245 gfc_init_block (&loopbody
);
5247 vref
= gfc_build_array_ref (var
, index
, NULL
);
5249 if (purpose
== COPY_ALLOC_COMP
)
5251 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
5252 gfc_add_expr_to_block (&fnblock
, tmp
);
5254 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest
));
5255 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
5256 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
5259 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
5261 gfc_add_expr_to_block (&loopbody
, tmp
);
5263 /* Build the loop and return. */
5264 gfc_init_loopinfo (&loop
);
5266 loop
.from
[0] = gfc_index_zero_node
;
5267 loop
.loopvar
[0] = index
;
5268 loop
.to
[0] = nelems
;
5269 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
5270 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
5272 tmp
= gfc_finish_block (&fnblock
);
5273 if (null_cond
!= NULL_TREE
)
5274 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
, build_empty_stmt ());
5279 /* Otherwise, act on the components or recursively call self to
5280 act on a chain of components. */
5281 for (c
= der_type
->components
; c
; c
= c
->next
)
5283 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
5284 && c
->ts
.derived
->attr
.alloc_comp
;
5285 cdecl = c
->backend_decl
;
5286 ctype
= TREE_TYPE (cdecl);
5290 case DEALLOCATE_ALLOC_COMP
:
5291 /* Do not deallocate the components of ultimate pointer
5293 if (cmp_has_alloc_comps
&& !c
->pointer
)
5295 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5296 rank
= c
->as
? c
->as
->rank
: 0;
5297 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5299 gfc_add_expr_to_block (&fnblock
, tmp
);
5304 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5305 tmp
= gfc_trans_dealloc_allocated (comp
);
5306 gfc_add_expr_to_block (&fnblock
, tmp
);
5310 case NULLIFY_ALLOC_COMP
:
5313 else if (c
->allocatable
)
5315 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5316 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
5318 else if (cmp_has_alloc_comps
)
5320 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5321 rank
= c
->as
? c
->as
->rank
: 0;
5322 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5324 gfc_add_expr_to_block (&fnblock
, tmp
);
5328 case COPY_ALLOC_COMP
:
5332 /* We need source and destination components. */
5333 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5334 dcmp
= build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
5335 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
5337 if (c
->allocatable
&& !cmp_has_alloc_comps
)
5339 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, c
->as
->rank
);
5340 gfc_add_expr_to_block (&fnblock
, tmp
);
5343 if (cmp_has_alloc_comps
)
5345 rank
= c
->as
? c
->as
->rank
: 0;
5346 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
5347 gfc_add_modify_expr (&fnblock
, dcmp
, tmp
);
5348 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, dcmp
,
5350 gfc_add_expr_to_block (&fnblock
, tmp
);
5360 return gfc_finish_block (&fnblock
);
5363 /* Recursively traverse an object of derived type, generating code to
5364 nullify allocatable components. */
5367 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5369 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5370 NULLIFY_ALLOC_COMP
);
5374 /* Recursively traverse an object of derived type, generating code to
5375 deallocate allocatable components. */
5378 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5380 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5381 DEALLOCATE_ALLOC_COMP
);
5385 /* Recursively traverse an object of derived type, generating code to
5386 copy its allocatable components. */
5389 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
5391 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
5395 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5396 Do likewise, recursively if necessary, with the allocatable components of
5400 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
5405 stmtblock_t fnblock
;
5408 bool sym_has_alloc_comp
;
5410 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
5411 && sym
->ts
.derived
->attr
.alloc_comp
;
5413 /* Make sure the frontend gets these right. */
5414 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
5415 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5416 "allocatable attribute or derived type without allocatable "
5419 gfc_init_block (&fnblock
);
5421 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
5422 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
5424 if (sym
->ts
.type
== BT_CHARACTER
5425 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
5427 gfc_conv_string_length (sym
->ts
.cl
, &fnblock
);
5428 gfc_trans_vla_type_sizes (sym
, &fnblock
);
5431 /* Dummy and use associated variables don't need anything special. */
5432 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
5434 gfc_add_expr_to_block (&fnblock
, body
);
5436 return gfc_finish_block (&fnblock
);
5439 gfc_get_backend_locus (&loc
);
5440 gfc_set_backend_locus (&sym
->declared_at
);
5441 descriptor
= sym
->backend_decl
;
5443 /* Although static, derived types with default initializers and
5444 allocatable components must not be nulled wholesale; instead they
5445 are treated component by component. */
5446 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
5448 /* SAVEd variables are not freed on exit. */
5449 gfc_trans_static_array_pointer (sym
);
5453 /* Get the descriptor type. */
5454 type
= TREE_TYPE (sym
->backend_decl
);
5456 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5458 if (!sym
->attr
.save
)
5460 rank
= sym
->as
? sym
->as
->rank
: 0;
5461 tmp
= gfc_nullify_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5462 gfc_add_expr_to_block (&fnblock
, tmp
);
5465 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
5467 /* If the backend_decl is not a descriptor, we must have a pointer
5469 descriptor
= build_fold_indirect_ref (sym
->backend_decl
);
5470 type
= TREE_TYPE (descriptor
);
5473 /* NULLIFY the data pointer. */
5474 if (GFC_DESCRIPTOR_TYPE_P (type
))
5475 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
5477 gfc_add_expr_to_block (&fnblock
, body
);
5479 gfc_set_backend_locus (&loc
);
5481 /* Allocatable arrays need to be freed when they go out of scope.
5482 The allocatable components of pointers must not be touched. */
5483 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
5484 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
5487 rank
= sym
->as
? sym
->as
->rank
: 0;
5488 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5489 gfc_add_expr_to_block (&fnblock
, tmp
);
5492 if (sym
->attr
.allocatable
)
5494 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
5495 gfc_add_expr_to_block (&fnblock
, tmp
);
5498 return gfc_finish_block (&fnblock
);
5501 /************ Expression Walking Functions ******************/
5503 /* Walk a variable reference.
5505 Possible extension - multiple component subscripts.
5506 x(:,:) = foo%a(:)%b(:)
5508 forall (i=..., j=...)
5509 x(i,j) = foo%a(j)%b(i)
5511 This adds a fair amount of complexity because you need to deal with more
5512 than one ref. Maybe handle in a similar manner to vector subscripts.
5513 Maybe not worth the effort. */
5517 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5525 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5526 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
5529 for (; ref
; ref
= ref
->next
)
5531 if (ref
->type
== REF_SUBSTRING
)
5533 newss
= gfc_get_ss ();
5534 newss
->type
= GFC_SS_SCALAR
;
5535 newss
->expr
= ref
->u
.ss
.start
;
5539 newss
= gfc_get_ss ();
5540 newss
->type
= GFC_SS_SCALAR
;
5541 newss
->expr
= ref
->u
.ss
.end
;
5546 /* We're only interested in array sections from now on. */
5547 if (ref
->type
!= REF_ARRAY
)
5554 for (n
= 0; n
< ar
->dimen
; n
++)
5556 newss
= gfc_get_ss ();
5557 newss
->type
= GFC_SS_SCALAR
;
5558 newss
->expr
= ar
->start
[n
];
5565 newss
= gfc_get_ss ();
5566 newss
->type
= GFC_SS_SECTION
;
5569 newss
->data
.info
.dimen
= ar
->as
->rank
;
5570 newss
->data
.info
.ref
= ref
;
5572 /* Make sure array is the same as array(:,:), this way
5573 we don't need to special case all the time. */
5574 ar
->dimen
= ar
->as
->rank
;
5575 for (n
= 0; n
< ar
->dimen
; n
++)
5577 newss
->data
.info
.dim
[n
] = n
;
5578 ar
->dimen_type
[n
] = DIMEN_RANGE
;
5580 gcc_assert (ar
->start
[n
] == NULL
);
5581 gcc_assert (ar
->end
[n
] == NULL
);
5582 gcc_assert (ar
->stride
[n
] == NULL
);
5588 newss
= gfc_get_ss ();
5589 newss
->type
= GFC_SS_SECTION
;
5592 newss
->data
.info
.dimen
= 0;
5593 newss
->data
.info
.ref
= ref
;
5597 /* We add SS chains for all the subscripts in the section. */
5598 for (n
= 0; n
< ar
->dimen
; n
++)
5602 switch (ar
->dimen_type
[n
])
5605 /* Add SS for elemental (scalar) subscripts. */
5606 gcc_assert (ar
->start
[n
]);
5607 indexss
= gfc_get_ss ();
5608 indexss
->type
= GFC_SS_SCALAR
;
5609 indexss
->expr
= ar
->start
[n
];
5610 indexss
->next
= gfc_ss_terminator
;
5611 indexss
->loop_chain
= gfc_ss_terminator
;
5612 newss
->data
.info
.subscript
[n
] = indexss
;
5616 /* We don't add anything for sections, just remember this
5617 dimension for later. */
5618 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5619 newss
->data
.info
.dimen
++;
5623 /* Create a GFC_SS_VECTOR index in which we can store
5624 the vector's descriptor. */
5625 indexss
= gfc_get_ss ();
5626 indexss
->type
= GFC_SS_VECTOR
;
5627 indexss
->expr
= ar
->start
[n
];
5628 indexss
->next
= gfc_ss_terminator
;
5629 indexss
->loop_chain
= gfc_ss_terminator
;
5630 newss
->data
.info
.subscript
[n
] = indexss
;
5631 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5632 newss
->data
.info
.dimen
++;
5636 /* We should know what sort of section it is by now. */
5640 /* We should have at least one non-elemental dimension. */
5641 gcc_assert (newss
->data
.info
.dimen
> 0);
5646 /* We should know what sort of section it is by now. */
5655 /* Walk an expression operator. If only one operand of a binary expression is
5656 scalar, we must also add the scalar term to the SS chain. */
5659 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5665 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
5666 if (expr
->value
.op
.op2
== NULL
)
5669 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
5671 /* All operands are scalar. Pass back and let the caller deal with it. */
5675 /* All operands require scalarization. */
5676 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
5679 /* One of the operands needs scalarization, the other is scalar.
5680 Create a gfc_ss for the scalar expression. */
5681 newss
= gfc_get_ss ();
5682 newss
->type
= GFC_SS_SCALAR
;
5685 /* First operand is scalar. We build the chain in reverse order, so
5686 add the scarar SS after the second operand. */
5688 while (head
&& head
->next
!= ss
)
5690 /* Check we haven't somehow broken the chain. */
5694 newss
->expr
= expr
->value
.op
.op1
;
5696 else /* head2 == head */
5698 gcc_assert (head2
== head
);
5699 /* Second operand is scalar. */
5700 newss
->next
= head2
;
5702 newss
->expr
= expr
->value
.op
.op2
;
5709 /* Reverse a SS chain. */
5712 gfc_reverse_ss (gfc_ss
* ss
)
5717 gcc_assert (ss
!= NULL
);
5719 head
= gfc_ss_terminator
;
5720 while (ss
!= gfc_ss_terminator
)
5723 /* Check we didn't somehow break the chain. */
5724 gcc_assert (next
!= NULL
);
5734 /* Walk the arguments of an elemental function. */
5737 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
5745 head
= gfc_ss_terminator
;
5748 for (; arg
; arg
= arg
->next
)
5753 newss
= gfc_walk_subexpr (head
, arg
->expr
);
5756 /* Scalar argument. */
5757 newss
= gfc_get_ss ();
5759 newss
->expr
= arg
->expr
;
5769 while (tail
->next
!= gfc_ss_terminator
)
5776 /* If all the arguments are scalar we don't need the argument SS. */
5777 gfc_free_ss_chain (head
);
5782 /* Add it onto the existing chain. */
5788 /* Walk a function call. Scalar functions are passed back, and taken out of
5789 scalarization loops. For elemental functions we walk their arguments.
5790 The result of functions returning arrays is stored in a temporary outside
5791 the loop, so that the function is only called once. Hence we do not need
5792 to walk their arguments. */
5795 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5798 gfc_intrinsic_sym
*isym
;
5801 isym
= expr
->value
.function
.isym
;
5803 /* Handle intrinsic functions separately. */
5805 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
5807 sym
= expr
->value
.function
.esym
;
5809 sym
= expr
->symtree
->n
.sym
;
5811 /* A function that returns arrays. */
5812 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
5814 newss
= gfc_get_ss ();
5815 newss
->type
= GFC_SS_FUNCTION
;
5818 newss
->data
.info
.dimen
= expr
->rank
;
5822 /* Walk the parameters of an elemental function. For now we always pass
5824 if (sym
->attr
.elemental
)
5825 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
5828 /* Scalar functions are OK as these are evaluated outside the scalarization
5829 loop. Pass back and let the caller deal with it. */
5834 /* An array temporary is constructed for array constructors. */
5837 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
5842 newss
= gfc_get_ss ();
5843 newss
->type
= GFC_SS_CONSTRUCTOR
;
5846 newss
->data
.info
.dimen
= expr
->rank
;
5847 for (n
= 0; n
< expr
->rank
; n
++)
5848 newss
->data
.info
.dim
[n
] = n
;
5854 /* Walk an expression. Add walked expressions to the head of the SS chain.
5855 A wholly scalar expression will not be added. */
5858 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
5862 switch (expr
->expr_type
)
5865 head
= gfc_walk_variable_expr (ss
, expr
);
5869 head
= gfc_walk_op_expr (ss
, expr
);
5873 head
= gfc_walk_function_expr (ss
, expr
);
5878 case EXPR_STRUCTURE
:
5879 /* Pass back and let the caller deal with it. */
5883 head
= gfc_walk_array_constructor (ss
, expr
);
5886 case EXPR_SUBSTRING
:
5887 /* Pass back and let the caller deal with it. */
5891 internal_error ("bad expression type during walk (%d)",
5898 /* Entry point for expression walking.
5899 A return value equal to the passed chain means this is
5900 a scalar expression. It is up to the caller to take whatever action is
5901 necessary to translate these. */
5904 gfc_walk_expr (gfc_expr
* expr
)
5908 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
5909 return gfc_reverse_ss (res
);