1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subecripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
84 #include "tree-gimple.h"
91 #include "trans-stmt.h"
92 #include "trans-types.h"
93 #include "trans-array.h"
94 #include "trans-const.h"
95 #include "dependency.h"
97 static gfc_ss
*gfc_walk_subexpr (gfc_ss
*, gfc_expr
*);
98 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor
*);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var
;
102 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
106 gfc_array_dataptr_type (tree desc
)
108 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
112 /* Build expressions to access the members of an array descriptor.
113 It's surprisingly easy to mess up here, so never access
114 an array descriptor by "brute force", always use these
115 functions. This also avoids problems if we change the format
116 of an array descriptor.
118 To understand these magic numbers, look at the comments
119 before gfc_build_array_type() in trans-types.c.
121 The code within these defines should be the only code which knows the format
122 of an array descriptor.
124 Any code just needing to read obtain the bounds of an array should use
125 gfc_conv_array_* rather than the following functions as these will return
126 know constant values, and work with arrays which do not have descriptors.
128 Don't forget to #undef these! */
131 #define OFFSET_FIELD 1
132 #define DTYPE_FIELD 2
133 #define DIMENSION_FIELD 3
135 #define STRIDE_SUBFIELD 0
136 #define LBOUND_SUBFIELD 1
137 #define UBOUND_SUBFIELD 2
139 /* This provides READ-ONLY access to the data field. The field itself
140 doesn't have the proper type. */
143 gfc_conv_descriptor_data_get (tree desc
)
147 type
= TREE_TYPE (desc
);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
150 field
= TYPE_FIELDS (type
);
151 gcc_assert (DATA_FIELD
== 0);
153 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
154 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set_tuples. */
168 gfc_conv_descriptor_data_set_internal (stmtblock_t
*block
,
169 tree desc
, tree value
,
174 type
= TREE_TYPE (desc
);
175 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
177 field
= TYPE_FIELDS (type
);
178 gcc_assert (DATA_FIELD
== 0);
180 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
181 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
), tuples_p
);
185 /* This provides address access to the data field. This should only be
186 used by array allocation, passing this on to the runtime. */
189 gfc_conv_descriptor_data_addr (tree desc
)
193 type
= TREE_TYPE (desc
);
194 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
196 field
= TYPE_FIELDS (type
);
197 gcc_assert (DATA_FIELD
== 0);
199 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
200 return build_fold_addr_expr (t
);
204 gfc_conv_descriptor_offset (tree desc
)
209 type
= TREE_TYPE (desc
);
210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
212 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
213 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
215 return build3 (COMPONENT_REF
, TREE_TYPE (field
), 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 build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
234 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
240 type
= TREE_TYPE (desc
);
241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
243 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
244 gcc_assert (field
!= NULL_TREE
245 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
246 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
248 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
249 tmp
= gfc_build_array_ref (tmp
, dim
);
254 gfc_conv_descriptor_stride (tree desc
, tree dim
)
259 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
260 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
261 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
262 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
264 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
269 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
274 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
275 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
276 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
277 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
279 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
284 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
289 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
290 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
291 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
292 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
294 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
299 /* Build a null array descriptor constructor. */
302 gfc_build_null_descriptor (tree type
)
307 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
308 gcc_assert (DATA_FIELD
== 0);
309 field
= TYPE_FIELDS (type
);
311 /* Set a NULL data pointer. */
312 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
313 TREE_CONSTANT (tmp
) = 1;
314 TREE_INVARIANT (tmp
) = 1;
315 /* All other fields are ignored. */
321 /* Cleanup those #defines. */
326 #undef DIMENSION_FIELD
327 #undef STRIDE_SUBFIELD
328 #undef LBOUND_SUBFIELD
329 #undef UBOUND_SUBFIELD
332 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
333 flags & 1 = Main loop body.
334 flags & 2 = temp copy loop. */
337 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
339 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
340 ss
->useflags
= flags
;
343 static void gfc_free_ss (gfc_ss
*);
346 /* Free a gfc_ss chain. */
349 gfc_free_ss_chain (gfc_ss
* ss
)
353 while (ss
!= gfc_ss_terminator
)
355 gcc_assert (ss
!= NULL
);
366 gfc_free_ss (gfc_ss
* ss
)
373 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
375 if (ss
->data
.info
.subscript
[n
])
376 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
388 /* Free all the SS associated with a loop. */
391 gfc_cleanup_loop (gfc_loopinfo
* loop
)
397 while (ss
!= gfc_ss_terminator
)
399 gcc_assert (ss
!= NULL
);
400 next
= ss
->loop_chain
;
407 /* Associate a SS chain with a loop. */
410 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
414 if (head
== gfc_ss_terminator
)
418 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
420 if (ss
->next
== gfc_ss_terminator
)
421 ss
->loop_chain
= loop
->ss
;
423 ss
->loop_chain
= ss
->next
;
425 gcc_assert (ss
== gfc_ss_terminator
);
430 /* Generate an initializer for a static pointer or allocatable array. */
433 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
437 gcc_assert (TREE_STATIC (sym
->backend_decl
));
438 /* Just zero the data member. */
439 type
= TREE_TYPE (sym
->backend_decl
);
440 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
444 /* If the bounds of SE's loop have not yet been set, see if they can be
445 determined from array spec AS, which is the array spec of a called
446 function. MAPPING maps the callee's dummy arguments to the values
447 that the caller is passing. Add any initialization and finalization
451 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
452 gfc_se
* se
, gfc_array_spec
* as
)
460 if (as
&& as
->type
== AS_EXPLICIT
)
461 for (dim
= 0; dim
< se
->loop
->dimen
; dim
++)
463 n
= se
->loop
->order
[dim
];
464 if (se
->loop
->to
[n
] == NULL_TREE
)
466 /* Evaluate the lower bound. */
467 gfc_init_se (&tmpse
, NULL
);
468 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
469 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
470 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
473 /* ...and the upper bound. */
474 gfc_init_se (&tmpse
, NULL
);
475 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
476 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
477 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
480 /* Set the upper bound of the loop to UPPER - LOWER. */
481 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
482 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
483 se
->loop
->to
[n
] = tmp
;
489 /* Generate code to allocate an array temporary, or create a variable to
490 hold the data. If size is NULL, zero the descriptor so that the
491 callee will allocate the array. If DEALLOC is true, also generate code to
492 free the array afterwards.
494 Initialization code is added to PRE and finalization code to POST.
495 DYNAMIC is true if the caller may want to extend the array later
496 using realloc. This prevents us from putting the array on the stack. */
499 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
500 gfc_ss_info
* info
, tree size
, tree nelem
,
501 bool dynamic
, bool dealloc
)
507 desc
= info
->descriptor
;
508 info
->offset
= gfc_index_zero_node
;
509 if (size
== NULL_TREE
|| integer_zerop (size
))
511 /* A callee allocated array. */
512 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
517 /* Allocate the temporary. */
518 onstack
= !dynamic
&& gfc_can_put_var_on_stack (size
);
522 /* Make a temporary variable to hold the data. */
523 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
525 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
527 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
529 tmp
= gfc_create_var (tmp
, "A");
530 tmp
= build_fold_addr_expr (tmp
);
531 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
535 /* Allocate memory to hold the data. */
536 if (gfc_index_integer_kind
== 4)
537 tmp
= gfor_fndecl_internal_malloc
;
538 else if (gfc_index_integer_kind
== 8)
539 tmp
= gfor_fndecl_internal_malloc64
;
542 tmp
= build_call_expr (tmp
, 1, size
);
543 tmp
= gfc_evaluate_now (tmp
, pre
);
544 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
547 info
->data
= gfc_conv_descriptor_data_get (desc
);
549 /* The offset is zero because we create temporaries with a zero
551 tmp
= gfc_conv_descriptor_offset (desc
);
552 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
554 if (dealloc
&& !onstack
)
556 /* Free the temporary. */
557 tmp
= gfc_conv_descriptor_data_get (desc
);
558 tmp
= fold_convert (pvoid_type_node
, tmp
);
559 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, tmp
);
560 gfc_add_expr_to_block (post
, tmp
);
565 /* Generate code to create and initialize the descriptor for a temporary
566 array. This is used for both temporaries needed by the scalarizer, and
567 functions returning arrays. Adjusts the loop variables to be
568 zero-based, and calculates the loop bounds for callee allocated arrays.
569 Allocate the array unless it's callee allocated (we have a callee
570 allocated array if 'callee_alloc' is true, or if loop->to[n] is
571 NULL_TREE for any n). Also fills in the descriptor, data and offset
572 fields of info if known. Returns the size of the array, or NULL for a
573 callee allocated array.
575 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
579 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
580 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
581 tree eltype
, bool dynamic
, bool dealloc
,
594 gcc_assert (info
->dimen
> 0);
595 /* Set the lower bound to zero. */
596 for (dim
= 0; dim
< info
->dimen
; dim
++)
598 n
= loop
->order
[dim
];
599 if (n
< loop
->temp_dim
)
600 gcc_assert (integer_zerop (loop
->from
[n
]));
603 /* Callee allocated arrays may not have a known bound yet. */
605 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
606 loop
->to
[n
], loop
->from
[n
]);
607 loop
->from
[n
] = gfc_index_zero_node
;
610 info
->delta
[dim
] = gfc_index_zero_node
;
611 info
->start
[dim
] = gfc_index_zero_node
;
612 info
->end
[dim
] = gfc_index_zero_node
;
613 info
->stride
[dim
] = gfc_index_one_node
;
614 info
->dim
[dim
] = dim
;
617 /* Initialize the descriptor. */
619 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
620 desc
= gfc_create_var (type
, "atmp");
621 GFC_DECL_PACKED_ARRAY (desc
) = 1;
623 info
->descriptor
= desc
;
624 size
= gfc_index_one_node
;
626 /* Fill in the array dtype. */
627 tmp
= gfc_conv_descriptor_dtype (desc
);
628 gfc_add_modify_expr (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
631 Fill in the bounds and stride. This is a packed array, so:
634 for (n = 0; n < rank; n++)
637 delta = ubound[n] + 1 - lbound[n];
640 size = size * sizeof(element);
645 for (n
= 0; n
< info
->dimen
; n
++)
647 if (loop
->to
[n
] == NULL_TREE
)
649 /* For a callee allocated array express the loop bounds in terms
650 of the descriptor fields. */
651 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
652 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
653 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
659 /* Store the stride and bound components in the descriptor. */
660 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
661 gfc_add_modify_expr (pre
, tmp
, size
);
663 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
664 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
666 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
667 gfc_add_modify_expr (pre
, tmp
, loop
->to
[n
]);
669 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
670 loop
->to
[n
], gfc_index_one_node
);
672 /* Check whether the size for this dimension is negative. */
673 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
674 gfc_index_zero_node
);
675 cond
= gfc_evaluate_now (cond
, pre
);
680 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
682 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
683 size
= gfc_evaluate_now (size
, pre
);
686 /* Get the size of the array. */
688 if (size
&& !callee_alloc
)
690 /* If or_expr is true, then the extent in at least one
691 dimension is zero and the size is set to zero. */
692 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
,
693 or_expr
, gfc_index_zero_node
, size
);
696 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
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
]));
783 loop
->to
[n
] = build2 (MINUS_EXPR
, gfc_array_index_type
,
784 gfc_conv_descriptor_ubound (dest
, dest_index
),
785 gfc_conv_descriptor_lbound (dest
, dest_index
));
789 /* Copy the data pointer. */
790 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
791 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
793 /* Copy the offset. This is not changed by transposition: the top-left
794 element is still at the same offset as before. */
795 dest_info
->offset
= gfc_conv_descriptor_offset (src
);
796 gfc_add_modify_expr (&se
->pre
,
797 gfc_conv_descriptor_offset (dest
),
800 if (dest_info
->dimen
> loop
->temp_dim
)
801 loop
->temp_dim
= dest_info
->dimen
;
805 /* Return the number of iterations in a loop that starts at START,
806 ends at END, and has step STEP. */
809 gfc_get_iteration_count (tree start
, tree end
, tree step
)
814 type
= TREE_TYPE (step
);
815 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
816 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
817 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
818 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
819 return fold_convert (gfc_array_index_type
, tmp
);
823 /* Extend the data in array DESC by EXTRA elements. */
826 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
833 if (integer_zerop (extra
))
836 ubound
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
838 /* Add EXTRA to the upper bound. */
839 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
840 gfc_add_modify_expr (pblock
, ubound
, tmp
);
842 /* Get the value of the current data pointer. */
843 arg0
= gfc_conv_descriptor_data_get (desc
);
845 /* Calculate the new array size. */
846 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
847 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, gfc_index_one_node
);
848 arg1
= build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
850 /* Pick the appropriate realloc function. */
851 if (gfc_index_integer_kind
== 4)
852 tmp
= gfor_fndecl_internal_realloc
;
853 else if (gfc_index_integer_kind
== 8)
854 tmp
= gfor_fndecl_internal_realloc64
;
858 /* Set the new data pointer. */
859 tmp
= build_call_expr (tmp
, 2, arg0
, arg1
);
860 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
864 /* Return true if the bounds of iterator I can only be determined
868 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
870 return (i
->start
->expr_type
!= EXPR_CONSTANT
871 || i
->end
->expr_type
!= EXPR_CONSTANT
872 || i
->step
->expr_type
!= EXPR_CONSTANT
);
876 /* Split the size of constructor element EXPR into the sum of two terms,
877 one of which can be determined at compile time and one of which must
878 be calculated at run time. Set *SIZE to the former and return true
879 if the latter might be nonzero. */
882 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
884 if (expr
->expr_type
== EXPR_ARRAY
)
885 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
886 else if (expr
->rank
> 0)
888 /* Calculate everything at run time. */
889 mpz_set_ui (*size
, 0);
894 /* A single element. */
895 mpz_set_ui (*size
, 1);
901 /* Like gfc_get_array_constructor_element_size, but applied to the whole
902 of array constructor C. */
905 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor
* c
)
912 mpz_set_ui (*size
, 0);
917 for (; c
; c
= c
->next
)
920 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
924 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
927 /* Multiply the static part of the element size by the
928 number of iterations. */
929 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
930 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
931 mpz_add_ui (val
, val
, 1);
932 if (mpz_sgn (val
) > 0)
933 mpz_mul (len
, len
, val
);
937 mpz_add (*size
, *size
, len
);
946 /* Make sure offset is a variable. */
949 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
952 /* We should have already created the offset variable. We cannot
953 create it here because we may be in an inner scope. */
954 gcc_assert (*offsetvar
!= NULL_TREE
);
955 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
956 *poffset
= *offsetvar
;
957 TREE_USED (*offsetvar
) = 1;
961 /* Assign an element of an array constructor. */
964 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
965 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
969 gfc_conv_expr (se
, expr
);
971 /* Store the value. */
972 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc
));
973 tmp
= gfc_build_array_ref (tmp
, offset
);
974 if (expr
->ts
.type
== BT_CHARACTER
)
976 gfc_conv_string_parameter (se
);
977 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
979 /* The temporary is an array of pointers. */
980 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
981 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
985 /* The temporary is an array of string values. */
986 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
987 /* We know the temporary and the value will be the same length,
988 so can use memcpy. */
989 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
990 tmp
, se
->expr
, se
->string_length
);
991 gfc_add_expr_to_block (&se
->pre
, tmp
);
996 /* TODO: Should the frontend already have done this conversion? */
997 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
998 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
1001 gfc_add_block_to_block (pblock
, &se
->pre
);
1002 gfc_add_block_to_block (pblock
, &se
->post
);
1006 /* Add the contents of an array to the constructor. DYNAMIC is as for
1007 gfc_trans_array_constructor_value. */
1010 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1011 tree type ATTRIBUTE_UNUSED
,
1012 tree desc
, gfc_expr
* expr
,
1013 tree
* poffset
, tree
* offsetvar
,
1024 /* We need this to be a variable so we can increment it. */
1025 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1027 gfc_init_se (&se
, NULL
);
1029 /* Walk the array expression. */
1030 ss
= gfc_walk_expr (expr
);
1031 gcc_assert (ss
!= gfc_ss_terminator
);
1033 /* Initialize the scalarizer. */
1034 gfc_init_loopinfo (&loop
);
1035 gfc_add_ss_to_loop (&loop
, ss
);
1037 /* Initialize the loop. */
1038 gfc_conv_ss_startstride (&loop
);
1039 gfc_conv_loop_setup (&loop
);
1041 /* Make sure the constructed array has room for the new data. */
1044 /* Set SIZE to the total number of elements in the subarray. */
1045 size
= gfc_index_one_node
;
1046 for (n
= 0; n
< loop
.dimen
; n
++)
1048 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1049 gfc_index_one_node
);
1050 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1053 /* Grow the constructed array by SIZE elements. */
1054 gfc_grow_array (&loop
.pre
, desc
, size
);
1057 /* Make the loop body. */
1058 gfc_mark_ss_chain_used (ss
, 1);
1059 gfc_start_scalarized_body (&loop
, &body
);
1060 gfc_copy_loopinfo_to_se (&se
, &loop
);
1063 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1064 gcc_assert (se
.ss
== gfc_ss_terminator
);
1066 /* Increment the offset. */
1067 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
1068 gfc_add_modify_expr (&body
, *poffset
, tmp
);
1070 /* Finish the loop. */
1071 gfc_trans_scalarizing_loops (&loop
, &body
);
1072 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1073 tmp
= gfc_finish_block (&loop
.pre
);
1074 gfc_add_expr_to_block (pblock
, tmp
);
1076 gfc_cleanup_loop (&loop
);
1080 /* Assign the values to the elements of an array constructor. DYNAMIC
1081 is true if descriptor DESC only contains enough data for the static
1082 size calculated by gfc_get_array_constructor_size. When true, memory
1083 for the dynamic parts must be allocated using realloc. */
1086 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1087 tree desc
, gfc_constructor
* c
,
1088 tree
* poffset
, tree
* offsetvar
,
1097 for (; c
; c
= c
->next
)
1099 /* If this is an iterator or an array, the offset must be a variable. */
1100 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1101 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1103 gfc_start_block (&body
);
1105 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1107 /* Array constructors can be nested. */
1108 gfc_trans_array_constructor_value (&body
, type
, desc
,
1109 c
->expr
->value
.constructor
,
1110 poffset
, offsetvar
, dynamic
);
1112 else if (c
->expr
->rank
> 0)
1114 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1115 poffset
, offsetvar
, dynamic
);
1119 /* This code really upsets the gimplifier so don't bother for now. */
1126 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1133 /* Scalar values. */
1134 gfc_init_se (&se
, NULL
);
1135 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1138 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1139 *poffset
, gfc_index_one_node
);
1143 /* Collect multiple scalar constants into a constructor. */
1151 /* Count the number of consecutive scalar constants. */
1152 while (p
&& !(p
->iterator
1153 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1155 gfc_init_se (&se
, NULL
);
1156 gfc_conv_constant (&se
, p
->expr
);
1157 if (p
->expr
->ts
.type
== BT_CHARACTER
1158 && POINTER_TYPE_P (type
))
1160 /* For constant character array constructors we build
1161 an array of pointers. */
1162 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
1166 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1171 bound
= build_int_cst (NULL_TREE
, n
- 1);
1172 /* Create an array type to hold them. */
1173 tmptype
= build_range_type (gfc_array_index_type
,
1174 gfc_index_zero_node
, bound
);
1175 tmptype
= build_array_type (type
, tmptype
);
1177 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1178 TREE_CONSTANT (init
) = 1;
1179 TREE_INVARIANT (init
) = 1;
1180 TREE_STATIC (init
) = 1;
1181 /* Create a static variable to hold the data. */
1182 tmp
= gfc_create_var (tmptype
, "data");
1183 TREE_STATIC (tmp
) = 1;
1184 TREE_CONSTANT (tmp
) = 1;
1185 TREE_INVARIANT (tmp
) = 1;
1186 TREE_READONLY (tmp
) = 1;
1187 DECL_INITIAL (tmp
) = init
;
1190 /* Use BUILTIN_MEMCPY to assign the values. */
1191 tmp
= gfc_conv_descriptor_data_get (desc
);
1192 tmp
= build_fold_indirect_ref (tmp
);
1193 tmp
= gfc_build_array_ref (tmp
, *poffset
);
1194 tmp
= build_fold_addr_expr (tmp
);
1195 init
= build_fold_addr_expr (init
);
1197 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1198 bound
= build_int_cst (NULL_TREE
, n
* size
);
1199 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
1201 gfc_add_expr_to_block (&body
, tmp
);
1203 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1204 *poffset
, build_int_cst (NULL_TREE
, n
));
1206 if (!INTEGER_CST_P (*poffset
))
1208 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
1209 *poffset
= *offsetvar
;
1213 /* The frontend should already have done any expansions possible
1217 /* Pass the code as is. */
1218 tmp
= gfc_finish_block (&body
);
1219 gfc_add_expr_to_block (pblock
, tmp
);
1223 /* Build the implied do-loop. */
1233 loopbody
= gfc_finish_block (&body
);
1235 gfc_init_se (&se
, NULL
);
1236 gfc_conv_expr (&se
, c
->iterator
->var
);
1237 gfc_add_block_to_block (pblock
, &se
.pre
);
1240 /* Make a temporary, store the current value in that
1241 and return it, once the loop is done. */
1242 tmp_loopvar
= gfc_create_var (TREE_TYPE (loopvar
), "loopvar");
1243 gfc_add_modify_expr (pblock
, tmp_loopvar
, loopvar
);
1245 /* Initialize the loop. */
1246 gfc_init_se (&se
, NULL
);
1247 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1248 gfc_add_block_to_block (pblock
, &se
.pre
);
1249 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
1251 gfc_init_se (&se
, NULL
);
1252 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1253 gfc_add_block_to_block (pblock
, &se
.pre
);
1254 end
= gfc_evaluate_now (se
.expr
, pblock
);
1256 gfc_init_se (&se
, NULL
);
1257 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1258 gfc_add_block_to_block (pblock
, &se
.pre
);
1259 step
= gfc_evaluate_now (se
.expr
, pblock
);
1261 /* If this array expands dynamically, and the number of iterations
1262 is not constant, we won't have allocated space for the static
1263 part of C->EXPR's size. Do that now. */
1264 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1266 /* Get the number of iterations. */
1267 tmp
= gfc_get_iteration_count (loopvar
, end
, step
);
1269 /* Get the static part of C->EXPR's size. */
1270 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1271 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1273 /* Grow the array by TMP * TMP2 elements. */
1274 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1275 gfc_grow_array (pblock
, desc
, tmp
);
1278 /* Generate the loop body. */
1279 exit_label
= gfc_build_label_decl (NULL_TREE
);
1280 gfc_start_block (&body
);
1282 /* Generate the exit condition. Depending on the sign of
1283 the step variable we have to generate the correct
1285 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1286 build_int_cst (TREE_TYPE (step
), 0));
1287 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1288 build2 (GT_EXPR
, boolean_type_node
,
1290 build2 (LT_EXPR
, boolean_type_node
,
1292 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1293 TREE_USED (exit_label
) = 1;
1294 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1295 gfc_add_expr_to_block (&body
, tmp
);
1297 /* The main loop body. */
1298 gfc_add_expr_to_block (&body
, loopbody
);
1300 /* Increase loop variable by step. */
1301 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
1302 gfc_add_modify_expr (&body
, loopvar
, tmp
);
1304 /* Finish the loop. */
1305 tmp
= gfc_finish_block (&body
);
1306 tmp
= build1_v (LOOP_EXPR
, tmp
);
1307 gfc_add_expr_to_block (pblock
, tmp
);
1309 /* Add the exit label. */
1310 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1311 gfc_add_expr_to_block (pblock
, tmp
);
1313 /* Restore the original value of the loop counter. */
1314 gfc_add_modify_expr (pblock
, loopvar
, tmp_loopvar
);
1321 /* Figure out the string length of a variable reference expression.
1322 Used by get_array_ctor_strlen. */
1325 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1331 /* Don't bother if we already know the length is a constant. */
1332 if (*len
&& INTEGER_CST_P (*len
))
1335 ts
= &expr
->symtree
->n
.sym
->ts
;
1336 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1341 /* Array references don't change the string length. */
1345 /* Use the length of the component. */
1346 ts
= &ref
->u
.c
.component
->ts
;
1350 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1351 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
)
1353 mpz_init_set_ui (char_len
, 1);
1354 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1355 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1356 *len
= gfc_conv_mpz_to_tree (char_len
,
1357 gfc_default_character_kind
);
1358 *len
= convert (gfc_charlen_type_node
, *len
);
1359 mpz_clear (char_len
);
1363 /* TODO: Substrings are tricky because we can't evaluate the
1364 expression more than once. For now we just give up, and hope
1365 we can figure it out elsewhere. */
1370 *len
= ts
->cl
->backend_decl
;
1374 /* Figure out the string length of a character array constructor.
1375 Returns TRUE if all elements are character constants. */
1378 get_array_ctor_strlen (gfc_constructor
* c
, tree
* len
)
1383 for (; c
; c
= c
->next
)
1385 switch (c
->expr
->expr_type
)
1388 if (!(*len
&& INTEGER_CST_P (*len
)))
1389 *len
= build_int_cstu (gfc_charlen_type_node
,
1390 c
->expr
->value
.character
.length
);
1394 if (!get_array_ctor_strlen (c
->expr
->value
.constructor
, len
))
1400 get_array_ctor_var_strlen (c
->expr
, len
);
1406 /* Hope that whatever we have possesses a constant character
1408 if (!(*len
&& INTEGER_CST_P (*len
)) && c
->expr
->ts
.cl
)
1410 gfc_conv_const_charlen (c
->expr
->ts
.cl
);
1411 *len
= c
->expr
->ts
.cl
->backend_decl
;
1413 /* TODO: For now we just ignore anything we don't know how to
1414 handle, and hope we can figure it out a different way. */
1422 /* Check whether the array constructor C consists entirely of constant
1423 elements, and if so returns the number of those elements, otherwise
1424 return zero. Note, an empty or NULL array constructor returns zero. */
1426 unsigned HOST_WIDE_INT
1427 gfc_constant_array_constructor_p (gfc_constructor
* c
)
1429 unsigned HOST_WIDE_INT nelem
= 0;
1434 || c
->expr
->rank
> 0
1435 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1444 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1445 and the tree type of it's elements, TYPE, return a static constant
1446 variable that is compile-time initialized. */
1449 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1451 tree tmptype
, list
, init
, tmp
;
1452 HOST_WIDE_INT nelem
;
1458 /* First traverse the constructor list, converting the constants
1459 to tree to build an initializer. */
1462 c
= expr
->value
.constructor
;
1465 gfc_init_se (&se
, NULL
);
1466 gfc_conv_constant (&se
, c
->expr
);
1467 if (c
->expr
->ts
.type
== BT_CHARACTER
1468 && POINTER_TYPE_P (type
))
1469 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
1470 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1475 /* Next determine the tree type for the array. We use the gfortran
1476 front-end's gfc_get_nodesc_array_type in order to create a suitable
1477 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1479 memset (&as
, 0, sizeof (gfc_array_spec
));
1481 as
.rank
= expr
->rank
;
1482 as
.type
= AS_EXPLICIT
;
1485 as
.lower
[0] = gfc_int_expr (0);
1486 as
.upper
[0] = gfc_int_expr (nelem
- 1);
1489 for (i
= 0; i
< expr
->rank
; i
++)
1491 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1492 as
.lower
[i
] = gfc_int_expr (0);
1493 as
.upper
[i
] = gfc_int_expr (tmp
- 1);
1496 tmptype
= gfc_get_nodesc_array_type (type
, &as
, 3);
1498 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1500 TREE_CONSTANT (init
) = 1;
1501 TREE_INVARIANT (init
) = 1;
1502 TREE_STATIC (init
) = 1;
1504 tmp
= gfc_create_var (tmptype
, "A");
1505 TREE_STATIC (tmp
) = 1;
1506 TREE_CONSTANT (tmp
) = 1;
1507 TREE_INVARIANT (tmp
) = 1;
1508 TREE_READONLY (tmp
) = 1;
1509 DECL_INITIAL (tmp
) = init
;
1515 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1516 This mostly initializes the scalarizer state info structure with the
1517 appropriate values to directly use the array created by the function
1518 gfc_build_constant_array_constructor. */
1521 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1522 gfc_ss
* ss
, tree type
)
1528 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1530 info
= &ss
->data
.info
;
1532 info
->descriptor
= tmp
;
1533 info
->data
= build_fold_addr_expr (tmp
);
1534 info
->offset
= fold_build1 (NEGATE_EXPR
, gfc_array_index_type
,
1537 for (i
= 0; i
< info
->dimen
; i
++)
1539 info
->delta
[i
] = gfc_index_zero_node
;
1540 info
->start
[i
] = gfc_index_zero_node
;
1541 info
->end
[i
] = gfc_index_zero_node
;
1542 info
->stride
[i
] = gfc_index_one_node
;
1546 if (info
->dimen
> loop
->temp_dim
)
1547 loop
->temp_dim
= info
->dimen
;
1550 /* Helper routine of gfc_trans_array_constructor to determine if the
1551 bounds of the loop specified by LOOP are constant and simple enough
1552 to use with gfc_trans_constant_array_constructor. Returns the
1553 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1556 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1558 tree size
= gfc_index_one_node
;
1562 for (i
= 0; i
< loop
->dimen
; i
++)
1564 /* If the bounds aren't constant, return NULL_TREE. */
1565 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1567 if (!integer_zerop (loop
->from
[i
]))
1569 /* Only allow non-zero "from" in one-dimensional arrays. */
1570 if (loop
->dimen
!= 1)
1572 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1573 loop
->to
[i
], loop
->from
[i
]);
1577 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1578 tmp
, gfc_index_one_node
);
1579 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1586 /* Array constructors are handled by constructing a temporary, then using that
1587 within the scalarization loop. This is not optimal, but seems by far the
1591 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1600 ss
->data
.info
.dimen
= loop
->dimen
;
1602 c
= ss
->expr
->value
.constructor
;
1603 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1605 bool const_string
= get_array_ctor_strlen (c
, &ss
->string_length
);
1606 if (!ss
->string_length
)
1607 gfc_todo_error ("complex character array constructors");
1609 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1611 type
= build_pointer_type (type
);
1614 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1616 /* See if the constructor determines the loop bounds. */
1618 if (loop
->to
[0] == NULL_TREE
)
1622 /* We should have a 1-dimensional, zero-based loop. */
1623 gcc_assert (loop
->dimen
== 1);
1624 gcc_assert (integer_zerop (loop
->from
[0]));
1626 /* Split the constructor size into a static part and a dynamic part.
1627 Allocate the static size up-front and record whether the dynamic
1628 size might be nonzero. */
1630 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1631 mpz_sub_ui (size
, size
, 1);
1632 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1636 /* Special case constant array constructors. */
1639 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1642 tree size
= constant_array_constructor_loop_size (loop
);
1643 if (size
&& compare_tree_int (size
, nelem
) == 0)
1645 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1651 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1652 type
, dynamic
, true, false);
1654 desc
= ss
->data
.info
.descriptor
;
1655 offset
= gfc_index_zero_node
;
1656 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1657 TREE_USED (offsetvar
) = 0;
1658 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1659 &offset
, &offsetvar
, dynamic
);
1661 /* If the array grows dynamically, the upper bound of the loop variable
1662 is determined by the array's final upper bound. */
1664 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1666 if (TREE_USED (offsetvar
))
1667 pushdecl (offsetvar
);
1669 gcc_assert (INTEGER_CST_P (offset
));
1671 /* Disable bound checking for now because it's probably broken. */
1672 if (flag_bounds_check
)
1680 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1681 called after evaluating all of INFO's vector dimensions. Go through
1682 each such vector dimension and see if we can now fill in any missing
1686 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1695 for (n
= 0; n
< loop
->dimen
; n
++)
1698 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1699 && loop
->to
[n
] == NULL
)
1701 /* Loop variable N indexes vector dimension DIM, and we don't
1702 yet know the upper bound of loop variable N. Set it to the
1703 difference between the vector's upper and lower bounds. */
1704 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1705 gcc_assert (info
->subscript
[dim
]
1706 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1708 gfc_init_se (&se
, NULL
);
1709 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1710 zero
= gfc_rank_cst
[0];
1711 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1712 gfc_conv_descriptor_ubound (desc
, zero
),
1713 gfc_conv_descriptor_lbound (desc
, zero
));
1714 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1721 /* Add the pre and post chains for all the scalar expressions in a SS chain
1722 to loop. This is called after the loop parameters have been calculated,
1723 but before the actual scalarizing loops. */
1726 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1731 /* TODO: This can generate bad code if there are ordering dependencies.
1732 eg. a callee allocated function and an unknown size constructor. */
1733 gcc_assert (ss
!= NULL
);
1735 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1742 /* Scalar expression. Evaluate this now. This includes elemental
1743 dimension indices, but not array section bounds. */
1744 gfc_init_se (&se
, NULL
);
1745 gfc_conv_expr (&se
, ss
->expr
);
1746 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1748 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1750 /* Move the evaluation of scalar expressions outside the
1751 scalarization loop. */
1753 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1754 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1755 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1758 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1760 ss
->data
.scalar
.expr
= se
.expr
;
1761 ss
->string_length
= se
.string_length
;
1764 case GFC_SS_REFERENCE
:
1765 /* Scalar reference. Evaluate this now. */
1766 gfc_init_se (&se
, NULL
);
1767 gfc_conv_expr_reference (&se
, ss
->expr
);
1768 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1769 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1771 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1772 ss
->string_length
= se
.string_length
;
1775 case GFC_SS_SECTION
:
1776 /* Add the expressions for scalar and vector subscripts. */
1777 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1778 if (ss
->data
.info
.subscript
[n
])
1779 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1781 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1785 /* Get the vector's descriptor and store it in SS. */
1786 gfc_init_se (&se
, NULL
);
1787 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1788 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1789 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1790 ss
->data
.info
.descriptor
= se
.expr
;
1793 case GFC_SS_INTRINSIC
:
1794 gfc_add_intrinsic_ss_code (loop
, ss
);
1797 case GFC_SS_FUNCTION
:
1798 /* Array function return value. We call the function and save its
1799 result in a temporary for use inside the loop. */
1800 gfc_init_se (&se
, NULL
);
1803 gfc_conv_expr (&se
, ss
->expr
);
1804 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1805 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1806 ss
->string_length
= se
.string_length
;
1809 case GFC_SS_CONSTRUCTOR
:
1810 gfc_trans_array_constructor (loop
, ss
);
1814 case GFC_SS_COMPONENT
:
1815 /* Do nothing. These are handled elsewhere. */
1825 /* Translate expressions for the descriptor and data pointer of a SS. */
1829 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1834 /* Get the descriptor for the array to be scalarized. */
1835 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1836 gfc_init_se (&se
, NULL
);
1837 se
.descriptor_only
= 1;
1838 gfc_conv_expr_lhs (&se
, ss
->expr
);
1839 gfc_add_block_to_block (block
, &se
.pre
);
1840 ss
->data
.info
.descriptor
= se
.expr
;
1841 ss
->string_length
= se
.string_length
;
1845 /* Also the data pointer. */
1846 tmp
= gfc_conv_array_data (se
.expr
);
1847 /* If this is a variable or address of a variable we use it directly.
1848 Otherwise we must evaluate it now to avoid breaking dependency
1849 analysis by pulling the expressions for elemental array indices
1852 || (TREE_CODE (tmp
) == ADDR_EXPR
1853 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1854 tmp
= gfc_evaluate_now (tmp
, block
);
1855 ss
->data
.info
.data
= tmp
;
1857 tmp
= gfc_conv_array_offset (se
.expr
);
1858 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1863 /* Initialize a gfc_loopinfo structure. */
1866 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1870 memset (loop
, 0, sizeof (gfc_loopinfo
));
1871 gfc_init_block (&loop
->pre
);
1872 gfc_init_block (&loop
->post
);
1874 /* Initially scalarize in order. */
1875 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1878 loop
->ss
= gfc_ss_terminator
;
1882 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1886 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1892 /* Return an expression for the data pointer of an array. */
1895 gfc_conv_array_data (tree descriptor
)
1899 type
= TREE_TYPE (descriptor
);
1900 if (GFC_ARRAY_TYPE_P (type
))
1902 if (TREE_CODE (type
) == POINTER_TYPE
)
1906 /* Descriptorless arrays. */
1907 return build_fold_addr_expr (descriptor
);
1911 return gfc_conv_descriptor_data_get (descriptor
);
1915 /* Return an expression for the base offset of an array. */
1918 gfc_conv_array_offset (tree descriptor
)
1922 type
= TREE_TYPE (descriptor
);
1923 if (GFC_ARRAY_TYPE_P (type
))
1924 return GFC_TYPE_ARRAY_OFFSET (type
);
1926 return gfc_conv_descriptor_offset (descriptor
);
1930 /* Get an expression for the array stride. */
1933 gfc_conv_array_stride (tree descriptor
, int dim
)
1938 type
= TREE_TYPE (descriptor
);
1940 /* For descriptorless arrays use the array size. */
1941 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1942 if (tmp
!= NULL_TREE
)
1945 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1950 /* Like gfc_conv_array_stride, but for the lower bound. */
1953 gfc_conv_array_lbound (tree descriptor
, int dim
)
1958 type
= TREE_TYPE (descriptor
);
1960 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1961 if (tmp
!= NULL_TREE
)
1964 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1969 /* Like gfc_conv_array_stride, but for the upper bound. */
1972 gfc_conv_array_ubound (tree descriptor
, int dim
)
1977 type
= TREE_TYPE (descriptor
);
1979 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1980 if (tmp
!= NULL_TREE
)
1983 /* This should only ever happen when passing an assumed shape array
1984 as an actual parameter. The value will never be used. */
1985 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1986 return gfc_index_zero_node
;
1988 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1993 /* Generate code to perform an array index bound check. */
1996 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2002 const char * name
= NULL
;
2004 if (!flag_bounds_check
)
2007 index
= gfc_evaluate_now (index
, &se
->pre
);
2009 /* We find a name for the error message. */
2011 name
= se
->ss
->expr
->symtree
->name
;
2013 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2014 && se
->loop
->ss
->expr
->symtree
)
2015 name
= se
->loop
->ss
->expr
->symtree
->name
;
2017 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2018 && se
->loop
->ss
->loop_chain
->expr
2019 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2020 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2022 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2023 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2024 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2026 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2028 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2029 && se
->loop
->ss
->expr
->value
.function
.name
)
2030 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2032 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2033 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2034 name
= "unnamed constant";
2037 /* Check lower bound. */
2038 tmp
= gfc_conv_array_lbound (descriptor
, n
);
2039 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
2041 asprintf (&msg
, "%s for array '%s', lower bound of dimension %d exceeded",
2042 gfc_msg_fault
, name
, n
+1);
2044 asprintf (&msg
, "%s, lower bound of dimension %d exceeded",
2045 gfc_msg_fault
, n
+1);
2046 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
2049 /* Check upper bound. */
2050 tmp
= gfc_conv_array_ubound (descriptor
, n
);
2051 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
2053 asprintf (&msg
, "%s for array '%s', upper bound of dimension %d exceeded",
2054 gfc_msg_fault
, name
, n
+1);
2056 asprintf (&msg
, "%s, upper bound of dimension %d exceeded",
2057 gfc_msg_fault
, n
+1);
2058 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
2065 /* Return the offset for an index. Performs bound checking for elemental
2066 dimensions. Single element references are processed separately. */
2069 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2070 gfc_array_ref
* ar
, tree stride
)
2076 /* Get the index into the array for this dimension. */
2079 gcc_assert (ar
->type
!= AR_ELEMENT
);
2080 switch (ar
->dimen_type
[dim
])
2083 gcc_assert (i
== -1);
2084 /* Elemental dimension. */
2085 gcc_assert (info
->subscript
[dim
]
2086 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2087 /* We've already translated this value outside the loop. */
2088 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2090 if ((ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
)
2091 || dim
< ar
->dimen
- 1)
2092 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2093 index
, dim
, &ar
->where
);
2097 gcc_assert (info
&& se
->loop
);
2098 gcc_assert (info
->subscript
[dim
]
2099 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2100 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2102 /* Get a zero-based index into the vector. */
2103 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2104 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2106 /* Multiply the index by the stride. */
2107 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2108 index
, gfc_conv_array_stride (desc
, 0));
2110 /* Read the vector to get an index into info->descriptor. */
2111 data
= build_fold_indirect_ref (gfc_conv_array_data (desc
));
2112 index
= gfc_build_array_ref (data
, index
);
2113 index
= gfc_evaluate_now (index
, &se
->pre
);
2115 /* Do any bounds checking on the final info->descriptor index. */
2116 if ((ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
)
2117 || dim
< ar
->dimen
- 1)
2118 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2119 index
, dim
, &ar
->where
);
2123 /* Scalarized dimension. */
2124 gcc_assert (info
&& se
->loop
);
2126 /* Multiply the loop variable by the stride and delta. */
2127 index
= se
->loop
->loopvar
[i
];
2128 if (!integer_onep (info
->stride
[i
]))
2129 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2131 if (!integer_zerop (info
->delta
[i
]))
2132 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2142 /* Temporary array or derived type component. */
2143 gcc_assert (se
->loop
);
2144 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2145 if (!integer_zerop (info
->delta
[i
]))
2146 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2147 index
, info
->delta
[i
]);
2150 /* Multiply by the stride. */
2151 if (!integer_onep (stride
))
2152 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2158 /* Build a scalarized reference to an array. */
2161 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2168 info
= &se
->ss
->data
.info
;
2170 n
= se
->loop
->order
[0];
2174 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2176 /* Add the offset for this dimension to the stored offset for all other
2178 if (!integer_zerop (info
->offset
))
2179 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2181 tmp
= build_fold_indirect_ref (info
->data
);
2182 se
->expr
= gfc_build_array_ref (tmp
, index
);
2186 /* Translate access of temporary array. */
2189 gfc_conv_tmp_array_ref (gfc_se
* se
)
2191 se
->string_length
= se
->ss
->string_length
;
2192 gfc_conv_scalarized_array_ref (se
, NULL
);
2196 /* Build an array reference. se->expr already holds the array descriptor.
2197 This should be either a variable, indirect variable reference or component
2198 reference. For arrays which do not have a descriptor, se->expr will be
2200 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2203 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2212 /* Handle scalarized references separately. */
2213 if (ar
->type
!= AR_ELEMENT
)
2215 gfc_conv_scalarized_array_ref (se
, ar
);
2216 gfc_advance_se_ss_chain (se
);
2220 index
= gfc_index_zero_node
;
2222 /* Calculate the offsets from all the dimensions. */
2223 for (n
= 0; n
< ar
->dimen
; n
++)
2225 /* Calculate the index for this dimension. */
2226 gfc_init_se (&indexse
, se
);
2227 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2228 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2230 if (flag_bounds_check
&&
2231 ((ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
)
2232 || n
< ar
->dimen
- 1))
2234 /* Check array bounds. */
2238 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2239 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2241 asprintf (&msg
, "%s for array '%s', "
2242 "lower bound of dimension %d exceeded", gfc_msg_fault
,
2244 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, where
);
2247 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2248 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2250 asprintf (&msg
, "%s for array '%s', "
2251 "upper bound of dimension %d exceeded", gfc_msg_fault
,
2253 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, where
);
2257 /* Multiply the index by the stride. */
2258 stride
= gfc_conv_array_stride (se
->expr
, n
);
2259 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2262 /* And add it to the total. */
2263 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2266 tmp
= gfc_conv_array_offset (se
->expr
);
2267 if (!integer_zerop (tmp
))
2268 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2270 /* Access the calculated element. */
2271 tmp
= gfc_conv_array_data (se
->expr
);
2272 tmp
= build_fold_indirect_ref (tmp
);
2273 se
->expr
= gfc_build_array_ref (tmp
, index
);
2277 /* Generate the code to be executed immediately before entering a
2278 scalarization loop. */
2281 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2282 stmtblock_t
* pblock
)
2291 /* This code will be executed before entering the scalarization loop
2292 for this dimension. */
2293 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2295 if ((ss
->useflags
& flag
) == 0)
2298 if (ss
->type
!= GFC_SS_SECTION
2299 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2300 && ss
->type
!= GFC_SS_COMPONENT
)
2303 info
= &ss
->data
.info
;
2305 if (dim
>= info
->dimen
)
2308 if (dim
== info
->dimen
- 1)
2310 /* For the outermost loop calculate the offset due to any
2311 elemental dimensions. It will have been initialized with the
2312 base offset of the array. */
2315 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2317 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2320 gfc_init_se (&se
, NULL
);
2322 se
.expr
= info
->descriptor
;
2323 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2324 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2327 gfc_add_block_to_block (pblock
, &se
.pre
);
2329 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2330 info
->offset
, index
);
2331 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2335 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2338 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2340 /* Calculate the stride of the innermost loop. Hopefully this will
2341 allow the backend optimizers to do their stuff more effectively.
2343 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2347 /* Add the offset for the previous loop dimension. */
2352 ar
= &info
->ref
->u
.ar
;
2353 i
= loop
->order
[dim
+ 1];
2361 gfc_init_se (&se
, NULL
);
2363 se
.expr
= info
->descriptor
;
2364 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2365 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2367 gfc_add_block_to_block (pblock
, &se
.pre
);
2368 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2369 info
->offset
, index
);
2370 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2373 /* Remember this offset for the second loop. */
2374 if (dim
== loop
->temp_dim
- 1)
2375 info
->saved_offset
= info
->offset
;
2380 /* Start a scalarized expression. Creates a scope and declares loop
2384 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2390 gcc_assert (!loop
->array_parameter
);
2392 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2394 n
= loop
->order
[dim
];
2396 gfc_start_block (&loop
->code
[n
]);
2398 /* Create the loop variable. */
2399 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2401 if (dim
< loop
->temp_dim
)
2405 /* Calculate values that will be constant within this loop. */
2406 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2408 gfc_start_block (pbody
);
2412 /* Generates the actual loop code for a scalarization loop. */
2415 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2416 stmtblock_t
* pbody
)
2424 loopbody
= gfc_finish_block (pbody
);
2426 /* Initialize the loopvar. */
2427 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2429 exit_label
= gfc_build_label_decl (NULL_TREE
);
2431 /* Generate the loop body. */
2432 gfc_init_block (&block
);
2434 /* The exit condition. */
2435 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2436 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2437 TREE_USED (exit_label
) = 1;
2438 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2439 gfc_add_expr_to_block (&block
, tmp
);
2441 /* The main body. */
2442 gfc_add_expr_to_block (&block
, loopbody
);
2444 /* Increment the loopvar. */
2445 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2446 loop
->loopvar
[n
], gfc_index_one_node
);
2447 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2449 /* Build the loop. */
2450 tmp
= gfc_finish_block (&block
);
2451 tmp
= build1_v (LOOP_EXPR
, tmp
);
2452 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2454 /* Add the exit label. */
2455 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2456 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2460 /* Finishes and generates the loops for a scalarized expression. */
2463 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2468 stmtblock_t
*pblock
;
2472 /* Generate the loops. */
2473 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2475 n
= loop
->order
[dim
];
2476 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2477 loop
->loopvar
[n
] = NULL_TREE
;
2478 pblock
= &loop
->code
[n
];
2481 tmp
= gfc_finish_block (pblock
);
2482 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2484 /* Clear all the used flags. */
2485 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2490 /* Finish the main body of a scalarized expression, and start the secondary
2494 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2498 stmtblock_t
*pblock
;
2502 /* We finish as many loops as are used by the temporary. */
2503 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2505 n
= loop
->order
[dim
];
2506 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2507 loop
->loopvar
[n
] = NULL_TREE
;
2508 pblock
= &loop
->code
[n
];
2511 /* We don't want to finish the outermost loop entirely. */
2512 n
= loop
->order
[loop
->temp_dim
- 1];
2513 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2515 /* Restore the initial offsets. */
2516 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2518 if ((ss
->useflags
& 2) == 0)
2521 if (ss
->type
!= GFC_SS_SECTION
2522 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2523 && ss
->type
!= GFC_SS_COMPONENT
)
2526 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2529 /* Restart all the inner loops we just finished. */
2530 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2532 n
= loop
->order
[dim
];
2534 gfc_start_block (&loop
->code
[n
]);
2536 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2538 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2541 /* Start a block for the secondary copying code. */
2542 gfc_start_block (body
);
2546 /* Calculate the upper bound of an array section. */
2549 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2558 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2560 info
= &ss
->data
.info
;
2563 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2564 /* We'll calculate the upper bound once we have access to the
2565 vector's descriptor. */
2568 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2569 desc
= info
->descriptor
;
2570 end
= info
->ref
->u
.ar
.end
[dim
];
2574 /* The upper bound was specified. */
2575 gfc_init_se (&se
, NULL
);
2576 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2577 gfc_add_block_to_block (pblock
, &se
.pre
);
2582 /* No upper bound was specified, so use the bound of the array. */
2583 bound
= gfc_conv_array_ubound (desc
, dim
);
2590 /* Calculate the lower bound of an array section. */
2593 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2603 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2605 info
= &ss
->data
.info
;
2608 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2610 /* We use a zero-based index to access the vector. */
2611 info
->start
[n
] = gfc_index_zero_node
;
2612 info
->end
[n
] = gfc_index_zero_node
;
2613 info
->stride
[n
] = gfc_index_one_node
;
2617 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2618 desc
= info
->descriptor
;
2619 start
= info
->ref
->u
.ar
.start
[dim
];
2620 end
= info
->ref
->u
.ar
.end
[dim
];
2621 stride
= info
->ref
->u
.ar
.stride
[dim
];
2623 /* Calculate the start of the range. For vector subscripts this will
2624 be the range of the vector. */
2627 /* Specified section start. */
2628 gfc_init_se (&se
, NULL
);
2629 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2630 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2631 info
->start
[n
] = se
.expr
;
2635 /* No lower bound specified so use the bound of the array. */
2636 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2638 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2640 /* Similarly calculate the end. Although this is not used in the
2641 scalarizer, it is needed when checking bounds and where the end
2642 is an expression with side-effects. */
2645 /* Specified section start. */
2646 gfc_init_se (&se
, NULL
);
2647 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2648 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2649 info
->end
[n
] = se
.expr
;
2653 /* No upper bound specified so use the bound of the array. */
2654 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
2656 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
2658 /* Calculate the stride. */
2660 info
->stride
[n
] = gfc_index_one_node
;
2663 gfc_init_se (&se
, NULL
);
2664 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2665 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2666 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2671 /* Calculates the range start and stride for a SS chain. Also gets the
2672 descriptor and data pointer. The range of vector subscripts is the size
2673 of the vector. Array bounds are also checked. */
2676 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2684 /* Determine the rank of the loop. */
2686 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2690 case GFC_SS_SECTION
:
2691 case GFC_SS_CONSTRUCTOR
:
2692 case GFC_SS_FUNCTION
:
2693 case GFC_SS_COMPONENT
:
2694 loop
->dimen
= ss
->data
.info
.dimen
;
2697 /* As usual, lbound and ubound are exceptions!. */
2698 case GFC_SS_INTRINSIC
:
2699 switch (ss
->expr
->value
.function
.isym
->generic_id
)
2701 case GFC_ISYM_LBOUND
:
2702 case GFC_ISYM_UBOUND
:
2703 loop
->dimen
= ss
->data
.info
.dimen
;
2714 if (loop
->dimen
== 0)
2715 gfc_todo_error ("Unable to determine rank of expression");
2718 /* Loop over all the SS in the chain. */
2719 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2721 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2722 ss
->shape
= ss
->expr
->shape
;
2726 case GFC_SS_SECTION
:
2727 /* Get the descriptor for the array. */
2728 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2730 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2731 gfc_conv_section_startstride (loop
, ss
, n
);
2734 case GFC_SS_INTRINSIC
:
2735 switch (ss
->expr
->value
.function
.isym
->generic_id
)
2737 /* Fall through to supply start and stride. */
2738 case GFC_ISYM_LBOUND
:
2739 case GFC_ISYM_UBOUND
:
2745 case GFC_SS_CONSTRUCTOR
:
2746 case GFC_SS_FUNCTION
:
2747 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2749 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2750 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
2751 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2760 /* The rest is just runtime bound checking. */
2761 if (flag_bounds_check
)
2764 tree lbound
, ubound
;
2766 tree size
[GFC_MAX_DIMENSIONS
];
2767 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
;
2772 gfc_start_block (&block
);
2774 for (n
= 0; n
< loop
->dimen
; n
++)
2775 size
[n
] = NULL_TREE
;
2777 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2779 if (ss
->type
!= GFC_SS_SECTION
)
2782 /* TODO: range checking for mapped dimensions. */
2783 info
= &ss
->data
.info
;
2785 /* This code only checks ranges. Elemental and vector
2786 dimensions are checked later. */
2787 for (n
= 0; n
< loop
->dimen
; n
++)
2790 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
2792 if (n
== info
->ref
->u
.ar
.dimen
- 1
2793 && (info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
2794 || info
->ref
->u
.ar
.as
->cp_was_assumed
))
2797 desc
= ss
->data
.info
.descriptor
;
2799 /* This is the run-time equivalent of resolve.c's
2800 check_dimension(). The logical is more readable there
2801 than it is here, with all the trees. */
2802 lbound
= gfc_conv_array_lbound (desc
, dim
);
2803 ubound
= gfc_conv_array_ubound (desc
, dim
);
2806 /* Zero stride is not allowed. */
2807 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
2808 gfc_index_zero_node
);
2809 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
2810 "of array '%s'", info
->dim
[n
]+1,
2811 ss
->expr
->symtree
->name
);
2812 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2815 /* non_zerosized is true when the selected range is not
2817 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
2818 info
->stride
[n
], gfc_index_zero_node
);
2819 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
2821 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2824 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
2825 info
->stride
[n
], gfc_index_zero_node
);
2826 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
2828 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2830 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2831 stride_pos
, stride_neg
);
2833 /* Check the start of the range against the lower and upper
2834 bounds of the array, if the range is not empty. */
2835 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, info
->start
[n
],
2837 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2838 non_zerosized
, tmp
);
2839 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2840 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2841 ss
->expr
->symtree
->name
);
2842 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2845 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, info
->start
[n
],
2847 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2848 non_zerosized
, tmp
);
2849 asprintf (&msg
, "%s, upper bound of dimension %d of array '%s'"
2850 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2851 ss
->expr
->symtree
->name
);
2852 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2855 /* Compute the last element of the range, which is not
2856 necessarily "end" (think 0:5:3, which doesn't contain 5)
2857 and check it against both lower and upper bounds. */
2858 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2860 tmp2
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp2
,
2862 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2865 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp2
, lbound
);
2866 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2867 non_zerosized
, tmp
);
2868 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2869 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2870 ss
->expr
->symtree
->name
);
2871 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2874 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp2
, ubound
);
2875 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2876 non_zerosized
, tmp
);
2877 asprintf (&msg
, "%s, upper bound of dimension %d of array '%s'"
2878 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2879 ss
->expr
->symtree
->name
);
2880 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2883 /* Check the section sizes match. */
2884 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2886 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2888 /* We remember the size of the first section, and check all the
2889 others against this. */
2893 fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
2894 asprintf (&msg
, "%s, size mismatch for dimension %d "
2895 "of array '%s'", gfc_msg_bounds
, info
->dim
[n
]+1,
2896 ss
->expr
->symtree
->name
);
2897 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2901 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2905 tmp
= gfc_finish_block (&block
);
2906 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2911 /* Return true if the two SS could be aliased, i.e. both point to the same data
2913 /* TODO: resolve aliases based on frontend expressions. */
2916 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2923 lsym
= lss
->expr
->symtree
->n
.sym
;
2924 rsym
= rss
->expr
->symtree
->n
.sym
;
2925 if (gfc_symbols_could_alias (lsym
, rsym
))
2928 if (rsym
->ts
.type
!= BT_DERIVED
2929 && lsym
->ts
.type
!= BT_DERIVED
)
2932 /* For derived types we must check all the component types. We can ignore
2933 array references as these will have the same base type as the previous
2935 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2937 if (lref
->type
!= REF_COMPONENT
)
2940 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2943 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2946 if (rref
->type
!= REF_COMPONENT
)
2949 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2954 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2956 if (rref
->type
!= REF_COMPONENT
)
2959 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2967 /* Resolve array data dependencies. Creates a temporary if required. */
2968 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2972 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2982 loop
->temp_ss
= NULL
;
2983 aref
= dest
->data
.info
.ref
;
2986 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2988 if (ss
->type
!= GFC_SS_SECTION
)
2991 if (gfc_could_be_alias (dest
, ss
)
2992 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
2998 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
3000 lref
= dest
->expr
->ref
;
3001 rref
= ss
->expr
->ref
;
3003 nDepend
= gfc_dep_resolver (lref
, rref
);
3005 /* TODO : loop shifting. */
3008 /* Mark the dimensions for LOOP SHIFTING */
3009 for (n
= 0; n
< loop
->dimen
; n
++)
3011 int dim
= dest
->data
.info
.dim
[n
];
3013 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3015 else if (! gfc_is_same_range (&lref
->u
.ar
,
3016 &rref
->u
.ar
, dim
, 0))
3020 /* Put all the dimensions with dependencies in the
3023 for (n
= 0; n
< loop
->dimen
; n
++)
3025 gcc_assert (loop
->order
[n
] == n
);
3027 loop
->order
[dim
++] = n
;
3030 for (n
= 0; n
< loop
->dimen
; n
++)
3033 loop
->order
[dim
++] = n
;
3036 gcc_assert (dim
== loop
->dimen
);
3045 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3046 if (GFC_ARRAY_TYPE_P (base_type
)
3047 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3048 base_type
= gfc_get_element_type (base_type
);
3049 loop
->temp_ss
= gfc_get_ss ();
3050 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3051 loop
->temp_ss
->data
.temp
.type
= base_type
;
3052 loop
->temp_ss
->string_length
= dest
->string_length
;
3053 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3054 loop
->temp_ss
->next
= gfc_ss_terminator
;
3055 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3058 loop
->temp_ss
= NULL
;
3062 /* Initialize the scalarization loop. Creates the loop variables. Determines
3063 the range of the loop variables. Creates a temporary if required.
3064 Calculates how to transform from loop variables to array indices for each
3065 expression. Also generates code for scalar expressions which have been
3066 moved outside the loop. */
3069 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
3074 gfc_ss_info
*specinfo
;
3078 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3079 bool dynamic
[GFC_MAX_DIMENSIONS
];
3085 for (n
= 0; n
< loop
->dimen
; n
++)
3089 /* We use one SS term, and use that to determine the bounds of the
3090 loop for this dimension. We try to pick the simplest term. */
3091 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3095 /* The frontend has worked out the size for us. */
3100 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3102 /* An unknown size constructor will always be rank one.
3103 Higher rank constructors will either have known shape,
3104 or still be wrapped in a call to reshape. */
3105 gcc_assert (loop
->dimen
== 1);
3107 /* Always prefer to use the constructor bounds if the size
3108 can be determined at compile time. Prefer not to otherwise,
3109 since the general case involves realloc, and it's better to
3110 avoid that overhead if possible. */
3111 c
= ss
->expr
->value
.constructor
;
3112 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
3113 if (!dynamic
[n
] || !loopspec
[n
])
3118 /* TODO: Pick the best bound if we have a choice between a
3119 function and something else. */
3120 if (ss
->type
== GFC_SS_FUNCTION
)
3126 if (ss
->type
!= GFC_SS_SECTION
)
3130 specinfo
= &loopspec
[n
]->data
.info
;
3133 info
= &ss
->data
.info
;
3137 /* Criteria for choosing a loop specifier (most important first):
3138 doesn't need realloc
3144 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3146 else if (integer_onep (info
->stride
[n
])
3147 && !integer_onep (specinfo
->stride
[n
]))
3149 else if (INTEGER_CST_P (info
->stride
[n
])
3150 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3152 else if (INTEGER_CST_P (info
->start
[n
])
3153 && !INTEGER_CST_P (specinfo
->start
[n
]))
3155 /* We don't work out the upper bound.
3156 else if (INTEGER_CST_P (info->finish[n])
3157 && ! INTEGER_CST_P (specinfo->finish[n]))
3158 loopspec[n] = ss; */
3162 gfc_todo_error ("Unable to find scalarization loop specifier");
3164 info
= &loopspec
[n
]->data
.info
;
3166 /* Set the extents of this range. */
3167 cshape
= loopspec
[n
]->shape
;
3168 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3169 && INTEGER_CST_P (info
->stride
[n
]))
3171 loop
->from
[n
] = info
->start
[n
];
3172 mpz_set (i
, cshape
[n
]);
3173 mpz_sub_ui (i
, i
, 1);
3174 /* To = from + (size - 1) * stride. */
3175 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3176 if (!integer_onep (info
->stride
[n
]))
3177 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3178 tmp
, info
->stride
[n
]);
3179 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3180 loop
->from
[n
], tmp
);
3184 loop
->from
[n
] = info
->start
[n
];
3185 switch (loopspec
[n
]->type
)
3187 case GFC_SS_CONSTRUCTOR
:
3188 /* The upper bound is calculated when we expand the
3190 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3193 case GFC_SS_SECTION
:
3194 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3198 case GFC_SS_FUNCTION
:
3199 /* The loop bound will be set when we generate the call. */
3200 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3208 /* Transform everything so we have a simple incrementing variable. */
3209 if (integer_onep (info
->stride
[n
]))
3210 info
->delta
[n
] = gfc_index_zero_node
;
3213 /* Set the delta for this section. */
3214 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3215 /* Number of iterations is (end - start + step) / step.
3216 with start = 0, this simplifies to
3218 for (i = 0; i<=last; i++){...}; */
3219 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3220 loop
->to
[n
], loop
->from
[n
]);
3221 tmp
= fold_build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
3222 tmp
, info
->stride
[n
]);
3223 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3224 /* Make the loop variable start at 0. */
3225 loop
->from
[n
] = gfc_index_zero_node
;
3229 /* Add all the scalar code that can be taken out of the loops.
3230 This may include calculating the loop bounds, so do it before
3231 allocating the temporary. */
3232 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
3234 /* If we want a temporary then create it. */
3235 if (loop
->temp_ss
!= NULL
)
3237 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3238 tmp
= loop
->temp_ss
->data
.temp
.type
;
3239 len
= loop
->temp_ss
->string_length
;
3240 n
= loop
->temp_ss
->data
.temp
.dimen
;
3241 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3242 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3243 loop
->temp_ss
->data
.info
.dimen
= n
;
3244 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3245 &loop
->temp_ss
->data
.info
, tmp
, false, true,
3249 for (n
= 0; n
< loop
->temp_dim
; n
++)
3250 loopspec
[loop
->order
[n
]] = NULL
;
3254 /* For array parameters we don't have loop variables, so don't calculate the
3256 if (loop
->array_parameter
)
3259 /* Calculate the translation from loop variables to array indices. */
3260 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3262 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
3265 info
= &ss
->data
.info
;
3267 for (n
= 0; n
< info
->dimen
; n
++)
3271 /* If we are specifying the range the delta is already set. */
3272 if (loopspec
[n
] != ss
)
3274 /* Calculate the offset relative to the loop variable.
3275 First multiply by the stride. */
3276 tmp
= loop
->from
[n
];
3277 if (!integer_onep (info
->stride
[n
]))
3278 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3279 tmp
, info
->stride
[n
]);
3281 /* Then subtract this from our starting value. */
3282 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3283 info
->start
[n
], tmp
);
3285 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3292 /* Fills in an array descriptor, and returns the size of the array. The size
3293 will be a simple_val, ie a variable or a constant. Also calculates the
3294 offset of the base. Returns the size of the array.
3298 for (n = 0; n < rank; n++)
3300 a.lbound[n] = specified_lower_bound;
3301 offset = offset + a.lbond[n] * stride;
3303 a.ubound[n] = specified_upper_bound;
3304 a.stride[n] = stride;
3305 size = ubound + size; //size = ubound + 1 - lbound
3306 stride = stride * size;
3313 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3314 gfc_expr
** lower
, gfc_expr
** upper
,
3315 stmtblock_t
* pblock
)
3327 stmtblock_t thenblock
;
3328 stmtblock_t elseblock
;
3333 type
= TREE_TYPE (descriptor
);
3335 stride
= gfc_index_one_node
;
3336 offset
= gfc_index_zero_node
;
3338 /* Set the dtype. */
3339 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3340 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3342 or_expr
= NULL_TREE
;
3344 for (n
= 0; n
< rank
; n
++)
3346 /* We have 3 possibilities for determining the size of the array:
3347 lower == NULL => lbound = 1, ubound = upper[n]
3348 upper[n] = NULL => lbound = 1, ubound = lower[n]
3349 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3352 /* Set lower bound. */
3353 gfc_init_se (&se
, NULL
);
3355 se
.expr
= gfc_index_one_node
;
3358 gcc_assert (lower
[n
]);
3361 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3362 gfc_add_block_to_block (pblock
, &se
.pre
);
3366 se
.expr
= gfc_index_one_node
;
3370 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
3371 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3373 /* Work out the offset for this component. */
3374 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3375 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3377 /* Start the calculation for the size of this dimension. */
3378 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3379 gfc_index_one_node
, se
.expr
);
3381 /* Set upper bound. */
3382 gfc_init_se (&se
, NULL
);
3383 gcc_assert (ubound
);
3384 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3385 gfc_add_block_to_block (pblock
, &se
.pre
);
3387 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
3388 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3390 /* Store the stride. */
3391 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
3392 gfc_add_modify_expr (pblock
, tmp
, stride
);
3394 /* Calculate the size of this dimension. */
3395 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3397 /* Check whether the size for this dimension is negative. */
3398 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3399 gfc_index_zero_node
);
3403 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3405 /* Multiply the stride by the number of elements in this dimension. */
3406 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3407 stride
= gfc_evaluate_now (stride
, pblock
);
3410 /* The stride is the number of elements in the array, so multiply by the
3411 size of an element to get the total size. */
3412 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3413 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
);
3415 if (poffset
!= NULL
)
3417 offset
= gfc_evaluate_now (offset
, pblock
);
3421 if (integer_zerop (or_expr
))
3423 if (integer_onep (or_expr
))
3424 return gfc_index_zero_node
;
3426 var
= gfc_create_var (TREE_TYPE (size
), "size");
3427 gfc_start_block (&thenblock
);
3428 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
3429 thencase
= gfc_finish_block (&thenblock
);
3431 gfc_start_block (&elseblock
);
3432 gfc_add_modify_expr (&elseblock
, var
, size
);
3433 elsecase
= gfc_finish_block (&elseblock
);
3435 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3436 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3437 gfc_add_expr_to_block (pblock
, tmp
);
3443 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3444 the work for an ALLOCATE statement. */
3448 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3457 gfc_ref
*ref
, *prev_ref
= NULL
;
3458 bool allocatable_array
;
3462 /* Find the last reference in the chain. */
3463 while (ref
&& ref
->next
!= NULL
)
3465 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3470 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3474 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3476 allocatable_array
= prev_ref
->u
.c
.component
->allocatable
;
3478 /* Figure out the size of the array. */
3479 switch (ref
->u
.ar
.type
)
3483 upper
= ref
->u
.ar
.start
;
3487 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
3489 lower
= ref
->u
.ar
.as
->lower
;
3490 upper
= ref
->u
.ar
.as
->upper
;
3494 lower
= ref
->u
.ar
.start
;
3495 upper
= ref
->u
.ar
.end
;
3503 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
3504 lower
, upper
, &se
->pre
);
3506 /* Allocate memory to store the data. */
3507 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
3508 STRIP_NOPS (pointer
);
3510 if (TYPE_PRECISION (gfc_array_index_type
) == 32)
3512 if (allocatable_array
)
3513 allocate
= gfor_fndecl_allocate_array
;
3515 allocate
= gfor_fndecl_allocate
;
3517 else if (TYPE_PRECISION (gfc_array_index_type
) == 64)
3519 if (allocatable_array
)
3520 allocate
= gfor_fndecl_allocate64_array
;
3522 allocate
= gfor_fndecl_allocate64
;
3527 /* The allocate_array variants take the old pointer as first argument. */
3528 if (allocatable_array
)
3529 tmp
= build_call_expr (allocate
, 3, pointer
, size
, pstat
);
3531 tmp
= build_call_expr (allocate
, 2, size
, pstat
);
3532 tmp
= build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
3533 gfc_add_expr_to_block (&se
->pre
, tmp
);
3535 tmp
= gfc_conv_descriptor_offset (se
->expr
);
3536 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
3538 if (expr
->ts
.type
== BT_DERIVED
3539 && expr
->ts
.derived
->attr
.alloc_comp
)
3541 tmp
= gfc_nullify_alloc_comp (expr
->ts
.derived
, se
->expr
,
3542 ref
->u
.ar
.as
->rank
);
3543 gfc_add_expr_to_block (&se
->pre
, tmp
);
3550 /* Deallocate an array variable. Also used when an allocated variable goes
3555 gfc_array_deallocate (tree descriptor
, tree pstat
)
3561 gfc_start_block (&block
);
3562 /* Get a pointer to the data. */
3563 var
= gfc_conv_descriptor_data_get (descriptor
);
3566 /* Parameter is the address of the data component. */
3567 tmp
= build_call_expr (gfor_fndecl_deallocate
, 2, var
, pstat
);
3568 gfc_add_expr_to_block (&block
, tmp
);
3570 /* Zero the data pointer. */
3571 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
3572 var
, build_int_cst (TREE_TYPE (var
), 0));
3573 gfc_add_expr_to_block (&block
, tmp
);
3575 return gfc_finish_block (&block
);
3579 /* Create an array constructor from an initialization expression.
3580 We assume the frontend already did any expansions and conversions. */
3583 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3590 unsigned HOST_WIDE_INT lo
;
3592 VEC(constructor_elt
,gc
) *v
= NULL
;
3594 switch (expr
->expr_type
)
3597 case EXPR_STRUCTURE
:
3598 /* A single scalar or derived type value. Create an array with all
3599 elements equal to that value. */
3600 gfc_init_se (&se
, NULL
);
3602 if (expr
->expr_type
== EXPR_CONSTANT
)
3603 gfc_conv_constant (&se
, expr
);
3605 gfc_conv_structure (&se
, expr
, 1);
3607 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3608 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3609 hi
= TREE_INT_CST_HIGH (tmp
);
3610 lo
= TREE_INT_CST_LOW (tmp
);
3614 /* This will probably eat buckets of memory for large arrays. */
3615 while (hi
!= 0 || lo
!= 0)
3617 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3625 /* Create a vector of all the elements. */
3626 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3630 /* Problems occur when we get something like
3631 integer :: a(lots) = (/(i, i=1,lots)/) */
3632 /* TODO: Unexpanded array initializers. */
3634 ("Possible frontend bug: array constructor not expanded");
3636 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3637 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3641 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3645 mpz_set (maxval
, c
->repeat
);
3646 mpz_add (maxval
, c
->n
.offset
, maxval
);
3647 mpz_sub_ui (maxval
, maxval
, 1);
3648 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3649 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3651 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3652 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3655 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3657 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3663 gfc_init_se (&se
, NULL
);
3664 switch (c
->expr
->expr_type
)
3667 gfc_conv_constant (&se
, c
->expr
);
3668 if (range
== NULL_TREE
)
3669 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3672 if (index
!= NULL_TREE
)
3673 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3674 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3678 case EXPR_STRUCTURE
:
3679 gfc_conv_structure (&se
, c
->expr
, 1);
3680 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3690 return gfc_build_null_descriptor (type
);
3696 /* Create a constructor from the list of elements. */
3697 tmp
= build_constructor (type
, v
);
3698 TREE_CONSTANT (tmp
) = 1;
3699 TREE_INVARIANT (tmp
) = 1;
3704 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3705 returns the size (in elements) of the array. */
3708 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3709 stmtblock_t
* pblock
)
3724 size
= gfc_index_one_node
;
3725 offset
= gfc_index_zero_node
;
3726 for (dim
= 0; dim
< as
->rank
; dim
++)
3728 /* Evaluate non-constant array bound expressions. */
3729 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3730 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3732 gfc_init_se (&se
, NULL
);
3733 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3734 gfc_add_block_to_block (pblock
, &se
.pre
);
3735 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3737 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3738 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3740 gfc_init_se (&se
, NULL
);
3741 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3742 gfc_add_block_to_block (pblock
, &se
.pre
);
3743 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
3745 /* The offset of this dimension. offset = offset - lbound * stride. */
3746 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
3747 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3749 /* The size of this dimension, and the stride of the next. */
3750 if (dim
+ 1 < as
->rank
)
3751 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3753 stride
= GFC_TYPE_ARRAY_SIZE (type
);
3755 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3757 /* Calculate stride = size * (ubound + 1 - lbound). */
3758 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3759 gfc_index_one_node
, lbound
);
3760 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
3761 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3763 gfc_add_modify_expr (pblock
, stride
, tmp
);
3765 stride
= gfc_evaluate_now (tmp
, pblock
);
3767 /* Make sure that negative size arrays are translated
3768 to being zero size. */
3769 tmp
= build2 (GE_EXPR
, boolean_type_node
,
3770 stride
, gfc_index_zero_node
);
3771 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3772 stride
, gfc_index_zero_node
);
3773 gfc_add_modify_expr (pblock
, stride
, tmp
);
3779 gfc_trans_vla_type_sizes (sym
, pblock
);
3786 /* Generate code to initialize/allocate an array variable. */
3789 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3799 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3801 /* Do nothing for USEd variables. */
3802 if (sym
->attr
.use_assoc
)
3805 type
= TREE_TYPE (decl
);
3806 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3807 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3809 gfc_start_block (&block
);
3811 /* Evaluate character string length. */
3812 if (sym
->ts
.type
== BT_CHARACTER
3813 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3815 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3817 gfc_trans_vla_type_sizes (sym
, &block
);
3819 /* Emit a DECL_EXPR for this variable, which will cause the
3820 gimplifier to allocate storage, and all that good stuff. */
3821 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3822 gfc_add_expr_to_block (&block
, tmp
);
3827 gfc_add_expr_to_block (&block
, fnbody
);
3828 return gfc_finish_block (&block
);
3831 type
= TREE_TYPE (type
);
3833 gcc_assert (!sym
->attr
.use_assoc
);
3834 gcc_assert (!TREE_STATIC (decl
));
3835 gcc_assert (!sym
->module
);
3837 if (sym
->ts
.type
== BT_CHARACTER
3838 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3839 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3841 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3843 /* Don't actually allocate space for Cray Pointees. */
3844 if (sym
->attr
.cray_pointee
)
3846 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3847 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3848 gfc_add_expr_to_block (&block
, fnbody
);
3849 return gfc_finish_block (&block
);
3852 /* The size is the number of elements in the array, so multiply by the
3853 size of an element to get the total size. */
3854 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3855 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3857 /* Allocate memory to hold the data. */
3858 if (gfc_index_integer_kind
== 4)
3859 fndecl
= gfor_fndecl_internal_malloc
;
3860 else if (gfc_index_integer_kind
== 8)
3861 fndecl
= gfor_fndecl_internal_malloc64
;
3864 tmp
= build_call_expr (fndecl
, 1, size
);
3865 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
3866 gfc_add_modify_expr (&block
, decl
, tmp
);
3868 /* Set offset of the array. */
3869 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3870 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3873 /* Automatic arrays should not have initializers. */
3874 gcc_assert (!sym
->value
);
3876 gfc_add_expr_to_block (&block
, fnbody
);
3878 /* Free the temporary. */
3879 tmp
= convert (pvoid_type_node
, decl
);
3880 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, tmp
);
3881 gfc_add_expr_to_block (&block
, tmp
);
3883 return gfc_finish_block (&block
);
3887 /* Generate entry and exit code for g77 calling convention arrays. */
3890 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3900 gfc_get_backend_locus (&loc
);
3901 gfc_set_backend_locus (&sym
->declared_at
);
3903 /* Descriptor type. */
3904 parm
= sym
->backend_decl
;
3905 type
= TREE_TYPE (parm
);
3906 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3908 gfc_start_block (&block
);
3910 if (sym
->ts
.type
== BT_CHARACTER
3911 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3912 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3914 /* Evaluate the bounds of the array. */
3915 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3917 /* Set the offset. */
3918 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3919 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3921 /* Set the pointer itself if we aren't using the parameter directly. */
3922 if (TREE_CODE (parm
) != PARM_DECL
)
3924 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3925 gfc_add_modify_expr (&block
, parm
, tmp
);
3927 stmt
= gfc_finish_block (&block
);
3929 gfc_set_backend_locus (&loc
);
3931 gfc_start_block (&block
);
3933 /* Add the initialization code to the start of the function. */
3935 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
3937 tmp
= gfc_conv_expr_present (sym
);
3938 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3941 gfc_add_expr_to_block (&block
, stmt
);
3942 gfc_add_expr_to_block (&block
, body
);
3944 return gfc_finish_block (&block
);
3948 /* Modify the descriptor of an array parameter so that it has the
3949 correct lower bound. Also move the upper bound accordingly.
3950 If the array is not packed, it will be copied into a temporary.
3951 For each dimension we set the new lower and upper bounds. Then we copy the
3952 stride and calculate the offset for this dimension. We also work out
3953 what the stride of a packed array would be, and see it the two match.
3954 If the array need repacking, we set the stride to the values we just
3955 calculated, recalculate the offset and copy the array data.
3956 Code is also added to copy the data back at the end of the function.
3960 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3967 stmtblock_t cleanup
;
3975 tree stride
, stride2
;
3985 /* Do nothing for pointer and allocatable arrays. */
3986 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3989 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3990 return gfc_trans_g77_array (sym
, body
);
3992 gfc_get_backend_locus (&loc
);
3993 gfc_set_backend_locus (&sym
->declared_at
);
3995 /* Descriptor type. */
3996 type
= TREE_TYPE (tmpdesc
);
3997 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3998 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3999 dumdesc
= build_fold_indirect_ref (dumdesc
);
4000 gfc_start_block (&block
);
4002 if (sym
->ts
.type
== BT_CHARACTER
4003 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4004 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
4006 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
4008 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4009 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4011 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4013 /* For non-constant shape arrays we only check if the first dimension
4014 is contiguous. Repacking higher dimensions wouldn't gain us
4015 anything as we still don't know the array stride. */
4016 partial
= gfc_create_var (boolean_type_node
, "partial");
4017 TREE_USED (partial
) = 1;
4018 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4019 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4020 gfc_add_modify_expr (&block
, partial
, tmp
);
4024 partial
= NULL_TREE
;
4027 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4028 here, however I think it does the right thing. */
4031 /* Set the first stride. */
4032 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4033 stride
= gfc_evaluate_now (stride
, &block
);
4035 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, gfc_index_zero_node
);
4036 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4037 gfc_index_one_node
, stride
);
4038 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4039 gfc_add_modify_expr (&block
, stride
, tmp
);
4041 /* Allow the user to disable array repacking. */
4042 stmt_unpacked
= NULL_TREE
;
4046 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4047 /* A library call to repack the array if necessary. */
4048 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4049 stmt_unpacked
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
4051 stride
= gfc_index_one_node
;
4054 /* This is for the case where the array data is used directly without
4055 calling the repack function. */
4056 if (no_repack
|| partial
!= NULL_TREE
)
4057 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4059 stmt_packed
= NULL_TREE
;
4061 /* Assign the data pointer. */
4062 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4064 /* Don't repack unknown shape arrays when the first stride is 1. */
4065 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
4066 stmt_packed
, stmt_unpacked
);
4069 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4070 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
4072 offset
= gfc_index_zero_node
;
4073 size
= gfc_index_one_node
;
4075 /* Evaluate the bounds of the array. */
4076 for (n
= 0; n
< sym
->as
->rank
; n
++)
4078 if (checkparm
|| !sym
->as
->upper
[n
])
4080 /* Get the bounds of the actual parameter. */
4081 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
4082 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
4086 dubound
= NULL_TREE
;
4087 dlbound
= NULL_TREE
;
4090 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4091 if (!INTEGER_CST_P (lbound
))
4093 gfc_init_se (&se
, NULL
);
4094 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4095 gfc_array_index_type
);
4096 gfc_add_block_to_block (&block
, &se
.pre
);
4097 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
4100 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4101 /* Set the desired upper bound. */
4102 if (sym
->as
->upper
[n
])
4104 /* We know what we want the upper bound to be. */
4105 if (!INTEGER_CST_P (ubound
))
4107 gfc_init_se (&se
, NULL
);
4108 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4109 gfc_array_index_type
);
4110 gfc_add_block_to_block (&block
, &se
.pre
);
4111 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
4114 /* Check the sizes match. */
4117 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4120 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4122 stride2
= build2 (MINUS_EXPR
, gfc_array_index_type
,
4124 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
4125 asprintf (&msg
, "%s for dimension %d of array '%s'",
4126 gfc_msg_bounds
, n
+1, sym
->name
);
4127 gfc_trans_runtime_check (tmp
, msg
, &block
, &loc
);
4133 /* For assumed shape arrays move the upper bound by the same amount
4134 as the lower bound. */
4135 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
4136 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4137 gfc_add_modify_expr (&block
, ubound
, tmp
);
4139 /* The offset of this dimension. offset = offset - lbound * stride. */
4140 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4141 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4143 /* The size of this dimension, and the stride of the next. */
4144 if (n
+ 1 < sym
->as
->rank
)
4146 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4148 if (no_repack
|| partial
!= NULL_TREE
)
4151 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
4154 /* Figure out the stride if not a known constant. */
4155 if (!INTEGER_CST_P (stride
))
4158 stmt_packed
= NULL_TREE
;
4161 /* Calculate stride = size * (ubound + 1 - lbound). */
4162 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4163 gfc_index_one_node
, lbound
);
4164 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4166 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4171 /* Assign the stride. */
4172 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4173 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4174 stmt_unpacked
, stmt_packed
);
4176 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4177 gfc_add_modify_expr (&block
, stride
, tmp
);
4182 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4184 if (stride
&& !INTEGER_CST_P (stride
))
4186 /* Calculate size = stride * (ubound + 1 - lbound). */
4187 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4188 gfc_index_one_node
, lbound
);
4189 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4191 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4192 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4193 gfc_add_modify_expr (&block
, stride
, tmp
);
4198 /* Set the offset. */
4199 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4200 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4202 gfc_trans_vla_type_sizes (sym
, &block
);
4204 stmt
= gfc_finish_block (&block
);
4206 gfc_start_block (&block
);
4208 /* Only do the entry/initialization code if the arg is present. */
4209 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4210 optional_arg
= (sym
->attr
.optional
4211 || (sym
->ns
->proc_name
->attr
.entry_master
4212 && sym
->attr
.dummy
));
4215 tmp
= gfc_conv_expr_present (sym
);
4216 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4218 gfc_add_expr_to_block (&block
, stmt
);
4220 /* Add the main function body. */
4221 gfc_add_expr_to_block (&block
, body
);
4226 gfc_start_block (&cleanup
);
4228 if (sym
->attr
.intent
!= INTENT_IN
)
4230 /* Copy the data back. */
4231 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4232 gfc_add_expr_to_block (&cleanup
, tmp
);
4235 /* Free the temporary. */
4236 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, tmpdesc
);
4237 gfc_add_expr_to_block (&cleanup
, tmp
);
4239 stmt
= gfc_finish_block (&cleanup
);
4241 /* Only do the cleanup if the array was repacked. */
4242 tmp
= build_fold_indirect_ref (dumdesc
);
4243 tmp
= gfc_conv_descriptor_data_get (tmp
);
4244 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4245 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4249 tmp
= gfc_conv_expr_present (sym
);
4250 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4252 gfc_add_expr_to_block (&block
, stmt
);
4254 /* We don't need to free any memory allocated by internal_pack as it will
4255 be freed at the end of the function by pop_context. */
4256 return gfc_finish_block (&block
);
4260 /* Convert an array for passing as an actual argument. Expressions and
4261 vector subscripts are evaluated and stored in a temporary, which is then
4262 passed. For whole arrays the descriptor is passed. For array sections
4263 a modified copy of the descriptor is passed, but using the original data.
4265 This function is also used for array pointer assignments, and there
4268 - want_pointer && !se->direct_byref
4269 EXPR is an actual argument. On exit, se->expr contains a
4270 pointer to the array descriptor.
4272 - !want_pointer && !se->direct_byref
4273 EXPR is an actual argument to an intrinsic function or the
4274 left-hand side of a pointer assignment. On exit, se->expr
4275 contains the descriptor for EXPR.
4277 - !want_pointer && se->direct_byref
4278 EXPR is the right-hand side of a pointer assignment and
4279 se->expr is the descriptor for the previously-evaluated
4280 left-hand side. The function creates an assignment from
4281 EXPR to se->expr. */
4284 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
4298 gcc_assert (ss
!= gfc_ss_terminator
);
4300 /* Special case things we know we can pass easily. */
4301 switch (expr
->expr_type
)
4304 /* If we have a linear array section, we can pass it directly.
4305 Otherwise we need to copy it into a temporary. */
4307 /* Find the SS for the array section. */
4309 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
4310 secss
= secss
->next
;
4312 gcc_assert (secss
!= gfc_ss_terminator
);
4313 info
= &secss
->data
.info
;
4315 /* Get the descriptor for the array. */
4316 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
4317 desc
= info
->descriptor
;
4319 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
);
4322 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4324 /* Create a new descriptor if the array doesn't have one. */
4327 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
4329 else if (se
->direct_byref
)
4332 full
= gfc_full_array_ref_p (info
->ref
);
4336 if (se
->direct_byref
)
4338 /* Copy the descriptor for pointer assignments. */
4339 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
4341 else if (se
->want_pointer
)
4343 /* We pass full arrays directly. This means that pointers and
4344 allocatable arrays should also work. */
4345 se
->expr
= build_fold_addr_expr (desc
);
4352 if (expr
->ts
.type
== BT_CHARACTER
)
4353 se
->string_length
= gfc_get_expr_charlen (expr
);
4360 /* A transformational function return value will be a temporary
4361 array descriptor. We still need to go through the scalarizer
4362 to create the descriptor. Elemental functions ar handled as
4363 arbitrary expressions, i.e. copy to a temporary. */
4365 /* Look for the SS for this function. */
4366 while (secss
!= gfc_ss_terminator
4367 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
4368 secss
= secss
->next
;
4370 if (se
->direct_byref
)
4372 gcc_assert (secss
!= gfc_ss_terminator
);
4374 /* For pointer assignments pass the descriptor directly. */
4376 se
->expr
= build_fold_addr_expr (se
->expr
);
4377 gfc_conv_expr (se
, expr
);
4381 if (secss
== gfc_ss_terminator
)
4383 /* Elemental function. */
4389 /* Transformational function. */
4390 info
= &secss
->data
.info
;
4396 /* Constant array constructors don't need a temporary. */
4397 if (ss
->type
== GFC_SS_CONSTRUCTOR
4398 && expr
->ts
.type
!= BT_CHARACTER
4399 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
4402 info
= &ss
->data
.info
;
4414 /* Something complicated. Copy it into a temporary. */
4422 gfc_init_loopinfo (&loop
);
4424 /* Associate the SS with the loop. */
4425 gfc_add_ss_to_loop (&loop
, ss
);
4427 /* Tell the scalarizer not to bother creating loop variables, etc. */
4429 loop
.array_parameter
= 1;
4431 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4432 gcc_assert (!se
->direct_byref
);
4434 /* Setup the scalarizing loops and bounds. */
4435 gfc_conv_ss_startstride (&loop
);
4439 /* Tell the scalarizer to make a temporary. */
4440 loop
.temp_ss
= gfc_get_ss ();
4441 loop
.temp_ss
->type
= GFC_SS_TEMP
;
4442 loop
.temp_ss
->next
= gfc_ss_terminator
;
4443 if (expr
->ts
.type
== BT_CHARACTER
)
4445 if (expr
->ts
.cl
== NULL
)
4447 /* This had better be a substring reference! */
4448 gfc_ref
*char_ref
= expr
->ref
;
4449 for (; char_ref
; char_ref
= char_ref
->next
)
4450 if (char_ref
->type
== REF_SUBSTRING
)
4453 expr
->ts
.cl
= gfc_get_charlen ();
4454 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
4455 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
4457 mpz_init_set_ui (char_len
, 1);
4458 mpz_add (char_len
, char_len
,
4459 char_ref
->u
.ss
.end
->value
.integer
);
4460 mpz_sub (char_len
, char_len
,
4461 char_ref
->u
.ss
.start
->value
.integer
);
4462 expr
->ts
.cl
->backend_decl
4463 = gfc_conv_mpz_to_tree (char_len
,
4464 gfc_default_character_kind
);
4465 /* Cast is necessary for *-charlen refs. */
4466 expr
->ts
.cl
->backend_decl
4467 = convert (gfc_charlen_type_node
,
4468 expr
->ts
.cl
->backend_decl
);
4469 mpz_clear (char_len
);
4472 gcc_assert (char_ref
!= NULL
);
4473 loop
.temp_ss
->data
.temp
.type
4474 = gfc_typenode_for_spec (&expr
->ts
);
4475 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4477 else if (expr
->ts
.cl
->length
4478 && expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4480 expr
->ts
.cl
->backend_decl
4481 = gfc_conv_mpz_to_tree (expr
->ts
.cl
->length
->value
.integer
,
4482 expr
->ts
.cl
->length
->ts
.kind
);
4483 loop
.temp_ss
->data
.temp
.type
4484 = gfc_typenode_for_spec (&expr
->ts
);
4485 loop
.temp_ss
->string_length
4486 = TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
4490 loop
.temp_ss
->data
.temp
.type
4491 = gfc_typenode_for_spec (&expr
->ts
);
4492 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4494 se
->string_length
= loop
.temp_ss
->string_length
;
4498 loop
.temp_ss
->data
.temp
.type
4499 = gfc_typenode_for_spec (&expr
->ts
);
4500 loop
.temp_ss
->string_length
= NULL
;
4502 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
4503 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4506 gfc_conv_loop_setup (&loop
);
4510 /* Copy into a temporary and pass that. We don't need to copy the data
4511 back because expressions and vector subscripts must be INTENT_IN. */
4512 /* TODO: Optimize passing function return values. */
4516 /* Start the copying loops. */
4517 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4518 gfc_mark_ss_chain_used (ss
, 1);
4519 gfc_start_scalarized_body (&loop
, &block
);
4521 /* Copy each data element. */
4522 gfc_init_se (&lse
, NULL
);
4523 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4524 gfc_init_se (&rse
, NULL
);
4525 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4527 lse
.ss
= loop
.temp_ss
;
4530 gfc_conv_scalarized_array_ref (&lse
, NULL
);
4531 if (expr
->ts
.type
== BT_CHARACTER
)
4533 gfc_conv_expr (&rse
, expr
);
4534 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
4535 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4538 gfc_conv_expr_val (&rse
, expr
);
4540 gfc_add_block_to_block (&block
, &rse
.pre
);
4541 gfc_add_block_to_block (&block
, &lse
.pre
);
4543 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
4545 /* Finish the copying loops. */
4546 gfc_trans_scalarizing_loops (&loop
, &block
);
4548 desc
= loop
.temp_ss
->data
.info
.descriptor
;
4550 gcc_assert (is_gimple_lvalue (desc
));
4552 else if (expr
->expr_type
== EXPR_FUNCTION
)
4554 desc
= info
->descriptor
;
4555 se
->string_length
= ss
->string_length
;
4559 /* We pass sections without copying to a temporary. Make a new
4560 descriptor and point it at the section we want. The loop variable
4561 limits will be the limits of the section.
4562 A function may decide to repack the array to speed up access, but
4563 we're not bothered about that here. */
4572 /* Set the string_length for a character array. */
4573 if (expr
->ts
.type
== BT_CHARACTER
)
4574 se
->string_length
= gfc_get_expr_charlen (expr
);
4576 desc
= info
->descriptor
;
4577 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
4578 if (se
->direct_byref
)
4580 /* For pointer assignments we fill in the destination. */
4582 parmtype
= TREE_TYPE (parm
);
4586 /* Otherwise make a new one. */
4587 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4588 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
4589 loop
.from
, loop
.to
, 0);
4590 parm
= gfc_create_var (parmtype
, "parm");
4593 offset
= gfc_index_zero_node
;
4596 /* The following can be somewhat confusing. We have two
4597 descriptors, a new one and the original array.
4598 {parm, parmtype, dim} refer to the new one.
4599 {desc, type, n, secss, loop} refer to the original, which maybe
4600 a descriptorless array.
4601 The bounds of the scalarization are the bounds of the section.
4602 We don't have to worry about numeric overflows when calculating
4603 the offsets because all elements are within the array data. */
4605 /* Set the dtype. */
4606 tmp
= gfc_conv_descriptor_dtype (parm
);
4607 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
4609 if (se
->direct_byref
)
4610 base
= gfc_index_zero_node
;
4614 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
4615 for (n
= 0; n
< ndim
; n
++)
4617 stride
= gfc_conv_array_stride (desc
, n
);
4619 /* Work out the offset. */
4621 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4623 gcc_assert (info
->subscript
[n
]
4624 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
4625 start
= info
->subscript
[n
]->data
.scalar
.expr
;
4629 /* Check we haven't somehow got out of sync. */
4630 gcc_assert (info
->dim
[dim
] == n
);
4632 /* Evaluate and remember the start of the section. */
4633 start
= info
->start
[dim
];
4634 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
4637 tmp
= gfc_conv_array_lbound (desc
, n
);
4638 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
4640 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
4641 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
4644 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4646 /* For elemental dimensions, we only need the offset. */
4650 /* Vector subscripts need copying and are handled elsewhere. */
4652 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
4654 /* Set the new lower bound. */
4655 from
= loop
.from
[dim
];
4658 /* If we have an array section or are assigning to a pointer,
4659 make sure that the lower bound is 1. References to the full
4660 array should otherwise keep the original bounds. */
4662 || info
->ref
->u
.ar
.type
!= AR_FULL
4663 || se
->direct_byref
)
4664 && !integer_onep (from
))
4666 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4667 gfc_index_one_node
, from
);
4668 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
4669 from
= gfc_index_one_node
;
4671 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
4672 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
4674 /* Set the new upper bound. */
4675 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
4676 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
4678 /* Multiply the stride by the section stride to get the
4680 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4681 stride
, info
->stride
[dim
]);
4683 if (se
->direct_byref
)
4684 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4687 /* Store the new stride. */
4688 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
4689 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
4694 if (se
->data_not_needed
)
4695 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, gfc_index_zero_node
);
4698 /* Point the data pointer at the first element in the section. */
4699 tmp
= gfc_conv_array_data (desc
);
4700 tmp
= build_fold_indirect_ref (tmp
);
4701 tmp
= gfc_build_array_ref (tmp
, offset
);
4702 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4703 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, offset
);
4706 if (se
->direct_byref
&& !se
->data_not_needed
)
4708 /* Set the offset. */
4709 tmp
= gfc_conv_descriptor_offset (parm
);
4710 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
4714 /* Only the callee knows what the correct offset it, so just set
4716 tmp
= gfc_conv_descriptor_offset (parm
);
4717 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
4722 if (!se
->direct_byref
)
4724 /* Get a pointer to the new descriptor. */
4725 if (se
->want_pointer
)
4726 se
->expr
= build_fold_addr_expr (desc
);
4731 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4732 gfc_add_block_to_block (&se
->post
, &loop
.post
);
4734 /* Cleanup the scalarizer. */
4735 gfc_cleanup_loop (&loop
);
4739 /* Convert an array for passing as an actual parameter. */
4740 /* TODO: Optimize passing g77 arrays. */
4743 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
4752 /* Passing address of the array if it is not pointer or assumed-shape. */
4753 if (expr
->expr_type
== EXPR_VARIABLE
4754 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
4756 sym
= expr
->symtree
->n
.sym
;
4757 tmp
= gfc_get_symbol_decl (sym
);
4759 if (sym
->ts
.type
== BT_CHARACTER
)
4760 se
->string_length
= sym
->ts
.cl
->backend_decl
;
4761 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
4762 && !sym
->attr
.allocatable
)
4764 /* Some variables are declared directly, others are declared as
4765 pointers and allocated on the heap. */
4766 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
4769 se
->expr
= build_fold_addr_expr (tmp
);
4772 if (sym
->attr
.allocatable
)
4774 if (sym
->attr
.dummy
)
4776 gfc_conv_expr_descriptor (se
, expr
, ss
);
4777 se
->expr
= gfc_conv_array_data (se
->expr
);
4780 se
->expr
= gfc_conv_array_data (tmp
);
4785 se
->want_pointer
= 1;
4786 gfc_conv_expr_descriptor (se
, expr
, ss
);
4788 /* Deallocate the allocatable components of structures that are
4790 if (expr
->ts
.type
== BT_DERIVED
4791 && expr
->ts
.derived
->attr
.alloc_comp
4792 && expr
->expr_type
!= EXPR_VARIABLE
)
4794 tmp
= build_fold_indirect_ref (se
->expr
);
4795 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.derived
, tmp
, expr
->rank
);
4796 gfc_add_expr_to_block (&se
->post
, tmp
);
4802 /* Repack the array. */
4803 ptr
= build_call_expr (gfor_fndecl_in_pack
, 1, desc
);
4804 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
4807 gfc_start_block (&block
);
4809 /* Copy the data back. */
4810 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, desc
, ptr
);
4811 gfc_add_expr_to_block (&block
, tmp
);
4813 /* Free the temporary. */
4814 tmp
= convert (pvoid_type_node
, ptr
);
4815 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, tmp
);
4816 gfc_add_expr_to_block (&block
, tmp
);
4818 stmt
= gfc_finish_block (&block
);
4820 gfc_init_block (&block
);
4821 /* Only if it was repacked. This code needs to be executed before the
4822 loop cleanup code. */
4823 tmp
= build_fold_indirect_ref (desc
);
4824 tmp
= gfc_conv_array_data (tmp
);
4825 tmp
= build2 (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
4826 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4828 gfc_add_expr_to_block (&block
, tmp
);
4829 gfc_add_block_to_block (&block
, &se
->post
);
4831 gfc_init_block (&se
->post
);
4832 gfc_add_block_to_block (&se
->post
, &block
);
4837 /* Generate code to deallocate an array, if it is allocated. */
4840 gfc_trans_dealloc_allocated (tree descriptor
)
4847 gfc_start_block (&block
);
4849 var
= gfc_conv_descriptor_data_get (descriptor
);
4851 tmp
= gfc_create_var (gfc_array_index_type
, NULL
);
4852 ptr
= build_fold_addr_expr (tmp
);
4854 /* Call array_deallocate with an int* present in the second argument.
4855 Although it is ignored here, it's presence ensures that arrays that
4856 are already deallocated are ignored. */
4857 tmp
= build_call_expr (gfor_fndecl_deallocate
, 2, var
, ptr
);
4858 gfc_add_expr_to_block (&block
, tmp
);
4860 /* Zero the data pointer. */
4861 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
4862 var
, build_int_cst (TREE_TYPE (var
), 0));
4863 gfc_add_expr_to_block (&block
, tmp
);
4865 return gfc_finish_block (&block
);
4869 /* This helper function calculates the size in words of a full array. */
4872 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
4877 idx
= gfc_rank_cst
[rank
- 1];
4878 nelems
= gfc_conv_descriptor_ubound (decl
, idx
);
4879 tmp
= gfc_conv_descriptor_lbound (decl
, idx
);
4880 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
4881 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
4882 tmp
, gfc_index_one_node
);
4883 tmp
= gfc_evaluate_now (tmp
, block
);
4885 nelems
= gfc_conv_descriptor_stride (decl
, idx
);
4886 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
4887 return gfc_evaluate_now (tmp
, block
);
4891 /* Allocate dest to the same size as src, and copy src -> dest. */
4894 gfc_duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
)
4903 /* If the source is null, set the destination to null. */
4904 gfc_init_block (&block
);
4905 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4906 null_data
= gfc_finish_block (&block
);
4908 gfc_init_block (&block
);
4910 nelems
= get_full_array_size (&block
, src
, rank
);
4911 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
,
4912 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
4914 /* Allocate memory to the destination. */
4915 if (gfc_index_integer_kind
== 4)
4916 tmp
= build_call_expr (gfor_fndecl_internal_malloc
, 1, size
);
4917 else if (gfc_index_integer_kind
== 8)
4918 tmp
= build_call_expr (gfor_fndecl_internal_malloc64
, 1, size
);
4921 tmp
= fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (src
)),
4923 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
4925 /* We know the temporary and the value will be the same length,
4926 so can use memcpy. */
4927 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
4928 tmp
= build_call_expr (tmp
, 3, gfc_conv_descriptor_data_get (dest
),
4929 gfc_conv_descriptor_data_get (src
), size
);
4930 gfc_add_expr_to_block (&block
, tmp
);
4931 tmp
= gfc_finish_block (&block
);
4933 /* Null the destination if the source is null; otherwise do
4934 the allocate and copy. */
4935 null_cond
= gfc_conv_descriptor_data_get (src
);
4936 null_cond
= convert (pvoid_type_node
, null_cond
);
4937 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
4939 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
4943 /* Recursively traverse an object of derived type, generating code to
4944 deallocate, nullify or copy allocatable components. This is the work horse
4945 function for the functions named in this enum. */
4947 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
};
4950 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
4951 tree dest
, int rank
, int purpose
)
4955 stmtblock_t fnblock
;
4956 stmtblock_t loopbody
;
4966 tree null_cond
= NULL_TREE
;
4968 gfc_init_block (&fnblock
);
4970 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
4971 decl
= build_fold_indirect_ref (decl
);
4973 /* If this an array of derived types with allocatable components
4974 build a loop and recursively call this function. */
4975 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
4976 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
4978 tmp
= gfc_conv_array_data (decl
);
4979 var
= build_fold_indirect_ref (tmp
);
4981 /* Get the number of elements - 1 and set the counter. */
4982 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
4984 /* Use the descriptor for an allocatable array. Since this
4985 is a full array reference, we only need the descriptor
4986 information from dimension = rank. */
4987 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
4988 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
4989 tmp
, gfc_index_one_node
);
4991 null_cond
= gfc_conv_descriptor_data_get (decl
);
4992 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
4993 build_int_cst (TREE_TYPE (null_cond
), 0));
4997 /* Otherwise use the TYPE_DOMAIN information. */
4998 tmp
= array_type_nelts (TREE_TYPE (decl
));
4999 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5002 /* Remember that this is, in fact, the no. of elements - 1. */
5003 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5004 index
= gfc_create_var (gfc_array_index_type
, "S");
5006 /* Build the body of the loop. */
5007 gfc_init_block (&loopbody
);
5009 vref
= gfc_build_array_ref (var
, index
);
5011 if (purpose
== COPY_ALLOC_COMP
)
5013 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
5014 gfc_add_expr_to_block (&fnblock
, tmp
);
5016 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest
));
5017 dref
= gfc_build_array_ref (tmp
, index
);
5018 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
5021 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
5023 gfc_add_expr_to_block (&loopbody
, tmp
);
5025 /* Build the loop and return. */
5026 gfc_init_loopinfo (&loop
);
5028 loop
.from
[0] = gfc_index_zero_node
;
5029 loop
.loopvar
[0] = index
;
5030 loop
.to
[0] = nelems
;
5031 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
5032 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
5034 tmp
= gfc_finish_block (&fnblock
);
5035 if (null_cond
!= NULL_TREE
)
5036 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
, build_empty_stmt ());
5041 /* Otherwise, act on the components or recursively call self to
5042 act on a chain of components. */
5043 for (c
= der_type
->components
; c
; c
= c
->next
)
5045 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
5046 && c
->ts
.derived
->attr
.alloc_comp
;
5047 cdecl = c
->backend_decl
;
5048 ctype
= TREE_TYPE (cdecl);
5052 case DEALLOCATE_ALLOC_COMP
:
5053 /* Do not deallocate the components of ultimate pointer
5055 if (cmp_has_alloc_comps
&& !c
->pointer
)
5057 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5058 rank
= c
->as
? c
->as
->rank
: 0;
5059 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5061 gfc_add_expr_to_block (&fnblock
, tmp
);
5066 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5067 tmp
= gfc_trans_dealloc_allocated (comp
);
5068 gfc_add_expr_to_block (&fnblock
, tmp
);
5072 case NULLIFY_ALLOC_COMP
:
5075 else if (c
->allocatable
)
5077 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5078 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
5080 else if (cmp_has_alloc_comps
)
5082 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5083 rank
= c
->as
? c
->as
->rank
: 0;
5084 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5086 gfc_add_expr_to_block (&fnblock
, tmp
);
5090 case COPY_ALLOC_COMP
:
5094 /* We need source and destination components. */
5095 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5096 dcmp
= build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
5097 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
5099 if (c
->allocatable
&& !cmp_has_alloc_comps
)
5101 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, c
->as
->rank
);
5102 gfc_add_expr_to_block (&fnblock
, tmp
);
5105 if (cmp_has_alloc_comps
)
5107 rank
= c
->as
? c
->as
->rank
: 0;
5108 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
5109 gfc_add_modify_expr (&fnblock
, dcmp
, tmp
);
5110 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, dcmp
,
5112 gfc_add_expr_to_block (&fnblock
, tmp
);
5122 return gfc_finish_block (&fnblock
);
5125 /* Recursively traverse an object of derived type, generating code to
5126 nullify allocatable components. */
5129 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5131 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5132 NULLIFY_ALLOC_COMP
);
5136 /* Recursively traverse an object of derived type, generating code to
5137 deallocate allocatable components. */
5140 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5142 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5143 DEALLOCATE_ALLOC_COMP
);
5147 /* Recursively traverse an object of derived type, generating code to
5148 copy its allocatable components. */
5151 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
5153 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
5157 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5158 Do likewise, recursively if necessary, with the allocatable components of
5162 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
5167 stmtblock_t fnblock
;
5170 bool sym_has_alloc_comp
;
5172 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
5173 && sym
->ts
.derived
->attr
.alloc_comp
;
5175 /* Make sure the frontend gets these right. */
5176 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
5177 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5178 "allocatable attribute or derived type without allocatable "
5181 gfc_init_block (&fnblock
);
5183 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
5184 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
5186 if (sym
->ts
.type
== BT_CHARACTER
5187 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
5189 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
5190 gfc_trans_vla_type_sizes (sym
, &fnblock
);
5193 /* Dummy and use associated variables don't need anything special. */
5194 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
5196 gfc_add_expr_to_block (&fnblock
, body
);
5198 return gfc_finish_block (&fnblock
);
5201 gfc_get_backend_locus (&loc
);
5202 gfc_set_backend_locus (&sym
->declared_at
);
5203 descriptor
= sym
->backend_decl
;
5205 /* Although static, derived types with default initializers and
5206 allocatable components must not be nulled wholesale; instead they
5207 are treated component by component. */
5208 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
5210 /* SAVEd variables are not freed on exit. */
5211 gfc_trans_static_array_pointer (sym
);
5215 /* Get the descriptor type. */
5216 type
= TREE_TYPE (sym
->backend_decl
);
5218 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5220 rank
= sym
->as
? sym
->as
->rank
: 0;
5221 tmp
= gfc_nullify_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5222 gfc_add_expr_to_block (&fnblock
, tmp
);
5224 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
5226 /* If the backend_decl is not a descriptor, we must have a pointer
5228 descriptor
= build_fold_indirect_ref (sym
->backend_decl
);
5229 type
= TREE_TYPE (descriptor
);
5232 /* NULLIFY the data pointer. */
5233 if (GFC_DESCRIPTOR_TYPE_P (type
))
5234 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
5236 gfc_add_expr_to_block (&fnblock
, body
);
5238 gfc_set_backend_locus (&loc
);
5240 /* Allocatable arrays need to be freed when they go out of scope.
5241 The allocatable components of pointers must not be touched. */
5242 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
5243 && !sym
->attr
.pointer
)
5246 rank
= sym
->as
? sym
->as
->rank
: 0;
5247 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5248 gfc_add_expr_to_block (&fnblock
, tmp
);
5251 if (sym
->attr
.allocatable
)
5253 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
5254 gfc_add_expr_to_block (&fnblock
, tmp
);
5257 return gfc_finish_block (&fnblock
);
5260 /************ Expression Walking Functions ******************/
5262 /* Walk a variable reference.
5264 Possible extension - multiple component subscripts.
5265 x(:,:) = foo%a(:)%b(:)
5267 forall (i=..., j=...)
5268 x(i,j) = foo%a(j)%b(i)
5270 This adds a fair amount of complexity because you need to deal with more
5271 than one ref. Maybe handle in a similar manner to vector subscripts.
5272 Maybe not worth the effort. */
5276 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5284 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5285 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
5288 for (; ref
; ref
= ref
->next
)
5290 if (ref
->type
== REF_SUBSTRING
)
5292 newss
= gfc_get_ss ();
5293 newss
->type
= GFC_SS_SCALAR
;
5294 newss
->expr
= ref
->u
.ss
.start
;
5298 newss
= gfc_get_ss ();
5299 newss
->type
= GFC_SS_SCALAR
;
5300 newss
->expr
= ref
->u
.ss
.end
;
5305 /* We're only interested in array sections from now on. */
5306 if (ref
->type
!= REF_ARRAY
)
5313 for (n
= 0; n
< ar
->dimen
; n
++)
5315 newss
= gfc_get_ss ();
5316 newss
->type
= GFC_SS_SCALAR
;
5317 newss
->expr
= ar
->start
[n
];
5324 newss
= gfc_get_ss ();
5325 newss
->type
= GFC_SS_SECTION
;
5328 newss
->data
.info
.dimen
= ar
->as
->rank
;
5329 newss
->data
.info
.ref
= ref
;
5331 /* Make sure array is the same as array(:,:), this way
5332 we don't need to special case all the time. */
5333 ar
->dimen
= ar
->as
->rank
;
5334 for (n
= 0; n
< ar
->dimen
; n
++)
5336 newss
->data
.info
.dim
[n
] = n
;
5337 ar
->dimen_type
[n
] = DIMEN_RANGE
;
5339 gcc_assert (ar
->start
[n
] == NULL
);
5340 gcc_assert (ar
->end
[n
] == NULL
);
5341 gcc_assert (ar
->stride
[n
] == NULL
);
5347 newss
= gfc_get_ss ();
5348 newss
->type
= GFC_SS_SECTION
;
5351 newss
->data
.info
.dimen
= 0;
5352 newss
->data
.info
.ref
= ref
;
5356 /* We add SS chains for all the subscripts in the section. */
5357 for (n
= 0; n
< ar
->dimen
; n
++)
5361 switch (ar
->dimen_type
[n
])
5364 /* Add SS for elemental (scalar) subscripts. */
5365 gcc_assert (ar
->start
[n
]);
5366 indexss
= gfc_get_ss ();
5367 indexss
->type
= GFC_SS_SCALAR
;
5368 indexss
->expr
= ar
->start
[n
];
5369 indexss
->next
= gfc_ss_terminator
;
5370 indexss
->loop_chain
= gfc_ss_terminator
;
5371 newss
->data
.info
.subscript
[n
] = indexss
;
5375 /* We don't add anything for sections, just remember this
5376 dimension for later. */
5377 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5378 newss
->data
.info
.dimen
++;
5382 /* Create a GFC_SS_VECTOR index in which we can store
5383 the vector's descriptor. */
5384 indexss
= gfc_get_ss ();
5385 indexss
->type
= GFC_SS_VECTOR
;
5386 indexss
->expr
= ar
->start
[n
];
5387 indexss
->next
= gfc_ss_terminator
;
5388 indexss
->loop_chain
= gfc_ss_terminator
;
5389 newss
->data
.info
.subscript
[n
] = indexss
;
5390 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5391 newss
->data
.info
.dimen
++;
5395 /* We should know what sort of section it is by now. */
5399 /* We should have at least one non-elemental dimension. */
5400 gcc_assert (newss
->data
.info
.dimen
> 0);
5405 /* We should know what sort of section it is by now. */
5414 /* Walk an expression operator. If only one operand of a binary expression is
5415 scalar, we must also add the scalar term to the SS chain. */
5418 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5424 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
5425 if (expr
->value
.op
.op2
== NULL
)
5428 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
5430 /* All operands are scalar. Pass back and let the caller deal with it. */
5434 /* All operands require scalarization. */
5435 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
5438 /* One of the operands needs scalarization, the other is scalar.
5439 Create a gfc_ss for the scalar expression. */
5440 newss
= gfc_get_ss ();
5441 newss
->type
= GFC_SS_SCALAR
;
5444 /* First operand is scalar. We build the chain in reverse order, so
5445 add the scarar SS after the second operand. */
5447 while (head
&& head
->next
!= ss
)
5449 /* Check we haven't somehow broken the chain. */
5453 newss
->expr
= expr
->value
.op
.op1
;
5455 else /* head2 == head */
5457 gcc_assert (head2
== head
);
5458 /* Second operand is scalar. */
5459 newss
->next
= head2
;
5461 newss
->expr
= expr
->value
.op
.op2
;
5468 /* Reverse a SS chain. */
5471 gfc_reverse_ss (gfc_ss
* ss
)
5476 gcc_assert (ss
!= NULL
);
5478 head
= gfc_ss_terminator
;
5479 while (ss
!= gfc_ss_terminator
)
5482 /* Check we didn't somehow break the chain. */
5483 gcc_assert (next
!= NULL
);
5493 /* Walk the arguments of an elemental function. */
5496 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
5504 head
= gfc_ss_terminator
;
5507 for (; arg
; arg
= arg
->next
)
5512 newss
= gfc_walk_subexpr (head
, arg
->expr
);
5515 /* Scalar argument. */
5516 newss
= gfc_get_ss ();
5518 newss
->expr
= arg
->expr
;
5528 while (tail
->next
!= gfc_ss_terminator
)
5535 /* If all the arguments are scalar we don't need the argument SS. */
5536 gfc_free_ss_chain (head
);
5541 /* Add it onto the existing chain. */
5547 /* Walk a function call. Scalar functions are passed back, and taken out of
5548 scalarization loops. For elemental functions we walk their arguments.
5549 The result of functions returning arrays is stored in a temporary outside
5550 the loop, so that the function is only called once. Hence we do not need
5551 to walk their arguments. */
5554 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5557 gfc_intrinsic_sym
*isym
;
5560 isym
= expr
->value
.function
.isym
;
5562 /* Handle intrinsic functions separately. */
5564 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
5566 sym
= expr
->value
.function
.esym
;
5568 sym
= expr
->symtree
->n
.sym
;
5570 /* A function that returns arrays. */
5571 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
5573 newss
= gfc_get_ss ();
5574 newss
->type
= GFC_SS_FUNCTION
;
5577 newss
->data
.info
.dimen
= expr
->rank
;
5581 /* Walk the parameters of an elemental function. For now we always pass
5583 if (sym
->attr
.elemental
)
5584 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
5587 /* Scalar functions are OK as these are evaluated outside the scalarization
5588 loop. Pass back and let the caller deal with it. */
5593 /* An array temporary is constructed for array constructors. */
5596 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
5601 newss
= gfc_get_ss ();
5602 newss
->type
= GFC_SS_CONSTRUCTOR
;
5605 newss
->data
.info
.dimen
= expr
->rank
;
5606 for (n
= 0; n
< expr
->rank
; n
++)
5607 newss
->data
.info
.dim
[n
] = n
;
5613 /* Walk an expression. Add walked expressions to the head of the SS chain.
5614 A wholly scalar expression will not be added. */
5617 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
5621 switch (expr
->expr_type
)
5624 head
= gfc_walk_variable_expr (ss
, expr
);
5628 head
= gfc_walk_op_expr (ss
, expr
);
5632 head
= gfc_walk_function_expr (ss
, expr
);
5637 case EXPR_STRUCTURE
:
5638 /* Pass back and let the caller deal with it. */
5642 head
= gfc_walk_array_constructor (ss
, expr
);
5645 case EXPR_SUBSTRING
:
5646 /* Pass back and let the caller deal with it. */
5650 internal_error ("bad expression type during walk (%d)",
5657 /* Entry point for expression walking.
5658 A return value equal to the passed chain means this is
5659 a scalar expression. It is up to the caller to take whatever action is
5660 necessary to translate these. */
5663 gfc_walk_expr (gfc_expr
* expr
)
5667 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
5668 return gfc_reverse_ss (res
);