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 Returns TRUE if all elements are character constants. */
1465 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor
* c
, tree
* len
)
1473 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1477 for (; c
; c
= c
->next
)
1479 switch (c
->expr
->expr_type
)
1482 if (!(*len
&& INTEGER_CST_P (*len
)))
1483 *len
= build_int_cstu (gfc_charlen_type_node
,
1484 c
->expr
->value
.character
.length
);
1488 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1494 get_array_ctor_var_strlen (c
->expr
, len
);
1499 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1507 /* Check whether the array constructor C consists entirely of constant
1508 elements, and if so returns the number of those elements, otherwise
1509 return zero. Note, an empty or NULL array constructor returns zero. */
1511 unsigned HOST_WIDE_INT
1512 gfc_constant_array_constructor_p (gfc_constructor
* c
)
1514 unsigned HOST_WIDE_INT nelem
= 0;
1519 || c
->expr
->rank
> 0
1520 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1529 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1530 and the tree type of it's elements, TYPE, return a static constant
1531 variable that is compile-time initialized. */
1534 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1536 tree tmptype
, list
, init
, tmp
;
1537 HOST_WIDE_INT nelem
;
1543 /* First traverse the constructor list, converting the constants
1544 to tree to build an initializer. */
1547 c
= expr
->value
.constructor
;
1550 gfc_init_se (&se
, NULL
);
1551 gfc_conv_constant (&se
, c
->expr
);
1552 if (c
->expr
->ts
.type
== BT_CHARACTER
&& POINTER_TYPE_P (type
))
1553 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
1555 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1560 /* Next determine the tree type for the array. We use the gfortran
1561 front-end's gfc_get_nodesc_array_type in order to create a suitable
1562 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1564 memset (&as
, 0, sizeof (gfc_array_spec
));
1566 as
.rank
= expr
->rank
;
1567 as
.type
= AS_EXPLICIT
;
1570 as
.lower
[0] = gfc_int_expr (0);
1571 as
.upper
[0] = gfc_int_expr (nelem
- 1);
1574 for (i
= 0; i
< expr
->rank
; i
++)
1576 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1577 as
.lower
[i
] = gfc_int_expr (0);
1578 as
.upper
[i
] = gfc_int_expr (tmp
- 1);
1581 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
);
1583 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1585 TREE_CONSTANT (init
) = 1;
1586 TREE_STATIC (init
) = 1;
1588 tmp
= gfc_create_var (tmptype
, "A");
1589 TREE_STATIC (tmp
) = 1;
1590 TREE_CONSTANT (tmp
) = 1;
1591 TREE_READONLY (tmp
) = 1;
1592 DECL_INITIAL (tmp
) = init
;
1598 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1599 This mostly initializes the scalarizer state info structure with the
1600 appropriate values to directly use the array created by the function
1601 gfc_build_constant_array_constructor. */
1604 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1605 gfc_ss
* ss
, tree type
)
1611 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1613 info
= &ss
->data
.info
;
1615 info
->descriptor
= tmp
;
1616 info
->data
= build_fold_addr_expr (tmp
);
1617 info
->offset
= fold_build1 (NEGATE_EXPR
, gfc_array_index_type
,
1620 for (i
= 0; i
< info
->dimen
; i
++)
1622 info
->delta
[i
] = gfc_index_zero_node
;
1623 info
->start
[i
] = gfc_index_zero_node
;
1624 info
->end
[i
] = gfc_index_zero_node
;
1625 info
->stride
[i
] = gfc_index_one_node
;
1629 if (info
->dimen
> loop
->temp_dim
)
1630 loop
->temp_dim
= info
->dimen
;
1633 /* Helper routine of gfc_trans_array_constructor to determine if the
1634 bounds of the loop specified by LOOP are constant and simple enough
1635 to use with gfc_trans_constant_array_constructor. Returns the
1636 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1639 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1641 tree size
= gfc_index_one_node
;
1645 for (i
= 0; i
< loop
->dimen
; i
++)
1647 /* If the bounds aren't constant, return NULL_TREE. */
1648 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1650 if (!integer_zerop (loop
->from
[i
]))
1652 /* Only allow nonzero "from" in one-dimensional arrays. */
1653 if (loop
->dimen
!= 1)
1655 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1656 loop
->to
[i
], loop
->from
[i
]);
1660 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1661 tmp
, gfc_index_one_node
);
1662 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1669 /* Array constructors are handled by constructing a temporary, then using that
1670 within the scalarization loop. This is not optimal, but seems by far the
1674 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1684 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1685 typespec was given for the array constructor. */
1686 typespec_chararray_ctor
= (ss
->expr
->ts
.cl
1687 && ss
->expr
->ts
.cl
->length_from_typespec
);
1689 if (flag_bounds_check
&& ss
->expr
->ts
.type
== BT_CHARACTER
1690 && !typespec_chararray_ctor
)
1692 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
1696 ss
->data
.info
.dimen
= loop
->dimen
;
1698 c
= ss
->expr
->value
.constructor
;
1699 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1703 /* get_array_ctor_strlen walks the elements of the constructor, if a
1704 typespec was given, we already know the string length and want the one
1706 if (typespec_chararray_ctor
&& ss
->expr
->ts
.cl
->length
1707 && ss
->expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1711 const_string
= false;
1712 gfc_init_se (&length_se
, NULL
);
1713 gfc_conv_expr_type (&length_se
, ss
->expr
->ts
.cl
->length
,
1714 gfc_charlen_type_node
);
1715 ss
->string_length
= length_se
.expr
;
1716 gfc_add_block_to_block (&loop
->pre
, &length_se
.pre
);
1717 gfc_add_block_to_block (&loop
->post
, &length_se
.post
);
1720 const_string
= get_array_ctor_strlen (&loop
->pre
, c
,
1721 &ss
->string_length
);
1723 /* Complex character array constructors should have been taken care of
1724 and not end up here. */
1725 gcc_assert (ss
->string_length
);
1727 ss
->expr
->ts
.cl
->backend_decl
= ss
->string_length
;
1729 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1731 type
= build_pointer_type (type
);
1734 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1736 /* See if the constructor determines the loop bounds. */
1739 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1741 /* We have a multidimensional parameter. */
1743 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1745 loop
->from
[n
] = gfc_index_zero_node
;
1746 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1747 gfc_index_integer_kind
);
1748 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1749 loop
->to
[n
], gfc_index_one_node
);
1753 if (loop
->to
[0] == NULL_TREE
)
1757 /* We should have a 1-dimensional, zero-based loop. */
1758 gcc_assert (loop
->dimen
== 1);
1759 gcc_assert (integer_zerop (loop
->from
[0]));
1761 /* Split the constructor size into a static part and a dynamic part.
1762 Allocate the static size up-front and record whether the dynamic
1763 size might be nonzero. */
1765 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1766 mpz_sub_ui (size
, size
, 1);
1767 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1771 /* Special case constant array constructors. */
1774 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1777 tree size
= constant_array_constructor_loop_size (loop
);
1778 if (size
&& compare_tree_int (size
, nelem
) == 0)
1780 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1786 /* Temporarily reset the loop variables, so that the returned temporary
1787 has the right size and bounds. This seems only to be necessary for
1789 if (!integer_zerop (loop
->from
[0]) && loop
->dimen
== 1)
1791 loopfrom
= loop
->from
[0];
1792 loop
->from
[0] = gfc_index_zero_node
;
1793 loop
->to
[0] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1794 loop
->to
[0], loopfrom
);
1797 loopfrom
= NULL_TREE
;
1799 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1800 type
, dynamic
, true, false);
1802 if (loopfrom
!= NULL_TREE
)
1804 loop
->from
[0] = loopfrom
;
1805 loop
->to
[0] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1806 loop
->to
[0], loopfrom
);
1807 /* In the case of a non-zero from, the temporary needs an offset
1808 so that subsequent indexing is correct. */
1809 ss
->data
.info
.offset
= fold_build1 (NEGATE_EXPR
,
1810 gfc_array_index_type
,
1814 desc
= ss
->data
.info
.descriptor
;
1815 offset
= gfc_index_zero_node
;
1816 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1817 TREE_NO_WARNING (offsetvar
) = 1;
1818 TREE_USED (offsetvar
) = 0;
1819 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1820 &offset
, &offsetvar
, dynamic
);
1822 /* If the array grows dynamically, the upper bound of the loop variable
1823 is determined by the array's final upper bound. */
1825 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1827 if (TREE_USED (offsetvar
))
1828 pushdecl (offsetvar
);
1830 gcc_assert (INTEGER_CST_P (offset
));
1832 /* Disable bound checking for now because it's probably broken. */
1833 if (flag_bounds_check
)
1841 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1842 called after evaluating all of INFO's vector dimensions. Go through
1843 each such vector dimension and see if we can now fill in any missing
1847 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1856 for (n
= 0; n
< loop
->dimen
; n
++)
1859 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1860 && loop
->to
[n
] == NULL
)
1862 /* Loop variable N indexes vector dimension DIM, and we don't
1863 yet know the upper bound of loop variable N. Set it to the
1864 difference between the vector's upper and lower bounds. */
1865 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1866 gcc_assert (info
->subscript
[dim
]
1867 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1869 gfc_init_se (&se
, NULL
);
1870 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1871 zero
= gfc_rank_cst
[0];
1872 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1873 gfc_conv_descriptor_ubound (desc
, zero
),
1874 gfc_conv_descriptor_lbound (desc
, zero
));
1875 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1882 /* Add the pre and post chains for all the scalar expressions in a SS chain
1883 to loop. This is called after the loop parameters have been calculated,
1884 but before the actual scalarizing loops. */
1887 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1892 /* TODO: This can generate bad code if there are ordering dependencies.
1893 eg. a callee allocated function and an unknown size constructor. */
1894 gcc_assert (ss
!= NULL
);
1896 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1903 /* Scalar expression. Evaluate this now. This includes elemental
1904 dimension indices, but not array section bounds. */
1905 gfc_init_se (&se
, NULL
);
1906 gfc_conv_expr (&se
, ss
->expr
);
1907 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1909 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1911 /* Move the evaluation of scalar expressions outside the
1912 scalarization loop, except for WHERE assignments. */
1914 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1916 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1917 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1920 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1922 ss
->data
.scalar
.expr
= se
.expr
;
1923 ss
->string_length
= se
.string_length
;
1926 case GFC_SS_REFERENCE
:
1927 /* Scalar reference. Evaluate this now. */
1928 gfc_init_se (&se
, NULL
);
1929 gfc_conv_expr_reference (&se
, ss
->expr
);
1930 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1931 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1933 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1934 ss
->string_length
= se
.string_length
;
1937 case GFC_SS_SECTION
:
1938 /* Add the expressions for scalar and vector subscripts. */
1939 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1940 if (ss
->data
.info
.subscript
[n
])
1941 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1943 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1947 /* Get the vector's descriptor and store it in SS. */
1948 gfc_init_se (&se
, NULL
);
1949 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1950 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1951 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1952 ss
->data
.info
.descriptor
= se
.expr
;
1955 case GFC_SS_INTRINSIC
:
1956 gfc_add_intrinsic_ss_code (loop
, ss
);
1959 case GFC_SS_FUNCTION
:
1960 /* Array function return value. We call the function and save its
1961 result in a temporary for use inside the loop. */
1962 gfc_init_se (&se
, NULL
);
1965 gfc_conv_expr (&se
, ss
->expr
);
1966 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1967 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1968 ss
->string_length
= se
.string_length
;
1971 case GFC_SS_CONSTRUCTOR
:
1972 if (ss
->expr
->ts
.type
== BT_CHARACTER
1973 && ss
->string_length
== NULL
1975 && ss
->expr
->ts
.cl
->length
)
1977 gfc_init_se (&se
, NULL
);
1978 gfc_conv_expr_type (&se
, ss
->expr
->ts
.cl
->length
,
1979 gfc_charlen_type_node
);
1980 ss
->string_length
= se
.expr
;
1981 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1982 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1984 gfc_trans_array_constructor (loop
, ss
);
1988 case GFC_SS_COMPONENT
:
1989 /* Do nothing. These are handled elsewhere. */
1999 /* Translate expressions for the descriptor and data pointer of a SS. */
2003 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2008 /* Get the descriptor for the array to be scalarized. */
2009 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
2010 gfc_init_se (&se
, NULL
);
2011 se
.descriptor_only
= 1;
2012 gfc_conv_expr_lhs (&se
, ss
->expr
);
2013 gfc_add_block_to_block (block
, &se
.pre
);
2014 ss
->data
.info
.descriptor
= se
.expr
;
2015 ss
->string_length
= se
.string_length
;
2019 /* Also the data pointer. */
2020 tmp
= gfc_conv_array_data (se
.expr
);
2021 /* If this is a variable or address of a variable we use it directly.
2022 Otherwise we must evaluate it now to avoid breaking dependency
2023 analysis by pulling the expressions for elemental array indices
2026 || (TREE_CODE (tmp
) == ADDR_EXPR
2027 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2028 tmp
= gfc_evaluate_now (tmp
, block
);
2029 ss
->data
.info
.data
= tmp
;
2031 tmp
= gfc_conv_array_offset (se
.expr
);
2032 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
2037 /* Initialize a gfc_loopinfo structure. */
2040 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2044 memset (loop
, 0, sizeof (gfc_loopinfo
));
2045 gfc_init_block (&loop
->pre
);
2046 gfc_init_block (&loop
->post
);
2048 /* Initially scalarize in order. */
2049 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2052 loop
->ss
= gfc_ss_terminator
;
2056 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2060 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2066 /* Return an expression for the data pointer of an array. */
2069 gfc_conv_array_data (tree descriptor
)
2073 type
= TREE_TYPE (descriptor
);
2074 if (GFC_ARRAY_TYPE_P (type
))
2076 if (TREE_CODE (type
) == POINTER_TYPE
)
2080 /* Descriptorless arrays. */
2081 return build_fold_addr_expr (descriptor
);
2085 return gfc_conv_descriptor_data_get (descriptor
);
2089 /* Return an expression for the base offset of an array. */
2092 gfc_conv_array_offset (tree descriptor
)
2096 type
= TREE_TYPE (descriptor
);
2097 if (GFC_ARRAY_TYPE_P (type
))
2098 return GFC_TYPE_ARRAY_OFFSET (type
);
2100 return gfc_conv_descriptor_offset (descriptor
);
2104 /* Get an expression for the array stride. */
2107 gfc_conv_array_stride (tree descriptor
, int dim
)
2112 type
= TREE_TYPE (descriptor
);
2114 /* For descriptorless arrays use the array size. */
2115 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2116 if (tmp
!= NULL_TREE
)
2119 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
2124 /* Like gfc_conv_array_stride, but for the lower bound. */
2127 gfc_conv_array_lbound (tree descriptor
, int dim
)
2132 type
= TREE_TYPE (descriptor
);
2134 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2135 if (tmp
!= NULL_TREE
)
2138 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
2143 /* Like gfc_conv_array_stride, but for the upper bound. */
2146 gfc_conv_array_ubound (tree descriptor
, int dim
)
2151 type
= TREE_TYPE (descriptor
);
2153 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2154 if (tmp
!= NULL_TREE
)
2157 /* This should only ever happen when passing an assumed shape array
2158 as an actual parameter. The value will never be used. */
2159 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2160 return gfc_index_zero_node
;
2162 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
2167 /* Generate code to perform an array index bound check. */
2170 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2171 locus
* where
, bool check_upper
)
2176 const char * name
= NULL
;
2178 if (!flag_bounds_check
)
2181 index
= gfc_evaluate_now (index
, &se
->pre
);
2183 /* We find a name for the error message. */
2185 name
= se
->ss
->expr
->symtree
->name
;
2187 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2188 && se
->loop
->ss
->expr
->symtree
)
2189 name
= se
->loop
->ss
->expr
->symtree
->name
;
2191 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2192 && se
->loop
->ss
->loop_chain
->expr
2193 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2194 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2196 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2197 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2198 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2200 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2202 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2203 && se
->loop
->ss
->expr
->value
.function
.name
)
2204 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2206 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2207 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2208 name
= "unnamed constant";
2211 /* Check lower bound. */
2212 tmp
= gfc_conv_array_lbound (descriptor
, n
);
2213 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
2215 asprintf (&msg
, "%s for array '%s', lower bound of dimension %d exceeded"
2216 "(%%ld < %%ld)", gfc_msg_fault
, name
, n
+1);
2218 asprintf (&msg
, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2219 gfc_msg_fault
, n
+1);
2220 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
2221 fold_convert (long_integer_type_node
, index
),
2222 fold_convert (long_integer_type_node
, tmp
));
2225 /* Check upper bound. */
2228 tmp
= gfc_conv_array_ubound (descriptor
, n
);
2229 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
2231 asprintf (&msg
, "%s for array '%s', upper bound of dimension %d "
2232 " exceeded (%%ld > %%ld)", gfc_msg_fault
, name
, n
+1);
2234 asprintf (&msg
, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2235 gfc_msg_fault
, n
+1);
2236 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
2237 fold_convert (long_integer_type_node
, index
),
2238 fold_convert (long_integer_type_node
, tmp
));
2246 /* Return the offset for an index. Performs bound checking for elemental
2247 dimensions. Single element references are processed separately. */
2250 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2251 gfc_array_ref
* ar
, tree stride
)
2257 /* Get the index into the array for this dimension. */
2260 gcc_assert (ar
->type
!= AR_ELEMENT
);
2261 switch (ar
->dimen_type
[dim
])
2264 /* Elemental dimension. */
2265 gcc_assert (info
->subscript
[dim
]
2266 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2267 /* We've already translated this value outside the loop. */
2268 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2270 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2271 index
, dim
, &ar
->where
,
2272 (ar
->as
->type
!= AS_ASSUMED_SIZE
2273 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2277 gcc_assert (info
&& se
->loop
);
2278 gcc_assert (info
->subscript
[dim
]
2279 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2280 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2282 /* Get a zero-based index into the vector. */
2283 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2284 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2286 /* Multiply the index by the stride. */
2287 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2288 index
, gfc_conv_array_stride (desc
, 0));
2290 /* Read the vector to get an index into info->descriptor. */
2291 data
= build_fold_indirect_ref (gfc_conv_array_data (desc
));
2292 index
= gfc_build_array_ref (data
, index
, NULL
);
2293 index
= gfc_evaluate_now (index
, &se
->pre
);
2295 /* Do any bounds checking on the final info->descriptor index. */
2296 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2297 index
, dim
, &ar
->where
,
2298 (ar
->as
->type
!= AS_ASSUMED_SIZE
2299 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2303 /* Scalarized dimension. */
2304 gcc_assert (info
&& se
->loop
);
2306 /* Multiply the loop variable by the stride and delta. */
2307 index
= se
->loop
->loopvar
[i
];
2308 if (!integer_onep (info
->stride
[i
]))
2309 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2311 if (!integer_zerop (info
->delta
[i
]))
2312 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2322 /* Temporary array or derived type component. */
2323 gcc_assert (se
->loop
);
2324 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2325 if (!integer_zerop (info
->delta
[i
]))
2326 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2327 index
, info
->delta
[i
]);
2330 /* Multiply by the stride. */
2331 if (!integer_onep (stride
))
2332 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2338 /* Build a scalarized reference to an array. */
2341 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2344 tree decl
= NULL_TREE
;
2349 info
= &se
->ss
->data
.info
;
2351 n
= se
->loop
->order
[0];
2355 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2357 /* Add the offset for this dimension to the stored offset for all other
2359 if (!integer_zerop (info
->offset
))
2360 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2362 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2363 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2365 tmp
= build_fold_indirect_ref (info
->data
);
2366 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2370 /* Translate access of temporary array. */
2373 gfc_conv_tmp_array_ref (gfc_se
* se
)
2375 se
->string_length
= se
->ss
->string_length
;
2376 gfc_conv_scalarized_array_ref (se
, NULL
);
2380 /* Build an array reference. se->expr already holds the array descriptor.
2381 This should be either a variable, indirect variable reference or component
2382 reference. For arrays which do not have a descriptor, se->expr will be
2384 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2387 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2396 /* Handle scalarized references separately. */
2397 if (ar
->type
!= AR_ELEMENT
)
2399 gfc_conv_scalarized_array_ref (se
, ar
);
2400 gfc_advance_se_ss_chain (se
);
2404 index
= gfc_index_zero_node
;
2406 /* Calculate the offsets from all the dimensions. */
2407 for (n
= 0; n
< ar
->dimen
; n
++)
2409 /* Calculate the index for this dimension. */
2410 gfc_init_se (&indexse
, se
);
2411 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2412 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2414 if (flag_bounds_check
)
2416 /* Check array bounds. */
2420 /* Evaluate the indexse.expr only once. */
2421 indexse
.expr
= save_expr (indexse
.expr
);
2424 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2425 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2427 asprintf (&msg
, "%s for array '%s', "
2428 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2429 gfc_msg_fault
, sym
->name
, n
+1);
2430 gfc_trans_runtime_check (cond
, &se
->pre
, where
, msg
,
2431 fold_convert (long_integer_type_node
,
2433 fold_convert (long_integer_type_node
, tmp
));
2436 /* Upper bound, but not for the last dimension of assumed-size
2438 if (n
< ar
->dimen
- 1
2439 || (ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
))
2441 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2442 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2444 asprintf (&msg
, "%s for array '%s', "
2445 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2446 gfc_msg_fault
, sym
->name
, n
+1);
2447 gfc_trans_runtime_check (cond
, &se
->pre
, where
, msg
,
2448 fold_convert (long_integer_type_node
,
2450 fold_convert (long_integer_type_node
, tmp
));
2455 /* Multiply the index by the stride. */
2456 stride
= gfc_conv_array_stride (se
->expr
, n
);
2457 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2460 /* And add it to the total. */
2461 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2464 tmp
= gfc_conv_array_offset (se
->expr
);
2465 if (!integer_zerop (tmp
))
2466 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2468 /* Access the calculated element. */
2469 tmp
= gfc_conv_array_data (se
->expr
);
2470 tmp
= build_fold_indirect_ref (tmp
);
2471 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2475 /* Generate the code to be executed immediately before entering a
2476 scalarization loop. */
2479 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2480 stmtblock_t
* pblock
)
2489 /* This code will be executed before entering the scalarization loop
2490 for this dimension. */
2491 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2493 if ((ss
->useflags
& flag
) == 0)
2496 if (ss
->type
!= GFC_SS_SECTION
2497 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2498 && ss
->type
!= GFC_SS_COMPONENT
)
2501 info
= &ss
->data
.info
;
2503 if (dim
>= info
->dimen
)
2506 if (dim
== info
->dimen
- 1)
2508 /* For the outermost loop calculate the offset due to any
2509 elemental dimensions. It will have been initialized with the
2510 base offset of the array. */
2513 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2515 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2518 gfc_init_se (&se
, NULL
);
2520 se
.expr
= info
->descriptor
;
2521 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2522 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2525 gfc_add_block_to_block (pblock
, &se
.pre
);
2527 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2528 info
->offset
, index
);
2529 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2533 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2536 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2538 /* Calculate the stride of the innermost loop. Hopefully this will
2539 allow the backend optimizers to do their stuff more effectively.
2541 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2545 /* Add the offset for the previous loop dimension. */
2550 ar
= &info
->ref
->u
.ar
;
2551 i
= loop
->order
[dim
+ 1];
2559 gfc_init_se (&se
, NULL
);
2561 se
.expr
= info
->descriptor
;
2562 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2563 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2565 gfc_add_block_to_block (pblock
, &se
.pre
);
2566 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2567 info
->offset
, index
);
2568 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2571 /* Remember this offset for the second loop. */
2572 if (dim
== loop
->temp_dim
- 1)
2573 info
->saved_offset
= info
->offset
;
2578 /* Start a scalarized expression. Creates a scope and declares loop
2582 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2588 gcc_assert (!loop
->array_parameter
);
2590 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2592 n
= loop
->order
[dim
];
2594 gfc_start_block (&loop
->code
[n
]);
2596 /* Create the loop variable. */
2597 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2599 if (dim
< loop
->temp_dim
)
2603 /* Calculate values that will be constant within this loop. */
2604 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2606 gfc_start_block (pbody
);
2610 /* Generates the actual loop code for a scalarization loop. */
2613 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2614 stmtblock_t
* pbody
)
2622 loopbody
= gfc_finish_block (pbody
);
2624 /* Initialize the loopvar. */
2625 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2627 exit_label
= gfc_build_label_decl (NULL_TREE
);
2629 /* Generate the loop body. */
2630 gfc_init_block (&block
);
2632 /* The exit condition. */
2633 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2634 loop
->loopvar
[n
], loop
->to
[n
]);
2635 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2636 TREE_USED (exit_label
) = 1;
2637 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2638 gfc_add_expr_to_block (&block
, tmp
);
2640 /* The main body. */
2641 gfc_add_expr_to_block (&block
, loopbody
);
2643 /* Increment the loopvar. */
2644 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2645 loop
->loopvar
[n
], gfc_index_one_node
);
2646 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2648 /* Build the loop. */
2649 tmp
= gfc_finish_block (&block
);
2650 tmp
= build1_v (LOOP_EXPR
, tmp
);
2651 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2653 /* Add the exit label. */
2654 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2655 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2659 /* Finishes and generates the loops for a scalarized expression. */
2662 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2667 stmtblock_t
*pblock
;
2671 /* Generate the loops. */
2672 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2674 n
= loop
->order
[dim
];
2675 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2676 loop
->loopvar
[n
] = NULL_TREE
;
2677 pblock
= &loop
->code
[n
];
2680 tmp
= gfc_finish_block (pblock
);
2681 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2683 /* Clear all the used flags. */
2684 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2689 /* Finish the main body of a scalarized expression, and start the secondary
2693 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2697 stmtblock_t
*pblock
;
2701 /* We finish as many loops as are used by the temporary. */
2702 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2704 n
= loop
->order
[dim
];
2705 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2706 loop
->loopvar
[n
] = NULL_TREE
;
2707 pblock
= &loop
->code
[n
];
2710 /* We don't want to finish the outermost loop entirely. */
2711 n
= loop
->order
[loop
->temp_dim
- 1];
2712 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2714 /* Restore the initial offsets. */
2715 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2717 if ((ss
->useflags
& 2) == 0)
2720 if (ss
->type
!= GFC_SS_SECTION
2721 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2722 && ss
->type
!= GFC_SS_COMPONENT
)
2725 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2728 /* Restart all the inner loops we just finished. */
2729 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2731 n
= loop
->order
[dim
];
2733 gfc_start_block (&loop
->code
[n
]);
2735 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2737 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2740 /* Start a block for the secondary copying code. */
2741 gfc_start_block (body
);
2745 /* Calculate the upper bound of an array section. */
2748 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2757 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2759 info
= &ss
->data
.info
;
2762 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2763 /* We'll calculate the upper bound once we have access to the
2764 vector's descriptor. */
2767 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2768 desc
= info
->descriptor
;
2769 end
= info
->ref
->u
.ar
.end
[dim
];
2773 /* The upper bound was specified. */
2774 gfc_init_se (&se
, NULL
);
2775 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2776 gfc_add_block_to_block (pblock
, &se
.pre
);
2781 /* No upper bound was specified, so use the bound of the array. */
2782 bound
= gfc_conv_array_ubound (desc
, dim
);
2789 /* Calculate the lower bound of an array section. */
2792 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2802 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2804 info
= &ss
->data
.info
;
2807 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2809 /* We use a zero-based index to access the vector. */
2810 info
->start
[n
] = gfc_index_zero_node
;
2811 info
->end
[n
] = gfc_index_zero_node
;
2812 info
->stride
[n
] = gfc_index_one_node
;
2816 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2817 desc
= info
->descriptor
;
2818 start
= info
->ref
->u
.ar
.start
[dim
];
2819 end
= info
->ref
->u
.ar
.end
[dim
];
2820 stride
= info
->ref
->u
.ar
.stride
[dim
];
2822 /* Calculate the start of the range. For vector subscripts this will
2823 be the range of the vector. */
2826 /* Specified section start. */
2827 gfc_init_se (&se
, NULL
);
2828 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2829 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2830 info
->start
[n
] = se
.expr
;
2834 /* No lower bound specified so use the bound of the array. */
2835 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2837 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2839 /* Similarly calculate the end. Although this is not used in the
2840 scalarizer, it is needed when checking bounds and where the end
2841 is an expression with side-effects. */
2844 /* Specified section start. */
2845 gfc_init_se (&se
, NULL
);
2846 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2847 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2848 info
->end
[n
] = se
.expr
;
2852 /* No upper bound specified so use the bound of the array. */
2853 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
2855 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
2857 /* Calculate the stride. */
2859 info
->stride
[n
] = gfc_index_one_node
;
2862 gfc_init_se (&se
, NULL
);
2863 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2864 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2865 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2870 /* Calculates the range start and stride for a SS chain. Also gets the
2871 descriptor and data pointer. The range of vector subscripts is the size
2872 of the vector. Array bounds are also checked. */
2875 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2883 /* Determine the rank of the loop. */
2885 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2889 case GFC_SS_SECTION
:
2890 case GFC_SS_CONSTRUCTOR
:
2891 case GFC_SS_FUNCTION
:
2892 case GFC_SS_COMPONENT
:
2893 loop
->dimen
= ss
->data
.info
.dimen
;
2896 /* As usual, lbound and ubound are exceptions!. */
2897 case GFC_SS_INTRINSIC
:
2898 switch (ss
->expr
->value
.function
.isym
->id
)
2900 case GFC_ISYM_LBOUND
:
2901 case GFC_ISYM_UBOUND
:
2902 loop
->dimen
= ss
->data
.info
.dimen
;
2913 /* We should have determined the rank of the expression by now. If
2914 not, that's bad news. */
2915 gcc_assert (loop
->dimen
!= 0);
2917 /* Loop over all the SS in the chain. */
2918 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2920 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2921 ss
->shape
= ss
->expr
->shape
;
2925 case GFC_SS_SECTION
:
2926 /* Get the descriptor for the array. */
2927 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2929 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2930 gfc_conv_section_startstride (loop
, ss
, n
);
2933 case GFC_SS_INTRINSIC
:
2934 switch (ss
->expr
->value
.function
.isym
->id
)
2936 /* Fall through to supply start and stride. */
2937 case GFC_ISYM_LBOUND
:
2938 case GFC_ISYM_UBOUND
:
2944 case GFC_SS_CONSTRUCTOR
:
2945 case GFC_SS_FUNCTION
:
2946 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2948 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2949 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
2950 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2959 /* The rest is just runtime bound checking. */
2960 if (flag_bounds_check
)
2963 tree lbound
, ubound
;
2965 tree size
[GFC_MAX_DIMENSIONS
];
2966 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
;
2971 gfc_start_block (&block
);
2973 for (n
= 0; n
< loop
->dimen
; n
++)
2974 size
[n
] = NULL_TREE
;
2976 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2980 if (ss
->type
!= GFC_SS_SECTION
)
2983 gfc_start_block (&inner
);
2985 /* TODO: range checking for mapped dimensions. */
2986 info
= &ss
->data
.info
;
2988 /* This code only checks ranges. Elemental and vector
2989 dimensions are checked later. */
2990 for (n
= 0; n
< loop
->dimen
; n
++)
2995 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
2998 if (dim
== info
->ref
->u
.ar
.dimen
- 1
2999 && (info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
3000 || info
->ref
->u
.ar
.as
->cp_was_assumed
))
3001 check_upper
= false;
3005 /* Zero stride is not allowed. */
3006 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
3007 gfc_index_zero_node
);
3008 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3009 "of array '%s'", info
->dim
[n
]+1,
3010 ss
->expr
->symtree
->name
);
3011 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
);
3014 desc
= ss
->data
.info
.descriptor
;
3016 /* This is the run-time equivalent of resolve.c's
3017 check_dimension(). The logical is more readable there
3018 than it is here, with all the trees. */
3019 lbound
= gfc_conv_array_lbound (desc
, dim
);
3022 ubound
= gfc_conv_array_ubound (desc
, dim
);
3026 /* non_zerosized is true when the selected range is not
3028 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
3029 info
->stride
[n
], gfc_index_zero_node
);
3030 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
3032 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3035 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
3036 info
->stride
[n
], gfc_index_zero_node
);
3037 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
3039 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3041 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
3042 stride_pos
, stride_neg
);
3044 /* Check the start of the range against the lower and upper
3045 bounds of the array, if the range is not empty. */
3046 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, info
->start
[n
],
3048 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3049 non_zerosized
, tmp
);
3050 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
3051 " exceeded (%%ld < %%ld)", gfc_msg_fault
,
3052 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3053 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
,
3054 fold_convert (long_integer_type_node
,
3056 fold_convert (long_integer_type_node
,
3062 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
,
3063 info
->start
[n
], ubound
);
3064 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3065 non_zerosized
, tmp
);
3066 asprintf (&msg
, "%s, upper bound of dimension %d of array "
3067 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault
,
3068 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3069 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
,
3070 fold_convert (long_integer_type_node
, info
->start
[n
]),
3071 fold_convert (long_integer_type_node
, ubound
));
3075 /* Compute the last element of the range, which is not
3076 necessarily "end" (think 0:5:3, which doesn't contain 5)
3077 and check it against both lower and upper bounds. */
3078 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3080 tmp2
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp2
,
3082 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3085 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp2
, lbound
);
3086 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3087 non_zerosized
, tmp
);
3088 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
3089 " exceeded (%%ld < %%ld)", gfc_msg_fault
,
3090 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3091 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
,
3092 fold_convert (long_integer_type_node
,
3094 fold_convert (long_integer_type_node
,
3100 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp2
, ubound
);
3101 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3102 non_zerosized
, tmp
);
3103 asprintf (&msg
, "%s, upper bound of dimension %d of array "
3104 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault
,
3105 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3106 gfc_trans_runtime_check (tmp
, &inner
, &ss
->expr
->where
, msg
,
3107 fold_convert (long_integer_type_node
, tmp2
),
3108 fold_convert (long_integer_type_node
, ubound
));
3112 /* Check the section sizes match. */
3113 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3115 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
3117 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3118 build_int_cst (gfc_array_index_type
, 0));
3119 /* We remember the size of the first section, and check all the
3120 others against this. */
3125 tmp3
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
3126 asprintf (&msg
, "%s, size mismatch for dimension %d "
3127 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds
,
3128 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3129 gfc_trans_runtime_check (tmp3
, &inner
, &ss
->expr
->where
, msg
,
3130 fold_convert (long_integer_type_node
, tmp
),
3131 fold_convert (long_integer_type_node
, size
[n
]));
3135 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
3138 tmp
= gfc_finish_block (&inner
);
3140 /* For optional arguments, only check bounds if the argument is
3142 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3143 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3144 tmp
= build3_v (COND_EXPR
,
3145 gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
),
3146 tmp
, build_empty_stmt ());
3148 gfc_add_expr_to_block (&block
, tmp
);
3152 tmp
= gfc_finish_block (&block
);
3153 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3158 /* Return true if the two SS could be aliased, i.e. both point to the same data
3160 /* TODO: resolve aliases based on frontend expressions. */
3163 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3170 lsym
= lss
->expr
->symtree
->n
.sym
;
3171 rsym
= rss
->expr
->symtree
->n
.sym
;
3172 if (gfc_symbols_could_alias (lsym
, rsym
))
3175 if (rsym
->ts
.type
!= BT_DERIVED
3176 && lsym
->ts
.type
!= BT_DERIVED
)
3179 /* For derived types we must check all the component types. We can ignore
3180 array references as these will have the same base type as the previous
3182 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3184 if (lref
->type
!= REF_COMPONENT
)
3187 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3190 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3193 if (rref
->type
!= REF_COMPONENT
)
3196 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3201 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3203 if (rref
->type
!= REF_COMPONENT
)
3206 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3214 /* Resolve array data dependencies. Creates a temporary if required. */
3215 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3219 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3229 loop
->temp_ss
= NULL
;
3230 aref
= dest
->data
.info
.ref
;
3233 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3235 if (ss
->type
!= GFC_SS_SECTION
)
3238 if (gfc_could_be_alias (dest
, ss
)
3239 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3245 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
3247 lref
= dest
->expr
->ref
;
3248 rref
= ss
->expr
->ref
;
3250 nDepend
= gfc_dep_resolver (lref
, rref
);
3254 /* TODO : loop shifting. */
3257 /* Mark the dimensions for LOOP SHIFTING */
3258 for (n
= 0; n
< loop
->dimen
; n
++)
3260 int dim
= dest
->data
.info
.dim
[n
];
3262 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3264 else if (! gfc_is_same_range (&lref
->u
.ar
,
3265 &rref
->u
.ar
, dim
, 0))
3269 /* Put all the dimensions with dependencies in the
3272 for (n
= 0; n
< loop
->dimen
; n
++)
3274 gcc_assert (loop
->order
[n
] == n
);
3276 loop
->order
[dim
++] = n
;
3279 for (n
= 0; n
< loop
->dimen
; n
++)
3282 loop
->order
[dim
++] = n
;
3285 gcc_assert (dim
== loop
->dimen
);
3294 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3295 if (GFC_ARRAY_TYPE_P (base_type
)
3296 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3297 base_type
= gfc_get_element_type (base_type
);
3298 loop
->temp_ss
= gfc_get_ss ();
3299 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3300 loop
->temp_ss
->data
.temp
.type
= base_type
;
3301 loop
->temp_ss
->string_length
= dest
->string_length
;
3302 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3303 loop
->temp_ss
->next
= gfc_ss_terminator
;
3304 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3307 loop
->temp_ss
= NULL
;
3311 /* Initialize the scalarization loop. Creates the loop variables. Determines
3312 the range of the loop variables. Creates a temporary if required.
3313 Calculates how to transform from loop variables to array indices for each
3314 expression. Also generates code for scalar expressions which have been
3315 moved outside the loop. */
3318 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
3323 gfc_ss_info
*specinfo
;
3327 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3328 bool dynamic
[GFC_MAX_DIMENSIONS
];
3334 for (n
= 0; n
< loop
->dimen
; n
++)
3338 /* We use one SS term, and use that to determine the bounds of the
3339 loop for this dimension. We try to pick the simplest term. */
3340 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3344 /* The frontend has worked out the size for us. */
3349 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3351 /* An unknown size constructor will always be rank one.
3352 Higher rank constructors will either have known shape,
3353 or still be wrapped in a call to reshape. */
3354 gcc_assert (loop
->dimen
== 1);
3356 /* Always prefer to use the constructor bounds if the size
3357 can be determined at compile time. Prefer not to otherwise,
3358 since the general case involves realloc, and it's better to
3359 avoid that overhead if possible. */
3360 c
= ss
->expr
->value
.constructor
;
3361 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
3362 if (!dynamic
[n
] || !loopspec
[n
])
3367 /* TODO: Pick the best bound if we have a choice between a
3368 function and something else. */
3369 if (ss
->type
== GFC_SS_FUNCTION
)
3375 if (ss
->type
!= GFC_SS_SECTION
)
3379 specinfo
= &loopspec
[n
]->data
.info
;
3382 info
= &ss
->data
.info
;
3386 /* Criteria for choosing a loop specifier (most important first):
3387 doesn't need realloc
3393 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3395 else if (integer_onep (info
->stride
[n
])
3396 && !integer_onep (specinfo
->stride
[n
]))
3398 else if (INTEGER_CST_P (info
->stride
[n
])
3399 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3401 else if (INTEGER_CST_P (info
->start
[n
])
3402 && !INTEGER_CST_P (specinfo
->start
[n
]))
3404 /* We don't work out the upper bound.
3405 else if (INTEGER_CST_P (info->finish[n])
3406 && ! INTEGER_CST_P (specinfo->finish[n]))
3407 loopspec[n] = ss; */
3410 /* We should have found the scalarization loop specifier. If not,
3412 gcc_assert (loopspec
[n
]);
3414 info
= &loopspec
[n
]->data
.info
;
3416 /* Set the extents of this range. */
3417 cshape
= loopspec
[n
]->shape
;
3418 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3419 && INTEGER_CST_P (info
->stride
[n
]))
3421 loop
->from
[n
] = info
->start
[n
];
3422 mpz_set (i
, cshape
[n
]);
3423 mpz_sub_ui (i
, i
, 1);
3424 /* To = from + (size - 1) * stride. */
3425 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3426 if (!integer_onep (info
->stride
[n
]))
3427 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3428 tmp
, info
->stride
[n
]);
3429 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3430 loop
->from
[n
], tmp
);
3434 loop
->from
[n
] = info
->start
[n
];
3435 switch (loopspec
[n
]->type
)
3437 case GFC_SS_CONSTRUCTOR
:
3438 /* The upper bound is calculated when we expand the
3440 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3443 case GFC_SS_SECTION
:
3444 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3448 case GFC_SS_FUNCTION
:
3449 /* The loop bound will be set when we generate the call. */
3450 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3458 /* Transform everything so we have a simple incrementing variable. */
3459 if (integer_onep (info
->stride
[n
]))
3460 info
->delta
[n
] = gfc_index_zero_node
;
3463 /* Set the delta for this section. */
3464 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3465 /* Number of iterations is (end - start + step) / step.
3466 with start = 0, this simplifies to
3468 for (i = 0; i<=last; i++){...}; */
3469 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3470 loop
->to
[n
], loop
->from
[n
]);
3471 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
,
3472 tmp
, info
->stride
[n
]);
3473 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3474 build_int_cst (gfc_array_index_type
, -1));
3475 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3476 /* Make the loop variable start at 0. */
3477 loop
->from
[n
] = gfc_index_zero_node
;
3481 /* Add all the scalar code that can be taken out of the loops.
3482 This may include calculating the loop bounds, so do it before
3483 allocating the temporary. */
3484 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
3486 /* If we want a temporary then create it. */
3487 if (loop
->temp_ss
!= NULL
)
3489 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3491 /* Make absolutely sure that this is a complete type. */
3492 if (loop
->temp_ss
->string_length
)
3493 loop
->temp_ss
->data
.temp
.type
3494 = gfc_get_character_type_len_for_eltype
3495 (TREE_TYPE (loop
->temp_ss
->data
.temp
.type
),
3496 loop
->temp_ss
->string_length
);
3498 tmp
= loop
->temp_ss
->data
.temp
.type
;
3499 len
= loop
->temp_ss
->string_length
;
3500 n
= loop
->temp_ss
->data
.temp
.dimen
;
3501 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3502 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3503 loop
->temp_ss
->data
.info
.dimen
= n
;
3504 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3505 &loop
->temp_ss
->data
.info
, tmp
, false, true,
3509 for (n
= 0; n
< loop
->temp_dim
; n
++)
3510 loopspec
[loop
->order
[n
]] = NULL
;
3514 /* For array parameters we don't have loop variables, so don't calculate the
3516 if (loop
->array_parameter
)
3519 /* Calculate the translation from loop variables to array indices. */
3520 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3522 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
3525 info
= &ss
->data
.info
;
3527 for (n
= 0; n
< info
->dimen
; n
++)
3531 /* If we are specifying the range the delta is already set. */
3532 if (loopspec
[n
] != ss
)
3534 /* Calculate the offset relative to the loop variable.
3535 First multiply by the stride. */
3536 tmp
= loop
->from
[n
];
3537 if (!integer_onep (info
->stride
[n
]))
3538 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3539 tmp
, info
->stride
[n
]);
3541 /* Then subtract this from our starting value. */
3542 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3543 info
->start
[n
], tmp
);
3545 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3552 /* Fills in an array descriptor, and returns the size of the array. The size
3553 will be a simple_val, ie a variable or a constant. Also calculates the
3554 offset of the base. Returns the size of the array.
3558 for (n = 0; n < rank; n++)
3560 a.lbound[n] = specified_lower_bound;
3561 offset = offset + a.lbond[n] * stride;
3563 a.ubound[n] = specified_upper_bound;
3564 a.stride[n] = stride;
3565 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3566 stride = stride * size;
3573 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3574 gfc_expr
** lower
, gfc_expr
** upper
,
3575 stmtblock_t
* pblock
)
3587 stmtblock_t thenblock
;
3588 stmtblock_t elseblock
;
3593 type
= TREE_TYPE (descriptor
);
3595 stride
= gfc_index_one_node
;
3596 offset
= gfc_index_zero_node
;
3598 /* Set the dtype. */
3599 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3600 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3602 or_expr
= NULL_TREE
;
3604 for (n
= 0; n
< rank
; n
++)
3606 /* We have 3 possibilities for determining the size of the array:
3607 lower == NULL => lbound = 1, ubound = upper[n]
3608 upper[n] = NULL => lbound = 1, ubound = lower[n]
3609 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3612 /* Set lower bound. */
3613 gfc_init_se (&se
, NULL
);
3615 se
.expr
= gfc_index_one_node
;
3618 gcc_assert (lower
[n
]);
3621 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3622 gfc_add_block_to_block (pblock
, &se
.pre
);
3626 se
.expr
= gfc_index_one_node
;
3630 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
3631 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3633 /* Work out the offset for this component. */
3634 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3635 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3637 /* Start the calculation for the size of this dimension. */
3638 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3639 gfc_index_one_node
, se
.expr
);
3641 /* Set upper bound. */
3642 gfc_init_se (&se
, NULL
);
3643 gcc_assert (ubound
);
3644 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3645 gfc_add_block_to_block (pblock
, &se
.pre
);
3647 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
3648 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3650 /* Store the stride. */
3651 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
3652 gfc_add_modify_expr (pblock
, tmp
, stride
);
3654 /* Calculate the size of this dimension. */
3655 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3657 /* Check whether the size for this dimension is negative. */
3658 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3659 gfc_index_zero_node
);
3663 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3665 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
3666 gfc_index_zero_node
, size
);
3668 /* Multiply the stride by the number of elements in this dimension. */
3669 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3670 stride
= gfc_evaluate_now (stride
, pblock
);
3673 /* The stride is the number of elements in the array, so multiply by the
3674 size of an element to get the total size. */
3675 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3676 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3677 fold_convert (gfc_array_index_type
, tmp
));
3679 if (poffset
!= NULL
)
3681 offset
= gfc_evaluate_now (offset
, pblock
);
3685 if (integer_zerop (or_expr
))
3687 if (integer_onep (or_expr
))
3688 return gfc_index_zero_node
;
3690 var
= gfc_create_var (TREE_TYPE (size
), "size");
3691 gfc_start_block (&thenblock
);
3692 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
3693 thencase
= gfc_finish_block (&thenblock
);
3695 gfc_start_block (&elseblock
);
3696 gfc_add_modify_expr (&elseblock
, var
, size
);
3697 elsecase
= gfc_finish_block (&elseblock
);
3699 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3700 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3701 gfc_add_expr_to_block (pblock
, tmp
);
3707 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3708 the work for an ALLOCATE statement. */
3712 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3720 gfc_ref
*ref
, *prev_ref
= NULL
;
3721 bool allocatable_array
;
3725 /* Find the last reference in the chain. */
3726 while (ref
&& ref
->next
!= NULL
)
3728 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3733 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3737 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3739 allocatable_array
= prev_ref
->u
.c
.component
->allocatable
;
3741 /* Figure out the size of the array. */
3742 switch (ref
->u
.ar
.type
)
3746 upper
= ref
->u
.ar
.start
;
3750 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
3752 lower
= ref
->u
.ar
.as
->lower
;
3753 upper
= ref
->u
.ar
.as
->upper
;
3757 lower
= ref
->u
.ar
.start
;
3758 upper
= ref
->u
.ar
.end
;
3766 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
3767 lower
, upper
, &se
->pre
);
3769 /* Allocate memory to store the data. */
3770 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
3771 STRIP_NOPS (pointer
);
3773 /* The allocate_array variants take the old pointer as first argument. */
3774 if (allocatable_array
)
3775 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
);
3777 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
3778 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
3779 gfc_add_expr_to_block (&se
->pre
, tmp
);
3781 tmp
= gfc_conv_descriptor_offset (se
->expr
);
3782 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
3784 if (expr
->ts
.type
== BT_DERIVED
3785 && expr
->ts
.derived
->attr
.alloc_comp
)
3787 tmp
= gfc_nullify_alloc_comp (expr
->ts
.derived
, se
->expr
,
3788 ref
->u
.ar
.as
->rank
);
3789 gfc_add_expr_to_block (&se
->pre
, tmp
);
3796 /* Deallocate an array variable. Also used when an allocated variable goes
3801 gfc_array_deallocate (tree descriptor
, tree pstat
)
3807 gfc_start_block (&block
);
3808 /* Get a pointer to the data. */
3809 var
= gfc_conv_descriptor_data_get (descriptor
);
3812 /* Parameter is the address of the data component. */
3813 tmp
= gfc_deallocate_with_status (var
, pstat
, false);
3814 gfc_add_expr_to_block (&block
, tmp
);
3816 /* Zero the data pointer. */
3817 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
3818 var
, build_int_cst (TREE_TYPE (var
), 0));
3819 gfc_add_expr_to_block (&block
, tmp
);
3821 return gfc_finish_block (&block
);
3825 /* Create an array constructor from an initialization expression.
3826 We assume the frontend already did any expansions and conversions. */
3829 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3836 unsigned HOST_WIDE_INT lo
;
3838 VEC(constructor_elt
,gc
) *v
= NULL
;
3840 switch (expr
->expr_type
)
3843 case EXPR_STRUCTURE
:
3844 /* A single scalar or derived type value. Create an array with all
3845 elements equal to that value. */
3846 gfc_init_se (&se
, NULL
);
3848 if (expr
->expr_type
== EXPR_CONSTANT
)
3849 gfc_conv_constant (&se
, expr
);
3851 gfc_conv_structure (&se
, expr
, 1);
3853 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3854 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3855 hi
= TREE_INT_CST_HIGH (tmp
);
3856 lo
= TREE_INT_CST_LOW (tmp
);
3860 /* This will probably eat buckets of memory for large arrays. */
3861 while (hi
!= 0 || lo
!= 0)
3863 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3871 /* Create a vector of all the elements. */
3872 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3876 /* Problems occur when we get something like
3877 integer :: a(lots) = (/(i, i=1,lots)/) */
3878 /* TODO: Unexpanded array initializers. */
3880 ("Possible frontend bug: array constructor not expanded");
3882 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3883 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3887 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3891 mpz_set (maxval
, c
->repeat
);
3892 mpz_add (maxval
, c
->n
.offset
, maxval
);
3893 mpz_sub_ui (maxval
, maxval
, 1);
3894 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3895 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3897 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3898 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3901 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3903 range
= fold_build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3909 gfc_init_se (&se
, NULL
);
3910 switch (c
->expr
->expr_type
)
3913 gfc_conv_constant (&se
, c
->expr
);
3914 if (range
== NULL_TREE
)
3915 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3918 if (index
!= NULL_TREE
)
3919 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3920 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3924 case EXPR_STRUCTURE
:
3925 gfc_conv_structure (&se
, c
->expr
, 1);
3926 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3936 return gfc_build_null_descriptor (type
);
3942 /* Create a constructor from the list of elements. */
3943 tmp
= build_constructor (type
, v
);
3944 TREE_CONSTANT (tmp
) = 1;
3949 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3950 returns the size (in elements) of the array. */
3953 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3954 stmtblock_t
* pblock
)
3969 size
= gfc_index_one_node
;
3970 offset
= gfc_index_zero_node
;
3971 for (dim
= 0; dim
< as
->rank
; dim
++)
3973 /* Evaluate non-constant array bound expressions. */
3974 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3975 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3977 gfc_init_se (&se
, NULL
);
3978 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3979 gfc_add_block_to_block (pblock
, &se
.pre
);
3980 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3982 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3983 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3985 gfc_init_se (&se
, NULL
);
3986 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3987 gfc_add_block_to_block (pblock
, &se
.pre
);
3988 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
3990 /* The offset of this dimension. offset = offset - lbound * stride. */
3991 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
3992 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3994 /* The size of this dimension, and the stride of the next. */
3995 if (dim
+ 1 < as
->rank
)
3996 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3998 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4000 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
4002 /* Calculate stride = size * (ubound + 1 - lbound). */
4003 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4004 gfc_index_one_node
, lbound
);
4005 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
4006 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
4008 gfc_add_modify_expr (pblock
, stride
, tmp
);
4010 stride
= gfc_evaluate_now (tmp
, pblock
);
4012 /* Make sure that negative size arrays are translated
4013 to being zero size. */
4014 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
,
4015 stride
, gfc_index_zero_node
);
4016 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4017 stride
, gfc_index_zero_node
);
4018 gfc_add_modify_expr (pblock
, stride
, tmp
);
4024 gfc_trans_vla_type_sizes (sym
, pblock
);
4031 /* Generate code to initialize/allocate an array variable. */
4034 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
4043 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
4045 /* Do nothing for USEd variables. */
4046 if (sym
->attr
.use_assoc
)
4049 type
= TREE_TYPE (decl
);
4050 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4051 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
4053 gfc_start_block (&block
);
4055 /* Evaluate character string length. */
4056 if (sym
->ts
.type
== BT_CHARACTER
4057 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
4059 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4061 gfc_trans_vla_type_sizes (sym
, &block
);
4063 /* Emit a DECL_EXPR for this variable, which will cause the
4064 gimplifier to allocate storage, and all that good stuff. */
4065 tmp
= fold_build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
4066 gfc_add_expr_to_block (&block
, tmp
);
4071 gfc_add_expr_to_block (&block
, fnbody
);
4072 return gfc_finish_block (&block
);
4075 type
= TREE_TYPE (type
);
4077 gcc_assert (!sym
->attr
.use_assoc
);
4078 gcc_assert (!TREE_STATIC (decl
));
4079 gcc_assert (!sym
->module
);
4081 if (sym
->ts
.type
== BT_CHARACTER
4082 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
4083 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4085 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4087 /* Don't actually allocate space for Cray Pointees. */
4088 if (sym
->attr
.cray_pointee
)
4090 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4091 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4092 gfc_add_expr_to_block (&block
, fnbody
);
4093 return gfc_finish_block (&block
);
4096 /* The size is the number of elements in the array, so multiply by the
4097 size of an element to get the total size. */
4098 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4099 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
4100 fold_convert (gfc_array_index_type
, tmp
));
4102 /* Allocate memory to hold the data. */
4103 tmp
= gfc_call_malloc (&block
, TREE_TYPE (decl
), size
);
4104 gfc_add_modify_expr (&block
, decl
, tmp
);
4106 /* Set offset of the array. */
4107 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4108 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4111 /* Automatic arrays should not have initializers. */
4112 gcc_assert (!sym
->value
);
4114 gfc_add_expr_to_block (&block
, fnbody
);
4116 /* Free the temporary. */
4117 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
4118 gfc_add_expr_to_block (&block
, tmp
);
4120 return gfc_finish_block (&block
);
4124 /* Generate entry and exit code for g77 calling convention arrays. */
4127 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
4137 gfc_get_backend_locus (&loc
);
4138 gfc_set_backend_locus (&sym
->declared_at
);
4140 /* Descriptor type. */
4141 parm
= sym
->backend_decl
;
4142 type
= TREE_TYPE (parm
);
4143 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4145 gfc_start_block (&block
);
4147 if (sym
->ts
.type
== BT_CHARACTER
4148 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4149 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4151 /* Evaluate the bounds of the array. */
4152 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4154 /* Set the offset. */
4155 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4156 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4158 /* Set the pointer itself if we aren't using the parameter directly. */
4159 if (TREE_CODE (parm
) != PARM_DECL
)
4161 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4162 gfc_add_modify_expr (&block
, parm
, tmp
);
4164 stmt
= gfc_finish_block (&block
);
4166 gfc_set_backend_locus (&loc
);
4168 gfc_start_block (&block
);
4170 /* Add the initialization code to the start of the function. */
4172 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4174 tmp
= gfc_conv_expr_present (sym
);
4175 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4178 gfc_add_expr_to_block (&block
, stmt
);
4179 gfc_add_expr_to_block (&block
, body
);
4181 return gfc_finish_block (&block
);
4185 /* Modify the descriptor of an array parameter so that it has the
4186 correct lower bound. Also move the upper bound accordingly.
4187 If the array is not packed, it will be copied into a temporary.
4188 For each dimension we set the new lower and upper bounds. Then we copy the
4189 stride and calculate the offset for this dimension. We also work out
4190 what the stride of a packed array would be, and see it the two match.
4191 If the array need repacking, we set the stride to the values we just
4192 calculated, recalculate the offset and copy the array data.
4193 Code is also added to copy the data back at the end of the function.
4197 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
4204 stmtblock_t cleanup
;
4212 tree stride
, stride2
;
4222 /* Do nothing for pointer and allocatable arrays. */
4223 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4226 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4227 return gfc_trans_g77_array (sym
, body
);
4229 gfc_get_backend_locus (&loc
);
4230 gfc_set_backend_locus (&sym
->declared_at
);
4232 /* Descriptor type. */
4233 type
= TREE_TYPE (tmpdesc
);
4234 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4235 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4236 dumdesc
= build_fold_indirect_ref (dumdesc
);
4237 gfc_start_block (&block
);
4239 if (sym
->ts
.type
== BT_CHARACTER
4240 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4241 gfc_conv_string_length (sym
->ts
.cl
, &block
);
4243 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
4245 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4246 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4248 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4250 /* For non-constant shape arrays we only check if the first dimension
4251 is contiguous. Repacking higher dimensions wouldn't gain us
4252 anything as we still don't know the array stride. */
4253 partial
= gfc_create_var (boolean_type_node
, "partial");
4254 TREE_USED (partial
) = 1;
4255 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4256 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4257 gfc_add_modify_expr (&block
, partial
, tmp
);
4261 partial
= NULL_TREE
;
4264 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4265 here, however I think it does the right thing. */
4268 /* Set the first stride. */
4269 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4270 stride
= gfc_evaluate_now (stride
, &block
);
4272 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4273 stride
, gfc_index_zero_node
);
4274 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4275 gfc_index_one_node
, stride
);
4276 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4277 gfc_add_modify_expr (&block
, stride
, tmp
);
4279 /* Allow the user to disable array repacking. */
4280 stmt_unpacked
= NULL_TREE
;
4284 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4285 /* A library call to repack the array if necessary. */
4286 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4287 stmt_unpacked
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
4289 stride
= gfc_index_one_node
;
4292 /* This is for the case where the array data is used directly without
4293 calling the repack function. */
4294 if (no_repack
|| partial
!= NULL_TREE
)
4295 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4297 stmt_packed
= NULL_TREE
;
4299 /* Assign the data pointer. */
4300 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4302 /* Don't repack unknown shape arrays when the first stride is 1. */
4303 tmp
= fold_build3 (COND_EXPR
, TREE_TYPE (stmt_packed
),
4304 partial
, stmt_packed
, stmt_unpacked
);
4307 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4308 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
4310 offset
= gfc_index_zero_node
;
4311 size
= gfc_index_one_node
;
4313 /* Evaluate the bounds of the array. */
4314 for (n
= 0; n
< sym
->as
->rank
; n
++)
4316 if (checkparm
|| !sym
->as
->upper
[n
])
4318 /* Get the bounds of the actual parameter. */
4319 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
4320 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
4324 dubound
= NULL_TREE
;
4325 dlbound
= NULL_TREE
;
4328 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4329 if (!INTEGER_CST_P (lbound
))
4331 gfc_init_se (&se
, NULL
);
4332 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4333 gfc_array_index_type
);
4334 gfc_add_block_to_block (&block
, &se
.pre
);
4335 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
4338 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4339 /* Set the desired upper bound. */
4340 if (sym
->as
->upper
[n
])
4342 /* We know what we want the upper bound to be. */
4343 if (!INTEGER_CST_P (ubound
))
4345 gfc_init_se (&se
, NULL
);
4346 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4347 gfc_array_index_type
);
4348 gfc_add_block_to_block (&block
, &se
.pre
);
4349 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
4352 /* Check the sizes match. */
4355 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4358 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4360 stride2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4362 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
4363 asprintf (&msg
, "%s for dimension %d of array '%s'",
4364 gfc_msg_bounds
, n
+1, sym
->name
);
4365 gfc_trans_runtime_check (tmp
, &block
, &loc
, msg
);
4371 /* For assumed shape arrays move the upper bound by the same amount
4372 as the lower bound. */
4373 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4375 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4376 gfc_add_modify_expr (&block
, ubound
, tmp
);
4378 /* The offset of this dimension. offset = offset - lbound * stride. */
4379 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4380 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4382 /* The size of this dimension, and the stride of the next. */
4383 if (n
+ 1 < sym
->as
->rank
)
4385 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4387 if (no_repack
|| partial
!= NULL_TREE
)
4390 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
4393 /* Figure out the stride if not a known constant. */
4394 if (!INTEGER_CST_P (stride
))
4397 stmt_packed
= NULL_TREE
;
4400 /* Calculate stride = size * (ubound + 1 - lbound). */
4401 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4402 gfc_index_one_node
, lbound
);
4403 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4405 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4410 /* Assign the stride. */
4411 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4412 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4413 stmt_unpacked
, stmt_packed
);
4415 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4416 gfc_add_modify_expr (&block
, stride
, tmp
);
4421 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4423 if (stride
&& !INTEGER_CST_P (stride
))
4425 /* Calculate size = stride * (ubound + 1 - lbound). */
4426 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4427 gfc_index_one_node
, lbound
);
4428 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4430 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4431 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4432 gfc_add_modify_expr (&block
, stride
, tmp
);
4437 /* Set the offset. */
4438 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4439 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4441 gfc_trans_vla_type_sizes (sym
, &block
);
4443 stmt
= gfc_finish_block (&block
);
4445 gfc_start_block (&block
);
4447 /* Only do the entry/initialization code if the arg is present. */
4448 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4449 optional_arg
= (sym
->attr
.optional
4450 || (sym
->ns
->proc_name
->attr
.entry_master
4451 && sym
->attr
.dummy
));
4454 tmp
= gfc_conv_expr_present (sym
);
4455 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4457 gfc_add_expr_to_block (&block
, stmt
);
4459 /* Add the main function body. */
4460 gfc_add_expr_to_block (&block
, body
);
4465 gfc_start_block (&cleanup
);
4467 if (sym
->attr
.intent
!= INTENT_IN
)
4469 /* Copy the data back. */
4470 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4471 gfc_add_expr_to_block (&cleanup
, tmp
);
4474 /* Free the temporary. */
4475 tmp
= gfc_call_free (tmpdesc
);
4476 gfc_add_expr_to_block (&cleanup
, tmp
);
4478 stmt
= gfc_finish_block (&cleanup
);
4480 /* Only do the cleanup if the array was repacked. */
4481 tmp
= build_fold_indirect_ref (dumdesc
);
4482 tmp
= gfc_conv_descriptor_data_get (tmp
);
4483 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4484 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4488 tmp
= gfc_conv_expr_present (sym
);
4489 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4491 gfc_add_expr_to_block (&block
, stmt
);
4493 /* We don't need to free any memory allocated by internal_pack as it will
4494 be freed at the end of the function by pop_context. */
4495 return gfc_finish_block (&block
);
4499 /* Calculate the overall offset, including subreferences. */
4501 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4502 bool subref
, gfc_expr
*expr
)
4512 /* If offset is NULL and this is not a subreferenced array, there is
4514 if (offset
== NULL_TREE
)
4517 offset
= gfc_index_zero_node
;
4522 tmp
= gfc_conv_array_data (desc
);
4523 tmp
= build_fold_indirect_ref (tmp
);
4524 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4526 /* Offset the data pointer for pointer assignments from arrays with
4527 subreferences; eg. my_integer => my_type(:)%integer_component. */
4530 /* Go past the array reference. */
4531 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4532 if (ref
->type
== REF_ARRAY
&&
4533 ref
->u
.ar
.type
!= AR_ELEMENT
)
4539 /* Calculate the offset for each subsequent subreference. */
4540 for (; ref
; ref
= ref
->next
)
4545 field
= ref
->u
.c
.component
->backend_decl
;
4546 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
4547 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4548 tmp
, field
, NULL_TREE
);
4552 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
4553 gfc_init_se (&start
, NULL
);
4554 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
4555 gfc_add_block_to_block (block
, &start
.pre
);
4556 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
4560 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
4561 && ref
->u
.ar
.type
== AR_ELEMENT
);
4563 /* TODO - Add bounds checking. */
4564 stride
= gfc_index_one_node
;
4565 index
= gfc_index_zero_node
;
4566 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4571 /* Update the index. */
4572 gfc_init_se (&start
, NULL
);
4573 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
4574 itmp
= gfc_evaluate_now (start
.expr
, block
);
4575 gfc_init_se (&start
, NULL
);
4576 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
4577 jtmp
= gfc_evaluate_now (start
.expr
, block
);
4578 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, itmp
, jtmp
);
4579 itmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, itmp
, stride
);
4580 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, itmp
, index
);
4581 index
= gfc_evaluate_now (index
, block
);
4583 /* Update the stride. */
4584 gfc_init_se (&start
, NULL
);
4585 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
4586 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, start
.expr
, jtmp
);
4587 itmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4588 gfc_index_one_node
, itmp
);
4589 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, itmp
);
4590 stride
= gfc_evaluate_now (stride
, block
);
4593 /* Apply the index to obtain the array element. */
4594 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
4604 /* Set the target data pointer. */
4605 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4606 gfc_conv_descriptor_data_set (block
, parm
, offset
);
4610 /* gfc_conv_expr_descriptor needs the character length of elemental
4611 functions before the function is called so that the size of the
4612 temporary can be obtained. The only way to do this is to convert
4613 the expression, mapping onto the actual arguments. */
4615 get_elemental_fcn_charlen (gfc_expr
*expr
, gfc_se
*se
)
4617 gfc_interface_mapping mapping
;
4618 gfc_formal_arglist
*formal
;
4619 gfc_actual_arglist
*arg
;
4622 formal
= expr
->symtree
->n
.sym
->formal
;
4623 arg
= expr
->value
.function
.actual
;
4624 gfc_init_interface_mapping (&mapping
);
4626 /* Set se = NULL in the calls to the interface mapping, to supress any
4628 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4633 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
4636 gfc_init_se (&tse
, NULL
);
4638 /* Build the expression for the character length and convert it. */
4639 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.cl
->length
);
4641 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
4642 gfc_add_block_to_block (&se
->post
, &tse
.post
);
4643 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
4644 tse
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tse
.expr
,
4645 build_int_cst (gfc_charlen_type_node
, 0));
4646 expr
->ts
.cl
->backend_decl
= tse
.expr
;
4647 gfc_free_interface_mapping (&mapping
);
4651 /* Convert an array for passing as an actual argument. Expressions and
4652 vector subscripts are evaluated and stored in a temporary, which is then
4653 passed. For whole arrays the descriptor is passed. For array sections
4654 a modified copy of the descriptor is passed, but using the original data.
4656 This function is also used for array pointer assignments, and there
4659 - se->want_pointer && !se->direct_byref
4660 EXPR is an actual argument. On exit, se->expr contains a
4661 pointer to the array descriptor.
4663 - !se->want_pointer && !se->direct_byref
4664 EXPR is an actual argument to an intrinsic function or the
4665 left-hand side of a pointer assignment. On exit, se->expr
4666 contains the descriptor for EXPR.
4668 - !se->want_pointer && se->direct_byref
4669 EXPR is the right-hand side of a pointer assignment and
4670 se->expr is the descriptor for the previously-evaluated
4671 left-hand side. The function creates an assignment from
4672 EXPR to se->expr. */
4675 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
4688 bool subref_array_target
= false;
4690 gcc_assert (ss
!= gfc_ss_terminator
);
4692 /* Special case things we know we can pass easily. */
4693 switch (expr
->expr_type
)
4696 /* If we have a linear array section, we can pass it directly.
4697 Otherwise we need to copy it into a temporary. */
4699 /* Find the SS for the array section. */
4701 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
4702 secss
= secss
->next
;
4704 gcc_assert (secss
!= gfc_ss_terminator
);
4705 info
= &secss
->data
.info
;
4707 /* Get the descriptor for the array. */
4708 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
4709 desc
= info
->descriptor
;
4711 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
4712 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
4713 && !subref_array_target
;
4717 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4719 /* Create a new descriptor if the array doesn't have one. */
4722 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
4724 else if (se
->direct_byref
)
4727 full
= gfc_full_array_ref_p (info
->ref
);
4731 if (se
->direct_byref
)
4733 /* Copy the descriptor for pointer assignments. */
4734 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
4736 /* Add any offsets from subreferences. */
4737 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
4738 subref_array_target
, expr
);
4740 else if (se
->want_pointer
)
4742 /* We pass full arrays directly. This means that pointers and
4743 allocatable arrays should also work. */
4744 se
->expr
= build_fold_addr_expr (desc
);
4751 if (expr
->ts
.type
== BT_CHARACTER
)
4752 se
->string_length
= gfc_get_expr_charlen (expr
);
4759 /* A transformational function return value will be a temporary
4760 array descriptor. We still need to go through the scalarizer
4761 to create the descriptor. Elemental functions ar handled as
4762 arbitrary expressions, i.e. copy to a temporary. */
4764 /* Look for the SS for this function. */
4765 while (secss
!= gfc_ss_terminator
4766 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
4767 secss
= secss
->next
;
4769 if (se
->direct_byref
)
4771 gcc_assert (secss
!= gfc_ss_terminator
);
4773 /* For pointer assignments pass the descriptor directly. */
4775 se
->expr
= build_fold_addr_expr (se
->expr
);
4776 gfc_conv_expr (se
, expr
);
4780 if (secss
== gfc_ss_terminator
)
4782 /* Elemental function. */
4784 if (expr
->ts
.type
== BT_CHARACTER
4785 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4786 get_elemental_fcn_charlen (expr
, se
);
4792 /* Transformational function. */
4793 info
= &secss
->data
.info
;
4799 /* Constant array constructors don't need a temporary. */
4800 if (ss
->type
== GFC_SS_CONSTRUCTOR
4801 && expr
->ts
.type
!= BT_CHARACTER
4802 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
4805 info
= &ss
->data
.info
;
4817 /* Something complicated. Copy it into a temporary. */
4825 gfc_init_loopinfo (&loop
);
4827 /* Associate the SS with the loop. */
4828 gfc_add_ss_to_loop (&loop
, ss
);
4830 /* Tell the scalarizer not to bother creating loop variables, etc. */
4832 loop
.array_parameter
= 1;
4834 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4835 gcc_assert (!se
->direct_byref
);
4837 /* Setup the scalarizing loops and bounds. */
4838 gfc_conv_ss_startstride (&loop
);
4842 /* Tell the scalarizer to make a temporary. */
4843 loop
.temp_ss
= gfc_get_ss ();
4844 loop
.temp_ss
->type
= GFC_SS_TEMP
;
4845 loop
.temp_ss
->next
= gfc_ss_terminator
;
4847 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
4848 gfc_conv_string_length (expr
->ts
.cl
, &se
->pre
);
4850 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
4852 if (expr
->ts
.type
== BT_CHARACTER
)
4853 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4855 loop
.temp_ss
->string_length
= NULL
;
4857 se
->string_length
= loop
.temp_ss
->string_length
;
4858 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
4859 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4862 gfc_conv_loop_setup (&loop
);
4866 /* Copy into a temporary and pass that. We don't need to copy the data
4867 back because expressions and vector subscripts must be INTENT_IN. */
4868 /* TODO: Optimize passing function return values. */
4872 /* Start the copying loops. */
4873 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4874 gfc_mark_ss_chain_used (ss
, 1);
4875 gfc_start_scalarized_body (&loop
, &block
);
4877 /* Copy each data element. */
4878 gfc_init_se (&lse
, NULL
);
4879 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4880 gfc_init_se (&rse
, NULL
);
4881 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4883 lse
.ss
= loop
.temp_ss
;
4886 gfc_conv_scalarized_array_ref (&lse
, NULL
);
4887 if (expr
->ts
.type
== BT_CHARACTER
)
4889 gfc_conv_expr (&rse
, expr
);
4890 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
4891 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4894 gfc_conv_expr_val (&rse
, expr
);
4896 gfc_add_block_to_block (&block
, &rse
.pre
);
4897 gfc_add_block_to_block (&block
, &lse
.pre
);
4899 lse
.string_length
= rse
.string_length
;
4900 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
4901 expr
->expr_type
== EXPR_VARIABLE
);
4902 gfc_add_expr_to_block (&block
, tmp
);
4904 /* Finish the copying loops. */
4905 gfc_trans_scalarizing_loops (&loop
, &block
);
4907 desc
= loop
.temp_ss
->data
.info
.descriptor
;
4909 gcc_assert (is_gimple_lvalue (desc
));
4911 else if (expr
->expr_type
== EXPR_FUNCTION
)
4913 desc
= info
->descriptor
;
4914 se
->string_length
= ss
->string_length
;
4918 /* We pass sections without copying to a temporary. Make a new
4919 descriptor and point it at the section we want. The loop variable
4920 limits will be the limits of the section.
4921 A function may decide to repack the array to speed up access, but
4922 we're not bothered about that here. */
4931 /* Set the string_length for a character array. */
4932 if (expr
->ts
.type
== BT_CHARACTER
)
4933 se
->string_length
= gfc_get_expr_charlen (expr
);
4935 desc
= info
->descriptor
;
4936 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
4937 if (se
->direct_byref
)
4939 /* For pointer assignments we fill in the destination. */
4941 parmtype
= TREE_TYPE (parm
);
4945 /* Otherwise make a new one. */
4946 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4947 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
4948 loop
.from
, loop
.to
, 0,
4950 parm
= gfc_create_var (parmtype
, "parm");
4953 offset
= gfc_index_zero_node
;
4956 /* The following can be somewhat confusing. We have two
4957 descriptors, a new one and the original array.
4958 {parm, parmtype, dim} refer to the new one.
4959 {desc, type, n, secss, loop} refer to the original, which maybe
4960 a descriptorless array.
4961 The bounds of the scalarization are the bounds of the section.
4962 We don't have to worry about numeric overflows when calculating
4963 the offsets because all elements are within the array data. */
4965 /* Set the dtype. */
4966 tmp
= gfc_conv_descriptor_dtype (parm
);
4967 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
4969 /* Set offset for assignments to pointer only to zero if it is not
4971 if (se
->direct_byref
4972 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
4973 base
= gfc_index_zero_node
;
4974 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4975 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
4979 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
4980 for (n
= 0; n
< ndim
; n
++)
4982 stride
= gfc_conv_array_stride (desc
, n
);
4984 /* Work out the offset. */
4986 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4988 gcc_assert (info
->subscript
[n
]
4989 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
4990 start
= info
->subscript
[n
]->data
.scalar
.expr
;
4994 /* Check we haven't somehow got out of sync. */
4995 gcc_assert (info
->dim
[dim
] == n
);
4997 /* Evaluate and remember the start of the section. */
4998 start
= info
->start
[dim
];
4999 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
5002 tmp
= gfc_conv_array_lbound (desc
, n
);
5003 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
5005 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
5006 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
5009 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5011 /* For elemental dimensions, we only need the offset. */
5015 /* Vector subscripts need copying and are handled elsewhere. */
5017 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
5019 /* Set the new lower bound. */
5020 from
= loop
.from
[dim
];
5023 /* If we have an array section or are assigning make sure that
5024 the lower bound is 1. References to the full
5025 array should otherwise keep the original bounds. */
5027 || info
->ref
->u
.ar
.type
!= AR_FULL
)
5028 && !integer_onep (from
))
5030 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5031 gfc_index_one_node
, from
);
5032 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
5033 from
= gfc_index_one_node
;
5035 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
5036 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
5038 /* Set the new upper bound. */
5039 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
5040 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
5042 /* Multiply the stride by the section stride to get the
5044 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
5045 stride
, info
->stride
[dim
]);
5047 if (se
->direct_byref
&& info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
5049 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5052 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5054 tmp
= gfc_conv_array_lbound (desc
, n
);
5055 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5056 tmp
, loop
.from
[dim
]);
5057 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
5058 tmp
, gfc_conv_array_stride (desc
, n
));
5059 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
5063 /* Store the new stride. */
5064 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
5065 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
5070 if (se
->data_not_needed
)
5071 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, gfc_index_zero_node
);
5073 /* Point the data pointer at the first element in the section. */
5074 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
5075 subref_array_target
, expr
);
5077 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5078 && !se
->data_not_needed
)
5080 /* Set the offset. */
5081 tmp
= gfc_conv_descriptor_offset (parm
);
5082 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
5086 /* Only the callee knows what the correct offset it, so just set
5088 tmp
= gfc_conv_descriptor_offset (parm
);
5089 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
5094 if (!se
->direct_byref
)
5096 /* Get a pointer to the new descriptor. */
5097 if (se
->want_pointer
)
5098 se
->expr
= build_fold_addr_expr (desc
);
5103 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5104 gfc_add_block_to_block (&se
->post
, &loop
.post
);
5106 /* Cleanup the scalarizer. */
5107 gfc_cleanup_loop (&loop
);
5111 /* Convert an array for passing as an actual parameter. */
5112 /* TODO: Optimize passing g77 arrays. */
5115 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
5119 tree tmp
= NULL_TREE
;
5121 tree parent
= DECL_CONTEXT (current_function_decl
);
5122 bool full_array_var
, this_array_result
;
5126 full_array_var
= (expr
->expr_type
== EXPR_VARIABLE
5127 && expr
->ref
->u
.ar
.type
== AR_FULL
);
5128 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
5130 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
5132 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
5133 expr
->ts
.cl
->backend_decl
= tmp
;
5134 se
->string_length
= tmp
;
5137 /* Is this the result of the enclosing procedure? */
5138 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
5139 if (this_array_result
5140 && (sym
->backend_decl
!= current_function_decl
)
5141 && (sym
->backend_decl
!= parent
))
5142 this_array_result
= false;
5144 /* Passing address of the array if it is not pointer or assumed-shape. */
5145 if (full_array_var
&& g77
&& !this_array_result
)
5147 tmp
= gfc_get_symbol_decl (sym
);
5149 if (sym
->ts
.type
== BT_CHARACTER
)
5150 se
->string_length
= sym
->ts
.cl
->backend_decl
;
5151 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
5152 && !sym
->attr
.allocatable
)
5154 /* Some variables are declared directly, others are declared as
5155 pointers and allocated on the heap. */
5156 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
5159 se
->expr
= build_fold_addr_expr (tmp
);
5162 if (sym
->attr
.allocatable
)
5164 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5166 gfc_conv_expr_descriptor (se
, expr
, ss
);
5167 se
->expr
= gfc_conv_array_data (se
->expr
);
5170 se
->expr
= gfc_conv_array_data (tmp
);
5175 if (this_array_result
)
5177 /* Result of the enclosing function. */
5178 gfc_conv_expr_descriptor (se
, expr
, ss
);
5179 se
->expr
= build_fold_addr_expr (se
->expr
);
5181 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
5182 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
5183 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref (se
->expr
));
5189 /* Every other type of array. */
5190 se
->want_pointer
= 1;
5191 gfc_conv_expr_descriptor (se
, expr
, ss
);
5195 /* Deallocate the allocatable components of structures that are
5197 if (expr
->ts
.type
== BT_DERIVED
5198 && expr
->ts
.derived
->attr
.alloc_comp
5199 && expr
->expr_type
!= EXPR_VARIABLE
)
5201 tmp
= build_fold_indirect_ref (se
->expr
);
5202 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.derived
, tmp
, expr
->rank
);
5203 gfc_add_expr_to_block (&se
->post
, tmp
);
5209 /* Repack the array. */
5210 ptr
= build_call_expr (gfor_fndecl_in_pack
, 1, desc
);
5211 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5214 gfc_start_block (&block
);
5216 /* Copy the data back. */
5217 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5218 gfc_add_expr_to_block (&block
, tmp
);
5220 /* Free the temporary. */
5221 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5222 gfc_add_expr_to_block (&block
, tmp
);
5224 stmt
= gfc_finish_block (&block
);
5226 gfc_init_block (&block
);
5227 /* Only if it was repacked. This code needs to be executed before the
5228 loop cleanup code. */
5229 tmp
= build_fold_indirect_ref (desc
);
5230 tmp
= gfc_conv_array_data (tmp
);
5231 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
5232 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5233 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
5235 gfc_add_expr_to_block (&block
, tmp
);
5236 gfc_add_block_to_block (&block
, &se
->post
);
5238 gfc_init_block (&se
->post
);
5239 gfc_add_block_to_block (&se
->post
, &block
);
5244 /* Generate code to deallocate an array, if it is allocated. */
5247 gfc_trans_dealloc_allocated (tree descriptor
)
5253 gfc_start_block (&block
);
5255 var
= gfc_conv_descriptor_data_get (descriptor
);
5258 /* Call array_deallocate with an int * present in the second argument.
5259 Although it is ignored here, it's presence ensures that arrays that
5260 are already deallocated are ignored. */
5261 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true);
5262 gfc_add_expr_to_block (&block
, tmp
);
5264 /* Zero the data pointer. */
5265 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5266 var
, build_int_cst (TREE_TYPE (var
), 0));
5267 gfc_add_expr_to_block (&block
, tmp
);
5269 return gfc_finish_block (&block
);
5273 /* This helper function calculates the size in words of a full array. */
5276 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
5281 idx
= gfc_rank_cst
[rank
- 1];
5282 nelems
= gfc_conv_descriptor_ubound (decl
, idx
);
5283 tmp
= gfc_conv_descriptor_lbound (decl
, idx
);
5284 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5285 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
5286 tmp
, gfc_index_one_node
);
5287 tmp
= gfc_evaluate_now (tmp
, block
);
5289 nelems
= gfc_conv_descriptor_stride (decl
, idx
);
5290 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5291 return gfc_evaluate_now (tmp
, block
);
5295 /* Allocate dest to the same size as src, and copy src -> dest. */
5298 gfc_duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
)
5307 /* If the source is null, set the destination to null. */
5308 gfc_init_block (&block
);
5309 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5310 null_data
= gfc_finish_block (&block
);
5312 gfc_init_block (&block
);
5314 nelems
= get_full_array_size (&block
, src
, rank
);
5315 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
,
5316 fold_convert (gfc_array_index_type
,
5317 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
5319 /* Allocate memory to the destination. */
5320 tmp
= gfc_call_malloc (&block
, TREE_TYPE (gfc_conv_descriptor_data_get (src
)),
5322 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5324 /* We know the temporary and the value will be the same length,
5325 so can use memcpy. */
5326 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5327 tmp
= build_call_expr (tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5328 gfc_conv_descriptor_data_get (src
), size
);
5329 gfc_add_expr_to_block (&block
, tmp
);
5330 tmp
= gfc_finish_block (&block
);
5332 /* Null the destination if the source is null; otherwise do
5333 the allocate and copy. */
5334 null_cond
= gfc_conv_descriptor_data_get (src
);
5335 null_cond
= convert (pvoid_type_node
, null_cond
);
5336 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
5337 null_cond
, null_pointer_node
);
5338 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5342 /* Recursively traverse an object of derived type, generating code to
5343 deallocate, nullify or copy allocatable components. This is the work horse
5344 function for the functions named in this enum. */
5346 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
};
5349 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5350 tree dest
, int rank
, int purpose
)
5354 stmtblock_t fnblock
;
5355 stmtblock_t loopbody
;
5365 tree null_cond
= NULL_TREE
;
5367 gfc_init_block (&fnblock
);
5369 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
5370 decl
= build_fold_indirect_ref (decl
);
5372 /* If this an array of derived types with allocatable components
5373 build a loop and recursively call this function. */
5374 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
5375 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5377 tmp
= gfc_conv_array_data (decl
);
5378 var
= build_fold_indirect_ref (tmp
);
5380 /* Get the number of elements - 1 and set the counter. */
5381 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5383 /* Use the descriptor for an allocatable array. Since this
5384 is a full array reference, we only need the descriptor
5385 information from dimension = rank. */
5386 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
5387 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5388 tmp
, gfc_index_one_node
);
5390 null_cond
= gfc_conv_descriptor_data_get (decl
);
5391 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5392 build_int_cst (TREE_TYPE (null_cond
), 0));
5396 /* Otherwise use the TYPE_DOMAIN information. */
5397 tmp
= array_type_nelts (TREE_TYPE (decl
));
5398 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5401 /* Remember that this is, in fact, the no. of elements - 1. */
5402 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5403 index
= gfc_create_var (gfc_array_index_type
, "S");
5405 /* Build the body of the loop. */
5406 gfc_init_block (&loopbody
);
5408 vref
= gfc_build_array_ref (var
, index
, NULL
);
5410 if (purpose
== COPY_ALLOC_COMP
)
5412 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
5413 gfc_add_expr_to_block (&fnblock
, tmp
);
5415 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest
));
5416 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
5417 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
5420 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
5422 gfc_add_expr_to_block (&loopbody
, tmp
);
5424 /* Build the loop and return. */
5425 gfc_init_loopinfo (&loop
);
5427 loop
.from
[0] = gfc_index_zero_node
;
5428 loop
.loopvar
[0] = index
;
5429 loop
.to
[0] = nelems
;
5430 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
5431 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
5433 tmp
= gfc_finish_block (&fnblock
);
5434 if (null_cond
!= NULL_TREE
)
5435 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
, build_empty_stmt ());
5440 /* Otherwise, act on the components or recursively call self to
5441 act on a chain of components. */
5442 for (c
= der_type
->components
; c
; c
= c
->next
)
5444 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
5445 && c
->ts
.derived
->attr
.alloc_comp
;
5446 cdecl = c
->backend_decl
;
5447 ctype
= TREE_TYPE (cdecl);
5451 case DEALLOCATE_ALLOC_COMP
:
5452 /* Do not deallocate the components of ultimate pointer
5454 if (cmp_has_alloc_comps
&& !c
->pointer
)
5456 comp
= fold_build3 (COMPONENT_REF
, ctype
,
5457 decl
, cdecl, NULL_TREE
);
5458 rank
= c
->as
? c
->as
->rank
: 0;
5459 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5461 gfc_add_expr_to_block (&fnblock
, tmp
);
5466 comp
= fold_build3 (COMPONENT_REF
, ctype
,
5467 decl
, cdecl, NULL_TREE
);
5468 tmp
= gfc_trans_dealloc_allocated (comp
);
5469 gfc_add_expr_to_block (&fnblock
, tmp
);
5473 case NULLIFY_ALLOC_COMP
:
5476 else if (c
->allocatable
)
5478 comp
= fold_build3 (COMPONENT_REF
, ctype
,
5479 decl
, cdecl, NULL_TREE
);
5480 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
5482 else if (cmp_has_alloc_comps
)
5484 comp
= fold_build3 (COMPONENT_REF
, ctype
,
5485 decl
, cdecl, NULL_TREE
);
5486 rank
= c
->as
? c
->as
->rank
: 0;
5487 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5489 gfc_add_expr_to_block (&fnblock
, tmp
);
5493 case COPY_ALLOC_COMP
:
5497 /* We need source and destination components. */
5498 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5499 dcmp
= fold_build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
5500 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
5502 if (c
->allocatable
&& !cmp_has_alloc_comps
)
5504 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, c
->as
->rank
);
5505 gfc_add_expr_to_block (&fnblock
, tmp
);
5508 if (cmp_has_alloc_comps
)
5510 rank
= c
->as
? c
->as
->rank
: 0;
5511 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
5512 gfc_add_modify_expr (&fnblock
, dcmp
, tmp
);
5513 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, dcmp
,
5515 gfc_add_expr_to_block (&fnblock
, tmp
);
5525 return gfc_finish_block (&fnblock
);
5528 /* Recursively traverse an object of derived type, generating code to
5529 nullify allocatable components. */
5532 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5534 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5535 NULLIFY_ALLOC_COMP
);
5539 /* Recursively traverse an object of derived type, generating code to
5540 deallocate allocatable components. */
5543 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5545 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5546 DEALLOCATE_ALLOC_COMP
);
5550 /* Recursively traverse an object of derived type, generating code to
5551 copy its allocatable components. */
5554 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
5556 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
5560 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5561 Do likewise, recursively if necessary, with the allocatable components of
5565 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
5570 stmtblock_t fnblock
;
5573 bool sym_has_alloc_comp
;
5575 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
5576 && sym
->ts
.derived
->attr
.alloc_comp
;
5578 /* Make sure the frontend gets these right. */
5579 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
5580 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5581 "allocatable attribute or derived type without allocatable "
5584 gfc_init_block (&fnblock
);
5586 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
5587 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
5589 if (sym
->ts
.type
== BT_CHARACTER
5590 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
5592 gfc_conv_string_length (sym
->ts
.cl
, &fnblock
);
5593 gfc_trans_vla_type_sizes (sym
, &fnblock
);
5596 /* Dummy and use associated variables don't need anything special. */
5597 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
5599 gfc_add_expr_to_block (&fnblock
, body
);
5601 return gfc_finish_block (&fnblock
);
5604 gfc_get_backend_locus (&loc
);
5605 gfc_set_backend_locus (&sym
->declared_at
);
5606 descriptor
= sym
->backend_decl
;
5608 /* Although static, derived types with default initializers and
5609 allocatable components must not be nulled wholesale; instead they
5610 are treated component by component. */
5611 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
5613 /* SAVEd variables are not freed on exit. */
5614 gfc_trans_static_array_pointer (sym
);
5618 /* Get the descriptor type. */
5619 type
= TREE_TYPE (sym
->backend_decl
);
5621 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5623 if (!sym
->attr
.save
)
5625 rank
= sym
->as
? sym
->as
->rank
: 0;
5626 tmp
= gfc_nullify_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5627 gfc_add_expr_to_block (&fnblock
, tmp
);
5630 tmp
= gfc_init_default_dt (sym
, NULL
);
5631 gfc_add_expr_to_block (&fnblock
, tmp
);
5635 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
5637 /* If the backend_decl is not a descriptor, we must have a pointer
5639 descriptor
= build_fold_indirect_ref (sym
->backend_decl
);
5640 type
= TREE_TYPE (descriptor
);
5643 /* NULLIFY the data pointer. */
5644 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
5645 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
5647 gfc_add_expr_to_block (&fnblock
, body
);
5649 gfc_set_backend_locus (&loc
);
5651 /* Allocatable arrays need to be freed when they go out of scope.
5652 The allocatable components of pointers must not be touched. */
5653 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
5654 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
5657 rank
= sym
->as
? sym
->as
->rank
: 0;
5658 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5659 gfc_add_expr_to_block (&fnblock
, tmp
);
5662 if (sym
->attr
.allocatable
&& !sym
->attr
.save
)
5664 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
5665 gfc_add_expr_to_block (&fnblock
, tmp
);
5668 return gfc_finish_block (&fnblock
);
5671 /************ Expression Walking Functions ******************/
5673 /* Walk a variable reference.
5675 Possible extension - multiple component subscripts.
5676 x(:,:) = foo%a(:)%b(:)
5678 forall (i=..., j=...)
5679 x(i,j) = foo%a(j)%b(i)
5681 This adds a fair amount of complexity because you need to deal with more
5682 than one ref. Maybe handle in a similar manner to vector subscripts.
5683 Maybe not worth the effort. */
5687 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5695 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5696 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
5699 for (; ref
; ref
= ref
->next
)
5701 if (ref
->type
== REF_SUBSTRING
)
5703 newss
= gfc_get_ss ();
5704 newss
->type
= GFC_SS_SCALAR
;
5705 newss
->expr
= ref
->u
.ss
.start
;
5709 newss
= gfc_get_ss ();
5710 newss
->type
= GFC_SS_SCALAR
;
5711 newss
->expr
= ref
->u
.ss
.end
;
5716 /* We're only interested in array sections from now on. */
5717 if (ref
->type
!= REF_ARRAY
)
5724 for (n
= 0; n
< ar
->dimen
; n
++)
5726 newss
= gfc_get_ss ();
5727 newss
->type
= GFC_SS_SCALAR
;
5728 newss
->expr
= ar
->start
[n
];
5735 newss
= gfc_get_ss ();
5736 newss
->type
= GFC_SS_SECTION
;
5739 newss
->data
.info
.dimen
= ar
->as
->rank
;
5740 newss
->data
.info
.ref
= ref
;
5742 /* Make sure array is the same as array(:,:), this way
5743 we don't need to special case all the time. */
5744 ar
->dimen
= ar
->as
->rank
;
5745 for (n
= 0; n
< ar
->dimen
; n
++)
5747 newss
->data
.info
.dim
[n
] = n
;
5748 ar
->dimen_type
[n
] = DIMEN_RANGE
;
5750 gcc_assert (ar
->start
[n
] == NULL
);
5751 gcc_assert (ar
->end
[n
] == NULL
);
5752 gcc_assert (ar
->stride
[n
] == NULL
);
5758 newss
= gfc_get_ss ();
5759 newss
->type
= GFC_SS_SECTION
;
5762 newss
->data
.info
.dimen
= 0;
5763 newss
->data
.info
.ref
= ref
;
5767 /* We add SS chains for all the subscripts in the section. */
5768 for (n
= 0; n
< ar
->dimen
; n
++)
5772 switch (ar
->dimen_type
[n
])
5775 /* Add SS for elemental (scalar) subscripts. */
5776 gcc_assert (ar
->start
[n
]);
5777 indexss
= gfc_get_ss ();
5778 indexss
->type
= GFC_SS_SCALAR
;
5779 indexss
->expr
= ar
->start
[n
];
5780 indexss
->next
= gfc_ss_terminator
;
5781 indexss
->loop_chain
= gfc_ss_terminator
;
5782 newss
->data
.info
.subscript
[n
] = indexss
;
5786 /* We don't add anything for sections, just remember this
5787 dimension for later. */
5788 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5789 newss
->data
.info
.dimen
++;
5793 /* Create a GFC_SS_VECTOR index in which we can store
5794 the vector's descriptor. */
5795 indexss
= gfc_get_ss ();
5796 indexss
->type
= GFC_SS_VECTOR
;
5797 indexss
->expr
= ar
->start
[n
];
5798 indexss
->next
= gfc_ss_terminator
;
5799 indexss
->loop_chain
= gfc_ss_terminator
;
5800 newss
->data
.info
.subscript
[n
] = indexss
;
5801 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5802 newss
->data
.info
.dimen
++;
5806 /* We should know what sort of section it is by now. */
5810 /* We should have at least one non-elemental dimension. */
5811 gcc_assert (newss
->data
.info
.dimen
> 0);
5816 /* We should know what sort of section it is by now. */
5825 /* Walk an expression operator. If only one operand of a binary expression is
5826 scalar, we must also add the scalar term to the SS chain. */
5829 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5835 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
5836 if (expr
->value
.op
.op2
== NULL
)
5839 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
5841 /* All operands are scalar. Pass back and let the caller deal with it. */
5845 /* All operands require scalarization. */
5846 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
5849 /* One of the operands needs scalarization, the other is scalar.
5850 Create a gfc_ss for the scalar expression. */
5851 newss
= gfc_get_ss ();
5852 newss
->type
= GFC_SS_SCALAR
;
5855 /* First operand is scalar. We build the chain in reverse order, so
5856 add the scarar SS after the second operand. */
5858 while (head
&& head
->next
!= ss
)
5860 /* Check we haven't somehow broken the chain. */
5864 newss
->expr
= expr
->value
.op
.op1
;
5866 else /* head2 == head */
5868 gcc_assert (head2
== head
);
5869 /* Second operand is scalar. */
5870 newss
->next
= head2
;
5872 newss
->expr
= expr
->value
.op
.op2
;
5879 /* Reverse a SS chain. */
5882 gfc_reverse_ss (gfc_ss
* ss
)
5887 gcc_assert (ss
!= NULL
);
5889 head
= gfc_ss_terminator
;
5890 while (ss
!= gfc_ss_terminator
)
5893 /* Check we didn't somehow break the chain. */
5894 gcc_assert (next
!= NULL
);
5904 /* Walk the arguments of an elemental function. */
5907 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
5915 head
= gfc_ss_terminator
;
5918 for (; arg
; arg
= arg
->next
)
5923 newss
= gfc_walk_subexpr (head
, arg
->expr
);
5926 /* Scalar argument. */
5927 newss
= gfc_get_ss ();
5929 newss
->expr
= arg
->expr
;
5939 while (tail
->next
!= gfc_ss_terminator
)
5946 /* If all the arguments are scalar we don't need the argument SS. */
5947 gfc_free_ss_chain (head
);
5952 /* Add it onto the existing chain. */
5958 /* Walk a function call. Scalar functions are passed back, and taken out of
5959 scalarization loops. For elemental functions we walk their arguments.
5960 The result of functions returning arrays is stored in a temporary outside
5961 the loop, so that the function is only called once. Hence we do not need
5962 to walk their arguments. */
5965 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5968 gfc_intrinsic_sym
*isym
;
5971 isym
= expr
->value
.function
.isym
;
5973 /* Handle intrinsic functions separately. */
5975 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
5977 sym
= expr
->value
.function
.esym
;
5979 sym
= expr
->symtree
->n
.sym
;
5981 /* A function that returns arrays. */
5982 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
5984 newss
= gfc_get_ss ();
5985 newss
->type
= GFC_SS_FUNCTION
;
5988 newss
->data
.info
.dimen
= expr
->rank
;
5992 /* Walk the parameters of an elemental function. For now we always pass
5994 if (sym
->attr
.elemental
)
5995 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
5998 /* Scalar functions are OK as these are evaluated outside the scalarization
5999 loop. Pass back and let the caller deal with it. */
6004 /* An array temporary is constructed for array constructors. */
6007 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
6012 newss
= gfc_get_ss ();
6013 newss
->type
= GFC_SS_CONSTRUCTOR
;
6016 newss
->data
.info
.dimen
= expr
->rank
;
6017 for (n
= 0; n
< expr
->rank
; n
++)
6018 newss
->data
.info
.dim
[n
] = n
;
6024 /* Walk an expression. Add walked expressions to the head of the SS chain.
6025 A wholly scalar expression will not be added. */
6028 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
6032 switch (expr
->expr_type
)
6035 head
= gfc_walk_variable_expr (ss
, expr
);
6039 head
= gfc_walk_op_expr (ss
, expr
);
6043 head
= gfc_walk_function_expr (ss
, expr
);
6048 case EXPR_STRUCTURE
:
6049 /* Pass back and let the caller deal with it. */
6053 head
= gfc_walk_array_constructor (ss
, expr
);
6056 case EXPR_SUBSTRING
:
6057 /* Pass back and let the caller deal with it. */
6061 internal_error ("bad expression type during walk (%d)",
6068 /* Entry point for expression walking.
6069 A return value equal to the passed chain means this is
6070 a scalar expression. It is up to the caller to take whatever action is
6071 necessary to translate these. */
6074 gfc_walk_expr (gfc_expr
* expr
)
6078 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
6079 return gfc_reverse_ss (res
);