1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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
= fold_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
= fold_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
= fold_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 fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
215 desc
, field
, NULL_TREE
);
219 gfc_conv_descriptor_dtype (tree desc
)
224 type
= TREE_TYPE (desc
);
225 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
227 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
228 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
230 return fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
231 desc
, field
, NULL_TREE
);
235 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
241 type
= TREE_TYPE (desc
);
242 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
244 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
245 gcc_assert (field
!= NULL_TREE
246 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
247 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
249 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
250 desc
, field
, NULL_TREE
);
251 tmp
= gfc_build_array_ref (tmp
, dim
, NULL
);
256 gfc_conv_descriptor_stride (tree desc
, tree dim
)
261 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
262 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
263 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
264 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
266 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
267 tmp
, field
, NULL_TREE
);
272 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
277 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
278 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
279 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
280 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
282 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
283 tmp
, field
, NULL_TREE
);
288 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
293 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
294 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
295 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
296 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
298 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
299 tmp
, field
, NULL_TREE
);
304 /* Build a null array descriptor constructor. */
307 gfc_build_null_descriptor (tree type
)
312 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
313 gcc_assert (DATA_FIELD
== 0);
314 field
= TYPE_FIELDS (type
);
316 /* Set a NULL data pointer. */
317 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
318 TREE_CONSTANT (tmp
) = 1;
319 /* All other fields are ignored. */
325 /* Cleanup those #defines. */
330 #undef DIMENSION_FIELD
331 #undef STRIDE_SUBFIELD
332 #undef LBOUND_SUBFIELD
333 #undef UBOUND_SUBFIELD
336 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
337 flags & 1 = Main loop body.
338 flags & 2 = temp copy loop. */
341 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
343 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
344 ss
->useflags
= flags
;
347 static void gfc_free_ss (gfc_ss
*);
350 /* Free a gfc_ss chain. */
353 gfc_free_ss_chain (gfc_ss
* ss
)
357 while (ss
!= gfc_ss_terminator
)
359 gcc_assert (ss
!= NULL
);
370 gfc_free_ss (gfc_ss
* ss
)
377 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
379 if (ss
->data
.info
.subscript
[n
])
380 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
392 /* Free all the SS associated with a loop. */
395 gfc_cleanup_loop (gfc_loopinfo
* loop
)
401 while (ss
!= gfc_ss_terminator
)
403 gcc_assert (ss
!= NULL
);
404 next
= ss
->loop_chain
;
411 /* Associate a SS chain with a loop. */
414 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
418 if (head
== gfc_ss_terminator
)
422 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
424 if (ss
->next
== gfc_ss_terminator
)
425 ss
->loop_chain
= loop
->ss
;
427 ss
->loop_chain
= ss
->next
;
429 gcc_assert (ss
== gfc_ss_terminator
);
434 /* Generate an initializer for a static pointer or allocatable array. */
437 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
441 gcc_assert (TREE_STATIC (sym
->backend_decl
));
442 /* Just zero the data member. */
443 type
= TREE_TYPE (sym
->backend_decl
);
444 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
448 /* If the bounds of SE's loop have not yet been set, see if they can be
449 determined from array spec AS, which is the array spec of a called
450 function. MAPPING maps the callee's dummy arguments to the values
451 that the caller is passing. Add any initialization and finalization
455 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
456 gfc_se
* se
, gfc_array_spec
* as
)
464 if (as
&& as
->type
== AS_EXPLICIT
)
465 for (dim
= 0; dim
< se
->loop
->dimen
; dim
++)
467 n
= se
->loop
->order
[dim
];
468 if (se
->loop
->to
[n
] == NULL_TREE
)
470 /* Evaluate the lower bound. */
471 gfc_init_se (&tmpse
, NULL
);
472 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
473 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
474 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
475 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
477 /* ...and the upper bound. */
478 gfc_init_se (&tmpse
, NULL
);
479 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
480 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
481 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
482 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
484 /* Set the upper bound of the loop to UPPER - LOWER. */
485 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
486 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
487 se
->loop
->to
[n
] = tmp
;
493 /* Generate code to allocate an array temporary, or create a variable to
494 hold the data. If size is NULL, zero the descriptor so that the
495 callee will allocate the array. If DEALLOC is true, also generate code to
496 free the array afterwards.
498 Initialization code is added to PRE and finalization code to POST.
499 DYNAMIC is true if the caller may want to extend the array later
500 using realloc. This prevents us from putting the array on the stack. */
503 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
504 gfc_ss_info
* info
, tree size
, tree nelem
,
505 bool dynamic
, bool dealloc
)
511 desc
= info
->descriptor
;
512 info
->offset
= gfc_index_zero_node
;
513 if (size
== NULL_TREE
|| integer_zerop (size
))
515 /* A callee allocated array. */
516 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
521 /* Allocate the temporary. */
522 onstack
= !dynamic
&& gfc_can_put_var_on_stack (size
);
526 /* Make a temporary variable to hold the data. */
527 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
529 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
531 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
533 tmp
= gfc_create_var (tmp
, "A");
534 tmp
= build_fold_addr_expr (tmp
);
535 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
539 /* Allocate memory to hold the data. */
540 tmp
= gfc_call_malloc (pre
, NULL
, size
);
541 tmp
= gfc_evaluate_now (tmp
, pre
);
542 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
545 info
->data
= gfc_conv_descriptor_data_get (desc
);
547 /* The offset is zero because we create temporaries with a zero
549 tmp
= gfc_conv_descriptor_offset (desc
);
550 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
552 if (dealloc
&& !onstack
)
554 /* Free the temporary. */
555 tmp
= gfc_conv_descriptor_data_get (desc
);
556 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
557 gfc_add_expr_to_block (post
, tmp
);
562 /* Generate code to create and initialize the descriptor for a temporary
563 array. This is used for both temporaries needed by the scalarizer, and
564 functions returning arrays. Adjusts the loop variables to be
565 zero-based, and calculates the loop bounds for callee allocated arrays.
566 Allocate the array unless it's callee allocated (we have a callee
567 allocated array if 'callee_alloc' is true, or if loop->to[n] is
568 NULL_TREE for any n). Also fills in the descriptor, data and offset
569 fields of info if known. Returns the size of the array, or NULL for a
570 callee allocated array.
572 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
576 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
577 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
578 tree eltype
, bool dynamic
, bool dealloc
,
591 gcc_assert (info
->dimen
> 0);
592 /* Set the lower bound to zero. */
593 for (dim
= 0; dim
< info
->dimen
; dim
++)
595 n
= loop
->order
[dim
];
596 /* TODO: Investigate why "if (n < loop->temp_dim)
597 gcc_assert (integer_zerop (loop->from[n]));" fails here. */
598 if (n
>= loop
->temp_dim
)
600 /* Callee allocated arrays may not have a known bound yet. */
602 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
603 loop
->to
[n
], loop
->from
[n
]);
604 loop
->from
[n
] = gfc_index_zero_node
;
607 info
->delta
[dim
] = gfc_index_zero_node
;
608 info
->start
[dim
] = gfc_index_zero_node
;
609 info
->end
[dim
] = gfc_index_zero_node
;
610 info
->stride
[dim
] = gfc_index_one_node
;
611 info
->dim
[dim
] = dim
;
614 /* Initialize the descriptor. */
616 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1,
618 desc
= gfc_create_var (type
, "atmp");
619 GFC_DECL_PACKED_ARRAY (desc
) = 1;
621 info
->descriptor
= desc
;
622 size
= gfc_index_one_node
;
624 /* Fill in the array dtype. */
625 tmp
= gfc_conv_descriptor_dtype (desc
);
626 gfc_add_modify_expr (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
629 Fill in the bounds and stride. This is a packed array, so:
632 for (n = 0; n < rank; n++)
635 delta = ubound[n] + 1 - lbound[n];
638 size = size * sizeof(element);
643 for (n
= 0; n
< info
->dimen
; n
++)
645 if (loop
->to
[n
] == NULL_TREE
)
647 /* For a callee allocated array express the loop bounds in terms
648 of the descriptor fields. */
650 fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
651 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
652 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
658 /* Store the stride and bound components in the descriptor. */
659 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
660 gfc_add_modify_expr (pre
, tmp
, size
);
662 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
663 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
665 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
666 gfc_add_modify_expr (pre
, tmp
, loop
->to
[n
]);
668 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
669 loop
->to
[n
], gfc_index_one_node
);
671 /* Check whether the size for this dimension is negative. */
672 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
673 gfc_index_zero_node
);
674 cond
= gfc_evaluate_now (cond
, pre
);
679 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
681 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
682 size
= gfc_evaluate_now (size
, pre
);
685 /* Get the size of the array. */
687 if (size
&& !callee_alloc
)
689 /* If or_expr is true, then the extent in at least one
690 dimension is zero and the size is set to zero. */
691 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
,
692 or_expr
, gfc_index_zero_node
, size
);
695 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
696 fold_convert (gfc_array_index_type
,
697 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
705 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, dynamic
,
708 if (info
->dimen
> loop
->temp_dim
)
709 loop
->temp_dim
= info
->dimen
;
715 /* Generate code to transpose array EXPR by creating a new descriptor
716 in which the dimension specifications have been reversed. */
719 gfc_conv_array_transpose (gfc_se
* se
, gfc_expr
* expr
)
721 tree dest
, src
, dest_index
, src_index
;
723 gfc_ss_info
*dest_info
, *src_info
;
724 gfc_ss
*dest_ss
, *src_ss
;
730 src_ss
= gfc_walk_expr (expr
);
733 src_info
= &src_ss
->data
.info
;
734 dest_info
= &dest_ss
->data
.info
;
735 gcc_assert (dest_info
->dimen
== 2);
736 gcc_assert (src_info
->dimen
== 2);
738 /* Get a descriptor for EXPR. */
739 gfc_init_se (&src_se
, NULL
);
740 gfc_conv_expr_descriptor (&src_se
, expr
, src_ss
);
741 gfc_add_block_to_block (&se
->pre
, &src_se
.pre
);
742 gfc_add_block_to_block (&se
->post
, &src_se
.post
);
745 /* Allocate a new descriptor for the return value. */
746 dest
= gfc_create_var (TREE_TYPE (src
), "atmp");
747 dest_info
->descriptor
= dest
;
750 /* Copy across the dtype field. */
751 gfc_add_modify_expr (&se
->pre
,
752 gfc_conv_descriptor_dtype (dest
),
753 gfc_conv_descriptor_dtype (src
));
755 /* Copy the dimension information, renumbering dimension 1 to 0 and
757 for (n
= 0; n
< 2; n
++)
759 dest_info
->delta
[n
] = gfc_index_zero_node
;
760 dest_info
->start
[n
] = gfc_index_zero_node
;
761 dest_info
->end
[n
] = gfc_index_zero_node
;
762 dest_info
->stride
[n
] = gfc_index_one_node
;
763 dest_info
->dim
[n
] = n
;
765 dest_index
= gfc_rank_cst
[n
];
766 src_index
= gfc_rank_cst
[1 - n
];
768 gfc_add_modify_expr (&se
->pre
,
769 gfc_conv_descriptor_stride (dest
, dest_index
),
770 gfc_conv_descriptor_stride (src
, src_index
));
772 gfc_add_modify_expr (&se
->pre
,
773 gfc_conv_descriptor_lbound (dest
, dest_index
),
774 gfc_conv_descriptor_lbound (src
, src_index
));
776 gfc_add_modify_expr (&se
->pre
,
777 gfc_conv_descriptor_ubound (dest
, dest_index
),
778 gfc_conv_descriptor_ubound (src
, src_index
));
782 gcc_assert (integer_zerop (loop
->from
[n
]));
784 fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
785 gfc_conv_descriptor_ubound (dest
, dest_index
),
786 gfc_conv_descriptor_lbound (dest
, dest_index
));
790 /* Copy the data pointer. */
791 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
792 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
794 /* Copy the offset. This is not changed by transposition; the top-left
795 element is still at the same offset as before, except where the loop
797 if (!integer_zerop (loop
->from
[0]))
798 dest_info
->offset
= gfc_conv_descriptor_offset (src
);
800 dest_info
->offset
= gfc_index_zero_node
;
802 gfc_add_modify_expr (&se
->pre
,
803 gfc_conv_descriptor_offset (dest
),
806 if (dest_info
->dimen
> loop
->temp_dim
)
807 loop
->temp_dim
= dest_info
->dimen
;
811 /* Return the number of iterations in a loop that starts at START,
812 ends at END, and has step STEP. */
815 gfc_get_iteration_count (tree start
, tree end
, tree step
)
820 type
= TREE_TYPE (step
);
821 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
822 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
823 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
824 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
825 return fold_convert (gfc_array_index_type
, tmp
);
829 /* Extend the data in array DESC by EXTRA elements. */
832 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
839 if (integer_zerop (extra
))
842 ubound
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
844 /* Add EXTRA to the upper bound. */
845 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
846 gfc_add_modify_expr (pblock
, ubound
, tmp
);
848 /* Get the value of the current data pointer. */
849 arg0
= gfc_conv_descriptor_data_get (desc
);
851 /* Calculate the new array size. */
852 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
853 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
854 ubound
, gfc_index_one_node
);
855 arg1
= fold_build2 (MULT_EXPR
, size_type_node
,
856 fold_convert (size_type_node
, tmp
),
857 fold_convert (size_type_node
, size
));
859 /* Call the realloc() function. */
860 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
861 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
865 /* Return true if the bounds of iterator I can only be determined
869 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
871 return (i
->start
->expr_type
!= EXPR_CONSTANT
872 || i
->end
->expr_type
!= EXPR_CONSTANT
873 || i
->step
->expr_type
!= EXPR_CONSTANT
);
877 /* Split the size of constructor element EXPR into the sum of two terms,
878 one of which can be determined at compile time and one of which must
879 be calculated at run time. Set *SIZE to the former and return true
880 if the latter might be nonzero. */
883 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
885 if (expr
->expr_type
== EXPR_ARRAY
)
886 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
887 else if (expr
->rank
> 0)
889 /* Calculate everything at run time. */
890 mpz_set_ui (*size
, 0);
895 /* A single element. */
896 mpz_set_ui (*size
, 1);
902 /* Like gfc_get_array_constructor_element_size, but applied to the whole
903 of array constructor C. */
906 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor
* c
)
913 mpz_set_ui (*size
, 0);
918 for (; c
; c
= c
->next
)
921 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
925 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
928 /* Multiply the static part of the element size by the
929 number of iterations. */
930 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
931 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
932 mpz_add_ui (val
, val
, 1);
933 if (mpz_sgn (val
) > 0)
934 mpz_mul (len
, len
, val
);
938 mpz_add (*size
, *size
, len
);
947 /* Make sure offset is a variable. */
950 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
953 /* We should have already created the offset variable. We cannot
954 create it here because we may be in an inner scope. */
955 gcc_assert (*offsetvar
!= NULL_TREE
);
956 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
957 *poffset
= *offsetvar
;
958 TREE_USED (*offsetvar
) = 1;
962 /* Variables needed for bounds-checking. */
963 static bool first_len
;
964 static tree first_len_val
;
965 static bool typespec_chararray_ctor
;
968 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
969 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
973 gfc_conv_expr (se
, expr
);
975 /* Store the value. */
976 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc
));
977 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
979 if (expr
->ts
.type
== BT_CHARACTER
)
981 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
984 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
985 esize
= fold_convert (gfc_charlen_type_node
, esize
);
986 esize
= fold_build2 (TRUNC_DIV_EXPR
, gfc_charlen_type_node
, esize
,
987 build_int_cst (gfc_charlen_type_node
,
988 gfc_character_kinds
[i
].bit_size
/ 8));
990 gfc_conv_string_parameter (se
);
991 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
993 /* The temporary is an array of pointers. */
994 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
995 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
999 /* The temporary is an array of string values. */
1000 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1001 /* We know the temporary and the value will be the same length,
1002 so can use memcpy. */
1003 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1004 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1006 if (flag_bounds_check
&& !typespec_chararray_ctor
)
1010 gfc_add_modify_expr (&se
->pre
, first_len_val
,
1016 /* Verify that all constructor elements are of the same
1018 tree cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
1019 first_len_val
, se
->string_length
);
1020 gfc_trans_runtime_check
1021 (cond
, &se
->pre
, &expr
->where
,
1022 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1023 fold_convert (long_integer_type_node
, first_len_val
),
1024 fold_convert (long_integer_type_node
, se
->string_length
));
1030 /* TODO: Should the frontend already have done this conversion? */
1031 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1032 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
1035 gfc_add_block_to_block (pblock
, &se
->pre
);
1036 gfc_add_block_to_block (pblock
, &se
->post
);
1040 /* Add the contents of an array to the constructor. DYNAMIC is as for
1041 gfc_trans_array_constructor_value. */
1044 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1045 tree type ATTRIBUTE_UNUSED
,
1046 tree desc
, gfc_expr
* expr
,
1047 tree
* poffset
, tree
* offsetvar
,
1058 /* We need this to be a variable so we can increment it. */
1059 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1061 gfc_init_se (&se
, NULL
);
1063 /* Walk the array expression. */
1064 ss
= gfc_walk_expr (expr
);
1065 gcc_assert (ss
!= gfc_ss_terminator
);
1067 /* Initialize the scalarizer. */
1068 gfc_init_loopinfo (&loop
);
1069 gfc_add_ss_to_loop (&loop
, ss
);
1071 /* Initialize the loop. */
1072 gfc_conv_ss_startstride (&loop
);
1073 gfc_conv_loop_setup (&loop
);
1075 /* Make sure the constructed array has room for the new data. */
1078 /* Set SIZE to the total number of elements in the subarray. */
1079 size
= gfc_index_one_node
;
1080 for (n
= 0; n
< loop
.dimen
; n
++)
1082 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1083 gfc_index_one_node
);
1084 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1087 /* Grow the constructed array by SIZE elements. */
1088 gfc_grow_array (&loop
.pre
, desc
, size
);
1091 /* Make the loop body. */
1092 gfc_mark_ss_chain_used (ss
, 1);
1093 gfc_start_scalarized_body (&loop
, &body
);
1094 gfc_copy_loopinfo_to_se (&se
, &loop
);
1097 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1098 gcc_assert (se
.ss
== gfc_ss_terminator
);
1100 /* Increment the offset. */
1101 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1102 *poffset
, gfc_index_one_node
);
1103 gfc_add_modify_expr (&body
, *poffset
, tmp
);
1105 /* Finish the loop. */
1106 gfc_trans_scalarizing_loops (&loop
, &body
);
1107 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1108 tmp
= gfc_finish_block (&loop
.pre
);
1109 gfc_add_expr_to_block (pblock
, tmp
);
1111 gfc_cleanup_loop (&loop
);
1115 /* Assign the values to the elements of an array constructor. DYNAMIC
1116 is true if descriptor DESC only contains enough data for the static
1117 size calculated by gfc_get_array_constructor_size. When true, memory
1118 for the dynamic parts must be allocated using realloc. */
1121 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1122 tree desc
, gfc_constructor
* c
,
1123 tree
* poffset
, tree
* offsetvar
,
1132 for (; c
; c
= c
->next
)
1134 /* If this is an iterator or an array, the offset must be a variable. */
1135 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1136 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1138 gfc_start_block (&body
);
1140 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1142 /* Array constructors can be nested. */
1143 gfc_trans_array_constructor_value (&body
, type
, desc
,
1144 c
->expr
->value
.constructor
,
1145 poffset
, offsetvar
, dynamic
);
1147 else if (c
->expr
->rank
> 0)
1149 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1150 poffset
, offsetvar
, dynamic
);
1154 /* This code really upsets the gimplifier so don't bother for now. */
1161 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1168 /* Scalar values. */
1169 gfc_init_se (&se
, NULL
);
1170 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1173 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1174 *poffset
, gfc_index_one_node
);
1178 /* Collect multiple scalar constants into a constructor. */
1186 /* Count the number of consecutive scalar constants. */
1187 while (p
&& !(p
->iterator
1188 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1190 gfc_init_se (&se
, NULL
);
1191 gfc_conv_constant (&se
, p
->expr
);
1193 /* For constant character array constructors we build
1194 an array of pointers. */
1195 if (p
->expr
->ts
.type
== BT_CHARACTER
1196 && POINTER_TYPE_P (type
))
1197 se
.expr
= gfc_build_addr_expr
1198 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1201 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1206 bound
= build_int_cst (NULL_TREE
, n
- 1);
1207 /* Create an array type to hold them. */
1208 tmptype
= build_range_type (gfc_array_index_type
,
1209 gfc_index_zero_node
, bound
);
1210 tmptype
= build_array_type (type
, tmptype
);
1212 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1213 TREE_CONSTANT (init
) = 1;
1214 TREE_STATIC (init
) = 1;
1215 /* Create a static variable to hold the data. */
1216 tmp
= gfc_create_var (tmptype
, "data");
1217 TREE_STATIC (tmp
) = 1;
1218 TREE_CONSTANT (tmp
) = 1;
1219 TREE_READONLY (tmp
) = 1;
1220 DECL_INITIAL (tmp
) = init
;
1223 /* Use BUILTIN_MEMCPY to assign the values. */
1224 tmp
= gfc_conv_descriptor_data_get (desc
);
1225 tmp
= build_fold_indirect_ref (tmp
);
1226 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1227 tmp
= build_fold_addr_expr (tmp
);
1228 init
= build_fold_addr_expr (init
);
1230 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1231 bound
= build_int_cst (NULL_TREE
, n
* size
);
1232 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
1234 gfc_add_expr_to_block (&body
, tmp
);
1236 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1238 build_int_cst (gfc_array_index_type
, n
));
1240 if (!INTEGER_CST_P (*poffset
))
1242 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
1243 *poffset
= *offsetvar
;
1247 /* The frontend should already have done any expansions possible
1251 /* Pass the code as is. */
1252 tmp
= gfc_finish_block (&body
);
1253 gfc_add_expr_to_block (pblock
, tmp
);
1257 /* Build the implied do-loop. */
1267 loopbody
= gfc_finish_block (&body
);
1269 if (c
->iterator
->var
->symtree
->n
.sym
->backend_decl
)
1271 gfc_init_se (&se
, NULL
);
1272 gfc_conv_expr (&se
, c
->iterator
->var
);
1273 gfc_add_block_to_block (pblock
, &se
.pre
);
1278 /* If the iterator appears in a specification expression in
1279 an interface mapping, we need to make a temp for the loop
1280 variable because it is not declared locally. */
1281 loopvar
= gfc_typenode_for_spec (&c
->iterator
->var
->ts
);
1282 loopvar
= gfc_create_var (loopvar
, "loopvar");
1285 /* Make a temporary, store the current value in that
1286 and return it, once the loop is done. */
1287 tmp_loopvar
= gfc_create_var (TREE_TYPE (loopvar
), "loopvar");
1288 gfc_add_modify_expr (pblock
, tmp_loopvar
, loopvar
);
1290 /* Initialize the loop. */
1291 gfc_init_se (&se
, NULL
);
1292 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1293 gfc_add_block_to_block (pblock
, &se
.pre
);
1294 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
1296 gfc_init_se (&se
, NULL
);
1297 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1298 gfc_add_block_to_block (pblock
, &se
.pre
);
1299 end
= gfc_evaluate_now (se
.expr
, pblock
);
1301 gfc_init_se (&se
, NULL
);
1302 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1303 gfc_add_block_to_block (pblock
, &se
.pre
);
1304 step
= gfc_evaluate_now (se
.expr
, pblock
);
1306 /* If this array expands dynamically, and the number of iterations
1307 is not constant, we won't have allocated space for the static
1308 part of C->EXPR's size. Do that now. */
1309 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1311 /* Get the number of iterations. */
1312 tmp
= gfc_get_iteration_count (loopvar
, end
, step
);
1314 /* Get the static part of C->EXPR's size. */
1315 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1316 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1318 /* Grow the array by TMP * TMP2 elements. */
1319 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1320 gfc_grow_array (pblock
, desc
, tmp
);
1323 /* Generate the loop body. */
1324 exit_label
= gfc_build_label_decl (NULL_TREE
);
1325 gfc_start_block (&body
);
1327 /* Generate the exit condition. Depending on the sign of
1328 the step variable we have to generate the correct
1330 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1331 build_int_cst (TREE_TYPE (step
), 0));
1332 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1333 fold_build2 (GT_EXPR
, boolean_type_node
,
1335 fold_build2 (LT_EXPR
, boolean_type_node
,
1337 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1338 TREE_USED (exit_label
) = 1;
1339 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1340 gfc_add_expr_to_block (&body
, tmp
);
1342 /* The main loop body. */
1343 gfc_add_expr_to_block (&body
, loopbody
);
1345 /* Increase loop variable by step. */
1346 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
1347 gfc_add_modify_expr (&body
, loopvar
, tmp
);
1349 /* Finish the loop. */
1350 tmp
= gfc_finish_block (&body
);
1351 tmp
= build1_v (LOOP_EXPR
, tmp
);
1352 gfc_add_expr_to_block (pblock
, tmp
);
1354 /* Add the exit label. */
1355 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1356 gfc_add_expr_to_block (pblock
, tmp
);
1358 /* Restore the original value of the loop counter. */
1359 gfc_add_modify_expr (pblock
, loopvar
, tmp_loopvar
);
1366 /* Figure out the string length of a variable reference expression.
1367 Used by get_array_ctor_strlen. */
1370 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1376 /* Don't bother if we already know the length is a constant. */
1377 if (*len
&& INTEGER_CST_P (*len
))
1380 ts
= &expr
->symtree
->n
.sym
->ts
;
1381 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1386 /* Array references don't change the string length. */
1390 /* Use the length of the component. */
1391 ts
= &ref
->u
.c
.component
->ts
;
1395 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1396 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1398 mpz_init_set_ui (char_len
, 1);
1399 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1400 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1401 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1402 *len
= convert (gfc_charlen_type_node
, *len
);
1403 mpz_clear (char_len
);
1407 /* TODO: Substrings are tricky because we can't evaluate the
1408 expression more than once. For now we just give up, and hope
1409 we can figure it out elsewhere. */
1414 *len
= ts
->cl
->backend_decl
;
1418 /* A catch-all to obtain the string length for anything that is not a
1419 constant, array or variable. */
1421 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1426 /* Don't bother if we already know the length is a constant. */
1427 if (*len
&& INTEGER_CST_P (*len
))
1430 if (!e
->ref
&& e
->ts
.cl
&& e
->ts
.cl
->length
1431 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1434 gfc_conv_const_charlen (e
->ts
.cl
);
1435 *len
= e
->ts
.cl
->backend_decl
;
1439 /* Otherwise, be brutal even if inefficient. */
1440 ss
= gfc_walk_expr (e
);
1441 gfc_init_se (&se
, NULL
);
1443 /* No function call, in case of side effects. */
1444 se
.no_function_call
= 1;
1445 if (ss
== gfc_ss_terminator
)
1446 gfc_conv_expr (&se
, e
);
1448 gfc_conv_expr_descriptor (&se
, e
, ss
);
1450 /* Fix the value. */
1451 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1453 gfc_add_block_to_block (block
, &se
.pre
);
1454 gfc_add_block_to_block (block
, &se
.post
);
1456 e
->ts
.cl
->backend_decl
= *len
;
1461 /* Figure out the string length of a character array constructor.
1462 If len is NULL, don't calculate the length; this happens for recursive calls
1463 when a sub-array-constructor is an element but not at the first position,
1464 so when we're not interested in the length.
1465 Returns TRUE if all elements are character constants. */
1468 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor
* c
, tree
* len
)
1477 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1481 /* Loop over all constructor elements to find out is_const, but in len we
1482 want to store the length of the first, not the last, element. We can
1483 of course exit the loop as soon as is_const is found to be false. */
1484 for (; c
&& is_const
; c
= c
->next
)
1486 switch (c
->expr
->expr_type
)
1489 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1490 *len
= build_int_cstu (gfc_charlen_type_node
,
1491 c
->expr
->value
.character
.length
);
1495 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1502 get_array_ctor_var_strlen (c
->expr
, len
);
1508 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1512 /* After the first iteration, we don't want the length modified. */
1519 /* Check whether the array constructor C consists entirely of constant
1520 elements, and if so returns the number of those elements, otherwise
1521 return zero. Note, an empty or NULL array constructor returns zero. */
1523 unsigned HOST_WIDE_INT
1524 gfc_constant_array_constructor_p (gfc_constructor
* c
)
1526 unsigned HOST_WIDE_INT nelem
= 0;
1531 || c
->expr
->rank
> 0
1532 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1541 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1542 and the tree type of it's elements, TYPE, return a static constant
1543 variable that is compile-time initialized. */
1546 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1548 tree tmptype
, list
, init
, tmp
;
1549 HOST_WIDE_INT nelem
;
1555 /* First traverse the constructor list, converting the constants
1556 to tree to build an initializer. */
1559 c
= expr
->value
.constructor
;
1562 gfc_init_se (&se
, NULL
);
1563 gfc_conv_constant (&se
, c
->expr
);
1564 if (c
->expr
->ts
.type
== BT_CHARACTER
&& POINTER_TYPE_P (type
))
1565 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
1567 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1572 /* Next determine the tree type for the array. We use the gfortran
1573 front-end's gfc_get_nodesc_array_type in order to create a suitable
1574 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1576 memset (&as
, 0, sizeof (gfc_array_spec
));
1578 as
.rank
= expr
->rank
;
1579 as
.type
= AS_EXPLICIT
;
1582 as
.lower
[0] = gfc_int_expr (0);
1583 as
.upper
[0] = gfc_int_expr (nelem
- 1);
1586 for (i
= 0; i
< expr
->rank
; i
++)
1588 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1589 as
.lower
[i
] = gfc_int_expr (0);
1590 as
.upper
[i
] = gfc_int_expr (tmp
- 1);
1593 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
);
1595 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1597 TREE_CONSTANT (init
) = 1;
1598 TREE_STATIC (init
) = 1;
1600 tmp
= gfc_create_var (tmptype
, "A");
1601 TREE_STATIC (tmp
) = 1;
1602 TREE_CONSTANT (tmp
) = 1;
1603 TREE_READONLY (tmp
) = 1;
1604 DECL_INITIAL (tmp
) = init
;
1610 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1611 This mostly initializes the scalarizer state info structure with the
1612 appropriate values to directly use the array created by the function
1613 gfc_build_constant_array_constructor. */
1616 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1617 gfc_ss
* ss
, tree type
)
1623 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1625 info
= &ss
->data
.info
;
1627 info
->descriptor
= tmp
;
1628 info
->data
= build_fold_addr_expr (tmp
);
1629 info
->offset
= fold_build1 (NEGATE_EXPR
, gfc_array_index_type
,
1632 for (i
= 0; i
< info
->dimen
; i
++)
1634 info
->delta
[i
] = gfc_index_zero_node
;
1635 info
->start
[i
] = gfc_index_zero_node
;
1636 info
->end
[i
] = gfc_index_zero_node
;
1637 info
->stride
[i
] = gfc_index_one_node
;
1641 if (info
->dimen
> loop
->temp_dim
)
1642 loop
->temp_dim
= info
->dimen
;
1645 /* Helper routine of gfc_trans_array_constructor to determine if the
1646 bounds of the loop specified by LOOP are constant and simple enough
1647 to use with gfc_trans_constant_array_constructor. Returns the
1648 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1651 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1653 tree size
= gfc_index_one_node
;
1657 for (i
= 0; i
< loop
->dimen
; i
++)
1659 /* If the bounds aren't constant, return NULL_TREE. */
1660 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1662 if (!integer_zerop (loop
->from
[i
]))
1664 /* Only allow nonzero "from" in one-dimensional arrays. */
1665 if (loop
->dimen
!= 1)
1667 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1668 loop
->to
[i
], loop
->from
[i
]);
1672 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1673 tmp
, gfc_index_one_node
);
1674 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1681 /* Array constructors are handled by constructing a temporary, then using that
1682 within the scalarization loop. This is not optimal, but seems by far the
1686 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1696 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1697 typespec was given for the array constructor. */
1698 typespec_chararray_ctor
= (ss
->expr
->ts
.cl
1699 && ss
->expr
->ts
.cl
->length_from_typespec
);
1701 if (flag_bounds_check
&& ss
->expr
->ts
.type
== BT_CHARACTER
1702 && !typespec_chararray_ctor
)
1704 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
1708 ss
->data
.info
.dimen
= loop
->dimen
;
1710 c
= ss
->expr
->value
.constructor
;
1711 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1715 /* get_array_ctor_strlen walks the elements of the constructor, if a
1716 typespec was given, we already know the string length and want the one
1718 if (typespec_chararray_ctor
&& ss
->expr
->ts
.cl
->length
1719 && ss
->expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1723 const_string
= false;
1724 gfc_init_se (&length_se
, NULL
);
1725 gfc_conv_expr_type (&length_se
, ss
->expr
->ts
.cl
->length
,
1726 gfc_charlen_type_node
);
1727 ss
->string_length
= length_se
.expr
;
1728 gfc_add_block_to_block (&loop
->pre
, &length_se
.pre
);
1729 gfc_add_block_to_block (&loop
->post
, &length_se
.post
);
1732 const_string
= get_array_ctor_strlen (&loop
->pre
, c
,
1733 &ss
->string_length
);
1735 /* Complex character array constructors should have been taken care of
1736 and not end up here. */
1737 gcc_assert (ss
->string_length
);
1739 ss
->expr
->ts
.cl
->backend_decl
= ss
->string_length
;
1741 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1743 type
= build_pointer_type (type
);
1746 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1748 /* See if the constructor determines the loop bounds. */
1751 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1753 /* We have a multidimensional parameter. */
1755 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1757 loop
->from
[n
] = gfc_index_zero_node
;
1758 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1759 gfc_index_integer_kind
);
1760 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1761 loop
->to
[n
], gfc_index_one_node
);
1765 if (loop
->to
[0] == NULL_TREE
)
1769 /* We should have a 1-dimensional, zero-based loop. */
1770 gcc_assert (loop
->dimen
== 1);
1771 gcc_assert (integer_zerop (loop
->from
[0]));
1773 /* Split the constructor size into a static part and a dynamic part.
1774 Allocate the static size up-front and record whether the dynamic
1775 size might be nonzero. */
1777 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1778 mpz_sub_ui (size
, size
, 1);
1779 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1783 /* Special case constant array constructors. */
1786 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1789 tree size
= constant_array_constructor_loop_size (loop
);
1790 if (size
&& compare_tree_int (size
, nelem
) == 0)
1792 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1798 /* Temporarily reset the loop variables, so that the returned temporary
1799 has the right size and bounds. This seems only to be necessary for
1801 if (!integer_zerop (loop
->from
[0]) && loop
->dimen
== 1)
1803 loopfrom
= loop
->from
[0];
1804 loop
->from
[0] = gfc_index_zero_node
;
1805 loop
->to
[0] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1806 loop
->to
[0], loopfrom
);
1809 loopfrom
= NULL_TREE
;
1811 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1812 type
, dynamic
, true, false);
1814 if (loopfrom
!= NULL_TREE
)
1816 loop
->from
[0] = loopfrom
;
1817 loop
->to
[0] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1818 loop
->to
[0], loopfrom
);
1819 /* In the case of a non-zero from, the temporary needs an offset
1820 so that subsequent indexing is correct. */
1821 ss
->data
.info
.offset
= fold_build1 (NEGATE_EXPR
,
1822 gfc_array_index_type
,
1826 desc
= ss
->data
.info
.descriptor
;
1827 offset
= gfc_index_zero_node
;
1828 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1829 TREE_NO_WARNING (offsetvar
) = 1;
1830 TREE_USED (offsetvar
) = 0;
1831 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1832 &offset
, &offsetvar
, dynamic
);
1834 /* If the array grows dynamically, the upper bound of the loop variable
1835 is determined by the array's final upper bound. */
1837 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1839 if (TREE_USED (offsetvar
))
1840 pushdecl (offsetvar
);
1842 gcc_assert (INTEGER_CST_P (offset
));
1844 /* Disable bound checking for now because it's probably broken. */
1845 if (flag_bounds_check
)
1853 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1854 called after evaluating all of INFO's vector dimensions. Go through
1855 each such vector dimension and see if we can now fill in any missing
1859 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1868 for (n
= 0; n
< loop
->dimen
; n
++)
1871 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1872 && loop
->to
[n
] == NULL
)
1874 /* Loop variable N indexes vector dimension DIM, and we don't
1875 yet know the upper bound of loop variable N. Set it to the
1876 difference between the vector's upper and lower bounds. */
1877 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1878 gcc_assert (info
->subscript
[dim
]
1879 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1881 gfc_init_se (&se
, NULL
);
1882 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1883 zero
= gfc_rank_cst
[0];
1884 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1885 gfc_conv_descriptor_ubound (desc
, zero
),
1886 gfc_conv_descriptor_lbound (desc
, zero
));
1887 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1894 /* Add the pre and post chains for all the scalar expressions in a SS chain
1895 to loop. This is called after the loop parameters have been calculated,
1896 but before the actual scalarizing loops. */
1899 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1904 /* TODO: This can generate bad code if there are ordering dependencies.
1905 eg. a callee allocated function and an unknown size constructor. */
1906 gcc_assert (ss
!= NULL
);
1908 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1915 /* Scalar expression. Evaluate this now. This includes elemental
1916 dimension indices, but not array section bounds. */
1917 gfc_init_se (&se
, NULL
);
1918 gfc_conv_expr (&se
, ss
->expr
);
1919 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1921 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1923 /* Move the evaluation of scalar expressions outside the
1924 scalarization loop, except for WHERE assignments. */
1926 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1928 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1929 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1932 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1934 ss
->data
.scalar
.expr
= se
.expr
;
1935 ss
->string_length
= se
.string_length
;
1938 case GFC_SS_REFERENCE
:
1939 /* Scalar reference. Evaluate this now. */
1940 gfc_init_se (&se
, NULL
);
1941 gfc_conv_expr_reference (&se
, ss
->expr
);
1942 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1943 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1945 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1946 ss
->string_length
= se
.string_length
;
1949 case GFC_SS_SECTION
:
1950 /* Add the expressions for scalar and vector subscripts. */
1951 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1952 if (ss
->data
.info
.subscript
[n
])
1953 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1955 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1959 /* Get the vector's descriptor and store it in SS. */
1960 gfc_init_se (&se
, NULL
);
1961 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1962 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1963 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1964 ss
->data
.info
.descriptor
= se
.expr
;
1967 case GFC_SS_INTRINSIC
:
1968 gfc_add_intrinsic_ss_code (loop
, ss
);
1971 case GFC_SS_FUNCTION
:
1972 /* Array function return value. We call the function and save its
1973 result in a temporary for use inside the loop. */
1974 gfc_init_se (&se
, NULL
);
1977 gfc_conv_expr (&se
, ss
->expr
);
1978 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1979 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1980 ss
->string_length
= se
.string_length
;
1983 case GFC_SS_CONSTRUCTOR
:
1984 if (ss
->expr
->ts
.type
== BT_CHARACTER
1985 && ss
->string_length
== NULL
1987 && ss
->expr
->ts
.cl
->length
)
1989 gfc_init_se (&se
, NULL
);
1990 gfc_conv_expr_type (&se
, ss
->expr
->ts
.cl
->length
,
1991 gfc_charlen_type_node
);
1992 ss
->string_length
= se
.expr
;
1993 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1994 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1996 gfc_trans_array_constructor (loop
, ss
);
2000 case GFC_SS_COMPONENT
:
2001 /* Do nothing. These are handled elsewhere. */
2011 /* Translate expressions for the descriptor and data pointer of a SS. */
2015 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2020 /* Get the descriptor for the array to be scalarized. */
2021 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
2022 gfc_init_se (&se
, NULL
);
2023 se
.descriptor_only
= 1;
2024 gfc_conv_expr_lhs (&se
, ss
->expr
);
2025 gfc_add_block_to_block (block
, &se
.pre
);
2026 ss
->data
.info
.descriptor
= se
.expr
;
2027 ss
->string_length
= se
.string_length
;
2031 /* Also the data pointer. */
2032 tmp
= gfc_conv_array_data (se
.expr
);
2033 /* If this is a variable or address of a variable we use it directly.
2034 Otherwise we must evaluate it now to avoid breaking dependency
2035 analysis by pulling the expressions for elemental array indices
2038 || (TREE_CODE (tmp
) == ADDR_EXPR
2039 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2040 tmp
= gfc_evaluate_now (tmp
, block
);
2041 ss
->data
.info
.data
= tmp
;
2043 tmp
= gfc_conv_array_offset (se
.expr
);
2044 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
2049 /* Initialize a gfc_loopinfo structure. */
2052 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2056 memset (loop
, 0, sizeof (gfc_loopinfo
));
2057 gfc_init_block (&loop
->pre
);
2058 gfc_init_block (&loop
->post
);
2060 /* Initially scalarize in order. */
2061 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2064 loop
->ss
= gfc_ss_terminator
;
2068 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2072 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2078 /* Return an expression for the data pointer of an array. */
2081 gfc_conv_array_data (tree descriptor
)
2085 type
= TREE_TYPE (descriptor
);
2086 if (GFC_ARRAY_TYPE_P (type
))
2088 if (TREE_CODE (type
) == POINTER_TYPE
)
2092 /* Descriptorless arrays. */
2093 return build_fold_addr_expr (descriptor
);
2097 return gfc_conv_descriptor_data_get (descriptor
);
2101 /* Return an expression for the base offset of an array. */
2104 gfc_conv_array_offset (tree descriptor
)
2108 type
= TREE_TYPE (descriptor
);
2109 if (GFC_ARRAY_TYPE_P (type
))
2110 return GFC_TYPE_ARRAY_OFFSET (type
);
2112 return gfc_conv_descriptor_offset (descriptor
);
2116 /* Get an expression for the array stride. */
2119 gfc_conv_array_stride (tree descriptor
, int dim
)
2124 type
= TREE_TYPE (descriptor
);
2126 /* For descriptorless arrays use the array size. */
2127 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2128 if (tmp
!= NULL_TREE
)
2131 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
2136 /* Like gfc_conv_array_stride, but for the lower bound. */
2139 gfc_conv_array_lbound (tree descriptor
, int dim
)
2144 type
= TREE_TYPE (descriptor
);
2146 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2147 if (tmp
!= NULL_TREE
)
2150 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
2155 /* Like gfc_conv_array_stride, but for the upper bound. */
2158 gfc_conv_array_ubound (tree descriptor
, int dim
)
2163 type
= TREE_TYPE (descriptor
);
2165 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2166 if (tmp
!= NULL_TREE
)
2169 /* This should only ever happen when passing an assumed shape array
2170 as an actual parameter. The value will never be used. */
2171 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2172 return gfc_index_zero_node
;
2174 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
2179 /* Generate code to perform an array index bound check. */
2182 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2183 locus
* where
, bool check_upper
)
2188 const char * name
= NULL
;
2190 if (!flag_bounds_check
)
2193 index
= gfc_evaluate_now (index
, &se
->pre
);
2195 /* We find a name for the error message. */
2197 name
= se
->ss
->expr
->symtree
->name
;
2199 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2200 && se
->loop
->ss
->expr
->symtree
)
2201 name
= se
->loop
->ss
->expr
->symtree
->name
;
2203 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2204 && se
->loop
->ss
->loop_chain
->expr
2205 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2206 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2208 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2209 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2210 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2212 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2214 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2215 && se
->loop
->ss
->expr
->value
.function
.name
)
2216 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2218 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2219 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2220 name
= "unnamed constant";
2223 /* Check lower bound. */
2224 tmp
= gfc_conv_array_lbound (descriptor
, n
);
2225 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
2227 asprintf (&msg
, "%s for array '%s', lower bound of dimension %d exceeded"
2228 "(%%ld < %%ld)", gfc_msg_fault
, name
, n
+1);
2230 asprintf (&msg
, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2231 gfc_msg_fault
, n
+1);
2232 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
2233 fold_convert (long_integer_type_node
, index
),
2234 fold_convert (long_integer_type_node
, tmp
));
2237 /* Check upper bound. */
2240 tmp
= gfc_conv_array_ubound (descriptor
, n
);
2241 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
2243 asprintf (&msg
, "%s for array '%s', upper bound of dimension %d "
2244 " exceeded (%%ld > %%ld)", gfc_msg_fault
, name
, n
+1);
2246 asprintf (&msg
, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2247 gfc_msg_fault
, n
+1);
2248 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
2249 fold_convert (long_integer_type_node
, index
),
2250 fold_convert (long_integer_type_node
, tmp
));
2258 /* Return the offset for an index. Performs bound checking for elemental
2259 dimensions. Single element references are processed separately. */
2262 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2263 gfc_array_ref
* ar
, tree stride
)
2269 /* Get the index into the array for this dimension. */
2272 gcc_assert (ar
->type
!= AR_ELEMENT
);
2273 switch (ar
->dimen_type
[dim
])
2276 /* Elemental dimension. */
2277 gcc_assert (info
->subscript
[dim
]
2278 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2279 /* We've already translated this value outside the loop. */
2280 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2282 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2283 index
, dim
, &ar
->where
,
2284 (ar
->as
->type
!= AS_ASSUMED_SIZE
2285 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2289 gcc_assert (info
&& se
->loop
);
2290 gcc_assert (info
->subscript
[dim
]
2291 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2292 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2294 /* Get a zero-based index into the vector. */
2295 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2296 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2298 /* Multiply the index by the stride. */
2299 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2300 index
, gfc_conv_array_stride (desc
, 0));
2302 /* Read the vector to get an index into info->descriptor. */
2303 data
= build_fold_indirect_ref (gfc_conv_array_data (desc
));
2304 index
= gfc_build_array_ref (data
, index
, NULL
);
2305 index
= gfc_evaluate_now (index
, &se
->pre
);
2307 /* Do any bounds checking on the final info->descriptor index. */
2308 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2309 index
, dim
, &ar
->where
,
2310 (ar
->as
->type
!= AS_ASSUMED_SIZE
2311 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2315 /* Scalarized dimension. */
2316 gcc_assert (info
&& se
->loop
);
2318 /* Multiply the loop variable by the stride and delta. */
2319 index
= se
->loop
->loopvar
[i
];
2320 if (!integer_onep (info
->stride
[i
]))
2321 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2323 if (!integer_zerop (info
->delta
[i
]))
2324 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2334 /* Temporary array or derived type component. */
2335 gcc_assert (se
->loop
);
2336 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2337 if (!integer_zerop (info
->delta
[i
]))
2338 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2339 index
, info
->delta
[i
]);
2342 /* Multiply by the stride. */
2343 if (!integer_onep (stride
))
2344 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2350 /* Build a scalarized reference to an array. */
2353 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2356 tree decl
= NULL_TREE
;
2361 info
= &se
->ss
->data
.info
;
2363 n
= se
->loop
->order
[0];
2367 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2369 /* Add the offset for this dimension to the stored offset for all other
2371 if (!integer_zerop (info
->offset
))
2372 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2374 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2375 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2377 tmp
= build_fold_indirect_ref (info
->data
);
2378 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2382 /* Translate access of temporary array. */
2385 gfc_conv_tmp_array_ref (gfc_se
* se
)
2387 se
->string_length
= se
->ss
->string_length
;
2388 gfc_conv_scalarized_array_ref (se
, NULL
);
2392 /* Build an array reference. se->expr already holds the array descriptor.
2393 This should be either a variable, indirect variable reference or component
2394 reference. For arrays which do not have a descriptor, se->expr will be
2396 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2399 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2408 /* Handle scalarized references separately. */
2409 if (ar
->type
!= AR_ELEMENT
)
2411 gfc_conv_scalarized_array_ref (se
, ar
);
2412 gfc_advance_se_ss_chain (se
);
2416 index
= gfc_index_zero_node
;
2418 /* Calculate the offsets from all the dimensions. */
2419 for (n
= 0; n
< ar
->dimen
; n
++)
2421 /* Calculate the index for this dimension. */
2422 gfc_init_se (&indexse
, se
);
2423 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2424 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2426 if (flag_bounds_check
)
2428 /* Check array bounds. */
2432 /* Evaluate the indexse.expr only once. */
2433 indexse
.expr
= save_expr (indexse
.expr
);
2436 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2437 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2439 asprintf (&msg
, "%s for array '%s', "
2440 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2441 gfc_msg_fault
, sym
->name
, n
+1);
2442 gfc_trans_runtime_check (cond
, &se
->pre
, where
, msg
,
2443 fold_convert (long_integer_type_node
,
2445 fold_convert (long_integer_type_node
, tmp
));
2448 /* Upper bound, but not for the last dimension of assumed-size
2450 if (n
< ar
->dimen
- 1
2451 || (ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
))
2453 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2454 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2456 asprintf (&msg
, "%s for array '%s', "
2457 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2458 gfc_msg_fault
, sym
->name
, n
+1);
2459 gfc_trans_runtime_check (cond
, &se
->pre
, where
, msg
,
2460 fold_convert (long_integer_type_node
,
2462 fold_convert (long_integer_type_node
, tmp
));
2467 /* Multiply the index by the stride. */
2468 stride
= gfc_conv_array_stride (se
->expr
, n
);
2469 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2472 /* And add it to the total. */
2473 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2476 tmp
= gfc_conv_array_offset (se
->expr
);
2477 if (!integer_zerop (tmp
))
2478 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2480 /* Access the calculated element. */
2481 tmp
= gfc_conv_array_data (se
->expr
);
2482 tmp
= build_fold_indirect_ref (tmp
);
2483 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2487 /* Generate the code to be executed immediately before entering a
2488 scalarization loop. */
2491 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2492 stmtblock_t
* pblock
)
2501 /* This code will be executed before entering the scalarization loop
2502 for this dimension. */
2503 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2505 if ((ss
->useflags
& flag
) == 0)
2508 if (ss
->type
!= GFC_SS_SECTION
2509 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2510 && ss
->type
!= GFC_SS_COMPONENT
)
2513 info
= &ss
->data
.info
;
2515 if (dim
>= info
->dimen
)
2518 if (dim
== info
->dimen
- 1)
2520 /* For the outermost loop calculate the offset due to any
2521 elemental dimensions. It will have been initialized with the
2522 base offset of the array. */
2525 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2527 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2530 gfc_init_se (&se
, NULL
);
2532 se
.expr
= info
->descriptor
;
2533 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2534 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2537 gfc_add_block_to_block (pblock
, &se
.pre
);
2539 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2540 info
->offset
, index
);
2541 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2545 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2548 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2550 /* Calculate the stride of the innermost loop. Hopefully this will
2551 allow the backend optimizers to do their stuff more effectively.
2553 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2557 /* Add the offset for the previous loop dimension. */
2562 ar
= &info
->ref
->u
.ar
;
2563 i
= loop
->order
[dim
+ 1];
2571 gfc_init_se (&se
, NULL
);
2573 se
.expr
= info
->descriptor
;
2574 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2575 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2577 gfc_add_block_to_block (pblock
, &se
.pre
);
2578 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2579 info
->offset
, index
);
2580 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2583 /* Remember this offset for the second loop. */
2584 if (dim
== loop
->temp_dim
- 1)
2585 info
->saved_offset
= info
->offset
;
2590 /* Start a scalarized expression. Creates a scope and declares loop
2594 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2600 gcc_assert (!loop
->array_parameter
);
2602 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2604 n
= loop
->order
[dim
];
2606 gfc_start_block (&loop
->code
[n
]);
2608 /* Create the loop variable. */
2609 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2611 if (dim
< loop
->temp_dim
)
2615 /* Calculate values that will be constant within this loop. */
2616 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2618 gfc_start_block (pbody
);
2622 /* Generates the actual loop code for a scalarization loop. */
2625 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2626 stmtblock_t
* pbody
)
2634 loopbody
= gfc_finish_block (pbody
);
2636 /* Initialize the loopvar. */
2637 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2639 exit_label
= gfc_build_label_decl (NULL_TREE
);
2641 /* Generate the loop body. */
2642 gfc_init_block (&block
);
2644 /* The exit condition. */
2645 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2646 loop
->loopvar
[n
], loop
->to
[n
]);
2647 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2648 TREE_USED (exit_label
) = 1;
2649 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2650 gfc_add_expr_to_block (&block
, tmp
);
2652 /* The main body. */
2653 gfc_add_expr_to_block (&block
, loopbody
);
2655 /* Increment the loopvar. */
2656 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2657 loop
->loopvar
[n
], gfc_index_one_node
);
2658 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2660 /* Build the loop. */
2661 tmp
= gfc_finish_block (&block
);
2662 tmp
= build1_v (LOOP_EXPR
, tmp
);
2663 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2665 /* Add the exit label. */
2666 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2667 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2671 /* Finishes and generates the loops for a scalarized expression. */
2674 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2679 stmtblock_t
*pblock
;
2683 /* Generate the loops. */
2684 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2686 n
= loop
->order
[dim
];
2687 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2688 loop
->loopvar
[n
] = NULL_TREE
;
2689 pblock
= &loop
->code
[n
];
2692 tmp
= gfc_finish_block (pblock
);
2693 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2695 /* Clear all the used flags. */
2696 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2701 /* Finish the main body of a scalarized expression, and start the secondary
2705 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2709 stmtblock_t
*pblock
;
2713 /* We finish as many loops as are used by the temporary. */
2714 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2716 n
= loop
->order
[dim
];
2717 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2718 loop
->loopvar
[n
] = NULL_TREE
;
2719 pblock
= &loop
->code
[n
];
2722 /* We don't want to finish the outermost loop entirely. */
2723 n
= loop
->order
[loop
->temp_dim
- 1];
2724 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2726 /* Restore the initial offsets. */
2727 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2729 if ((ss
->useflags
& 2) == 0)
2732 if (ss
->type
!= GFC_SS_SECTION
2733 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2734 && ss
->type
!= GFC_SS_COMPONENT
)
2737 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2740 /* Restart all the inner loops we just finished. */
2741 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2743 n
= loop
->order
[dim
];
2745 gfc_start_block (&loop
->code
[n
]);
2747 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2749 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2752 /* Start a block for the secondary copying code. */
2753 gfc_start_block (body
);
2757 /* Calculate the upper bound of an array section. */
2760 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2769 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2771 info
= &ss
->data
.info
;
2774 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2775 /* We'll calculate the upper bound once we have access to the
2776 vector's descriptor. */
2779 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2780 desc
= info
->descriptor
;
2781 end
= info
->ref
->u
.ar
.end
[dim
];
2785 /* The upper bound was specified. */
2786 gfc_init_se (&se
, NULL
);
2787 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2788 gfc_add_block_to_block (pblock
, &se
.pre
);
2793 /* No upper bound was specified, so use the bound of the array. */
2794 bound
= gfc_conv_array_ubound (desc
, dim
);
2801 /* Calculate the lower bound of an array section. */
2804 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2814 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2816 info
= &ss
->data
.info
;
2819 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2821 /* We use a zero-based index to access the vector. */
2822 info
->start
[n
] = gfc_index_zero_node
;
2823 info
->end
[n
] = gfc_index_zero_node
;
2824 info
->stride
[n
] = gfc_index_one_node
;
2828 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2829 desc
= info
->descriptor
;
2830 start
= info
->ref
->u
.ar
.start
[dim
];
2831 end
= info
->ref
->u
.ar
.end
[dim
];
2832 stride
= info
->ref
->u
.ar
.stride
[dim
];
2834 /* Calculate the start of the range. For vector subscripts this will
2835 be the range of the vector. */
2838 /* Specified section start. */
2839 gfc_init_se (&se
, NULL
);
2840 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2841 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2842 info
->start
[n
] = se
.expr
;
2846 /* No lower bound specified so use the bound of the array. */
2847 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2849 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2851 /* Similarly calculate the end. Although this is not used in the
2852 scalarizer, it is needed when checking bounds and where the end
2853 is an expression with side-effects. */
2856 /* Specified section start. */
2857 gfc_init_se (&se
, NULL
);
2858 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2859 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2860 info
->end
[n
] = se
.expr
;
2864 /* No upper bound specified so use the bound of the array. */
2865 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
2867 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
2869 /* Calculate the stride. */
2871 info
->stride
[n
] = gfc_index_one_node
;
2874 gfc_init_se (&se
, NULL
);
2875 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2876 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2877 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2882 /* Calculates the range start and stride for a SS chain. Also gets the
2883 descriptor and data pointer. The range of vector subscripts is the size
2884 of the vector. Array bounds are also checked. */
2887 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2895 /* Determine the rank of the loop. */
2897 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2901 case GFC_SS_SECTION
:
2902 case GFC_SS_CONSTRUCTOR
:
2903 case GFC_SS_FUNCTION
:
2904 case GFC_SS_COMPONENT
:
2905 loop
->dimen
= ss
->data
.info
.dimen
;
2908 /* As usual, lbound and ubound are exceptions!. */
2909 case GFC_SS_INTRINSIC
:
2910 switch (ss
->expr
->value
.function
.isym
->id
)
2912 case GFC_ISYM_LBOUND
:
2913 case GFC_ISYM_UBOUND
:
2914 loop
->dimen
= ss
->data
.info
.dimen
;
2925 /* We should have determined the rank of the expression by now. If
2926 not, that's bad news. */
2927 gcc_assert (loop
->dimen
!= 0);
2929 /* Loop over all the SS in the chain. */
2930 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2932 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2933 ss
->shape
= ss
->expr
->shape
;
2937 case GFC_SS_SECTION
:
2938 /* Get the descriptor for the array. */
2939 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2941 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2942 gfc_conv_section_startstride (loop
, ss
, n
);
2945 case GFC_SS_INTRINSIC
:
2946 switch (ss
->expr
->value
.function
.isym
->id
)
2948 /* Fall through to supply start and stride. */
2949 case GFC_ISYM_LBOUND
:
2950 case GFC_ISYM_UBOUND
:
2956 case GFC_SS_CONSTRUCTOR
:
2957 case GFC_SS_FUNCTION
:
2958 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2960 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2961 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
2962 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2971 /* The rest is just runtime bound checking. */
2972 if (flag_bounds_check
)
2975 tree lbound
, ubound
;
2977 tree size
[GFC_MAX_DIMENSIONS
];
2978 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
;
2983 gfc_start_block (&block
);
2985 for (n
= 0; n
< loop
->dimen
; n
++)
2986 size
[n
] = NULL_TREE
;
2988 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2992 if (ss
->type
!= GFC_SS_SECTION
)
2995 gfc_start_block (&inner
);
2997 /* TODO: range checking for mapped dimensions. */
2998 info
= &ss
->data
.info
;
3000 /* This code only checks ranges. Elemental and vector
3001 dimensions are checked later. */
3002 for (n
= 0; n
< loop
->dimen
; n
++)
3007 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3010 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3011 && (info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
3012 || info
->ref
->u
.ar
.as
->cp_was_assumed
))
3013 check_upper
= false;
3017 /* Zero stride is not allowed. */
3018 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
3019 gfc_index_zero_node
);
3020 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3021 "of array '%s'", info
->dim
[n
]+1,
3022 ss
->expr
->symtree
->name
);
3023 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
);
3026 desc
= ss
->data
.info
.descriptor
;
3028 /* This is the run-time equivalent of resolve.c's
3029 check_dimension(). The logical is more readable there
3030 than it is here, with all the trees. */
3031 lbound
= gfc_conv_array_lbound (desc
, dim
);
3034 ubound
= gfc_conv_array_ubound (desc
, dim
);
3038 /* non_zerosized is true when the selected range is not
3040 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
3041 info
->stride
[n
], gfc_index_zero_node
);
3042 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
3044 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3047 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
3048 info
->stride
[n
], gfc_index_zero_node
);
3049 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
3051 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3053 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
3054 stride_pos
, stride_neg
);
3056 /* Check the start of the range against the lower and upper
3057 bounds of the array, if the range is not empty. */
3058 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, info
->start
[n
],
3060 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3061 non_zerosized
, tmp
);
3062 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
3063 " exceeded (%%ld < %%ld)", gfc_msg_fault
,
3064 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3065 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
,
3066 fold_convert (long_integer_type_node
,
3068 fold_convert (long_integer_type_node
,
3074 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
,
3075 info
->start
[n
], ubound
);
3076 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3077 non_zerosized
, tmp
);
3078 asprintf (&msg
, "%s, upper bound of dimension %d of array "
3079 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault
,
3080 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3081 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
,
3082 fold_convert (long_integer_type_node
, info
->start
[n
]),
3083 fold_convert (long_integer_type_node
, ubound
));
3087 /* Compute the last element of the range, which is not
3088 necessarily "end" (think 0:5:3, which doesn't contain 5)
3089 and check it against both lower and upper bounds. */
3090 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3092 tmp2
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp2
,
3094 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3097 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp2
, lbound
);
3098 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3099 non_zerosized
, tmp
);
3100 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
3101 " exceeded (%%ld < %%ld)", gfc_msg_fault
,
3102 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3103 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
,
3104 fold_convert (long_integer_type_node
,
3106 fold_convert (long_integer_type_node
,
3112 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp2
, ubound
);
3113 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3114 non_zerosized
, tmp
);
3115 asprintf (&msg
, "%s, upper bound of dimension %d of array "
3116 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault
,
3117 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3118 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
,
3119 fold_convert (long_integer_type_node
, tmp2
),
3120 fold_convert (long_integer_type_node
, ubound
));
3124 /* Check the section sizes match. */
3125 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3127 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
3129 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3130 build_int_cst (gfc_array_index_type
, 0));
3131 /* We remember the size of the first section, and check all the
3132 others against this. */
3137 tmp3
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
3138 asprintf (&msg
, "%s, size mismatch for dimension %d "
3139 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds
,
3140 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3141 gfc_trans_runtime_check (tmp3
, &inner
, &ss
->expr
->where
, msg
,
3142 fold_convert (long_integer_type_node
, tmp
),
3143 fold_convert (long_integer_type_node
, size
[n
]));
3147 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
3150 tmp
= gfc_finish_block (&inner
);
3152 /* For optional arguments, only check bounds if the argument is
3154 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3155 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3156 tmp
= build3_v (COND_EXPR
,
3157 gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
),
3158 tmp
, build_empty_stmt ());
3160 gfc_add_expr_to_block (&block
, tmp
);
3164 tmp
= gfc_finish_block (&block
);
3165 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3170 /* Return true if the two SS could be aliased, i.e. both point to the same data
3172 /* TODO: resolve aliases based on frontend expressions. */
3175 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3182 lsym
= lss
->expr
->symtree
->n
.sym
;
3183 rsym
= rss
->expr
->symtree
->n
.sym
;
3184 if (gfc_symbols_could_alias (lsym
, rsym
))
3187 if (rsym
->ts
.type
!= BT_DERIVED
3188 && lsym
->ts
.type
!= BT_DERIVED
)
3191 /* For derived types we must check all the component types. We can ignore
3192 array references as these will have the same base type as the previous
3194 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3196 if (lref
->type
!= REF_COMPONENT
)
3199 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3202 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3205 if (rref
->type
!= REF_COMPONENT
)
3208 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3213 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3215 if (rref
->type
!= REF_COMPONENT
)
3218 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3226 /* Resolve array data dependencies. Creates a temporary if required. */
3227 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3231 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3241 loop
->temp_ss
= NULL
;
3242 aref
= dest
->data
.info
.ref
;
3245 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3247 if (ss
->type
!= GFC_SS_SECTION
)
3250 if (gfc_could_be_alias (dest
, ss
)
3251 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3257 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
3259 lref
= dest
->expr
->ref
;
3260 rref
= ss
->expr
->ref
;
3262 nDepend
= gfc_dep_resolver (lref
, rref
);
3266 /* TODO : loop shifting. */
3269 /* Mark the dimensions for LOOP SHIFTING */
3270 for (n
= 0; n
< loop
->dimen
; n
++)
3272 int dim
= dest
->data
.info
.dim
[n
];
3274 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3276 else if (! gfc_is_same_range (&lref
->u
.ar
,
3277 &rref
->u
.ar
, dim
, 0))
3281 /* Put all the dimensions with dependencies in the
3284 for (n
= 0; n
< loop
->dimen
; n
++)
3286 gcc_assert (loop
->order
[n
] == n
);
3288 loop
->order
[dim
++] = n
;
3291 for (n
= 0; n
< loop
->dimen
; n
++)
3294 loop
->order
[dim
++] = n
;
3297 gcc_assert (dim
== loop
->dimen
);
3306 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3307 if (GFC_ARRAY_TYPE_P (base_type
)
3308 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3309 base_type
= gfc_get_element_type (base_type
);
3310 loop
->temp_ss
= gfc_get_ss ();
3311 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3312 loop
->temp_ss
->data
.temp
.type
= base_type
;
3313 loop
->temp_ss
->string_length
= dest
->string_length
;
3314 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3315 loop
->temp_ss
->next
= gfc_ss_terminator
;
3316 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3319 loop
->temp_ss
= NULL
;
3323 /* Initialize the scalarization loop. Creates the loop variables. Determines
3324 the range of the loop variables. Creates a temporary if required.
3325 Calculates how to transform from loop variables to array indices for each
3326 expression. Also generates code for scalar expressions which have been
3327 moved outside the loop. */
3330 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
3335 gfc_ss_info
*specinfo
;
3339 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3340 bool dynamic
[GFC_MAX_DIMENSIONS
];
3346 for (n
= 0; n
< loop
->dimen
; n
++)
3350 /* We use one SS term, and use that to determine the bounds of the
3351 loop for this dimension. We try to pick the simplest term. */
3352 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3356 /* The frontend has worked out the size for us. */
3361 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3363 /* An unknown size constructor will always be rank one.
3364 Higher rank constructors will either have known shape,
3365 or still be wrapped in a call to reshape. */
3366 gcc_assert (loop
->dimen
== 1);
3368 /* Always prefer to use the constructor bounds if the size
3369 can be determined at compile time. Prefer not to otherwise,
3370 since the general case involves realloc, and it's better to
3371 avoid that overhead if possible. */
3372 c
= ss
->expr
->value
.constructor
;
3373 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
3374 if (!dynamic
[n
] || !loopspec
[n
])
3379 /* TODO: Pick the best bound if we have a choice between a
3380 function and something else. */
3381 if (ss
->type
== GFC_SS_FUNCTION
)
3387 if (ss
->type
!= GFC_SS_SECTION
)
3391 specinfo
= &loopspec
[n
]->data
.info
;
3394 info
= &ss
->data
.info
;
3398 /* Criteria for choosing a loop specifier (most important first):
3399 doesn't need realloc
3405 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3407 else if (integer_onep (info
->stride
[n
])
3408 && !integer_onep (specinfo
->stride
[n
]))
3410 else if (INTEGER_CST_P (info
->stride
[n
])
3411 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3413 else if (INTEGER_CST_P (info
->start
[n
])
3414 && !INTEGER_CST_P (specinfo
->start
[n
]))
3416 /* We don't work out the upper bound.
3417 else if (INTEGER_CST_P (info->finish[n])
3418 && ! INTEGER_CST_P (specinfo->finish[n]))
3419 loopspec[n] = ss; */
3422 /* We should have found the scalarization loop specifier. If not,
3424 gcc_assert (loopspec
[n
]);
3426 info
= &loopspec
[n
]->data
.info
;
3428 /* Set the extents of this range. */
3429 cshape
= loopspec
[n
]->shape
;
3430 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3431 && INTEGER_CST_P (info
->stride
[n
]))
3433 loop
->from
[n
] = info
->start
[n
];
3434 mpz_set (i
, cshape
[n
]);
3435 mpz_sub_ui (i
, i
, 1);
3436 /* To = from + (size - 1) * stride. */
3437 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3438 if (!integer_onep (info
->stride
[n
]))
3439 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3440 tmp
, info
->stride
[n
]);
3441 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3442 loop
->from
[n
], tmp
);
3446 loop
->from
[n
] = info
->start
[n
];
3447 switch (loopspec
[n
]->type
)
3449 case GFC_SS_CONSTRUCTOR
:
3450 /* The upper bound is calculated when we expand the
3452 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3455 case GFC_SS_SECTION
:
3456 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3460 case GFC_SS_FUNCTION
:
3461 /* The loop bound will be set when we generate the call. */
3462 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3470 /* Transform everything so we have a simple incrementing variable. */
3471 if (integer_onep (info
->stride
[n
]))
3472 info
->delta
[n
] = gfc_index_zero_node
;
3475 /* Set the delta for this section. */
3476 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3477 /* Number of iterations is (end - start + step) / step.
3478 with start = 0, this simplifies to
3480 for (i = 0; i<=last; i++){...}; */
3481 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3482 loop
->to
[n
], loop
->from
[n
]);
3483 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
,
3484 tmp
, info
->stride
[n
]);
3485 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3486 build_int_cst (gfc_array_index_type
, -1));
3487 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3488 /* Make the loop variable start at 0. */
3489 loop
->from
[n
] = gfc_index_zero_node
;
3493 /* Add all the scalar code that can be taken out of the loops.
3494 This may include calculating the loop bounds, so do it before
3495 allocating the temporary. */
3496 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
3498 /* If we want a temporary then create it. */
3499 if (loop
->temp_ss
!= NULL
)
3501 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3503 /* Make absolutely sure that this is a complete type. */
3504 if (loop
->temp_ss
->string_length
)
3505 loop
->temp_ss
->data
.temp
.type
3506 = gfc_get_character_type_len_for_eltype
3507 (TREE_TYPE (loop
->temp_ss
->data
.temp
.type
),
3508 loop
->temp_ss
->string_length
);
3510 tmp
= loop
->temp_ss
->data
.temp
.type
;
3511 len
= loop
->temp_ss
->string_length
;
3512 n
= loop
->temp_ss
->data
.temp
.dimen
;
3513 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3514 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3515 loop
->temp_ss
->data
.info
.dimen
= n
;
3516 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3517 &loop
->temp_ss
->data
.info
, tmp
, false, true,
3521 for (n
= 0; n
< loop
->temp_dim
; n
++)
3522 loopspec
[loop
->order
[n
]] = NULL
;
3526 /* For array parameters we don't have loop variables, so don't calculate the
3528 if (loop
->array_parameter
)
3531 /* Calculate the translation from loop variables to array indices. */
3532 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3534 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
3537 info
= &ss
->data
.info
;
3539 for (n
= 0; n
< info
->dimen
; n
++)
3543 /* If we are specifying the range the delta is already set. */
3544 if (loopspec
[n
] != ss
)
3546 /* Calculate the offset relative to the loop variable.
3547 First multiply by the stride. */
3548 tmp
= loop
->from
[n
];
3549 if (!integer_onep (info
->stride
[n
]))
3550 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3551 tmp
, info
->stride
[n
]);
3553 /* Then subtract this from our starting value. */
3554 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3555 info
->start
[n
], tmp
);
3557 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3564 /* Fills in an array descriptor, and returns the size of the array. The size
3565 will be a simple_val, ie a variable or a constant. Also calculates the
3566 offset of the base. Returns the size of the array.
3570 for (n = 0; n < rank; n++)
3572 a.lbound[n] = specified_lower_bound;
3573 offset = offset + a.lbond[n] * stride;
3575 a.ubound[n] = specified_upper_bound;
3576 a.stride[n] = stride;
3577 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3578 stride = stride * size;
3585 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3586 gfc_expr
** lower
, gfc_expr
** upper
,
3587 stmtblock_t
* pblock
)
3599 stmtblock_t thenblock
;
3600 stmtblock_t elseblock
;
3605 type
= TREE_TYPE (descriptor
);
3607 stride
= gfc_index_one_node
;
3608 offset
= gfc_index_zero_node
;
3610 /* Set the dtype. */
3611 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3612 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3614 or_expr
= NULL_TREE
;
3616 for (n
= 0; n
< rank
; n
++)
3618 /* We have 3 possibilities for determining the size of the array:
3619 lower == NULL => lbound = 1, ubound = upper[n]
3620 upper[n] = NULL => lbound = 1, ubound = lower[n]
3621 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3624 /* Set lower bound. */
3625 gfc_init_se (&se
, NULL
);
3627 se
.expr
= gfc_index_one_node
;
3630 gcc_assert (lower
[n
]);
3633 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3634 gfc_add_block_to_block (pblock
, &se
.pre
);
3638 se
.expr
= gfc_index_one_node
;
3642 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
3643 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3645 /* Work out the offset for this component. */
3646 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3647 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3649 /* Start the calculation for the size of this dimension. */
3650 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3651 gfc_index_one_node
, se
.expr
);
3653 /* Set upper bound. */
3654 gfc_init_se (&se
, NULL
);
3655 gcc_assert (ubound
);
3656 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3657 gfc_add_block_to_block (pblock
, &se
.pre
);
3659 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
3660 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3662 /* Store the stride. */
3663 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
3664 gfc_add_modify_expr (pblock
, tmp
, stride
);
3666 /* Calculate the size of this dimension. */
3667 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3669 /* Check whether the size for this dimension is negative. */
3670 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3671 gfc_index_zero_node
);
3675 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3677 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
3678 gfc_index_zero_node
, size
);
3680 /* Multiply the stride by the number of elements in this dimension. */
3681 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3682 stride
= gfc_evaluate_now (stride
, pblock
);
3685 /* The stride is the number of elements in the array, so multiply by the
3686 size of an element to get the total size. */
3687 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3688 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3689 fold_convert (gfc_array_index_type
, tmp
));
3691 if (poffset
!= NULL
)
3693 offset
= gfc_evaluate_now (offset
, pblock
);
3697 if (integer_zerop (or_expr
))
3699 if (integer_onep (or_expr
))
3700 return gfc_index_zero_node
;
3702 var
= gfc_create_var (TREE_TYPE (size
), "size");
3703 gfc_start_block (&thenblock
);
3704 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
3705 thencase
= gfc_finish_block (&thenblock
);
3707 gfc_start_block (&elseblock
);
3708 gfc_add_modify_expr (&elseblock
, var
, size
);
3709 elsecase
= gfc_finish_block (&elseblock
);
3711 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3712 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3713 gfc_add_expr_to_block (pblock
, tmp
);
3719 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3720 the work for an ALLOCATE statement. */
3724 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3732 gfc_ref
*ref
, *prev_ref
= NULL
;
3733 bool allocatable_array
;
3737 /* Find the last reference in the chain. */
3738 while (ref
&& ref
->next
!= NULL
)
3740 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3745 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3749 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3751 allocatable_array
= prev_ref
->u
.c
.component
->allocatable
;
3753 /* Figure out the size of the array. */
3754 switch (ref
->u
.ar
.type
)
3758 upper
= ref
->u
.ar
.start
;
3762 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
3764 lower
= ref
->u
.ar
.as
->lower
;
3765 upper
= ref
->u
.ar
.as
->upper
;
3769 lower
= ref
->u
.ar
.start
;
3770 upper
= ref
->u
.ar
.end
;
3778 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
3779 lower
, upper
, &se
->pre
);
3781 /* Allocate memory to store the data. */
3782 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
3783 STRIP_NOPS (pointer
);
3785 /* The allocate_array variants take the old pointer as first argument. */
3786 if (allocatable_array
)
3787 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
);
3789 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
3790 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
3791 gfc_add_expr_to_block (&se
->pre
, tmp
);
3793 tmp
= gfc_conv_descriptor_offset (se
->expr
);
3794 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
3796 if (expr
->ts
.type
== BT_DERIVED
3797 && expr
->ts
.derived
->attr
.alloc_comp
)
3799 tmp
= gfc_nullify_alloc_comp (expr
->ts
.derived
, se
->expr
,
3800 ref
->u
.ar
.as
->rank
);
3801 gfc_add_expr_to_block (&se
->pre
, tmp
);
3808 /* Deallocate an array variable. Also used when an allocated variable goes
3813 gfc_array_deallocate (tree descriptor
, tree pstat
)
3819 gfc_start_block (&block
);
3820 /* Get a pointer to the data. */
3821 var
= gfc_conv_descriptor_data_get (descriptor
);
3824 /* Parameter is the address of the data component. */
3825 tmp
= gfc_deallocate_with_status (var
, pstat
, false);
3826 gfc_add_expr_to_block (&block
, tmp
);
3828 /* Zero the data pointer. */
3829 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
3830 var
, build_int_cst (TREE_TYPE (var
), 0));
3831 gfc_add_expr_to_block (&block
, tmp
);
3833 return gfc_finish_block (&block
);
3837 /* Create an array constructor from an initialization expression.
3838 We assume the frontend already did any expansions and conversions. */
3841 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3848 unsigned HOST_WIDE_INT lo
;
3850 VEC(constructor_elt
,gc
) *v
= NULL
;
3852 switch (expr
->expr_type
)
3855 case EXPR_STRUCTURE
:
3856 /* A single scalar or derived type value. Create an array with all
3857 elements equal to that value. */
3858 gfc_init_se (&se
, NULL
);
3860 if (expr
->expr_type
== EXPR_CONSTANT
)
3861 gfc_conv_constant (&se
, expr
);
3863 gfc_conv_structure (&se
, expr
, 1);
3865 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3866 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3867 hi
= TREE_INT_CST_HIGH (tmp
);
3868 lo
= TREE_INT_CST_LOW (tmp
);
3872 /* This will probably eat buckets of memory for large arrays. */
3873 while (hi
!= 0 || lo
!= 0)
3875 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3883 /* Create a vector of all the elements. */
3884 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3888 /* Problems occur when we get something like
3889 integer :: a(lots) = (/(i, i=1,lots)/) */
3890 /* TODO: Unexpanded array initializers. */
3892 ("Possible frontend bug: array constructor not expanded");
3894 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3895 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3899 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3903 mpz_set (maxval
, c
->repeat
);
3904 mpz_add (maxval
, c
->n
.offset
, maxval
);
3905 mpz_sub_ui (maxval
, maxval
, 1);
3906 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3907 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3909 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3910 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3913 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3915 range
= fold_build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3921 gfc_init_se (&se
, NULL
);
3922 switch (c
->expr
->expr_type
)
3925 gfc_conv_constant (&se
, c
->expr
);
3926 if (range
== NULL_TREE
)
3927 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3930 if (index
!= NULL_TREE
)
3931 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3932 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3936 case EXPR_STRUCTURE
:
3937 gfc_conv_structure (&se
, c
->expr
, 1);
3938 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3948 return gfc_build_null_descriptor (type
);
3954 /* Create a constructor from the list of elements. */
3955 tmp
= build_constructor (type
, v
);
3956 TREE_CONSTANT (tmp
) = 1;
3961 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3962 returns the size (in elements) of the array. */
3965 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3966 stmtblock_t
* pblock
)
3981 size
= gfc_index_one_node
;
3982 offset
= gfc_index_zero_node
;
3983 for (dim
= 0; dim
< as
->rank
; dim
++)
3985 /* Evaluate non-constant array bound expressions. */
3986 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3987 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3989 gfc_init_se (&se
, NULL
);
3990 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3991 gfc_add_block_to_block (pblock
, &se
.pre
);
3992 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3994 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3995 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3997 gfc_init_se (&se
, NULL
);
3998 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3999 gfc_add_block_to_block (pblock
, &se
.pre
);
4000 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
4002 /* The offset of this dimension. offset = offset - lbound * stride. */
4003 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
4004 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4006 /* The size of this dimension, and the stride of the next. */
4007 if (dim
+ 1 < as
->rank
)
4008 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
4010 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4012 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
4014 /* Calculate stride = size * (ubound + 1 - lbound). */
4015 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4016 gfc_index_one_node
, lbound
);
4017 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
4018 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
4020 gfc_add_modify_expr (pblock
, stride
, tmp
);
4022 stride
= gfc_evaluate_now (tmp
, pblock
);
4024 /* Make sure that negative size arrays are translated
4025 to being zero size. */
4026 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
,
4027 stride
, gfc_index_zero_node
);
4028 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4029 stride
, gfc_index_zero_node
);
4030 gfc_add_modify_expr (pblock
, stride
, tmp
);
4036 gfc_trans_vla_type_sizes (sym
, pblock
);
4043 /* Generate code to initialize/allocate an array variable. */
4046 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
4055 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
4057 /* Do nothing for USEd variables. */
4058 if (sym
->attr
.use_assoc
)
4061 type
= TREE_TYPE (decl
);
4062 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4063 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
4065 gfc_start_block (&block
);
4067 /* Evaluate character string length. */
4068 if (sym
->ts
.type
== BT_CHARACTER
4069 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
4071 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4073 gfc_trans_vla_type_sizes (sym
, &block
);
4075 /* Emit a DECL_EXPR for this variable, which will cause the
4076 gimplifier to allocate storage, and all that good stuff. */
4077 tmp
= fold_build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
4078 gfc_add_expr_to_block (&block
, tmp
);
4083 gfc_add_expr_to_block (&block
, fnbody
);
4084 return gfc_finish_block (&block
);
4087 type
= TREE_TYPE (type
);
4089 gcc_assert (!sym
->attr
.use_assoc
);
4090 gcc_assert (!TREE_STATIC (decl
));
4091 gcc_assert (!sym
->module
);
4093 if (sym
->ts
.type
== BT_CHARACTER
4094 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
4095 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4097 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4099 /* Don't actually allocate space for Cray Pointees. */
4100 if (sym
->attr
.cray_pointee
)
4102 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4103 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4104 gfc_add_expr_to_block (&block
, fnbody
);
4105 return gfc_finish_block (&block
);
4108 /* The size is the number of elements in the array, so multiply by the
4109 size of an element to get the total size. */
4110 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4111 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
4112 fold_convert (gfc_array_index_type
, tmp
));
4114 /* Allocate memory to hold the data. */
4115 tmp
= gfc_call_malloc (&block
, TREE_TYPE (decl
), size
);
4116 gfc_add_modify_expr (&block
, decl
, tmp
);
4118 /* Set offset of the array. */
4119 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4120 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4123 /* Automatic arrays should not have initializers. */
4124 gcc_assert (!sym
->value
);
4126 gfc_add_expr_to_block (&block
, fnbody
);
4128 /* Free the temporary. */
4129 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
4130 gfc_add_expr_to_block (&block
, tmp
);
4132 return gfc_finish_block (&block
);
4136 /* Generate entry and exit code for g77 calling convention arrays. */
4139 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
4149 gfc_get_backend_locus (&loc
);
4150 gfc_set_backend_locus (&sym
->declared_at
);
4152 /* Descriptor type. */
4153 parm
= sym
->backend_decl
;
4154 type
= TREE_TYPE (parm
);
4155 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4157 gfc_start_block (&block
);
4159 if (sym
->ts
.type
== BT_CHARACTER
4160 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4161 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4163 /* Evaluate the bounds of the array. */
4164 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4166 /* Set the offset. */
4167 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4168 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4170 /* Set the pointer itself if we aren't using the parameter directly. */
4171 if (TREE_CODE (parm
) != PARM_DECL
)
4173 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4174 gfc_add_modify_expr (&block
, parm
, tmp
);
4176 stmt
= gfc_finish_block (&block
);
4178 gfc_set_backend_locus (&loc
);
4180 gfc_start_block (&block
);
4182 /* Add the initialization code to the start of the function. */
4184 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4186 tmp
= gfc_conv_expr_present (sym
);
4187 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4190 gfc_add_expr_to_block (&block
, stmt
);
4191 gfc_add_expr_to_block (&block
, body
);
4193 return gfc_finish_block (&block
);
4197 /* Modify the descriptor of an array parameter so that it has the
4198 correct lower bound. Also move the upper bound accordingly.
4199 If the array is not packed, it will be copied into a temporary.
4200 For each dimension we set the new lower and upper bounds. Then we copy the
4201 stride and calculate the offset for this dimension. We also work out
4202 what the stride of a packed array would be, and see it the two match.
4203 If the array need repacking, we set the stride to the values we just
4204 calculated, recalculate the offset and copy the array data.
4205 Code is also added to copy the data back at the end of the function.
4209 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
4216 stmtblock_t cleanup
;
4224 tree stride
, stride2
;
4234 /* Do nothing for pointer and allocatable arrays. */
4235 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4238 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4239 return gfc_trans_g77_array (sym
, body
);
4241 gfc_get_backend_locus (&loc
);
4242 gfc_set_backend_locus (&sym
->declared_at
);
4244 /* Descriptor type. */
4245 type
= TREE_TYPE (tmpdesc
);
4246 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4247 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4248 dumdesc
= build_fold_indirect_ref (dumdesc
);
4249 gfc_start_block (&block
);
4251 if (sym
->ts
.type
== BT_CHARACTER
4252 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4253 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4255 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
4257 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4258 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4260 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4262 /* For non-constant shape arrays we only check if the first dimension
4263 is contiguous. Repacking higher dimensions wouldn't gain us
4264 anything as we still don't know the array stride. */
4265 partial
= gfc_create_var (boolean_type_node
, "partial");
4266 TREE_USED (partial
) = 1;
4267 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4268 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4269 gfc_add_modify_expr (&block
, partial
, tmp
);
4273 partial
= NULL_TREE
;
4276 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4277 here, however I think it does the right thing. */
4280 /* Set the first stride. */
4281 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4282 stride
= gfc_evaluate_now (stride
, &block
);
4284 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4285 stride
, gfc_index_zero_node
);
4286 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4287 gfc_index_one_node
, stride
);
4288 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4289 gfc_add_modify_expr (&block
, stride
, tmp
);
4291 /* Allow the user to disable array repacking. */
4292 stmt_unpacked
= NULL_TREE
;
4296 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4297 /* A library call to repack the array if necessary. */
4298 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4299 stmt_unpacked
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
4301 stride
= gfc_index_one_node
;
4304 /* This is for the case where the array data is used directly without
4305 calling the repack function. */
4306 if (no_repack
|| partial
!= NULL_TREE
)
4307 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4309 stmt_packed
= NULL_TREE
;
4311 /* Assign the data pointer. */
4312 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4314 /* Don't repack unknown shape arrays when the first stride is 1. */
4315 tmp
= fold_build3 (COND_EXPR
, TREE_TYPE (stmt_packed
),
4316 partial
, stmt_packed
, stmt_unpacked
);
4319 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4320 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
4322 offset
= gfc_index_zero_node
;
4323 size
= gfc_index_one_node
;
4325 /* Evaluate the bounds of the array. */
4326 for (n
= 0; n
< sym
->as
->rank
; n
++)
4328 if (checkparm
|| !sym
->as
->upper
[n
])
4330 /* Get the bounds of the actual parameter. */
4331 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
4332 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
4336 dubound
= NULL_TREE
;
4337 dlbound
= NULL_TREE
;
4340 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4341 if (!INTEGER_CST_P (lbound
))
4343 gfc_init_se (&se
, NULL
);
4344 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4345 gfc_array_index_type
);
4346 gfc_add_block_to_block (&block
, &se
.pre
);
4347 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
4350 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4351 /* Set the desired upper bound. */
4352 if (sym
->as
->upper
[n
])
4354 /* We know what we want the upper bound to be. */
4355 if (!INTEGER_CST_P (ubound
))
4357 gfc_init_se (&se
, NULL
);
4358 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4359 gfc_array_index_type
);
4360 gfc_add_block_to_block (&block
, &se
.pre
);
4361 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
4364 /* Check the sizes match. */
4367 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4370 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4372 stride2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4374 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
4375 asprintf (&msg
, "%s for dimension %d of array '%s'",
4376 gfc_msg_bounds
, n
+1, sym
->name
);
4377 gfc_trans_runtime_check (tmp
, &block
, &loc
, msg
);
4383 /* For assumed shape arrays move the upper bound by the same amount
4384 as the lower bound. */
4385 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4387 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4388 gfc_add_modify_expr (&block
, ubound
, tmp
);
4390 /* The offset of this dimension. offset = offset - lbound * stride. */
4391 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4392 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4394 /* The size of this dimension, and the stride of the next. */
4395 if (n
+ 1 < sym
->as
->rank
)
4397 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4399 if (no_repack
|| partial
!= NULL_TREE
)
4402 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
4405 /* Figure out the stride if not a known constant. */
4406 if (!INTEGER_CST_P (stride
))
4409 stmt_packed
= NULL_TREE
;
4412 /* Calculate stride = size * (ubound + 1 - lbound). */
4413 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4414 gfc_index_one_node
, lbound
);
4415 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4417 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4422 /* Assign the stride. */
4423 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4424 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4425 stmt_unpacked
, stmt_packed
);
4427 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4428 gfc_add_modify_expr (&block
, stride
, tmp
);
4433 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4435 if (stride
&& !INTEGER_CST_P (stride
))
4437 /* Calculate size = stride * (ubound + 1 - lbound). */
4438 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4439 gfc_index_one_node
, lbound
);
4440 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4442 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4443 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4444 gfc_add_modify_expr (&block
, stride
, tmp
);
4449 /* Set the offset. */
4450 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4451 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4453 gfc_trans_vla_type_sizes (sym
, &block
);
4455 stmt
= gfc_finish_block (&block
);
4457 gfc_start_block (&block
);
4459 /* Only do the entry/initialization code if the arg is present. */
4460 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4461 optional_arg
= (sym
->attr
.optional
4462 || (sym
->ns
->proc_name
->attr
.entry_master
4463 && sym
->attr
.dummy
));
4466 tmp
= gfc_conv_expr_present (sym
);
4467 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4469 gfc_add_expr_to_block (&block
, stmt
);
4471 /* Add the main function body. */
4472 gfc_add_expr_to_block (&block
, body
);
4477 gfc_start_block (&cleanup
);
4479 if (sym
->attr
.intent
!= INTENT_IN
)
4481 /* Copy the data back. */
4482 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4483 gfc_add_expr_to_block (&cleanup
, tmp
);
4486 /* Free the temporary. */
4487 tmp
= gfc_call_free (tmpdesc
);
4488 gfc_add_expr_to_block (&cleanup
, tmp
);
4490 stmt
= gfc_finish_block (&cleanup
);
4492 /* Only do the cleanup if the array was repacked. */
4493 tmp
= build_fold_indirect_ref (dumdesc
);
4494 tmp
= gfc_conv_descriptor_data_get (tmp
);
4495 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4496 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4500 tmp
= gfc_conv_expr_present (sym
);
4501 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4503 gfc_add_expr_to_block (&block
, stmt
);
4505 /* We don't need to free any memory allocated by internal_pack as it will
4506 be freed at the end of the function by pop_context. */
4507 return gfc_finish_block (&block
);
4511 /* Calculate the overall offset, including subreferences. */
4513 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4514 bool subref
, gfc_expr
*expr
)
4524 /* If offset is NULL and this is not a subreferenced array, there is
4526 if (offset
== NULL_TREE
)
4529 offset
= gfc_index_zero_node
;
4534 tmp
= gfc_conv_array_data (desc
);
4535 tmp
= build_fold_indirect_ref (tmp
);
4536 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4538 /* Offset the data pointer for pointer assignments from arrays with
4539 subreferences; eg. my_integer => my_type(:)%integer_component. */
4542 /* Go past the array reference. */
4543 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4544 if (ref
->type
== REF_ARRAY
&&
4545 ref
->u
.ar
.type
!= AR_ELEMENT
)
4551 /* Calculate the offset for each subsequent subreference. */
4552 for (; ref
; ref
= ref
->next
)
4557 field
= ref
->u
.c
.component
->backend_decl
;
4558 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
4559 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4560 tmp
, field
, NULL_TREE
);
4564 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
4565 gfc_init_se (&start
, NULL
);
4566 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
4567 gfc_add_block_to_block (block
, &start
.pre
);
4568 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
4572 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
4573 && ref
->u
.ar
.type
== AR_ELEMENT
);
4575 /* TODO - Add bounds checking. */
4576 stride
= gfc_index_one_node
;
4577 index
= gfc_index_zero_node
;
4578 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4583 /* Update the index. */
4584 gfc_init_se (&start
, NULL
);
4585 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
4586 itmp
= gfc_evaluate_now (start
.expr
, block
);
4587 gfc_init_se (&start
, NULL
);
4588 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
4589 jtmp
= gfc_evaluate_now (start
.expr
, block
);
4590 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, itmp
, jtmp
);
4591 itmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, itmp
, stride
);
4592 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, itmp
, index
);
4593 index
= gfc_evaluate_now (index
, block
);
4595 /* Update the stride. */
4596 gfc_init_se (&start
, NULL
);
4597 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
4598 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, start
.expr
, jtmp
);
4599 itmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4600 gfc_index_one_node
, itmp
);
4601 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, itmp
);
4602 stride
= gfc_evaluate_now (stride
, block
);
4605 /* Apply the index to obtain the array element. */
4606 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
4616 /* Set the target data pointer. */
4617 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4618 gfc_conv_descriptor_data_set (block
, parm
, offset
);
4622 /* gfc_conv_expr_descriptor needs the character length of elemental
4623 functions before the function is called so that the size of the
4624 temporary can be obtained. The only way to do this is to convert
4625 the expression, mapping onto the actual arguments. */
4627 get_elemental_fcn_charlen (gfc_expr
*expr
, gfc_se
*se
)
4629 gfc_interface_mapping mapping
;
4630 gfc_formal_arglist
*formal
;
4631 gfc_actual_arglist
*arg
;
4634 formal
= expr
->symtree
->n
.sym
->formal
;
4635 arg
= expr
->value
.function
.actual
;
4636 gfc_init_interface_mapping (&mapping
);
4638 /* Set se = NULL in the calls to the interface mapping, to supress any
4640 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4645 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
4648 gfc_init_se (&tse
, NULL
);
4650 /* Build the expression for the character length and convert it. */
4651 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.cl
->length
);
4653 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
4654 gfc_add_block_to_block (&se
->post
, &tse
.post
);
4655 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
4656 tse
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tse
.expr
,
4657 build_int_cst (gfc_charlen_type_node
, 0));
4658 expr
->ts
.cl
->backend_decl
= tse
.expr
;
4659 gfc_free_interface_mapping (&mapping
);
4663 /* Convert an array for passing as an actual argument. Expressions and
4664 vector subscripts are evaluated and stored in a temporary, which is then
4665 passed. For whole arrays the descriptor is passed. For array sections
4666 a modified copy of the descriptor is passed, but using the original data.
4668 This function is also used for array pointer assignments, and there
4671 - se->want_pointer && !se->direct_byref
4672 EXPR is an actual argument. On exit, se->expr contains a
4673 pointer to the array descriptor.
4675 - !se->want_pointer && !se->direct_byref
4676 EXPR is an actual argument to an intrinsic function or the
4677 left-hand side of a pointer assignment. On exit, se->expr
4678 contains the descriptor for EXPR.
4680 - !se->want_pointer && se->direct_byref
4681 EXPR is the right-hand side of a pointer assignment and
4682 se->expr is the descriptor for the previously-evaluated
4683 left-hand side. The function creates an assignment from
4684 EXPR to se->expr. */
4687 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
4700 bool subref_array_target
= false;
4702 gcc_assert (ss
!= gfc_ss_terminator
);
4704 /* Special case things we know we can pass easily. */
4705 switch (expr
->expr_type
)
4708 /* If we have a linear array section, we can pass it directly.
4709 Otherwise we need to copy it into a temporary. */
4711 /* Find the SS for the array section. */
4713 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
4714 secss
= secss
->next
;
4716 gcc_assert (secss
!= gfc_ss_terminator
);
4717 info
= &secss
->data
.info
;
4719 /* Get the descriptor for the array. */
4720 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
4721 desc
= info
->descriptor
;
4723 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
4724 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
4725 && !subref_array_target
;
4729 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4731 /* Create a new descriptor if the array doesn't have one. */
4734 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
4736 else if (se
->direct_byref
)
4739 full
= gfc_full_array_ref_p (info
->ref
);
4743 if (se
->direct_byref
)
4745 /* Copy the descriptor for pointer assignments. */
4746 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
4748 /* Add any offsets from subreferences. */
4749 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
4750 subref_array_target
, expr
);
4752 else if (se
->want_pointer
)
4754 /* We pass full arrays directly. This means that pointers and
4755 allocatable arrays should also work. */
4756 se
->expr
= build_fold_addr_expr (desc
);
4763 if (expr
->ts
.type
== BT_CHARACTER
)
4764 se
->string_length
= gfc_get_expr_charlen (expr
);
4771 /* A transformational function return value will be a temporary
4772 array descriptor. We still need to go through the scalarizer
4773 to create the descriptor. Elemental functions ar handled as
4774 arbitrary expressions, i.e. copy to a temporary. */
4776 /* Look for the SS for this function. */
4777 while (secss
!= gfc_ss_terminator
4778 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
4779 secss
= secss
->next
;
4781 if (se
->direct_byref
)
4783 gcc_assert (secss
!= gfc_ss_terminator
);
4785 /* For pointer assignments pass the descriptor directly. */
4787 se
->expr
= build_fold_addr_expr (se
->expr
);
4788 gfc_conv_expr (se
, expr
);
4792 if (secss
== gfc_ss_terminator
)
4794 /* Elemental function. */
4796 if (expr
->ts
.type
== BT_CHARACTER
4797 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4798 get_elemental_fcn_charlen (expr
, se
);
4804 /* Transformational function. */
4805 info
= &secss
->data
.info
;
4811 /* Constant array constructors don't need a temporary. */
4812 if (ss
->type
== GFC_SS_CONSTRUCTOR
4813 && expr
->ts
.type
!= BT_CHARACTER
4814 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
4817 info
= &ss
->data
.info
;
4829 /* Something complicated. Copy it into a temporary. */
4837 gfc_init_loopinfo (&loop
);
4839 /* Associate the SS with the loop. */
4840 gfc_add_ss_to_loop (&loop
, ss
);
4842 /* Tell the scalarizer not to bother creating loop variables, etc. */
4844 loop
.array_parameter
= 1;
4846 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4847 gcc_assert (!se
->direct_byref
);
4849 /* Setup the scalarizing loops and bounds. */
4850 gfc_conv_ss_startstride (&loop
);
4854 /* Tell the scalarizer to make a temporary. */
4855 loop
.temp_ss
= gfc_get_ss ();
4856 loop
.temp_ss
->type
= GFC_SS_TEMP
;
4857 loop
.temp_ss
->next
= gfc_ss_terminator
;
4859 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
4860 gfc_conv_string_length (expr
->ts
.cl
, &se
->pre
);
4862 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
4864 if (expr
->ts
.type
== BT_CHARACTER
)
4865 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4867 loop
.temp_ss
->string_length
= NULL
;
4869 se
->string_length
= loop
.temp_ss
->string_length
;
4870 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
4871 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4874 gfc_conv_loop_setup (&loop
);
4878 /* Copy into a temporary and pass that. We don't need to copy the data
4879 back because expressions and vector subscripts must be INTENT_IN. */
4880 /* TODO: Optimize passing function return values. */
4884 /* Start the copying loops. */
4885 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4886 gfc_mark_ss_chain_used (ss
, 1);
4887 gfc_start_scalarized_body (&loop
, &block
);
4889 /* Copy each data element. */
4890 gfc_init_se (&lse
, NULL
);
4891 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4892 gfc_init_se (&rse
, NULL
);
4893 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4895 lse
.ss
= loop
.temp_ss
;
4898 gfc_conv_scalarized_array_ref (&lse
, NULL
);
4899 if (expr
->ts
.type
== BT_CHARACTER
)
4901 gfc_conv_expr (&rse
, expr
);
4902 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
4903 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4906 gfc_conv_expr_val (&rse
, expr
);
4908 gfc_add_block_to_block (&block
, &rse
.pre
);
4909 gfc_add_block_to_block (&block
, &lse
.pre
);
4911 lse
.string_length
= rse
.string_length
;
4912 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
4913 expr
->expr_type
== EXPR_VARIABLE
);
4914 gfc_add_expr_to_block (&block
, tmp
);
4916 /* Finish the copying loops. */
4917 gfc_trans_scalarizing_loops (&loop
, &block
);
4919 desc
= loop
.temp_ss
->data
.info
.descriptor
;
4921 gcc_assert (is_gimple_lvalue (desc
));
4923 else if (expr
->expr_type
== EXPR_FUNCTION
)
4925 desc
= info
->descriptor
;
4926 se
->string_length
= ss
->string_length
;
4930 /* We pass sections without copying to a temporary. Make a new
4931 descriptor and point it at the section we want. The loop variable
4932 limits will be the limits of the section.
4933 A function may decide to repack the array to speed up access, but
4934 we're not bothered about that here. */
4943 /* Set the string_length for a character array. */
4944 if (expr
->ts
.type
== BT_CHARACTER
)
4945 se
->string_length
= gfc_get_expr_charlen (expr
);
4947 desc
= info
->descriptor
;
4948 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
4949 if (se
->direct_byref
)
4951 /* For pointer assignments we fill in the destination. */
4953 parmtype
= TREE_TYPE (parm
);
4957 /* Otherwise make a new one. */
4958 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4959 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
4960 loop
.from
, loop
.to
, 0,
4962 parm
= gfc_create_var (parmtype
, "parm");
4965 offset
= gfc_index_zero_node
;
4968 /* The following can be somewhat confusing. We have two
4969 descriptors, a new one and the original array.
4970 {parm, parmtype, dim} refer to the new one.
4971 {desc, type, n, secss, loop} refer to the original, which maybe
4972 a descriptorless array.
4973 The bounds of the scalarization are the bounds of the section.
4974 We don't have to worry about numeric overflows when calculating
4975 the offsets because all elements are within the array data. */
4977 /* Set the dtype. */
4978 tmp
= gfc_conv_descriptor_dtype (parm
);
4979 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
4981 /* Set offset for assignments to pointer only to zero if it is not
4983 if (se
->direct_byref
4984 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
4985 base
= gfc_index_zero_node
;
4986 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4987 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
4991 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
4992 for (n
= 0; n
< ndim
; n
++)
4994 stride
= gfc_conv_array_stride (desc
, n
);
4996 /* Work out the offset. */
4998 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5000 gcc_assert (info
->subscript
[n
]
5001 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
5002 start
= info
->subscript
[n
]->data
.scalar
.expr
;
5006 /* Check we haven't somehow got out of sync. */
5007 gcc_assert (info
->dim
[dim
] == n
);
5009 /* Evaluate and remember the start of the section. */
5010 start
= info
->start
[dim
];
5011 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
5014 tmp
= gfc_conv_array_lbound (desc
, n
);
5015 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
5017 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
5018 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
5021 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5023 /* For elemental dimensions, we only need the offset. */
5027 /* Vector subscripts need copying and are handled elsewhere. */
5029 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
5031 /* Set the new lower bound. */
5032 from
= loop
.from
[dim
];
5035 /* If we have an array section or are assigning make sure that
5036 the lower bound is 1. References to the full
5037 array should otherwise keep the original bounds. */
5039 || info
->ref
->u
.ar
.type
!= AR_FULL
)
5040 && !integer_onep (from
))
5042 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5043 gfc_index_one_node
, from
);
5044 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
5045 from
= gfc_index_one_node
;
5047 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
5048 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
5050 /* Set the new upper bound. */
5051 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
5052 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
5054 /* Multiply the stride by the section stride to get the
5056 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
5057 stride
, info
->stride
[dim
]);
5059 if (se
->direct_byref
&& info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
5061 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5064 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5066 tmp
= gfc_conv_array_lbound (desc
, n
);
5067 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5068 tmp
, loop
.from
[dim
]);
5069 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
5070 tmp
, gfc_conv_array_stride (desc
, n
));
5071 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
5075 /* Store the new stride. */
5076 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
5077 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
5082 if (se
->data_not_needed
)
5083 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, gfc_index_zero_node
);
5085 /* Point the data pointer at the first element in the section. */
5086 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
5087 subref_array_target
, expr
);
5089 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5090 && !se
->data_not_needed
)
5092 /* Set the offset. */
5093 tmp
= gfc_conv_descriptor_offset (parm
);
5094 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
5098 /* Only the callee knows what the correct offset it, so just set
5100 tmp
= gfc_conv_descriptor_offset (parm
);
5101 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
5106 if (!se
->direct_byref
)
5108 /* Get a pointer to the new descriptor. */
5109 if (se
->want_pointer
)
5110 se
->expr
= build_fold_addr_expr (desc
);
5115 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5116 gfc_add_block_to_block (&se
->post
, &loop
.post
);
5118 /* Cleanup the scalarizer. */
5119 gfc_cleanup_loop (&loop
);
5123 /* Convert an array for passing as an actual parameter. */
5124 /* TODO: Optimize passing g77 arrays. */
5127 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
5131 tree tmp
= NULL_TREE
;
5133 tree parent
= DECL_CONTEXT (current_function_decl
);
5134 bool full_array_var
, this_array_result
;
5138 full_array_var
= (expr
->expr_type
== EXPR_VARIABLE
5139 && expr
->ref
->u
.ar
.type
== AR_FULL
);
5140 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
5142 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
5144 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
5145 expr
->ts
.cl
->backend_decl
= tmp
;
5146 se
->string_length
= tmp
;
5149 /* Is this the result of the enclosing procedure? */
5150 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
5151 if (this_array_result
5152 && (sym
->backend_decl
!= current_function_decl
)
5153 && (sym
->backend_decl
!= parent
))
5154 this_array_result
= false;
5156 /* Passing address of the array if it is not pointer or assumed-shape. */
5157 if (full_array_var
&& g77
&& !this_array_result
)
5159 tmp
= gfc_get_symbol_decl (sym
);
5161 if (sym
->ts
.type
== BT_CHARACTER
)
5162 se
->string_length
= sym
->ts
.cl
->backend_decl
;
5163 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
5164 && !sym
->attr
.allocatable
)
5166 /* Some variables are declared directly, others are declared as
5167 pointers and allocated on the heap. */
5168 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
5171 se
->expr
= build_fold_addr_expr (tmp
);
5174 if (sym
->attr
.allocatable
)
5176 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5178 gfc_conv_expr_descriptor (se
, expr
, ss
);
5179 se
->expr
= gfc_conv_array_data (se
->expr
);
5182 se
->expr
= gfc_conv_array_data (tmp
);
5187 if (this_array_result
)
5189 /* Result of the enclosing function. */
5190 gfc_conv_expr_descriptor (se
, expr
, ss
);
5191 se
->expr
= build_fold_addr_expr (se
->expr
);
5193 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
5194 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
5195 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref (se
->expr
));
5201 /* Every other type of array. */
5202 se
->want_pointer
= 1;
5203 gfc_conv_expr_descriptor (se
, expr
, ss
);
5207 /* Deallocate the allocatable components of structures that are
5209 if (expr
->ts
.type
== BT_DERIVED
5210 && expr
->ts
.derived
->attr
.alloc_comp
5211 && expr
->expr_type
!= EXPR_VARIABLE
)
5213 tmp
= build_fold_indirect_ref (se
->expr
);
5214 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.derived
, tmp
, expr
->rank
);
5215 gfc_add_expr_to_block (&se
->post
, tmp
);
5221 /* Repack the array. */
5222 ptr
= build_call_expr (gfor_fndecl_in_pack
, 1, desc
);
5223 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5226 gfc_start_block (&block
);
5228 /* Copy the data back. */
5229 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5230 gfc_add_expr_to_block (&block
, tmp
);
5232 /* Free the temporary. */
5233 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5234 gfc_add_expr_to_block (&block
, tmp
);
5236 stmt
= gfc_finish_block (&block
);
5238 gfc_init_block (&block
);
5239 /* Only if it was repacked. This code needs to be executed before the
5240 loop cleanup code. */
5241 tmp
= build_fold_indirect_ref (desc
);
5242 tmp
= gfc_conv_array_data (tmp
);
5243 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
5244 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5245 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
5247 gfc_add_expr_to_block (&block
, tmp
);
5248 gfc_add_block_to_block (&block
, &se
->post
);
5250 gfc_init_block (&se
->post
);
5251 gfc_add_block_to_block (&se
->post
, &block
);
5256 /* Generate code to deallocate an array, if it is allocated. */
5259 gfc_trans_dealloc_allocated (tree descriptor
)
5265 gfc_start_block (&block
);
5267 var
= gfc_conv_descriptor_data_get (descriptor
);
5270 /* Call array_deallocate with an int * present in the second argument.
5271 Although it is ignored here, it's presence ensures that arrays that
5272 are already deallocated are ignored. */
5273 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true);
5274 gfc_add_expr_to_block (&block
, tmp
);
5276 /* Zero the data pointer. */
5277 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5278 var
, build_int_cst (TREE_TYPE (var
), 0));
5279 gfc_add_expr_to_block (&block
, tmp
);
5281 return gfc_finish_block (&block
);
5285 /* This helper function calculates the size in words of a full array. */
5288 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
5293 idx
= gfc_rank_cst
[rank
- 1];
5294 nelems
= gfc_conv_descriptor_ubound (decl
, idx
);
5295 tmp
= gfc_conv_descriptor_lbound (decl
, idx
);
5296 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5297 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
5298 tmp
, gfc_index_one_node
);
5299 tmp
= gfc_evaluate_now (tmp
, block
);
5301 nelems
= gfc_conv_descriptor_stride (decl
, idx
);
5302 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5303 return gfc_evaluate_now (tmp
, block
);
5307 /* Allocate dest to the same size as src, and copy src -> dest. */
5310 gfc_duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
)
5319 /* If the source is null, set the destination to null. */
5320 gfc_init_block (&block
);
5321 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5322 null_data
= gfc_finish_block (&block
);
5324 gfc_init_block (&block
);
5326 nelems
= get_full_array_size (&block
, src
, rank
);
5327 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
,
5328 fold_convert (gfc_array_index_type
,
5329 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
5331 /* Allocate memory to the destination. */
5332 tmp
= gfc_call_malloc (&block
, TREE_TYPE (gfc_conv_descriptor_data_get (src
)),
5334 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5336 /* We know the temporary and the value will be the same length,
5337 so can use memcpy. */
5338 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5339 tmp
= build_call_expr (tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5340 gfc_conv_descriptor_data_get (src
), size
);
5341 gfc_add_expr_to_block (&block
, tmp
);
5342 tmp
= gfc_finish_block (&block
);
5344 /* Null the destination if the source is null; otherwise do
5345 the allocate and copy. */
5346 null_cond
= gfc_conv_descriptor_data_get (src
);
5347 null_cond
= convert (pvoid_type_node
, null_cond
);
5348 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
5349 null_cond
, null_pointer_node
);
5350 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5354 /* Recursively traverse an object of derived type, generating code to
5355 deallocate, nullify or copy allocatable components. This is the work horse
5356 function for the functions named in this enum. */
5358 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
};
5361 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5362 tree dest
, int rank
, int purpose
)
5366 stmtblock_t fnblock
;
5367 stmtblock_t loopbody
;
5377 tree null_cond
= NULL_TREE
;
5379 gfc_init_block (&fnblock
);
5381 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
5382 decl
= build_fold_indirect_ref (decl
);
5384 /* If this an array of derived types with allocatable components
5385 build a loop and recursively call this function. */
5386 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
5387 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5389 tmp
= gfc_conv_array_data (decl
);
5390 var
= build_fold_indirect_ref (tmp
);
5392 /* Get the number of elements - 1 and set the counter. */
5393 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5395 /* Use the descriptor for an allocatable array. Since this
5396 is a full array reference, we only need the descriptor
5397 information from dimension = rank. */
5398 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
5399 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5400 tmp
, gfc_index_one_node
);
5402 null_cond
= gfc_conv_descriptor_data_get (decl
);
5403 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5404 build_int_cst (TREE_TYPE (null_cond
), 0));
5408 /* Otherwise use the TYPE_DOMAIN information. */
5409 tmp
= array_type_nelts (TREE_TYPE (decl
));
5410 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5413 /* Remember that this is, in fact, the no. of elements - 1. */
5414 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5415 index
= gfc_create_var (gfc_array_index_type
, "S");
5417 /* Build the body of the loop. */
5418 gfc_init_block (&loopbody
);
5420 vref
= gfc_build_array_ref (var
, index
, NULL
);
5422 if (purpose
== COPY_ALLOC_COMP
)
5424 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
5425 gfc_add_expr_to_block (&fnblock
, tmp
);
5427 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest
));
5428 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
5429 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
5432 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
5434 gfc_add_expr_to_block (&loopbody
, tmp
);
5436 /* Build the loop and return. */
5437 gfc_init_loopinfo (&loop
);
5439 loop
.from
[0] = gfc_index_zero_node
;
5440 loop
.loopvar
[0] = index
;
5441 loop
.to
[0] = nelems
;
5442 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
5443 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
5445 tmp
= gfc_finish_block (&fnblock
);
5446 if (null_cond
!= NULL_TREE
)
5447 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
, build_empty_stmt ());
5452 /* Otherwise, act on the components or recursively call self to
5453 act on a chain of components. */
5454 for (c
= der_type
->components
; c
; c
= c
->next
)
5456 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
5457 && c
->ts
.derived
->attr
.alloc_comp
;
5458 cdecl = c
->backend_decl
;
5459 ctype
= TREE_TYPE (cdecl);
5463 case DEALLOCATE_ALLOC_COMP
:
5464 /* Do not deallocate the components of ultimate pointer
5466 if (cmp_has_alloc_comps
&& !c
->pointer
)
5468 comp
= fold_build3 (COMPONENT_REF
, ctype
,
5469 decl
, cdecl, NULL_TREE
);
5470 rank
= c
->as
? c
->as
->rank
: 0;
5471 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5473 gfc_add_expr_to_block (&fnblock
, tmp
);
5478 comp
= fold_build3 (COMPONENT_REF
, ctype
,
5479 decl
, cdecl, NULL_TREE
);
5480 tmp
= gfc_trans_dealloc_allocated (comp
);
5481 gfc_add_expr_to_block (&fnblock
, tmp
);
5485 case NULLIFY_ALLOC_COMP
:
5488 else if (c
->allocatable
)
5490 comp
= fold_build3 (COMPONENT_REF
, ctype
,
5491 decl
, cdecl, NULL_TREE
);
5492 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
5494 else if (cmp_has_alloc_comps
)
5496 comp
= fold_build3 (COMPONENT_REF
, ctype
,
5497 decl
, cdecl, NULL_TREE
);
5498 rank
= c
->as
? c
->as
->rank
: 0;
5499 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5501 gfc_add_expr_to_block (&fnblock
, tmp
);
5505 case COPY_ALLOC_COMP
:
5509 /* We need source and destination components. */
5510 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5511 dcmp
= fold_build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
5512 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
5514 if (c
->allocatable
&& !cmp_has_alloc_comps
)
5516 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, c
->as
->rank
);
5517 gfc_add_expr_to_block (&fnblock
, tmp
);
5520 if (cmp_has_alloc_comps
)
5522 rank
= c
->as
? c
->as
->rank
: 0;
5523 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
5524 gfc_add_modify_expr (&fnblock
, dcmp
, tmp
);
5525 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, dcmp
,
5527 gfc_add_expr_to_block (&fnblock
, tmp
);
5537 return gfc_finish_block (&fnblock
);
5540 /* Recursively traverse an object of derived type, generating code to
5541 nullify allocatable components. */
5544 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5546 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5547 NULLIFY_ALLOC_COMP
);
5551 /* Recursively traverse an object of derived type, generating code to
5552 deallocate allocatable components. */
5555 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5557 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5558 DEALLOCATE_ALLOC_COMP
);
5562 /* Recursively traverse an object of derived type, generating code to
5563 copy its allocatable components. */
5566 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
5568 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
5572 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5573 Do likewise, recursively if necessary, with the allocatable components of
5577 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
5582 stmtblock_t fnblock
;
5585 bool sym_has_alloc_comp
;
5587 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
5588 && sym
->ts
.derived
->attr
.alloc_comp
;
5590 /* Make sure the frontend gets these right. */
5591 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
5592 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5593 "allocatable attribute or derived type without allocatable "
5596 gfc_init_block (&fnblock
);
5598 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
5599 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
5601 if (sym
->ts
.type
== BT_CHARACTER
5602 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
5604 gfc_conv_string_length (sym
->ts
.cl
, &fnblock
);
5605 gfc_trans_vla_type_sizes (sym
, &fnblock
);
5608 /* Dummy and use associated variables don't need anything special. */
5609 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
5611 gfc_add_expr_to_block (&fnblock
, body
);
5613 return gfc_finish_block (&fnblock
);
5616 gfc_get_backend_locus (&loc
);
5617 gfc_set_backend_locus (&sym
->declared_at
);
5618 descriptor
= sym
->backend_decl
;
5620 /* Although static, derived types with default initializers and
5621 allocatable components must not be nulled wholesale; instead they
5622 are treated component by component. */
5623 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
5625 /* SAVEd variables are not freed on exit. */
5626 gfc_trans_static_array_pointer (sym
);
5630 /* Get the descriptor type. */
5631 type
= TREE_TYPE (sym
->backend_decl
);
5633 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5635 if (!sym
->attr
.save
)
5637 rank
= sym
->as
? sym
->as
->rank
: 0;
5638 tmp
= gfc_nullify_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5639 gfc_add_expr_to_block (&fnblock
, tmp
);
5642 tmp
= gfc_init_default_dt (sym
, NULL
);
5643 gfc_add_expr_to_block (&fnblock
, tmp
);
5647 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
5649 /* If the backend_decl is not a descriptor, we must have a pointer
5651 descriptor
= build_fold_indirect_ref (sym
->backend_decl
);
5652 type
= TREE_TYPE (descriptor
);
5655 /* NULLIFY the data pointer. */
5656 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
5657 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
5659 gfc_add_expr_to_block (&fnblock
, body
);
5661 gfc_set_backend_locus (&loc
);
5663 /* Allocatable arrays need to be freed when they go out of scope.
5664 The allocatable components of pointers must not be touched. */
5665 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
5666 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
5669 rank
= sym
->as
? sym
->as
->rank
: 0;
5670 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5671 gfc_add_expr_to_block (&fnblock
, tmp
);
5674 if (sym
->attr
.allocatable
&& !sym
->attr
.save
)
5676 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
5677 gfc_add_expr_to_block (&fnblock
, tmp
);
5680 return gfc_finish_block (&fnblock
);
5683 /************ Expression Walking Functions ******************/
5685 /* Walk a variable reference.
5687 Possible extension - multiple component subscripts.
5688 x(:,:) = foo%a(:)%b(:)
5690 forall (i=..., j=...)
5691 x(i,j) = foo%a(j)%b(i)
5693 This adds a fair amount of complexity because you need to deal with more
5694 than one ref. Maybe handle in a similar manner to vector subscripts.
5695 Maybe not worth the effort. */
5699 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5707 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5708 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
5711 for (; ref
; ref
= ref
->next
)
5713 if (ref
->type
== REF_SUBSTRING
)
5715 newss
= gfc_get_ss ();
5716 newss
->type
= GFC_SS_SCALAR
;
5717 newss
->expr
= ref
->u
.ss
.start
;
5721 newss
= gfc_get_ss ();
5722 newss
->type
= GFC_SS_SCALAR
;
5723 newss
->expr
= ref
->u
.ss
.end
;
5728 /* We're only interested in array sections from now on. */
5729 if (ref
->type
!= REF_ARRAY
)
5736 for (n
= 0; n
< ar
->dimen
; n
++)
5738 newss
= gfc_get_ss ();
5739 newss
->type
= GFC_SS_SCALAR
;
5740 newss
->expr
= ar
->start
[n
];
5747 newss
= gfc_get_ss ();
5748 newss
->type
= GFC_SS_SECTION
;
5751 newss
->data
.info
.dimen
= ar
->as
->rank
;
5752 newss
->data
.info
.ref
= ref
;
5754 /* Make sure array is the same as array(:,:), this way
5755 we don't need to special case all the time. */
5756 ar
->dimen
= ar
->as
->rank
;
5757 for (n
= 0; n
< ar
->dimen
; n
++)
5759 newss
->data
.info
.dim
[n
] = n
;
5760 ar
->dimen_type
[n
] = DIMEN_RANGE
;
5762 gcc_assert (ar
->start
[n
] == NULL
);
5763 gcc_assert (ar
->end
[n
] == NULL
);
5764 gcc_assert (ar
->stride
[n
] == NULL
);
5770 newss
= gfc_get_ss ();
5771 newss
->type
= GFC_SS_SECTION
;
5774 newss
->data
.info
.dimen
= 0;
5775 newss
->data
.info
.ref
= ref
;
5779 /* We add SS chains for all the subscripts in the section. */
5780 for (n
= 0; n
< ar
->dimen
; n
++)
5784 switch (ar
->dimen_type
[n
])
5787 /* Add SS for elemental (scalar) subscripts. */
5788 gcc_assert (ar
->start
[n
]);
5789 indexss
= gfc_get_ss ();
5790 indexss
->type
= GFC_SS_SCALAR
;
5791 indexss
->expr
= ar
->start
[n
];
5792 indexss
->next
= gfc_ss_terminator
;
5793 indexss
->loop_chain
= gfc_ss_terminator
;
5794 newss
->data
.info
.subscript
[n
] = indexss
;
5798 /* We don't add anything for sections, just remember this
5799 dimension for later. */
5800 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5801 newss
->data
.info
.dimen
++;
5805 /* Create a GFC_SS_VECTOR index in which we can store
5806 the vector's descriptor. */
5807 indexss
= gfc_get_ss ();
5808 indexss
->type
= GFC_SS_VECTOR
;
5809 indexss
->expr
= ar
->start
[n
];
5810 indexss
->next
= gfc_ss_terminator
;
5811 indexss
->loop_chain
= gfc_ss_terminator
;
5812 newss
->data
.info
.subscript
[n
] = indexss
;
5813 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5814 newss
->data
.info
.dimen
++;
5818 /* We should know what sort of section it is by now. */
5822 /* We should have at least one non-elemental dimension. */
5823 gcc_assert (newss
->data
.info
.dimen
> 0);
5828 /* We should know what sort of section it is by now. */
5837 /* Walk an expression operator. If only one operand of a binary expression is
5838 scalar, we must also add the scalar term to the SS chain. */
5841 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5847 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
5848 if (expr
->value
.op
.op2
== NULL
)
5851 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
5853 /* All operands are scalar. Pass back and let the caller deal with it. */
5857 /* All operands require scalarization. */
5858 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
5861 /* One of the operands needs scalarization, the other is scalar.
5862 Create a gfc_ss for the scalar expression. */
5863 newss
= gfc_get_ss ();
5864 newss
->type
= GFC_SS_SCALAR
;
5867 /* First operand is scalar. We build the chain in reverse order, so
5868 add the scarar SS after the second operand. */
5870 while (head
&& head
->next
!= ss
)
5872 /* Check we haven't somehow broken the chain. */
5876 newss
->expr
= expr
->value
.op
.op1
;
5878 else /* head2 == head */
5880 gcc_assert (head2
== head
);
5881 /* Second operand is scalar. */
5882 newss
->next
= head2
;
5884 newss
->expr
= expr
->value
.op
.op2
;
5891 /* Reverse a SS chain. */
5894 gfc_reverse_ss (gfc_ss
* ss
)
5899 gcc_assert (ss
!= NULL
);
5901 head
= gfc_ss_terminator
;
5902 while (ss
!= gfc_ss_terminator
)
5905 /* Check we didn't somehow break the chain. */
5906 gcc_assert (next
!= NULL
);
5916 /* Walk the arguments of an elemental function. */
5919 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
5927 head
= gfc_ss_terminator
;
5930 for (; arg
; arg
= arg
->next
)
5935 newss
= gfc_walk_subexpr (head
, arg
->expr
);
5938 /* Scalar argument. */
5939 newss
= gfc_get_ss ();
5941 newss
->expr
= arg
->expr
;
5951 while (tail
->next
!= gfc_ss_terminator
)
5958 /* If all the arguments are scalar we don't need the argument SS. */
5959 gfc_free_ss_chain (head
);
5964 /* Add it onto the existing chain. */
5970 /* Walk a function call. Scalar functions are passed back, and taken out of
5971 scalarization loops. For elemental functions we walk their arguments.
5972 The result of functions returning arrays is stored in a temporary outside
5973 the loop, so that the function is only called once. Hence we do not need
5974 to walk their arguments. */
5977 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5980 gfc_intrinsic_sym
*isym
;
5983 isym
= expr
->value
.function
.isym
;
5985 /* Handle intrinsic functions separately. */
5987 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
5989 sym
= expr
->value
.function
.esym
;
5991 sym
= expr
->symtree
->n
.sym
;
5993 /* A function that returns arrays. */
5994 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
5996 newss
= gfc_get_ss ();
5997 newss
->type
= GFC_SS_FUNCTION
;
6000 newss
->data
.info
.dimen
= expr
->rank
;
6004 /* Walk the parameters of an elemental function. For now we always pass
6006 if (sym
->attr
.elemental
)
6007 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
6010 /* Scalar functions are OK as these are evaluated outside the scalarization
6011 loop. Pass back and let the caller deal with it. */
6016 /* An array temporary is constructed for array constructors. */
6019 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
6024 newss
= gfc_get_ss ();
6025 newss
->type
= GFC_SS_CONSTRUCTOR
;
6028 newss
->data
.info
.dimen
= expr
->rank
;
6029 for (n
= 0; n
< expr
->rank
; n
++)
6030 newss
->data
.info
.dim
[n
] = n
;
6036 /* Walk an expression. Add walked expressions to the head of the SS chain.
6037 A wholly scalar expression will not be added. */
6040 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
6044 switch (expr
->expr_type
)
6047 head
= gfc_walk_variable_expr (ss
, expr
);
6051 head
= gfc_walk_op_expr (ss
, expr
);
6055 head
= gfc_walk_function_expr (ss
, expr
);
6060 case EXPR_STRUCTURE
:
6061 /* Pass back and let the caller deal with it. */
6065 head
= gfc_walk_array_constructor (ss
, expr
);
6068 case EXPR_SUBSTRING
:
6069 /* Pass back and let the caller deal with it. */
6073 internal_error ("bad expression type during walk (%d)",
6080 /* Entry point for expression walking.
6081 A return value equal to the passed chain means this is
6082 a scalar expression. It is up to the caller to take whatever action is
6083 necessary to translate these. */
6086 gfc_walk_expr (gfc_expr
* expr
)
6090 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
6091 return gfc_reverse_ss (res
);