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 tmp
= gfc_call_malloc (pre
, NULL
, size
);
537 tmp
= gfc_evaluate_now (tmp
, pre
);
538 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
541 info
->data
= gfc_conv_descriptor_data_get (desc
);
543 /* The offset is zero because we create temporaries with a zero
545 tmp
= gfc_conv_descriptor_offset (desc
);
546 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
548 if (dealloc
&& !onstack
)
550 /* Free the temporary. */
551 tmp
= gfc_conv_descriptor_data_get (desc
);
552 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
553 gfc_add_expr_to_block (post
, tmp
);
558 /* Generate code to create and initialize the descriptor for a temporary
559 array. This is used for both temporaries needed by the scalarizer, and
560 functions returning arrays. Adjusts the loop variables to be
561 zero-based, and calculates the loop bounds for callee allocated arrays.
562 Allocate the array unless it's callee allocated (we have a callee
563 allocated array if 'callee_alloc' is true, or if loop->to[n] is
564 NULL_TREE for any n). Also fills in the descriptor, data and offset
565 fields of info if known. Returns the size of the array, or NULL for a
566 callee allocated array.
568 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
572 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
573 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
574 tree eltype
, bool dynamic
, bool dealloc
,
587 gcc_assert (info
->dimen
> 0);
588 /* Set the lower bound to zero. */
589 for (dim
= 0; dim
< info
->dimen
; dim
++)
591 n
= loop
->order
[dim
];
592 if (n
< loop
->temp_dim
)
593 gcc_assert (integer_zerop (loop
->from
[n
]));
596 /* Callee allocated arrays may not have a known bound yet. */
598 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
599 loop
->to
[n
], loop
->from
[n
]);
600 loop
->from
[n
] = gfc_index_zero_node
;
603 info
->delta
[dim
] = gfc_index_zero_node
;
604 info
->start
[dim
] = gfc_index_zero_node
;
605 info
->end
[dim
] = gfc_index_zero_node
;
606 info
->stride
[dim
] = gfc_index_one_node
;
607 info
->dim
[dim
] = dim
;
610 /* Initialize the descriptor. */
612 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
613 desc
= gfc_create_var (type
, "atmp");
614 GFC_DECL_PACKED_ARRAY (desc
) = 1;
616 info
->descriptor
= desc
;
617 size
= gfc_index_one_node
;
619 /* Fill in the array dtype. */
620 tmp
= gfc_conv_descriptor_dtype (desc
);
621 gfc_add_modify_expr (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
624 Fill in the bounds and stride. This is a packed array, so:
627 for (n = 0; n < rank; n++)
630 delta = ubound[n] + 1 - lbound[n];
633 size = size * sizeof(element);
638 for (n
= 0; n
< info
->dimen
; n
++)
640 if (loop
->to
[n
] == NULL_TREE
)
642 /* For a callee allocated array express the loop bounds in terms
643 of the descriptor fields. */
644 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
645 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
646 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
652 /* Store the stride and bound components in the descriptor. */
653 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
654 gfc_add_modify_expr (pre
, tmp
, size
);
656 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
657 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
659 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
660 gfc_add_modify_expr (pre
, tmp
, loop
->to
[n
]);
662 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
663 loop
->to
[n
], gfc_index_one_node
);
665 /* Check whether the size for this dimension is negative. */
666 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
667 gfc_index_zero_node
);
668 cond
= gfc_evaluate_now (cond
, pre
);
673 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
675 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
676 size
= gfc_evaluate_now (size
, pre
);
679 /* Get the size of the array. */
681 if (size
&& !callee_alloc
)
683 /* If or_expr is true, then the extent in at least one
684 dimension is zero and the size is set to zero. */
685 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
,
686 or_expr
, gfc_index_zero_node
, size
);
689 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
690 fold_convert (gfc_array_index_type
,
691 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
699 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, dynamic
,
702 if (info
->dimen
> loop
->temp_dim
)
703 loop
->temp_dim
= info
->dimen
;
709 /* Generate code to transpose array EXPR by creating a new descriptor
710 in which the dimension specifications have been reversed. */
713 gfc_conv_array_transpose (gfc_se
* se
, gfc_expr
* expr
)
715 tree dest
, src
, dest_index
, src_index
;
717 gfc_ss_info
*dest_info
, *src_info
;
718 gfc_ss
*dest_ss
, *src_ss
;
724 src_ss
= gfc_walk_expr (expr
);
727 src_info
= &src_ss
->data
.info
;
728 dest_info
= &dest_ss
->data
.info
;
729 gcc_assert (dest_info
->dimen
== 2);
730 gcc_assert (src_info
->dimen
== 2);
732 /* Get a descriptor for EXPR. */
733 gfc_init_se (&src_se
, NULL
);
734 gfc_conv_expr_descriptor (&src_se
, expr
, src_ss
);
735 gfc_add_block_to_block (&se
->pre
, &src_se
.pre
);
736 gfc_add_block_to_block (&se
->post
, &src_se
.post
);
739 /* Allocate a new descriptor for the return value. */
740 dest
= gfc_create_var (TREE_TYPE (src
), "atmp");
741 dest_info
->descriptor
= dest
;
744 /* Copy across the dtype field. */
745 gfc_add_modify_expr (&se
->pre
,
746 gfc_conv_descriptor_dtype (dest
),
747 gfc_conv_descriptor_dtype (src
));
749 /* Copy the dimension information, renumbering dimension 1 to 0 and
751 for (n
= 0; n
< 2; n
++)
753 dest_info
->delta
[n
] = gfc_index_zero_node
;
754 dest_info
->start
[n
] = gfc_index_zero_node
;
755 dest_info
->end
[n
] = gfc_index_zero_node
;
756 dest_info
->stride
[n
] = gfc_index_one_node
;
757 dest_info
->dim
[n
] = n
;
759 dest_index
= gfc_rank_cst
[n
];
760 src_index
= gfc_rank_cst
[1 - n
];
762 gfc_add_modify_expr (&se
->pre
,
763 gfc_conv_descriptor_stride (dest
, dest_index
),
764 gfc_conv_descriptor_stride (src
, src_index
));
766 gfc_add_modify_expr (&se
->pre
,
767 gfc_conv_descriptor_lbound (dest
, dest_index
),
768 gfc_conv_descriptor_lbound (src
, src_index
));
770 gfc_add_modify_expr (&se
->pre
,
771 gfc_conv_descriptor_ubound (dest
, dest_index
),
772 gfc_conv_descriptor_ubound (src
, src_index
));
776 gcc_assert (integer_zerop (loop
->from
[n
]));
777 loop
->to
[n
] = build2 (MINUS_EXPR
, gfc_array_index_type
,
778 gfc_conv_descriptor_ubound (dest
, dest_index
),
779 gfc_conv_descriptor_lbound (dest
, dest_index
));
783 /* Copy the data pointer. */
784 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
785 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
787 /* Copy the offset. This is not changed by transposition: the top-left
788 element is still at the same offset as before. */
789 dest_info
->offset
= gfc_conv_descriptor_offset (src
);
790 gfc_add_modify_expr (&se
->pre
,
791 gfc_conv_descriptor_offset (dest
),
794 if (dest_info
->dimen
> loop
->temp_dim
)
795 loop
->temp_dim
= dest_info
->dimen
;
799 /* Return the number of iterations in a loop that starts at START,
800 ends at END, and has step STEP. */
803 gfc_get_iteration_count (tree start
, tree end
, tree step
)
808 type
= TREE_TYPE (step
);
809 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
810 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
811 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
812 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
813 return fold_convert (gfc_array_index_type
, tmp
);
817 /* Extend the data in array DESC by EXTRA elements. */
820 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
827 if (integer_zerop (extra
))
830 ubound
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
832 /* Add EXTRA to the upper bound. */
833 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
834 gfc_add_modify_expr (pblock
, ubound
, tmp
);
836 /* Get the value of the current data pointer. */
837 arg0
= gfc_conv_descriptor_data_get (desc
);
839 /* Calculate the new array size. */
840 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
841 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, gfc_index_one_node
);
842 arg1
= build2 (MULT_EXPR
, gfc_array_index_type
, tmp
,
843 fold_convert (gfc_array_index_type
, size
));
845 /* Pick the realloc function. */
846 if (gfc_index_integer_kind
== 4 || gfc_index_integer_kind
== 8)
847 tmp
= gfor_fndecl_internal_realloc
;
851 /* Set the new data pointer. */
852 tmp
= build_call_expr (tmp
, 2, arg0
, arg1
);
853 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
857 /* Return true if the bounds of iterator I can only be determined
861 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
863 return (i
->start
->expr_type
!= EXPR_CONSTANT
864 || i
->end
->expr_type
!= EXPR_CONSTANT
865 || i
->step
->expr_type
!= EXPR_CONSTANT
);
869 /* Split the size of constructor element EXPR into the sum of two terms,
870 one of which can be determined at compile time and one of which must
871 be calculated at run time. Set *SIZE to the former and return true
872 if the latter might be nonzero. */
875 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
877 if (expr
->expr_type
== EXPR_ARRAY
)
878 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
879 else if (expr
->rank
> 0)
881 /* Calculate everything at run time. */
882 mpz_set_ui (*size
, 0);
887 /* A single element. */
888 mpz_set_ui (*size
, 1);
894 /* Like gfc_get_array_constructor_element_size, but applied to the whole
895 of array constructor C. */
898 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor
* c
)
905 mpz_set_ui (*size
, 0);
910 for (; c
; c
= c
->next
)
913 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
917 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
920 /* Multiply the static part of the element size by the
921 number of iterations. */
922 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
923 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
924 mpz_add_ui (val
, val
, 1);
925 if (mpz_sgn (val
) > 0)
926 mpz_mul (len
, len
, val
);
930 mpz_add (*size
, *size
, len
);
939 /* Make sure offset is a variable. */
942 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
945 /* We should have already created the offset variable. We cannot
946 create it here because we may be in an inner scope. */
947 gcc_assert (*offsetvar
!= NULL_TREE
);
948 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
949 *poffset
= *offsetvar
;
950 TREE_USED (*offsetvar
) = 1;
954 /* Assign an element of an array constructor. */
957 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
958 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
962 gfc_conv_expr (se
, expr
);
964 /* Store the value. */
965 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc
));
966 tmp
= gfc_build_array_ref (tmp
, offset
);
967 if (expr
->ts
.type
== BT_CHARACTER
)
969 gfc_conv_string_parameter (se
);
970 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
972 /* The temporary is an array of pointers. */
973 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
974 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
978 /* The temporary is an array of string values. */
979 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
980 /* We know the temporary and the value will be the same length,
981 so can use memcpy. */
982 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
983 tmp
, se
->expr
, se
->string_length
);
984 gfc_add_expr_to_block (&se
->pre
, tmp
);
989 /* TODO: Should the frontend already have done this conversion? */
990 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
991 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
994 gfc_add_block_to_block (pblock
, &se
->pre
);
995 gfc_add_block_to_block (pblock
, &se
->post
);
999 /* Add the contents of an array to the constructor. DYNAMIC is as for
1000 gfc_trans_array_constructor_value. */
1003 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1004 tree type ATTRIBUTE_UNUSED
,
1005 tree desc
, gfc_expr
* expr
,
1006 tree
* poffset
, tree
* offsetvar
,
1017 /* We need this to be a variable so we can increment it. */
1018 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1020 gfc_init_se (&se
, NULL
);
1022 /* Walk the array expression. */
1023 ss
= gfc_walk_expr (expr
);
1024 gcc_assert (ss
!= gfc_ss_terminator
);
1026 /* Initialize the scalarizer. */
1027 gfc_init_loopinfo (&loop
);
1028 gfc_add_ss_to_loop (&loop
, ss
);
1030 /* Initialize the loop. */
1031 gfc_conv_ss_startstride (&loop
);
1032 gfc_conv_loop_setup (&loop
);
1034 /* Make sure the constructed array has room for the new data. */
1037 /* Set SIZE to the total number of elements in the subarray. */
1038 size
= gfc_index_one_node
;
1039 for (n
= 0; n
< loop
.dimen
; n
++)
1041 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1042 gfc_index_one_node
);
1043 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1046 /* Grow the constructed array by SIZE elements. */
1047 gfc_grow_array (&loop
.pre
, desc
, size
);
1050 /* Make the loop body. */
1051 gfc_mark_ss_chain_used (ss
, 1);
1052 gfc_start_scalarized_body (&loop
, &body
);
1053 gfc_copy_loopinfo_to_se (&se
, &loop
);
1056 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1057 gcc_assert (se
.ss
== gfc_ss_terminator
);
1059 /* Increment the offset. */
1060 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
1061 gfc_add_modify_expr (&body
, *poffset
, tmp
);
1063 /* Finish the loop. */
1064 gfc_trans_scalarizing_loops (&loop
, &body
);
1065 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1066 tmp
= gfc_finish_block (&loop
.pre
);
1067 gfc_add_expr_to_block (pblock
, tmp
);
1069 gfc_cleanup_loop (&loop
);
1073 /* Assign the values to the elements of an array constructor. DYNAMIC
1074 is true if descriptor DESC only contains enough data for the static
1075 size calculated by gfc_get_array_constructor_size. When true, memory
1076 for the dynamic parts must be allocated using realloc. */
1079 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1080 tree desc
, gfc_constructor
* c
,
1081 tree
* poffset
, tree
* offsetvar
,
1090 for (; c
; c
= c
->next
)
1092 /* If this is an iterator or an array, the offset must be a variable. */
1093 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1094 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1096 gfc_start_block (&body
);
1098 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1100 /* Array constructors can be nested. */
1101 gfc_trans_array_constructor_value (&body
, type
, desc
,
1102 c
->expr
->value
.constructor
,
1103 poffset
, offsetvar
, dynamic
);
1105 else if (c
->expr
->rank
> 0)
1107 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1108 poffset
, offsetvar
, dynamic
);
1112 /* This code really upsets the gimplifier so don't bother for now. */
1119 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1126 /* Scalar values. */
1127 gfc_init_se (&se
, NULL
);
1128 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1131 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1132 *poffset
, gfc_index_one_node
);
1136 /* Collect multiple scalar constants into a constructor. */
1144 /* Count the number of consecutive scalar constants. */
1145 while (p
&& !(p
->iterator
1146 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1148 gfc_init_se (&se
, NULL
);
1149 gfc_conv_constant (&se
, p
->expr
);
1150 if (p
->expr
->ts
.type
== BT_CHARACTER
1151 && POINTER_TYPE_P (type
))
1153 /* For constant character array constructors we build
1154 an array of pointers. */
1155 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
1159 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1164 bound
= build_int_cst (NULL_TREE
, n
- 1);
1165 /* Create an array type to hold them. */
1166 tmptype
= build_range_type (gfc_array_index_type
,
1167 gfc_index_zero_node
, bound
);
1168 tmptype
= build_array_type (type
, tmptype
);
1170 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1171 TREE_CONSTANT (init
) = 1;
1172 TREE_INVARIANT (init
) = 1;
1173 TREE_STATIC (init
) = 1;
1174 /* Create a static variable to hold the data. */
1175 tmp
= gfc_create_var (tmptype
, "data");
1176 TREE_STATIC (tmp
) = 1;
1177 TREE_CONSTANT (tmp
) = 1;
1178 TREE_INVARIANT (tmp
) = 1;
1179 TREE_READONLY (tmp
) = 1;
1180 DECL_INITIAL (tmp
) = init
;
1183 /* Use BUILTIN_MEMCPY to assign the values. */
1184 tmp
= gfc_conv_descriptor_data_get (desc
);
1185 tmp
= build_fold_indirect_ref (tmp
);
1186 tmp
= gfc_build_array_ref (tmp
, *poffset
);
1187 tmp
= build_fold_addr_expr (tmp
);
1188 init
= build_fold_addr_expr (init
);
1190 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1191 bound
= build_int_cst (NULL_TREE
, n
* size
);
1192 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3,
1194 gfc_add_expr_to_block (&body
, tmp
);
1196 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1198 build_int_cst (gfc_array_index_type
, n
));
1200 if (!INTEGER_CST_P (*poffset
))
1202 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
1203 *poffset
= *offsetvar
;
1207 /* The frontend should already have done any expansions possible
1211 /* Pass the code as is. */
1212 tmp
= gfc_finish_block (&body
);
1213 gfc_add_expr_to_block (pblock
, tmp
);
1217 /* Build the implied do-loop. */
1227 loopbody
= gfc_finish_block (&body
);
1229 gfc_init_se (&se
, NULL
);
1230 gfc_conv_expr (&se
, c
->iterator
->var
);
1231 gfc_add_block_to_block (pblock
, &se
.pre
);
1234 /* Make a temporary, store the current value in that
1235 and return it, once the loop is done. */
1236 tmp_loopvar
= gfc_create_var (TREE_TYPE (loopvar
), "loopvar");
1237 gfc_add_modify_expr (pblock
, tmp_loopvar
, loopvar
);
1239 /* Initialize the loop. */
1240 gfc_init_se (&se
, NULL
);
1241 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1242 gfc_add_block_to_block (pblock
, &se
.pre
);
1243 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
1245 gfc_init_se (&se
, NULL
);
1246 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1247 gfc_add_block_to_block (pblock
, &se
.pre
);
1248 end
= gfc_evaluate_now (se
.expr
, pblock
);
1250 gfc_init_se (&se
, NULL
);
1251 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1252 gfc_add_block_to_block (pblock
, &se
.pre
);
1253 step
= gfc_evaluate_now (se
.expr
, pblock
);
1255 /* If this array expands dynamically, and the number of iterations
1256 is not constant, we won't have allocated space for the static
1257 part of C->EXPR's size. Do that now. */
1258 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1260 /* Get the number of iterations. */
1261 tmp
= gfc_get_iteration_count (loopvar
, end
, step
);
1263 /* Get the static part of C->EXPR's size. */
1264 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1265 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1267 /* Grow the array by TMP * TMP2 elements. */
1268 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1269 gfc_grow_array (pblock
, desc
, tmp
);
1272 /* Generate the loop body. */
1273 exit_label
= gfc_build_label_decl (NULL_TREE
);
1274 gfc_start_block (&body
);
1276 /* Generate the exit condition. Depending on the sign of
1277 the step variable we have to generate the correct
1279 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1280 build_int_cst (TREE_TYPE (step
), 0));
1281 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1282 build2 (GT_EXPR
, boolean_type_node
,
1284 build2 (LT_EXPR
, boolean_type_node
,
1286 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1287 TREE_USED (exit_label
) = 1;
1288 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1289 gfc_add_expr_to_block (&body
, tmp
);
1291 /* The main loop body. */
1292 gfc_add_expr_to_block (&body
, loopbody
);
1294 /* Increase loop variable by step. */
1295 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
1296 gfc_add_modify_expr (&body
, loopvar
, tmp
);
1298 /* Finish the loop. */
1299 tmp
= gfc_finish_block (&body
);
1300 tmp
= build1_v (LOOP_EXPR
, tmp
);
1301 gfc_add_expr_to_block (pblock
, tmp
);
1303 /* Add the exit label. */
1304 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1305 gfc_add_expr_to_block (pblock
, tmp
);
1307 /* Restore the original value of the loop counter. */
1308 gfc_add_modify_expr (pblock
, loopvar
, tmp_loopvar
);
1315 /* Figure out the string length of a variable reference expression.
1316 Used by get_array_ctor_strlen. */
1319 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1325 /* Don't bother if we already know the length is a constant. */
1326 if (*len
&& INTEGER_CST_P (*len
))
1329 ts
= &expr
->symtree
->n
.sym
->ts
;
1330 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1335 /* Array references don't change the string length. */
1339 /* Use the length of the component. */
1340 ts
= &ref
->u
.c
.component
->ts
;
1344 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1345 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
)
1347 mpz_init_set_ui (char_len
, 1);
1348 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1349 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1350 *len
= gfc_conv_mpz_to_tree (char_len
,
1351 gfc_default_character_kind
);
1352 *len
= convert (gfc_charlen_type_node
, *len
);
1353 mpz_clear (char_len
);
1357 /* TODO: Substrings are tricky because we can't evaluate the
1358 expression more than once. For now we just give up, and hope
1359 we can figure it out elsewhere. */
1364 *len
= ts
->cl
->backend_decl
;
1368 /* A catch-all to obtain the string length for anything that is not a
1369 constant, array or variable. */
1371 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1376 /* Don't bother if we already know the length is a constant. */
1377 if (*len
&& INTEGER_CST_P (*len
))
1380 if (!e
->ref
&& e
->ts
.cl
->length
1381 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1384 gfc_conv_const_charlen (e
->ts
.cl
);
1385 *len
= e
->ts
.cl
->backend_decl
;
1389 /* Otherwise, be brutal even if inefficient. */
1390 ss
= gfc_walk_expr (e
);
1391 gfc_init_se (&se
, NULL
);
1393 /* No function call, in case of side effects. */
1394 se
.no_function_call
= 1;
1395 if (ss
== gfc_ss_terminator
)
1396 gfc_conv_expr (&se
, e
);
1398 gfc_conv_expr_descriptor (&se
, e
, ss
);
1400 /* Fix the value. */
1401 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1403 gfc_add_block_to_block (block
, &se
.pre
);
1404 gfc_add_block_to_block (block
, &se
.post
);
1406 e
->ts
.cl
->backend_decl
= *len
;
1411 /* Figure out the string length of a character array constructor.
1412 Returns TRUE if all elements are character constants. */
1415 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor
* c
, tree
* len
)
1420 for (; c
; c
= c
->next
)
1422 switch (c
->expr
->expr_type
)
1425 if (!(*len
&& INTEGER_CST_P (*len
)))
1426 *len
= build_int_cstu (gfc_charlen_type_node
,
1427 c
->expr
->value
.character
.length
);
1431 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1437 get_array_ctor_var_strlen (c
->expr
, len
);
1442 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1450 /* Check whether the array constructor C consists entirely of constant
1451 elements, and if so returns the number of those elements, otherwise
1452 return zero. Note, an empty or NULL array constructor returns zero. */
1454 unsigned HOST_WIDE_INT
1455 gfc_constant_array_constructor_p (gfc_constructor
* c
)
1457 unsigned HOST_WIDE_INT nelem
= 0;
1462 || c
->expr
->rank
> 0
1463 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1472 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1473 and the tree type of it's elements, TYPE, return a static constant
1474 variable that is compile-time initialized. */
1477 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1479 tree tmptype
, list
, init
, tmp
;
1480 HOST_WIDE_INT nelem
;
1486 /* First traverse the constructor list, converting the constants
1487 to tree to build an initializer. */
1490 c
= expr
->value
.constructor
;
1493 gfc_init_se (&se
, NULL
);
1494 gfc_conv_constant (&se
, c
->expr
);
1495 if (c
->expr
->ts
.type
== BT_CHARACTER
1496 && POINTER_TYPE_P (type
))
1497 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
1498 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1503 /* Next determine the tree type for the array. We use the gfortran
1504 front-end's gfc_get_nodesc_array_type in order to create a suitable
1505 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1507 memset (&as
, 0, sizeof (gfc_array_spec
));
1509 as
.rank
= expr
->rank
;
1510 as
.type
= AS_EXPLICIT
;
1513 as
.lower
[0] = gfc_int_expr (0);
1514 as
.upper
[0] = gfc_int_expr (nelem
- 1);
1517 for (i
= 0; i
< expr
->rank
; i
++)
1519 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1520 as
.lower
[i
] = gfc_int_expr (0);
1521 as
.upper
[i
] = gfc_int_expr (tmp
- 1);
1524 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
);
1526 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1528 TREE_CONSTANT (init
) = 1;
1529 TREE_INVARIANT (init
) = 1;
1530 TREE_STATIC (init
) = 1;
1532 tmp
= gfc_create_var (tmptype
, "A");
1533 TREE_STATIC (tmp
) = 1;
1534 TREE_CONSTANT (tmp
) = 1;
1535 TREE_INVARIANT (tmp
) = 1;
1536 TREE_READONLY (tmp
) = 1;
1537 DECL_INITIAL (tmp
) = init
;
1543 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1544 This mostly initializes the scalarizer state info structure with the
1545 appropriate values to directly use the array created by the function
1546 gfc_build_constant_array_constructor. */
1549 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1550 gfc_ss
* ss
, tree type
)
1556 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1558 info
= &ss
->data
.info
;
1560 info
->descriptor
= tmp
;
1561 info
->data
= build_fold_addr_expr (tmp
);
1562 info
->offset
= fold_build1 (NEGATE_EXPR
, gfc_array_index_type
,
1565 for (i
= 0; i
< info
->dimen
; i
++)
1567 info
->delta
[i
] = gfc_index_zero_node
;
1568 info
->start
[i
] = gfc_index_zero_node
;
1569 info
->end
[i
] = gfc_index_zero_node
;
1570 info
->stride
[i
] = gfc_index_one_node
;
1574 if (info
->dimen
> loop
->temp_dim
)
1575 loop
->temp_dim
= info
->dimen
;
1578 /* Helper routine of gfc_trans_array_constructor to determine if the
1579 bounds of the loop specified by LOOP are constant and simple enough
1580 to use with gfc_trans_constant_array_constructor. Returns the
1581 the iteration count of the loop if suitable, and NULL_TREE otherwise. */
1584 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1586 tree size
= gfc_index_one_node
;
1590 for (i
= 0; i
< loop
->dimen
; i
++)
1592 /* If the bounds aren't constant, return NULL_TREE. */
1593 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1595 if (!integer_zerop (loop
->from
[i
]))
1597 /* Only allow non-zero "from" in one-dimensional arrays. */
1598 if (loop
->dimen
!= 1)
1600 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1601 loop
->to
[i
], loop
->from
[i
]);
1605 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1606 tmp
, gfc_index_one_node
);
1607 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1614 /* Array constructors are handled by constructing a temporary, then using that
1615 within the scalarization loop. This is not optimal, but seems by far the
1619 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1628 ss
->data
.info
.dimen
= loop
->dimen
;
1630 c
= ss
->expr
->value
.constructor
;
1631 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1633 bool const_string
= get_array_ctor_strlen (&loop
->pre
, c
, &ss
->string_length
);
1634 if (!ss
->string_length
)
1635 gfc_todo_error ("complex character array constructors");
1637 /* It is surprising but still possible to wind up with expressions that
1638 lack a character length.
1639 TODO Find the offending part of the front end and cure this properly.
1640 Concatenation involving arrays is the main culprit. */
1641 if (!ss
->expr
->ts
.cl
)
1643 ss
->expr
->ts
.cl
= gfc_get_charlen ();
1644 ss
->expr
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1645 gfc_current_ns
->cl_list
= ss
->expr
->ts
.cl
->next
;
1648 ss
->expr
->ts
.cl
->backend_decl
= ss
->string_length
;
1650 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1652 type
= build_pointer_type (type
);
1655 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1657 /* See if the constructor determines the loop bounds. */
1659 if (loop
->to
[0] == NULL_TREE
)
1663 /* We should have a 1-dimensional, zero-based loop. */
1664 gcc_assert (loop
->dimen
== 1);
1665 gcc_assert (integer_zerop (loop
->from
[0]));
1667 /* Split the constructor size into a static part and a dynamic part.
1668 Allocate the static size up-front and record whether the dynamic
1669 size might be nonzero. */
1671 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1672 mpz_sub_ui (size
, size
, 1);
1673 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1677 /* Special case constant array constructors. */
1680 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1683 tree size
= constant_array_constructor_loop_size (loop
);
1684 if (size
&& compare_tree_int (size
, nelem
) == 0)
1686 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1692 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1693 type
, dynamic
, true, false);
1695 desc
= ss
->data
.info
.descriptor
;
1696 offset
= gfc_index_zero_node
;
1697 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1698 TREE_USED (offsetvar
) = 0;
1699 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1700 &offset
, &offsetvar
, dynamic
);
1702 /* If the array grows dynamically, the upper bound of the loop variable
1703 is determined by the array's final upper bound. */
1705 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1707 if (TREE_USED (offsetvar
))
1708 pushdecl (offsetvar
);
1710 gcc_assert (INTEGER_CST_P (offset
));
1712 /* Disable bound checking for now because it's probably broken. */
1713 if (flag_bounds_check
)
1721 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1722 called after evaluating all of INFO's vector dimensions. Go through
1723 each such vector dimension and see if we can now fill in any missing
1727 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1736 for (n
= 0; n
< loop
->dimen
; n
++)
1739 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1740 && loop
->to
[n
] == NULL
)
1742 /* Loop variable N indexes vector dimension DIM, and we don't
1743 yet know the upper bound of loop variable N. Set it to the
1744 difference between the vector's upper and lower bounds. */
1745 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1746 gcc_assert (info
->subscript
[dim
]
1747 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1749 gfc_init_se (&se
, NULL
);
1750 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1751 zero
= gfc_rank_cst
[0];
1752 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1753 gfc_conv_descriptor_ubound (desc
, zero
),
1754 gfc_conv_descriptor_lbound (desc
, zero
));
1755 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1762 /* Add the pre and post chains for all the scalar expressions in a SS chain
1763 to loop. This is called after the loop parameters have been calculated,
1764 but before the actual scalarizing loops. */
1767 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1772 /* TODO: This can generate bad code if there are ordering dependencies.
1773 eg. a callee allocated function and an unknown size constructor. */
1774 gcc_assert (ss
!= NULL
);
1776 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1783 /* Scalar expression. Evaluate this now. This includes elemental
1784 dimension indices, but not array section bounds. */
1785 gfc_init_se (&se
, NULL
);
1786 gfc_conv_expr (&se
, ss
->expr
);
1787 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1789 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1791 /* Move the evaluation of scalar expressions outside the
1792 scalarization loop. */
1794 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1795 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1796 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1799 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1801 ss
->data
.scalar
.expr
= se
.expr
;
1802 ss
->string_length
= se
.string_length
;
1805 case GFC_SS_REFERENCE
:
1806 /* Scalar reference. Evaluate this now. */
1807 gfc_init_se (&se
, NULL
);
1808 gfc_conv_expr_reference (&se
, ss
->expr
);
1809 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1810 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1812 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1813 ss
->string_length
= se
.string_length
;
1816 case GFC_SS_SECTION
:
1817 /* Add the expressions for scalar and vector subscripts. */
1818 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1819 if (ss
->data
.info
.subscript
[n
])
1820 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1822 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1826 /* Get the vector's descriptor and store it in SS. */
1827 gfc_init_se (&se
, NULL
);
1828 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1829 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1830 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1831 ss
->data
.info
.descriptor
= se
.expr
;
1834 case GFC_SS_INTRINSIC
:
1835 gfc_add_intrinsic_ss_code (loop
, ss
);
1838 case GFC_SS_FUNCTION
:
1839 /* Array function return value. We call the function and save its
1840 result in a temporary for use inside the loop. */
1841 gfc_init_se (&se
, NULL
);
1844 gfc_conv_expr (&se
, ss
->expr
);
1845 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1846 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1847 ss
->string_length
= se
.string_length
;
1850 case GFC_SS_CONSTRUCTOR
:
1851 gfc_trans_array_constructor (loop
, ss
);
1855 case GFC_SS_COMPONENT
:
1856 /* Do nothing. These are handled elsewhere. */
1866 /* Translate expressions for the descriptor and data pointer of a SS. */
1870 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1875 /* Get the descriptor for the array to be scalarized. */
1876 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1877 gfc_init_se (&se
, NULL
);
1878 se
.descriptor_only
= 1;
1879 gfc_conv_expr_lhs (&se
, ss
->expr
);
1880 gfc_add_block_to_block (block
, &se
.pre
);
1881 ss
->data
.info
.descriptor
= se
.expr
;
1882 ss
->string_length
= se
.string_length
;
1886 /* Also the data pointer. */
1887 tmp
= gfc_conv_array_data (se
.expr
);
1888 /* If this is a variable or address of a variable we use it directly.
1889 Otherwise we must evaluate it now to avoid breaking dependency
1890 analysis by pulling the expressions for elemental array indices
1893 || (TREE_CODE (tmp
) == ADDR_EXPR
1894 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1895 tmp
= gfc_evaluate_now (tmp
, block
);
1896 ss
->data
.info
.data
= tmp
;
1898 tmp
= gfc_conv_array_offset (se
.expr
);
1899 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1904 /* Initialize a gfc_loopinfo structure. */
1907 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1911 memset (loop
, 0, sizeof (gfc_loopinfo
));
1912 gfc_init_block (&loop
->pre
);
1913 gfc_init_block (&loop
->post
);
1915 /* Initially scalarize in order. */
1916 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1919 loop
->ss
= gfc_ss_terminator
;
1923 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1927 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1933 /* Return an expression for the data pointer of an array. */
1936 gfc_conv_array_data (tree descriptor
)
1940 type
= TREE_TYPE (descriptor
);
1941 if (GFC_ARRAY_TYPE_P (type
))
1943 if (TREE_CODE (type
) == POINTER_TYPE
)
1947 /* Descriptorless arrays. */
1948 return build_fold_addr_expr (descriptor
);
1952 return gfc_conv_descriptor_data_get (descriptor
);
1956 /* Return an expression for the base offset of an array. */
1959 gfc_conv_array_offset (tree descriptor
)
1963 type
= TREE_TYPE (descriptor
);
1964 if (GFC_ARRAY_TYPE_P (type
))
1965 return GFC_TYPE_ARRAY_OFFSET (type
);
1967 return gfc_conv_descriptor_offset (descriptor
);
1971 /* Get an expression for the array stride. */
1974 gfc_conv_array_stride (tree descriptor
, int dim
)
1979 type
= TREE_TYPE (descriptor
);
1981 /* For descriptorless arrays use the array size. */
1982 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1983 if (tmp
!= NULL_TREE
)
1986 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1991 /* Like gfc_conv_array_stride, but for the lower bound. */
1994 gfc_conv_array_lbound (tree descriptor
, int dim
)
1999 type
= TREE_TYPE (descriptor
);
2001 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2002 if (tmp
!= NULL_TREE
)
2005 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
2010 /* Like gfc_conv_array_stride, but for the upper bound. */
2013 gfc_conv_array_ubound (tree descriptor
, int dim
)
2018 type
= TREE_TYPE (descriptor
);
2020 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2021 if (tmp
!= NULL_TREE
)
2024 /* This should only ever happen when passing an assumed shape array
2025 as an actual parameter. The value will never be used. */
2026 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2027 return gfc_index_zero_node
;
2029 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
2034 /* Generate code to perform an array index bound check. */
2037 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2038 locus
* where
, bool check_upper
)
2043 const char * name
= NULL
;
2045 if (!flag_bounds_check
)
2048 index
= gfc_evaluate_now (index
, &se
->pre
);
2050 /* We find a name for the error message. */
2052 name
= se
->ss
->expr
->symtree
->name
;
2054 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2055 && se
->loop
->ss
->expr
->symtree
)
2056 name
= se
->loop
->ss
->expr
->symtree
->name
;
2058 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2059 && se
->loop
->ss
->loop_chain
->expr
2060 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2061 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2063 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2064 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2065 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2067 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2069 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2070 && se
->loop
->ss
->expr
->value
.function
.name
)
2071 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2073 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2074 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2075 name
= "unnamed constant";
2078 /* Check lower bound. */
2079 tmp
= gfc_conv_array_lbound (descriptor
, n
);
2080 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
2082 asprintf (&msg
, "%s for array '%s', lower bound of dimension %d exceeded",
2083 gfc_msg_fault
, name
, n
+1);
2085 asprintf (&msg
, "%s, lower bound of dimension %d exceeded",
2086 gfc_msg_fault
, n
+1);
2087 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
2090 /* Check upper bound. */
2093 tmp
= gfc_conv_array_ubound (descriptor
, n
);
2094 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
2096 asprintf (&msg
, "%s for array '%s', upper bound of dimension %d "
2097 " exceeded", gfc_msg_fault
, name
, n
+1);
2099 asprintf (&msg
, "%s, upper bound of dimension %d exceeded",
2100 gfc_msg_fault
, n
+1);
2101 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
2109 /* Return the offset for an index. Performs bound checking for elemental
2110 dimensions. Single element references are processed separately. */
2113 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2114 gfc_array_ref
* ar
, tree stride
)
2120 /* Get the index into the array for this dimension. */
2123 gcc_assert (ar
->type
!= AR_ELEMENT
);
2124 switch (ar
->dimen_type
[dim
])
2127 gcc_assert (i
== -1);
2128 /* Elemental dimension. */
2129 gcc_assert (info
->subscript
[dim
]
2130 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2131 /* We've already translated this value outside the loop. */
2132 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2134 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2135 index
, dim
, &ar
->where
,
2136 (ar
->as
->type
!= AS_ASSUMED_SIZE
2137 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2141 gcc_assert (info
&& se
->loop
);
2142 gcc_assert (info
->subscript
[dim
]
2143 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2144 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2146 /* Get a zero-based index into the vector. */
2147 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2148 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2150 /* Multiply the index by the stride. */
2151 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2152 index
, gfc_conv_array_stride (desc
, 0));
2154 /* Read the vector to get an index into info->descriptor. */
2155 data
= build_fold_indirect_ref (gfc_conv_array_data (desc
));
2156 index
= gfc_build_array_ref (data
, index
);
2157 index
= gfc_evaluate_now (index
, &se
->pre
);
2159 /* Do any bounds checking on the final info->descriptor index. */
2160 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2161 index
, dim
, &ar
->where
,
2162 (ar
->as
->type
!= AS_ASSUMED_SIZE
2163 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2167 /* Scalarized dimension. */
2168 gcc_assert (info
&& se
->loop
);
2170 /* Multiply the loop variable by the stride and delta. */
2171 index
= se
->loop
->loopvar
[i
];
2172 if (!integer_onep (info
->stride
[i
]))
2173 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2175 if (!integer_zerop (info
->delta
[i
]))
2176 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2186 /* Temporary array or derived type component. */
2187 gcc_assert (se
->loop
);
2188 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2189 if (!integer_zerop (info
->delta
[i
]))
2190 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2191 index
, info
->delta
[i
]);
2194 /* Multiply by the stride. */
2195 if (!integer_onep (stride
))
2196 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2202 /* Build a scalarized reference to an array. */
2205 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2212 info
= &se
->ss
->data
.info
;
2214 n
= se
->loop
->order
[0];
2218 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2220 /* Add the offset for this dimension to the stored offset for all other
2222 if (!integer_zerop (info
->offset
))
2223 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2225 tmp
= build_fold_indirect_ref (info
->data
);
2226 se
->expr
= gfc_build_array_ref (tmp
, index
);
2230 /* Translate access of temporary array. */
2233 gfc_conv_tmp_array_ref (gfc_se
* se
)
2235 se
->string_length
= se
->ss
->string_length
;
2236 gfc_conv_scalarized_array_ref (se
, NULL
);
2240 /* Build an array reference. se->expr already holds the array descriptor.
2241 This should be either a variable, indirect variable reference or component
2242 reference. For arrays which do not have a descriptor, se->expr will be
2244 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2247 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2256 /* Handle scalarized references separately. */
2257 if (ar
->type
!= AR_ELEMENT
)
2259 gfc_conv_scalarized_array_ref (se
, ar
);
2260 gfc_advance_se_ss_chain (se
);
2264 index
= gfc_index_zero_node
;
2266 /* Calculate the offsets from all the dimensions. */
2267 for (n
= 0; n
< ar
->dimen
; n
++)
2269 /* Calculate the index for this dimension. */
2270 gfc_init_se (&indexse
, se
);
2271 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2272 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2274 if (flag_bounds_check
)
2276 /* Check array bounds. */
2281 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2282 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2284 asprintf (&msg
, "%s for array '%s', "
2285 "lower bound of dimension %d exceeded", gfc_msg_fault
,
2287 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, where
);
2290 /* Upper bound, but not for the last dimension of assumed-size
2292 if (n
< ar
->dimen
- 1
2293 || (ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
))
2295 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2296 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2298 asprintf (&msg
, "%s for array '%s', "
2299 "upper bound of dimension %d exceeded", gfc_msg_fault
,
2301 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, where
);
2306 /* Multiply the index by the stride. */
2307 stride
= gfc_conv_array_stride (se
->expr
, n
);
2308 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2311 /* And add it to the total. */
2312 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2315 tmp
= gfc_conv_array_offset (se
->expr
);
2316 if (!integer_zerop (tmp
))
2317 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2319 /* Access the calculated element. */
2320 tmp
= gfc_conv_array_data (se
->expr
);
2321 tmp
= build_fold_indirect_ref (tmp
);
2322 se
->expr
= gfc_build_array_ref (tmp
, index
);
2326 /* Generate the code to be executed immediately before entering a
2327 scalarization loop. */
2330 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2331 stmtblock_t
* pblock
)
2340 /* This code will be executed before entering the scalarization loop
2341 for this dimension. */
2342 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2344 if ((ss
->useflags
& flag
) == 0)
2347 if (ss
->type
!= GFC_SS_SECTION
2348 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2349 && ss
->type
!= GFC_SS_COMPONENT
)
2352 info
= &ss
->data
.info
;
2354 if (dim
>= info
->dimen
)
2357 if (dim
== info
->dimen
- 1)
2359 /* For the outermost loop calculate the offset due to any
2360 elemental dimensions. It will have been initialized with the
2361 base offset of the array. */
2364 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2366 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2369 gfc_init_se (&se
, NULL
);
2371 se
.expr
= info
->descriptor
;
2372 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2373 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2376 gfc_add_block_to_block (pblock
, &se
.pre
);
2378 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2379 info
->offset
, index
);
2380 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2384 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2387 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2389 /* Calculate the stride of the innermost loop. Hopefully this will
2390 allow the backend optimizers to do their stuff more effectively.
2392 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2396 /* Add the offset for the previous loop dimension. */
2401 ar
= &info
->ref
->u
.ar
;
2402 i
= loop
->order
[dim
+ 1];
2410 gfc_init_se (&se
, NULL
);
2412 se
.expr
= info
->descriptor
;
2413 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2414 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2416 gfc_add_block_to_block (pblock
, &se
.pre
);
2417 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2418 info
->offset
, index
);
2419 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2422 /* Remember this offset for the second loop. */
2423 if (dim
== loop
->temp_dim
- 1)
2424 info
->saved_offset
= info
->offset
;
2429 /* Start a scalarized expression. Creates a scope and declares loop
2433 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2439 gcc_assert (!loop
->array_parameter
);
2441 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2443 n
= loop
->order
[dim
];
2445 gfc_start_block (&loop
->code
[n
]);
2447 /* Create the loop variable. */
2448 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2450 if (dim
< loop
->temp_dim
)
2454 /* Calculate values that will be constant within this loop. */
2455 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2457 gfc_start_block (pbody
);
2461 /* Generates the actual loop code for a scalarization loop. */
2464 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2465 stmtblock_t
* pbody
)
2473 loopbody
= gfc_finish_block (pbody
);
2475 /* Initialize the loopvar. */
2476 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2478 exit_label
= gfc_build_label_decl (NULL_TREE
);
2480 /* Generate the loop body. */
2481 gfc_init_block (&block
);
2483 /* The exit condition. */
2484 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2485 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2486 TREE_USED (exit_label
) = 1;
2487 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2488 gfc_add_expr_to_block (&block
, tmp
);
2490 /* The main body. */
2491 gfc_add_expr_to_block (&block
, loopbody
);
2493 /* Increment the loopvar. */
2494 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2495 loop
->loopvar
[n
], gfc_index_one_node
);
2496 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2498 /* Build the loop. */
2499 tmp
= gfc_finish_block (&block
);
2500 tmp
= build1_v (LOOP_EXPR
, tmp
);
2501 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2503 /* Add the exit label. */
2504 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2505 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2509 /* Finishes and generates the loops for a scalarized expression. */
2512 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2517 stmtblock_t
*pblock
;
2521 /* Generate the loops. */
2522 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2524 n
= loop
->order
[dim
];
2525 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2526 loop
->loopvar
[n
] = NULL_TREE
;
2527 pblock
= &loop
->code
[n
];
2530 tmp
= gfc_finish_block (pblock
);
2531 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2533 /* Clear all the used flags. */
2534 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2539 /* Finish the main body of a scalarized expression, and start the secondary
2543 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2547 stmtblock_t
*pblock
;
2551 /* We finish as many loops as are used by the temporary. */
2552 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2554 n
= loop
->order
[dim
];
2555 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2556 loop
->loopvar
[n
] = NULL_TREE
;
2557 pblock
= &loop
->code
[n
];
2560 /* We don't want to finish the outermost loop entirely. */
2561 n
= loop
->order
[loop
->temp_dim
- 1];
2562 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2564 /* Restore the initial offsets. */
2565 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2567 if ((ss
->useflags
& 2) == 0)
2570 if (ss
->type
!= GFC_SS_SECTION
2571 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2572 && ss
->type
!= GFC_SS_COMPONENT
)
2575 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2578 /* Restart all the inner loops we just finished. */
2579 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2581 n
= loop
->order
[dim
];
2583 gfc_start_block (&loop
->code
[n
]);
2585 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2587 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2590 /* Start a block for the secondary copying code. */
2591 gfc_start_block (body
);
2595 /* Calculate the upper bound of an array section. */
2598 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2607 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2609 info
= &ss
->data
.info
;
2612 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2613 /* We'll calculate the upper bound once we have access to the
2614 vector's descriptor. */
2617 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2618 desc
= info
->descriptor
;
2619 end
= info
->ref
->u
.ar
.end
[dim
];
2623 /* The upper bound was specified. */
2624 gfc_init_se (&se
, NULL
);
2625 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2626 gfc_add_block_to_block (pblock
, &se
.pre
);
2631 /* No upper bound was specified, so use the bound of the array. */
2632 bound
= gfc_conv_array_ubound (desc
, dim
);
2639 /* Calculate the lower bound of an array section. */
2642 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2652 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2654 info
= &ss
->data
.info
;
2657 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2659 /* We use a zero-based index to access the vector. */
2660 info
->start
[n
] = gfc_index_zero_node
;
2661 info
->end
[n
] = gfc_index_zero_node
;
2662 info
->stride
[n
] = gfc_index_one_node
;
2666 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2667 desc
= info
->descriptor
;
2668 start
= info
->ref
->u
.ar
.start
[dim
];
2669 end
= info
->ref
->u
.ar
.end
[dim
];
2670 stride
= info
->ref
->u
.ar
.stride
[dim
];
2672 /* Calculate the start of the range. For vector subscripts this will
2673 be the range of the vector. */
2676 /* Specified section start. */
2677 gfc_init_se (&se
, NULL
);
2678 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2679 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2680 info
->start
[n
] = se
.expr
;
2684 /* No lower bound specified so use the bound of the array. */
2685 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2687 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2689 /* Similarly calculate the end. Although this is not used in the
2690 scalarizer, it is needed when checking bounds and where the end
2691 is an expression with side-effects. */
2694 /* Specified section start. */
2695 gfc_init_se (&se
, NULL
);
2696 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2697 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2698 info
->end
[n
] = se
.expr
;
2702 /* No upper bound specified so use the bound of the array. */
2703 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
2705 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
2707 /* Calculate the stride. */
2709 info
->stride
[n
] = gfc_index_one_node
;
2712 gfc_init_se (&se
, NULL
);
2713 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2714 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2715 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2720 /* Calculates the range start and stride for a SS chain. Also gets the
2721 descriptor and data pointer. The range of vector subscripts is the size
2722 of the vector. Array bounds are also checked. */
2725 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2733 /* Determine the rank of the loop. */
2735 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2739 case GFC_SS_SECTION
:
2740 case GFC_SS_CONSTRUCTOR
:
2741 case GFC_SS_FUNCTION
:
2742 case GFC_SS_COMPONENT
:
2743 loop
->dimen
= ss
->data
.info
.dimen
;
2746 /* As usual, lbound and ubound are exceptions!. */
2747 case GFC_SS_INTRINSIC
:
2748 switch (ss
->expr
->value
.function
.isym
->id
)
2750 case GFC_ISYM_LBOUND
:
2751 case GFC_ISYM_UBOUND
:
2752 loop
->dimen
= ss
->data
.info
.dimen
;
2763 if (loop
->dimen
== 0)
2764 gfc_todo_error ("Unable to determine rank of expression");
2767 /* Loop over all the SS in the chain. */
2768 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2770 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2771 ss
->shape
= ss
->expr
->shape
;
2775 case GFC_SS_SECTION
:
2776 /* Get the descriptor for the array. */
2777 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2779 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2780 gfc_conv_section_startstride (loop
, ss
, n
);
2783 case GFC_SS_INTRINSIC
:
2784 switch (ss
->expr
->value
.function
.isym
->id
)
2786 /* Fall through to supply start and stride. */
2787 case GFC_ISYM_LBOUND
:
2788 case GFC_ISYM_UBOUND
:
2794 case GFC_SS_CONSTRUCTOR
:
2795 case GFC_SS_FUNCTION
:
2796 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2798 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2799 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
2800 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2809 /* The rest is just runtime bound checking. */
2810 if (flag_bounds_check
)
2813 tree lbound
, ubound
;
2815 tree size
[GFC_MAX_DIMENSIONS
];
2816 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
;
2821 gfc_start_block (&block
);
2823 for (n
= 0; n
< loop
->dimen
; n
++)
2824 size
[n
] = NULL_TREE
;
2826 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2828 if (ss
->type
!= GFC_SS_SECTION
)
2831 /* TODO: range checking for mapped dimensions. */
2832 info
= &ss
->data
.info
;
2834 /* This code only checks ranges. Elemental and vector
2835 dimensions are checked later. */
2836 for (n
= 0; n
< loop
->dimen
; n
++)
2841 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
2844 if (n
== info
->ref
->u
.ar
.dimen
- 1
2845 && (info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
2846 || info
->ref
->u
.ar
.as
->cp_was_assumed
))
2847 check_upper
= false;
2851 /* Zero stride is not allowed. */
2852 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
2853 gfc_index_zero_node
);
2854 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
2855 "of array '%s'", info
->dim
[n
]+1,
2856 ss
->expr
->symtree
->name
);
2857 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2860 desc
= ss
->data
.info
.descriptor
;
2862 /* This is the run-time equivalent of resolve.c's
2863 check_dimension(). The logical is more readable there
2864 than it is here, with all the trees. */
2865 lbound
= gfc_conv_array_lbound (desc
, dim
);
2868 ubound
= gfc_conv_array_ubound (desc
, dim
);
2872 /* non_zerosized is true when the selected range is not
2874 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
2875 info
->stride
[n
], gfc_index_zero_node
);
2876 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
2878 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2881 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
2882 info
->stride
[n
], gfc_index_zero_node
);
2883 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
2885 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2887 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2888 stride_pos
, stride_neg
);
2890 /* Check the start of the range against the lower and upper
2891 bounds of the array, if the range is not empty. */
2892 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, info
->start
[n
],
2894 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2895 non_zerosized
, tmp
);
2896 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2897 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2898 ss
->expr
->symtree
->name
);
2899 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2904 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
,
2905 info
->start
[n
], ubound
);
2906 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2907 non_zerosized
, tmp
);
2908 asprintf (&msg
, "%s, upper bound of dimension %d of array "
2909 "'%s' exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2910 ss
->expr
->symtree
->name
);
2911 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2915 /* Compute the last element of the range, which is not
2916 necessarily "end" (think 0:5:3, which doesn't contain 5)
2917 and check it against both lower and upper bounds. */
2918 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2920 tmp2
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp2
,
2922 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2925 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp2
, lbound
);
2926 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2927 non_zerosized
, tmp
);
2928 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2929 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2930 ss
->expr
->symtree
->name
);
2931 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2936 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp2
, ubound
);
2937 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2938 non_zerosized
, tmp
);
2939 asprintf (&msg
, "%s, upper bound of dimension %d of array "
2940 "'%s' exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2941 ss
->expr
->symtree
->name
);
2942 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2946 /* Check the section sizes match. */
2947 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2949 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2951 /* We remember the size of the first section, and check all the
2952 others against this. */
2956 fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
2957 asprintf (&msg
, "%s, size mismatch for dimension %d "
2958 "of array '%s'", gfc_msg_bounds
, info
->dim
[n
]+1,
2959 ss
->expr
->symtree
->name
);
2960 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2964 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2968 tmp
= gfc_finish_block (&block
);
2969 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2974 /* Return true if the two SS could be aliased, i.e. both point to the same data
2976 /* TODO: resolve aliases based on frontend expressions. */
2979 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2986 lsym
= lss
->expr
->symtree
->n
.sym
;
2987 rsym
= rss
->expr
->symtree
->n
.sym
;
2988 if (gfc_symbols_could_alias (lsym
, rsym
))
2991 if (rsym
->ts
.type
!= BT_DERIVED
2992 && lsym
->ts
.type
!= BT_DERIVED
)
2995 /* For derived types we must check all the component types. We can ignore
2996 array references as these will have the same base type as the previous
2998 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3000 if (lref
->type
!= REF_COMPONENT
)
3003 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3006 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3009 if (rref
->type
!= REF_COMPONENT
)
3012 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3017 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3019 if (rref
->type
!= REF_COMPONENT
)
3022 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3030 /* Resolve array data dependencies. Creates a temporary if required. */
3031 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3035 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3045 loop
->temp_ss
= NULL
;
3046 aref
= dest
->data
.info
.ref
;
3049 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3051 if (ss
->type
!= GFC_SS_SECTION
)
3054 if (gfc_could_be_alias (dest
, ss
)
3055 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3061 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
3063 lref
= dest
->expr
->ref
;
3064 rref
= ss
->expr
->ref
;
3066 nDepend
= gfc_dep_resolver (lref
, rref
);
3070 /* TODO : loop shifting. */
3073 /* Mark the dimensions for LOOP SHIFTING */
3074 for (n
= 0; n
< loop
->dimen
; n
++)
3076 int dim
= dest
->data
.info
.dim
[n
];
3078 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3080 else if (! gfc_is_same_range (&lref
->u
.ar
,
3081 &rref
->u
.ar
, dim
, 0))
3085 /* Put all the dimensions with dependencies in the
3088 for (n
= 0; n
< loop
->dimen
; n
++)
3090 gcc_assert (loop
->order
[n
] == n
);
3092 loop
->order
[dim
++] = n
;
3095 for (n
= 0; n
< loop
->dimen
; n
++)
3098 loop
->order
[dim
++] = n
;
3101 gcc_assert (dim
== loop
->dimen
);
3110 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3111 if (GFC_ARRAY_TYPE_P (base_type
)
3112 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3113 base_type
= gfc_get_element_type (base_type
);
3114 loop
->temp_ss
= gfc_get_ss ();
3115 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3116 loop
->temp_ss
->data
.temp
.type
= base_type
;
3117 loop
->temp_ss
->string_length
= dest
->string_length
;
3118 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3119 loop
->temp_ss
->next
= gfc_ss_terminator
;
3120 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3123 loop
->temp_ss
= NULL
;
3127 /* Initialize the scalarization loop. Creates the loop variables. Determines
3128 the range of the loop variables. Creates a temporary if required.
3129 Calculates how to transform from loop variables to array indices for each
3130 expression. Also generates code for scalar expressions which have been
3131 moved outside the loop. */
3134 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
3139 gfc_ss_info
*specinfo
;
3143 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3144 bool dynamic
[GFC_MAX_DIMENSIONS
];
3150 for (n
= 0; n
< loop
->dimen
; n
++)
3154 /* We use one SS term, and use that to determine the bounds of the
3155 loop for this dimension. We try to pick the simplest term. */
3156 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3160 /* The frontend has worked out the size for us. */
3165 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3167 /* An unknown size constructor will always be rank one.
3168 Higher rank constructors will either have known shape,
3169 or still be wrapped in a call to reshape. */
3170 gcc_assert (loop
->dimen
== 1);
3172 /* Always prefer to use the constructor bounds if the size
3173 can be determined at compile time. Prefer not to otherwise,
3174 since the general case involves realloc, and it's better to
3175 avoid that overhead if possible. */
3176 c
= ss
->expr
->value
.constructor
;
3177 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
3178 if (!dynamic
[n
] || !loopspec
[n
])
3183 /* TODO: Pick the best bound if we have a choice between a
3184 function and something else. */
3185 if (ss
->type
== GFC_SS_FUNCTION
)
3191 if (ss
->type
!= GFC_SS_SECTION
)
3195 specinfo
= &loopspec
[n
]->data
.info
;
3198 info
= &ss
->data
.info
;
3202 /* Criteria for choosing a loop specifier (most important first):
3203 doesn't need realloc
3209 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3211 else if (integer_onep (info
->stride
[n
])
3212 && !integer_onep (specinfo
->stride
[n
]))
3214 else if (INTEGER_CST_P (info
->stride
[n
])
3215 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3217 else if (INTEGER_CST_P (info
->start
[n
])
3218 && !INTEGER_CST_P (specinfo
->start
[n
]))
3220 /* We don't work out the upper bound.
3221 else if (INTEGER_CST_P (info->finish[n])
3222 && ! INTEGER_CST_P (specinfo->finish[n]))
3223 loopspec[n] = ss; */
3227 gfc_todo_error ("Unable to find scalarization loop specifier");
3229 info
= &loopspec
[n
]->data
.info
;
3231 /* Set the extents of this range. */
3232 cshape
= loopspec
[n
]->shape
;
3233 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3234 && INTEGER_CST_P (info
->stride
[n
]))
3236 loop
->from
[n
] = info
->start
[n
];
3237 mpz_set (i
, cshape
[n
]);
3238 mpz_sub_ui (i
, i
, 1);
3239 /* To = from + (size - 1) * stride. */
3240 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3241 if (!integer_onep (info
->stride
[n
]))
3242 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3243 tmp
, info
->stride
[n
]);
3244 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3245 loop
->from
[n
], tmp
);
3249 loop
->from
[n
] = info
->start
[n
];
3250 switch (loopspec
[n
]->type
)
3252 case GFC_SS_CONSTRUCTOR
:
3253 /* The upper bound is calculated when we expand the
3255 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3258 case GFC_SS_SECTION
:
3259 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3263 case GFC_SS_FUNCTION
:
3264 /* The loop bound will be set when we generate the call. */
3265 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3273 /* Transform everything so we have a simple incrementing variable. */
3274 if (integer_onep (info
->stride
[n
]))
3275 info
->delta
[n
] = gfc_index_zero_node
;
3278 /* Set the delta for this section. */
3279 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3280 /* Number of iterations is (end - start + step) / step.
3281 with start = 0, this simplifies to
3283 for (i = 0; i<=last; i++){...}; */
3284 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3285 loop
->to
[n
], loop
->from
[n
]);
3286 tmp
= fold_build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
3287 tmp
, info
->stride
[n
]);
3288 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3289 /* Make the loop variable start at 0. */
3290 loop
->from
[n
] = gfc_index_zero_node
;
3294 /* Add all the scalar code that can be taken out of the loops.
3295 This may include calculating the loop bounds, so do it before
3296 allocating the temporary. */
3297 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
3299 /* If we want a temporary then create it. */
3300 if (loop
->temp_ss
!= NULL
)
3302 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3303 tmp
= loop
->temp_ss
->data
.temp
.type
;
3304 len
= loop
->temp_ss
->string_length
;
3305 n
= loop
->temp_ss
->data
.temp
.dimen
;
3306 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3307 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3308 loop
->temp_ss
->data
.info
.dimen
= n
;
3309 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3310 &loop
->temp_ss
->data
.info
, tmp
, false, true,
3314 for (n
= 0; n
< loop
->temp_dim
; n
++)
3315 loopspec
[loop
->order
[n
]] = NULL
;
3319 /* For array parameters we don't have loop variables, so don't calculate the
3321 if (loop
->array_parameter
)
3324 /* Calculate the translation from loop variables to array indices. */
3325 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3327 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
3330 info
= &ss
->data
.info
;
3332 for (n
= 0; n
< info
->dimen
; n
++)
3336 /* If we are specifying the range the delta is already set. */
3337 if (loopspec
[n
] != ss
)
3339 /* Calculate the offset relative to the loop variable.
3340 First multiply by the stride. */
3341 tmp
= loop
->from
[n
];
3342 if (!integer_onep (info
->stride
[n
]))
3343 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3344 tmp
, info
->stride
[n
]);
3346 /* Then subtract this from our starting value. */
3347 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3348 info
->start
[n
], tmp
);
3350 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3357 /* Fills in an array descriptor, and returns the size of the array. The size
3358 will be a simple_val, ie a variable or a constant. Also calculates the
3359 offset of the base. Returns the size of the array.
3363 for (n = 0; n < rank; n++)
3365 a.lbound[n] = specified_lower_bound;
3366 offset = offset + a.lbond[n] * stride;
3368 a.ubound[n] = specified_upper_bound;
3369 a.stride[n] = stride;
3370 size = ubound + size; //size = ubound + 1 - lbound
3371 stride = stride * size;
3378 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3379 gfc_expr
** lower
, gfc_expr
** upper
,
3380 stmtblock_t
* pblock
)
3392 stmtblock_t thenblock
;
3393 stmtblock_t elseblock
;
3398 type
= TREE_TYPE (descriptor
);
3400 stride
= gfc_index_one_node
;
3401 offset
= gfc_index_zero_node
;
3403 /* Set the dtype. */
3404 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3405 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3407 or_expr
= NULL_TREE
;
3409 for (n
= 0; n
< rank
; n
++)
3411 /* We have 3 possibilities for determining the size of the array:
3412 lower == NULL => lbound = 1, ubound = upper[n]
3413 upper[n] = NULL => lbound = 1, ubound = lower[n]
3414 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3417 /* Set lower bound. */
3418 gfc_init_se (&se
, NULL
);
3420 se
.expr
= gfc_index_one_node
;
3423 gcc_assert (lower
[n
]);
3426 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3427 gfc_add_block_to_block (pblock
, &se
.pre
);
3431 se
.expr
= gfc_index_one_node
;
3435 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
3436 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3438 /* Work out the offset for this component. */
3439 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3440 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3442 /* Start the calculation for the size of this dimension. */
3443 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3444 gfc_index_one_node
, se
.expr
);
3446 /* Set upper bound. */
3447 gfc_init_se (&se
, NULL
);
3448 gcc_assert (ubound
);
3449 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3450 gfc_add_block_to_block (pblock
, &se
.pre
);
3452 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
3453 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3455 /* Store the stride. */
3456 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
3457 gfc_add_modify_expr (pblock
, tmp
, stride
);
3459 /* Calculate the size of this dimension. */
3460 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3462 /* Check whether the size for this dimension is negative. */
3463 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3464 gfc_index_zero_node
);
3468 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3470 /* Multiply the stride by the number of elements in this dimension. */
3471 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3472 stride
= gfc_evaluate_now (stride
, pblock
);
3475 /* The stride is the number of elements in the array, so multiply by the
3476 size of an element to get the total size. */
3477 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3478 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3479 fold_convert (gfc_array_index_type
, tmp
));
3481 if (poffset
!= NULL
)
3483 offset
= gfc_evaluate_now (offset
, pblock
);
3487 if (integer_zerop (or_expr
))
3489 if (integer_onep (or_expr
))
3490 return gfc_index_zero_node
;
3492 var
= gfc_create_var (TREE_TYPE (size
), "size");
3493 gfc_start_block (&thenblock
);
3494 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
3495 thencase
= gfc_finish_block (&thenblock
);
3497 gfc_start_block (&elseblock
);
3498 gfc_add_modify_expr (&elseblock
, var
, size
);
3499 elsecase
= gfc_finish_block (&elseblock
);
3501 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3502 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3503 gfc_add_expr_to_block (pblock
, tmp
);
3509 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3510 the work for an ALLOCATE statement. */
3514 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3523 gfc_ref
*ref
, *prev_ref
= NULL
;
3524 bool allocatable_array
;
3528 /* Find the last reference in the chain. */
3529 while (ref
&& ref
->next
!= NULL
)
3531 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3536 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3540 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3542 allocatable_array
= prev_ref
->u
.c
.component
->allocatable
;
3544 /* Figure out the size of the array. */
3545 switch (ref
->u
.ar
.type
)
3549 upper
= ref
->u
.ar
.start
;
3553 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
3555 lower
= ref
->u
.ar
.as
->lower
;
3556 upper
= ref
->u
.ar
.as
->upper
;
3560 lower
= ref
->u
.ar
.start
;
3561 upper
= ref
->u
.ar
.end
;
3569 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
3570 lower
, upper
, &se
->pre
);
3572 /* Allocate memory to store the data. */
3573 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
3574 STRIP_NOPS (pointer
);
3576 if (TYPE_PRECISION (gfc_array_index_type
) == 32 ||
3577 TYPE_PRECISION (gfc_array_index_type
) == 64)
3579 if (allocatable_array
)
3580 allocate
= gfor_fndecl_allocate_array
;
3582 allocate
= gfor_fndecl_allocate
;
3587 /* The allocate_array variants take the old pointer as first argument. */
3588 if (allocatable_array
)
3589 tmp
= build_call_expr (allocate
, 3, pointer
, size
, pstat
);
3591 tmp
= build_call_expr (allocate
, 2, size
, pstat
);
3592 tmp
= build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
3593 gfc_add_expr_to_block (&se
->pre
, tmp
);
3595 tmp
= gfc_conv_descriptor_offset (se
->expr
);
3596 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
3598 if (expr
->ts
.type
== BT_DERIVED
3599 && expr
->ts
.derived
->attr
.alloc_comp
)
3601 tmp
= gfc_nullify_alloc_comp (expr
->ts
.derived
, se
->expr
,
3602 ref
->u
.ar
.as
->rank
);
3603 gfc_add_expr_to_block (&se
->pre
, tmp
);
3610 /* Deallocate an array variable. Also used when an allocated variable goes
3615 gfc_array_deallocate (tree descriptor
, tree pstat
)
3621 gfc_start_block (&block
);
3622 /* Get a pointer to the data. */
3623 var
= gfc_conv_descriptor_data_get (descriptor
);
3626 /* Parameter is the address of the data component. */
3627 tmp
= build_call_expr (gfor_fndecl_deallocate
, 2, var
, pstat
);
3628 gfc_add_expr_to_block (&block
, tmp
);
3630 /* Zero the data pointer. */
3631 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
3632 var
, build_int_cst (TREE_TYPE (var
), 0));
3633 gfc_add_expr_to_block (&block
, tmp
);
3635 return gfc_finish_block (&block
);
3639 /* Create an array constructor from an initialization expression.
3640 We assume the frontend already did any expansions and conversions. */
3643 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3650 unsigned HOST_WIDE_INT lo
;
3652 VEC(constructor_elt
,gc
) *v
= NULL
;
3654 switch (expr
->expr_type
)
3657 case EXPR_STRUCTURE
:
3658 /* A single scalar or derived type value. Create an array with all
3659 elements equal to that value. */
3660 gfc_init_se (&se
, NULL
);
3662 if (expr
->expr_type
== EXPR_CONSTANT
)
3663 gfc_conv_constant (&se
, expr
);
3665 gfc_conv_structure (&se
, expr
, 1);
3667 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3668 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3669 hi
= TREE_INT_CST_HIGH (tmp
);
3670 lo
= TREE_INT_CST_LOW (tmp
);
3674 /* This will probably eat buckets of memory for large arrays. */
3675 while (hi
!= 0 || lo
!= 0)
3677 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3685 /* Create a vector of all the elements. */
3686 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3690 /* Problems occur when we get something like
3691 integer :: a(lots) = (/(i, i=1,lots)/) */
3692 /* TODO: Unexpanded array initializers. */
3694 ("Possible frontend bug: array constructor not expanded");
3696 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3697 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3701 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3705 mpz_set (maxval
, c
->repeat
);
3706 mpz_add (maxval
, c
->n
.offset
, maxval
);
3707 mpz_sub_ui (maxval
, maxval
, 1);
3708 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3709 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3711 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3712 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3715 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3717 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3723 gfc_init_se (&se
, NULL
);
3724 switch (c
->expr
->expr_type
)
3727 gfc_conv_constant (&se
, c
->expr
);
3728 if (range
== NULL_TREE
)
3729 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3732 if (index
!= NULL_TREE
)
3733 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3734 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3738 case EXPR_STRUCTURE
:
3739 gfc_conv_structure (&se
, c
->expr
, 1);
3740 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3750 return gfc_build_null_descriptor (type
);
3756 /* Create a constructor from the list of elements. */
3757 tmp
= build_constructor (type
, v
);
3758 TREE_CONSTANT (tmp
) = 1;
3759 TREE_INVARIANT (tmp
) = 1;
3764 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3765 returns the size (in elements) of the array. */
3768 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3769 stmtblock_t
* pblock
)
3784 size
= gfc_index_one_node
;
3785 offset
= gfc_index_zero_node
;
3786 for (dim
= 0; dim
< as
->rank
; dim
++)
3788 /* Evaluate non-constant array bound expressions. */
3789 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3790 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3792 gfc_init_se (&se
, NULL
);
3793 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3794 gfc_add_block_to_block (pblock
, &se
.pre
);
3795 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3797 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3798 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3800 gfc_init_se (&se
, NULL
);
3801 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3802 gfc_add_block_to_block (pblock
, &se
.pre
);
3803 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
3805 /* The offset of this dimension. offset = offset - lbound * stride. */
3806 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
3807 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3809 /* The size of this dimension, and the stride of the next. */
3810 if (dim
+ 1 < as
->rank
)
3811 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3813 stride
= GFC_TYPE_ARRAY_SIZE (type
);
3815 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3817 /* Calculate stride = size * (ubound + 1 - lbound). */
3818 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3819 gfc_index_one_node
, lbound
);
3820 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
3821 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3823 gfc_add_modify_expr (pblock
, stride
, tmp
);
3825 stride
= gfc_evaluate_now (tmp
, pblock
);
3827 /* Make sure that negative size arrays are translated
3828 to being zero size. */
3829 tmp
= build2 (GE_EXPR
, boolean_type_node
,
3830 stride
, gfc_index_zero_node
);
3831 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3832 stride
, gfc_index_zero_node
);
3833 gfc_add_modify_expr (pblock
, stride
, tmp
);
3839 gfc_trans_vla_type_sizes (sym
, pblock
);
3846 /* Generate code to initialize/allocate an array variable. */
3849 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3858 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3860 /* Do nothing for USEd variables. */
3861 if (sym
->attr
.use_assoc
)
3864 type
= TREE_TYPE (decl
);
3865 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3866 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3868 gfc_start_block (&block
);
3870 /* Evaluate character string length. */
3871 if (sym
->ts
.type
== BT_CHARACTER
3872 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3874 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3876 gfc_trans_vla_type_sizes (sym
, &block
);
3878 /* Emit a DECL_EXPR for this variable, which will cause the
3879 gimplifier to allocate storage, and all that good stuff. */
3880 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3881 gfc_add_expr_to_block (&block
, tmp
);
3886 gfc_add_expr_to_block (&block
, fnbody
);
3887 return gfc_finish_block (&block
);
3890 type
= TREE_TYPE (type
);
3892 gcc_assert (!sym
->attr
.use_assoc
);
3893 gcc_assert (!TREE_STATIC (decl
));
3894 gcc_assert (!sym
->module
);
3896 if (sym
->ts
.type
== BT_CHARACTER
3897 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3898 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3900 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3902 /* Don't actually allocate space for Cray Pointees. */
3903 if (sym
->attr
.cray_pointee
)
3905 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3906 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3907 gfc_add_expr_to_block (&block
, fnbody
);
3908 return gfc_finish_block (&block
);
3911 /* The size is the number of elements in the array, so multiply by the
3912 size of an element to get the total size. */
3913 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3914 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
3915 fold_convert (gfc_array_index_type
, tmp
));
3917 /* Allocate memory to hold the data. */
3918 tmp
= gfc_call_malloc (&block
, TREE_TYPE (decl
), size
);
3919 gfc_add_modify_expr (&block
, decl
, tmp
);
3921 /* Set offset of the array. */
3922 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3923 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3926 /* Automatic arrays should not have initializers. */
3927 gcc_assert (!sym
->value
);
3929 gfc_add_expr_to_block (&block
, fnbody
);
3931 /* Free the temporary. */
3932 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
3933 gfc_add_expr_to_block (&block
, tmp
);
3935 return gfc_finish_block (&block
);
3939 /* Generate entry and exit code for g77 calling convention arrays. */
3942 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3952 gfc_get_backend_locus (&loc
);
3953 gfc_set_backend_locus (&sym
->declared_at
);
3955 /* Descriptor type. */
3956 parm
= sym
->backend_decl
;
3957 type
= TREE_TYPE (parm
);
3958 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3960 gfc_start_block (&block
);
3962 if (sym
->ts
.type
== BT_CHARACTER
3963 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3964 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3966 /* Evaluate the bounds of the array. */
3967 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3969 /* Set the offset. */
3970 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3971 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3973 /* Set the pointer itself if we aren't using the parameter directly. */
3974 if (TREE_CODE (parm
) != PARM_DECL
)
3976 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3977 gfc_add_modify_expr (&block
, parm
, tmp
);
3979 stmt
= gfc_finish_block (&block
);
3981 gfc_set_backend_locus (&loc
);
3983 gfc_start_block (&block
);
3985 /* Add the initialization code to the start of the function. */
3987 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
3989 tmp
= gfc_conv_expr_present (sym
);
3990 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3993 gfc_add_expr_to_block (&block
, stmt
);
3994 gfc_add_expr_to_block (&block
, body
);
3996 return gfc_finish_block (&block
);
4000 /* Modify the descriptor of an array parameter so that it has the
4001 correct lower bound. Also move the upper bound accordingly.
4002 If the array is not packed, it will be copied into a temporary.
4003 For each dimension we set the new lower and upper bounds. Then we copy the
4004 stride and calculate the offset for this dimension. We also work out
4005 what the stride of a packed array would be, and see it the two match.
4006 If the array need repacking, we set the stride to the values we just
4007 calculated, recalculate the offset and copy the array data.
4008 Code is also added to copy the data back at the end of the function.
4012 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
4019 stmtblock_t cleanup
;
4027 tree stride
, stride2
;
4037 /* Do nothing for pointer and allocatable arrays. */
4038 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4041 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4042 return gfc_trans_g77_array (sym
, body
);
4044 gfc_get_backend_locus (&loc
);
4045 gfc_set_backend_locus (&sym
->declared_at
);
4047 /* Descriptor type. */
4048 type
= TREE_TYPE (tmpdesc
);
4049 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4050 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4051 dumdesc
= build_fold_indirect_ref (dumdesc
);
4052 gfc_start_block (&block
);
4054 if (sym
->ts
.type
== BT_CHARACTER
4055 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4056 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
4058 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
4060 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4061 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4063 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4065 /* For non-constant shape arrays we only check if the first dimension
4066 is contiguous. Repacking higher dimensions wouldn't gain us
4067 anything as we still don't know the array stride. */
4068 partial
= gfc_create_var (boolean_type_node
, "partial");
4069 TREE_USED (partial
) = 1;
4070 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4071 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4072 gfc_add_modify_expr (&block
, partial
, tmp
);
4076 partial
= NULL_TREE
;
4079 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4080 here, however I think it does the right thing. */
4083 /* Set the first stride. */
4084 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4085 stride
= gfc_evaluate_now (stride
, &block
);
4087 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, gfc_index_zero_node
);
4088 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4089 gfc_index_one_node
, stride
);
4090 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4091 gfc_add_modify_expr (&block
, stride
, tmp
);
4093 /* Allow the user to disable array repacking. */
4094 stmt_unpacked
= NULL_TREE
;
4098 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4099 /* A library call to repack the array if necessary. */
4100 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4101 stmt_unpacked
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
4103 stride
= gfc_index_one_node
;
4106 /* This is for the case where the array data is used directly without
4107 calling the repack function. */
4108 if (no_repack
|| partial
!= NULL_TREE
)
4109 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4111 stmt_packed
= NULL_TREE
;
4113 /* Assign the data pointer. */
4114 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4116 /* Don't repack unknown shape arrays when the first stride is 1. */
4117 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
4118 stmt_packed
, stmt_unpacked
);
4121 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4122 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
4124 offset
= gfc_index_zero_node
;
4125 size
= gfc_index_one_node
;
4127 /* Evaluate the bounds of the array. */
4128 for (n
= 0; n
< sym
->as
->rank
; n
++)
4130 if (checkparm
|| !sym
->as
->upper
[n
])
4132 /* Get the bounds of the actual parameter. */
4133 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
4134 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
4138 dubound
= NULL_TREE
;
4139 dlbound
= NULL_TREE
;
4142 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4143 if (!INTEGER_CST_P (lbound
))
4145 gfc_init_se (&se
, NULL
);
4146 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4147 gfc_array_index_type
);
4148 gfc_add_block_to_block (&block
, &se
.pre
);
4149 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
4152 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4153 /* Set the desired upper bound. */
4154 if (sym
->as
->upper
[n
])
4156 /* We know what we want the upper bound to be. */
4157 if (!INTEGER_CST_P (ubound
))
4159 gfc_init_se (&se
, NULL
);
4160 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4161 gfc_array_index_type
);
4162 gfc_add_block_to_block (&block
, &se
.pre
);
4163 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
4166 /* Check the sizes match. */
4169 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4172 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4174 stride2
= build2 (MINUS_EXPR
, gfc_array_index_type
,
4176 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
4177 asprintf (&msg
, "%s for dimension %d of array '%s'",
4178 gfc_msg_bounds
, n
+1, sym
->name
);
4179 gfc_trans_runtime_check (tmp
, msg
, &block
, &loc
);
4185 /* For assumed shape arrays move the upper bound by the same amount
4186 as the lower bound. */
4187 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
4188 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4189 gfc_add_modify_expr (&block
, ubound
, tmp
);
4191 /* The offset of this dimension. offset = offset - lbound * stride. */
4192 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4193 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4195 /* The size of this dimension, and the stride of the next. */
4196 if (n
+ 1 < sym
->as
->rank
)
4198 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4200 if (no_repack
|| partial
!= NULL_TREE
)
4203 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
4206 /* Figure out the stride if not a known constant. */
4207 if (!INTEGER_CST_P (stride
))
4210 stmt_packed
= NULL_TREE
;
4213 /* Calculate stride = size * (ubound + 1 - lbound). */
4214 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4215 gfc_index_one_node
, lbound
);
4216 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4218 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4223 /* Assign the stride. */
4224 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4225 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4226 stmt_unpacked
, stmt_packed
);
4228 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4229 gfc_add_modify_expr (&block
, stride
, tmp
);
4234 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4236 if (stride
&& !INTEGER_CST_P (stride
))
4238 /* Calculate size = stride * (ubound + 1 - lbound). */
4239 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4240 gfc_index_one_node
, lbound
);
4241 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4243 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4244 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4245 gfc_add_modify_expr (&block
, stride
, tmp
);
4250 /* Set the offset. */
4251 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4252 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4254 gfc_trans_vla_type_sizes (sym
, &block
);
4256 stmt
= gfc_finish_block (&block
);
4258 gfc_start_block (&block
);
4260 /* Only do the entry/initialization code if the arg is present. */
4261 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4262 optional_arg
= (sym
->attr
.optional
4263 || (sym
->ns
->proc_name
->attr
.entry_master
4264 && sym
->attr
.dummy
));
4267 tmp
= gfc_conv_expr_present (sym
);
4268 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4270 gfc_add_expr_to_block (&block
, stmt
);
4272 /* Add the main function body. */
4273 gfc_add_expr_to_block (&block
, body
);
4278 gfc_start_block (&cleanup
);
4280 if (sym
->attr
.intent
!= INTENT_IN
)
4282 /* Copy the data back. */
4283 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4284 gfc_add_expr_to_block (&cleanup
, tmp
);
4287 /* Free the temporary. */
4288 tmp
= gfc_call_free (tmpdesc
);
4289 gfc_add_expr_to_block (&cleanup
, tmp
);
4291 stmt
= gfc_finish_block (&cleanup
);
4293 /* Only do the cleanup if the array was repacked. */
4294 tmp
= build_fold_indirect_ref (dumdesc
);
4295 tmp
= gfc_conv_descriptor_data_get (tmp
);
4296 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4297 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4301 tmp
= gfc_conv_expr_present (sym
);
4302 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4304 gfc_add_expr_to_block (&block
, stmt
);
4306 /* We don't need to free any memory allocated by internal_pack as it will
4307 be freed at the end of the function by pop_context. */
4308 return gfc_finish_block (&block
);
4312 /* Convert an array for passing as an actual argument. Expressions and
4313 vector subscripts are evaluated and stored in a temporary, which is then
4314 passed. For whole arrays the descriptor is passed. For array sections
4315 a modified copy of the descriptor is passed, but using the original data.
4317 This function is also used for array pointer assignments, and there
4320 - se->want_pointer && !se->direct_byref
4321 EXPR is an actual argument. On exit, se->expr contains a
4322 pointer to the array descriptor.
4324 - !se->want_pointer && !se->direct_byref
4325 EXPR is an actual argument to an intrinsic function or the
4326 left-hand side of a pointer assignment. On exit, se->expr
4327 contains the descriptor for EXPR.
4329 - !se->want_pointer && se->direct_byref
4330 EXPR is the right-hand side of a pointer assignment and
4331 se->expr is the descriptor for the previously-evaluated
4332 left-hand side. The function creates an assignment from
4333 EXPR to se->expr. */
4336 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
4350 gcc_assert (ss
!= gfc_ss_terminator
);
4352 /* Special case things we know we can pass easily. */
4353 switch (expr
->expr_type
)
4356 /* If we have a linear array section, we can pass it directly.
4357 Otherwise we need to copy it into a temporary. */
4359 /* Find the SS for the array section. */
4361 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
4362 secss
= secss
->next
;
4364 gcc_assert (secss
!= gfc_ss_terminator
);
4365 info
= &secss
->data
.info
;
4367 /* Get the descriptor for the array. */
4368 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
4369 desc
= info
->descriptor
;
4371 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
);
4374 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4376 /* Create a new descriptor if the array doesn't have one. */
4379 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
4381 else if (se
->direct_byref
)
4384 full
= gfc_full_array_ref_p (info
->ref
);
4388 if (se
->direct_byref
)
4390 /* Copy the descriptor for pointer assignments. */
4391 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
4393 else if (se
->want_pointer
)
4395 /* We pass full arrays directly. This means that pointers and
4396 allocatable arrays should also work. */
4397 se
->expr
= build_fold_addr_expr (desc
);
4404 if (expr
->ts
.type
== BT_CHARACTER
)
4405 se
->string_length
= gfc_get_expr_charlen (expr
);
4412 /* A transformational function return value will be a temporary
4413 array descriptor. We still need to go through the scalarizer
4414 to create the descriptor. Elemental functions ar handled as
4415 arbitrary expressions, i.e. copy to a temporary. */
4417 /* Look for the SS for this function. */
4418 while (secss
!= gfc_ss_terminator
4419 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
4420 secss
= secss
->next
;
4422 if (se
->direct_byref
)
4424 gcc_assert (secss
!= gfc_ss_terminator
);
4426 /* For pointer assignments pass the descriptor directly. */
4428 se
->expr
= build_fold_addr_expr (se
->expr
);
4429 gfc_conv_expr (se
, expr
);
4433 if (secss
== gfc_ss_terminator
)
4435 /* Elemental function. */
4441 /* Transformational function. */
4442 info
= &secss
->data
.info
;
4448 /* Constant array constructors don't need a temporary. */
4449 if (ss
->type
== GFC_SS_CONSTRUCTOR
4450 && expr
->ts
.type
!= BT_CHARACTER
4451 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
4454 info
= &ss
->data
.info
;
4466 /* Something complicated. Copy it into a temporary. */
4474 gfc_init_loopinfo (&loop
);
4476 /* Associate the SS with the loop. */
4477 gfc_add_ss_to_loop (&loop
, ss
);
4479 /* Tell the scalarizer not to bother creating loop variables, etc. */
4481 loop
.array_parameter
= 1;
4483 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4484 gcc_assert (!se
->direct_byref
);
4486 /* Setup the scalarizing loops and bounds. */
4487 gfc_conv_ss_startstride (&loop
);
4491 /* Tell the scalarizer to make a temporary. */
4492 loop
.temp_ss
= gfc_get_ss ();
4493 loop
.temp_ss
->type
= GFC_SS_TEMP
;
4494 loop
.temp_ss
->next
= gfc_ss_terminator
;
4495 if (expr
->ts
.type
== BT_CHARACTER
)
4497 if (expr
->ts
.cl
== NULL
)
4499 /* This had better be a substring reference! */
4500 gfc_ref
*char_ref
= expr
->ref
;
4501 for (; char_ref
; char_ref
= char_ref
->next
)
4502 if (char_ref
->type
== REF_SUBSTRING
)
4505 expr
->ts
.cl
= gfc_get_charlen ();
4506 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
4507 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
4509 mpz_init_set_ui (char_len
, 1);
4510 mpz_add (char_len
, char_len
,
4511 char_ref
->u
.ss
.end
->value
.integer
);
4512 mpz_sub (char_len
, char_len
,
4513 char_ref
->u
.ss
.start
->value
.integer
);
4514 expr
->ts
.cl
->backend_decl
4515 = gfc_conv_mpz_to_tree (char_len
,
4516 gfc_default_character_kind
);
4517 /* Cast is necessary for *-charlen refs. */
4518 expr
->ts
.cl
->backend_decl
4519 = convert (gfc_charlen_type_node
,
4520 expr
->ts
.cl
->backend_decl
);
4521 mpz_clear (char_len
);
4524 gcc_assert (char_ref
!= NULL
);
4525 loop
.temp_ss
->data
.temp
.type
4526 = gfc_typenode_for_spec (&expr
->ts
);
4527 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4529 else if (expr
->ts
.cl
->length
4530 && expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4532 expr
->ts
.cl
->backend_decl
4533 = gfc_conv_mpz_to_tree (expr
->ts
.cl
->length
->value
.integer
,
4534 expr
->ts
.cl
->length
->ts
.kind
);
4535 loop
.temp_ss
->data
.temp
.type
4536 = gfc_typenode_for_spec (&expr
->ts
);
4537 loop
.temp_ss
->string_length
4538 = TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
4542 loop
.temp_ss
->data
.temp
.type
4543 = gfc_typenode_for_spec (&expr
->ts
);
4544 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4546 se
->string_length
= loop
.temp_ss
->string_length
;
4550 loop
.temp_ss
->data
.temp
.type
4551 = gfc_typenode_for_spec (&expr
->ts
);
4552 loop
.temp_ss
->string_length
= NULL
;
4554 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
4555 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4558 gfc_conv_loop_setup (&loop
);
4562 /* Copy into a temporary and pass that. We don't need to copy the data
4563 back because expressions and vector subscripts must be INTENT_IN. */
4564 /* TODO: Optimize passing function return values. */
4568 /* Start the copying loops. */
4569 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4570 gfc_mark_ss_chain_used (ss
, 1);
4571 gfc_start_scalarized_body (&loop
, &block
);
4573 /* Copy each data element. */
4574 gfc_init_se (&lse
, NULL
);
4575 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4576 gfc_init_se (&rse
, NULL
);
4577 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4579 lse
.ss
= loop
.temp_ss
;
4582 gfc_conv_scalarized_array_ref (&lse
, NULL
);
4583 if (expr
->ts
.type
== BT_CHARACTER
)
4585 gfc_conv_expr (&rse
, expr
);
4586 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
4587 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4590 gfc_conv_expr_val (&rse
, expr
);
4592 gfc_add_block_to_block (&block
, &rse
.pre
);
4593 gfc_add_block_to_block (&block
, &lse
.pre
);
4595 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
4597 /* Finish the copying loops. */
4598 gfc_trans_scalarizing_loops (&loop
, &block
);
4600 desc
= loop
.temp_ss
->data
.info
.descriptor
;
4602 gcc_assert (is_gimple_lvalue (desc
));
4604 else if (expr
->expr_type
== EXPR_FUNCTION
)
4606 desc
= info
->descriptor
;
4607 se
->string_length
= ss
->string_length
;
4611 /* We pass sections without copying to a temporary. Make a new
4612 descriptor and point it at the section we want. The loop variable
4613 limits will be the limits of the section.
4614 A function may decide to repack the array to speed up access, but
4615 we're not bothered about that here. */
4624 /* Set the string_length for a character array. */
4625 if (expr
->ts
.type
== BT_CHARACTER
)
4626 se
->string_length
= gfc_get_expr_charlen (expr
);
4628 desc
= info
->descriptor
;
4629 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
4630 if (se
->direct_byref
)
4632 /* For pointer assignments we fill in the destination. */
4634 parmtype
= TREE_TYPE (parm
);
4638 /* Otherwise make a new one. */
4639 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4640 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
4641 loop
.from
, loop
.to
, 0);
4642 parm
= gfc_create_var (parmtype
, "parm");
4645 offset
= gfc_index_zero_node
;
4648 /* The following can be somewhat confusing. We have two
4649 descriptors, a new one and the original array.
4650 {parm, parmtype, dim} refer to the new one.
4651 {desc, type, n, secss, loop} refer to the original, which maybe
4652 a descriptorless array.
4653 The bounds of the scalarization are the bounds of the section.
4654 We don't have to worry about numeric overflows when calculating
4655 the offsets because all elements are within the array data. */
4657 /* Set the dtype. */
4658 tmp
= gfc_conv_descriptor_dtype (parm
);
4659 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
4661 if (se
->direct_byref
)
4662 base
= gfc_index_zero_node
;
4663 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4664 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
4668 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
4669 for (n
= 0; n
< ndim
; n
++)
4671 stride
= gfc_conv_array_stride (desc
, n
);
4673 /* Work out the offset. */
4675 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4677 gcc_assert (info
->subscript
[n
]
4678 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
4679 start
= info
->subscript
[n
]->data
.scalar
.expr
;
4683 /* Check we haven't somehow got out of sync. */
4684 gcc_assert (info
->dim
[dim
] == n
);
4686 /* Evaluate and remember the start of the section. */
4687 start
= info
->start
[dim
];
4688 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
4691 tmp
= gfc_conv_array_lbound (desc
, n
);
4692 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
4694 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
4695 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
4698 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4700 /* For elemental dimensions, we only need the offset. */
4704 /* Vector subscripts need copying and are handled elsewhere. */
4706 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
4708 /* Set the new lower bound. */
4709 from
= loop
.from
[dim
];
4712 /* If we have an array section or are assigning to a pointer,
4713 make sure that the lower bound is 1. References to the full
4714 array should otherwise keep the original bounds. */
4716 || info
->ref
->u
.ar
.type
!= AR_FULL
4717 || se
->direct_byref
)
4718 && !integer_onep (from
))
4720 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4721 gfc_index_one_node
, from
);
4722 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
4723 from
= gfc_index_one_node
;
4725 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
4726 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
4728 /* Set the new upper bound. */
4729 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
4730 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
4732 /* Multiply the stride by the section stride to get the
4734 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4735 stride
, info
->stride
[dim
]);
4737 if (se
->direct_byref
)
4739 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4742 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4744 tmp
= gfc_conv_array_lbound (desc
, n
);
4745 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4746 tmp
, loop
.from
[dim
]);
4747 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
4748 tmp
, gfc_conv_array_stride (desc
, n
));
4749 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
4753 /* Store the new stride. */
4754 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
4755 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
4760 if (se
->data_not_needed
)
4761 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, gfc_index_zero_node
);
4764 /* Point the data pointer at the first element in the section. */
4765 tmp
= gfc_conv_array_data (desc
);
4766 tmp
= build_fold_indirect_ref (tmp
);
4767 tmp
= gfc_build_array_ref (tmp
, offset
);
4768 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4769 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, offset
);
4772 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4773 && !se
->data_not_needed
)
4775 /* Set the offset. */
4776 tmp
= gfc_conv_descriptor_offset (parm
);
4777 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
4781 /* Only the callee knows what the correct offset it, so just set
4783 tmp
= gfc_conv_descriptor_offset (parm
);
4784 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
4789 if (!se
->direct_byref
)
4791 /* Get a pointer to the new descriptor. */
4792 if (se
->want_pointer
)
4793 se
->expr
= build_fold_addr_expr (desc
);
4798 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4799 gfc_add_block_to_block (&se
->post
, &loop
.post
);
4801 /* Cleanup the scalarizer. */
4802 gfc_cleanup_loop (&loop
);
4806 /* Convert an array for passing as an actual parameter. */
4807 /* TODO: Optimize passing g77 arrays. */
4810 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
4814 tree tmp
= NULL_TREE
;
4816 tree parent
= DECL_CONTEXT (current_function_decl
);
4817 bool full_array_var
, this_array_result
;
4821 full_array_var
= (expr
->expr_type
== EXPR_VARIABLE
4822 && expr
->ref
->u
.ar
.type
== AR_FULL
);
4823 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
4825 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
4827 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
4828 expr
->ts
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &se
->pre
);
4829 se
->string_length
= expr
->ts
.cl
->backend_decl
;
4832 /* Is this the result of the enclosing procedure? */
4833 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
4834 if (this_array_result
4835 && (sym
->backend_decl
!= current_function_decl
)
4836 && (sym
->backend_decl
!= parent
))
4837 this_array_result
= false;
4839 /* Passing address of the array if it is not pointer or assumed-shape. */
4840 if (full_array_var
&& g77
&& !this_array_result
)
4842 tmp
= gfc_get_symbol_decl (sym
);
4844 if (sym
->ts
.type
== BT_CHARACTER
)
4845 se
->string_length
= sym
->ts
.cl
->backend_decl
;
4846 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
4847 && !sym
->attr
.allocatable
)
4849 /* Some variables are declared directly, others are declared as
4850 pointers and allocated on the heap. */
4851 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
4854 se
->expr
= build_fold_addr_expr (tmp
);
4857 if (sym
->attr
.allocatable
)
4859 if (sym
->attr
.dummy
)
4861 gfc_conv_expr_descriptor (se
, expr
, ss
);
4862 se
->expr
= gfc_conv_array_data (se
->expr
);
4865 se
->expr
= gfc_conv_array_data (tmp
);
4870 if (this_array_result
)
4872 /* Result of the enclosing function. */
4873 gfc_conv_expr_descriptor (se
, expr
, ss
);
4874 se
->expr
= build_fold_addr_expr (se
->expr
);
4876 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
4877 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4878 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref (se
->expr
));
4884 /* Every other type of array. */
4885 se
->want_pointer
= 1;
4886 gfc_conv_expr_descriptor (se
, expr
, ss
);
4890 /* Deallocate the allocatable components of structures that are
4892 if (expr
->ts
.type
== BT_DERIVED
4893 && expr
->ts
.derived
->attr
.alloc_comp
4894 && expr
->expr_type
!= EXPR_VARIABLE
)
4896 tmp
= build_fold_indirect_ref (se
->expr
);
4897 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.derived
, tmp
, expr
->rank
);
4898 gfc_add_expr_to_block (&se
->post
, tmp
);
4904 /* Repack the array. */
4905 ptr
= build_call_expr (gfor_fndecl_in_pack
, 1, desc
);
4906 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
4909 gfc_start_block (&block
);
4911 /* Copy the data back. */
4912 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, desc
, ptr
);
4913 gfc_add_expr_to_block (&block
, tmp
);
4915 /* Free the temporary. */
4916 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
4917 gfc_add_expr_to_block (&block
, tmp
);
4919 stmt
= gfc_finish_block (&block
);
4921 gfc_init_block (&block
);
4922 /* Only if it was repacked. This code needs to be executed before the
4923 loop cleanup code. */
4924 tmp
= build_fold_indirect_ref (desc
);
4925 tmp
= gfc_conv_array_data (tmp
);
4926 tmp
= build2 (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
4927 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4929 gfc_add_expr_to_block (&block
, tmp
);
4930 gfc_add_block_to_block (&block
, &se
->post
);
4932 gfc_init_block (&se
->post
);
4933 gfc_add_block_to_block (&se
->post
, &block
);
4938 /* Generate code to deallocate an array, if it is allocated. */
4941 gfc_trans_dealloc_allocated (tree descriptor
)
4948 gfc_start_block (&block
);
4950 var
= gfc_conv_descriptor_data_get (descriptor
);
4952 tmp
= gfc_create_var (gfc_array_index_type
, NULL
);
4953 ptr
= build_fold_addr_expr (tmp
);
4955 /* Call array_deallocate with an int* present in the second argument.
4956 Although it is ignored here, it's presence ensures that arrays that
4957 are already deallocated are ignored. */
4958 tmp
= build_call_expr (gfor_fndecl_deallocate
, 2, var
, ptr
);
4959 gfc_add_expr_to_block (&block
, tmp
);
4961 /* Zero the data pointer. */
4962 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
4963 var
, build_int_cst (TREE_TYPE (var
), 0));
4964 gfc_add_expr_to_block (&block
, tmp
);
4966 return gfc_finish_block (&block
);
4970 /* This helper function calculates the size in words of a full array. */
4973 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
4978 idx
= gfc_rank_cst
[rank
- 1];
4979 nelems
= gfc_conv_descriptor_ubound (decl
, idx
);
4980 tmp
= gfc_conv_descriptor_lbound (decl
, idx
);
4981 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
4982 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
4983 tmp
, gfc_index_one_node
);
4984 tmp
= gfc_evaluate_now (tmp
, block
);
4986 nelems
= gfc_conv_descriptor_stride (decl
, idx
);
4987 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
4988 return gfc_evaluate_now (tmp
, block
);
4992 /* Allocate dest to the same size as src, and copy src -> dest. */
4995 gfc_duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
)
5004 /* If the source is null, set the destination to null. */
5005 gfc_init_block (&block
);
5006 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5007 null_data
= gfc_finish_block (&block
);
5009 gfc_init_block (&block
);
5011 nelems
= get_full_array_size (&block
, src
, rank
);
5012 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
,
5013 fold_convert (gfc_array_index_type
,
5014 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
5016 /* Allocate memory to the destination. */
5017 tmp
= gfc_call_malloc (&block
, TREE_TYPE (gfc_conv_descriptor_data_get (src
)),
5019 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5021 /* We know the temporary and the value will be the same length,
5022 so can use memcpy. */
5023 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5024 tmp
= build_call_expr (tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5025 gfc_conv_descriptor_data_get (src
), size
);
5026 gfc_add_expr_to_block (&block
, tmp
);
5027 tmp
= gfc_finish_block (&block
);
5029 /* Null the destination if the source is null; otherwise do
5030 the allocate and copy. */
5031 null_cond
= gfc_conv_descriptor_data_get (src
);
5032 null_cond
= convert (pvoid_type_node
, null_cond
);
5033 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5035 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5039 /* Recursively traverse an object of derived type, generating code to
5040 deallocate, nullify or copy allocatable components. This is the work horse
5041 function for the functions named in this enum. */
5043 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
};
5046 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5047 tree dest
, int rank
, int purpose
)
5051 stmtblock_t fnblock
;
5052 stmtblock_t loopbody
;
5062 tree null_cond
= NULL_TREE
;
5064 gfc_init_block (&fnblock
);
5066 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
5067 decl
= build_fold_indirect_ref (decl
);
5069 /* If this an array of derived types with allocatable components
5070 build a loop and recursively call this function. */
5071 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
5072 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5074 tmp
= gfc_conv_array_data (decl
);
5075 var
= build_fold_indirect_ref (tmp
);
5077 /* Get the number of elements - 1 and set the counter. */
5078 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5080 /* Use the descriptor for an allocatable array. Since this
5081 is a full array reference, we only need the descriptor
5082 information from dimension = rank. */
5083 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
5084 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
5085 tmp
, gfc_index_one_node
);
5087 null_cond
= gfc_conv_descriptor_data_get (decl
);
5088 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5089 build_int_cst (TREE_TYPE (null_cond
), 0));
5093 /* Otherwise use the TYPE_DOMAIN information. */
5094 tmp
= array_type_nelts (TREE_TYPE (decl
));
5095 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5098 /* Remember that this is, in fact, the no. of elements - 1. */
5099 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5100 index
= gfc_create_var (gfc_array_index_type
, "S");
5102 /* Build the body of the loop. */
5103 gfc_init_block (&loopbody
);
5105 vref
= gfc_build_array_ref (var
, index
);
5107 if (purpose
== COPY_ALLOC_COMP
)
5109 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
5110 gfc_add_expr_to_block (&fnblock
, tmp
);
5112 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest
));
5113 dref
= gfc_build_array_ref (tmp
, index
);
5114 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
5117 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
5119 gfc_add_expr_to_block (&loopbody
, tmp
);
5121 /* Build the loop and return. */
5122 gfc_init_loopinfo (&loop
);
5124 loop
.from
[0] = gfc_index_zero_node
;
5125 loop
.loopvar
[0] = index
;
5126 loop
.to
[0] = nelems
;
5127 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
5128 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
5130 tmp
= gfc_finish_block (&fnblock
);
5131 if (null_cond
!= NULL_TREE
)
5132 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
, build_empty_stmt ());
5137 /* Otherwise, act on the components or recursively call self to
5138 act on a chain of components. */
5139 for (c
= der_type
->components
; c
; c
= c
->next
)
5141 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
5142 && c
->ts
.derived
->attr
.alloc_comp
;
5143 cdecl = c
->backend_decl
;
5144 ctype
= TREE_TYPE (cdecl);
5148 case DEALLOCATE_ALLOC_COMP
:
5149 /* Do not deallocate the components of ultimate pointer
5151 if (cmp_has_alloc_comps
&& !c
->pointer
)
5153 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5154 rank
= c
->as
? c
->as
->rank
: 0;
5155 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5157 gfc_add_expr_to_block (&fnblock
, tmp
);
5162 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5163 tmp
= gfc_trans_dealloc_allocated (comp
);
5164 gfc_add_expr_to_block (&fnblock
, tmp
);
5168 case NULLIFY_ALLOC_COMP
:
5171 else if (c
->allocatable
)
5173 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5174 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
5176 else if (cmp_has_alloc_comps
)
5178 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5179 rank
= c
->as
? c
->as
->rank
: 0;
5180 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5182 gfc_add_expr_to_block (&fnblock
, tmp
);
5186 case COPY_ALLOC_COMP
:
5190 /* We need source and destination components. */
5191 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5192 dcmp
= build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
5193 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
5195 if (c
->allocatable
&& !cmp_has_alloc_comps
)
5197 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, c
->as
->rank
);
5198 gfc_add_expr_to_block (&fnblock
, tmp
);
5201 if (cmp_has_alloc_comps
)
5203 rank
= c
->as
? c
->as
->rank
: 0;
5204 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
5205 gfc_add_modify_expr (&fnblock
, dcmp
, tmp
);
5206 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, dcmp
,
5208 gfc_add_expr_to_block (&fnblock
, tmp
);
5218 return gfc_finish_block (&fnblock
);
5221 /* Recursively traverse an object of derived type, generating code to
5222 nullify allocatable components. */
5225 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5227 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5228 NULLIFY_ALLOC_COMP
);
5232 /* Recursively traverse an object of derived type, generating code to
5233 deallocate allocatable components. */
5236 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5238 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5239 DEALLOCATE_ALLOC_COMP
);
5243 /* Recursively traverse an object of derived type, generating code to
5244 copy its allocatable components. */
5247 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
5249 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
5253 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5254 Do likewise, recursively if necessary, with the allocatable components of
5258 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
5263 stmtblock_t fnblock
;
5266 bool sym_has_alloc_comp
;
5268 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
5269 && sym
->ts
.derived
->attr
.alloc_comp
;
5271 /* Make sure the frontend gets these right. */
5272 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
5273 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5274 "allocatable attribute or derived type without allocatable "
5277 gfc_init_block (&fnblock
);
5279 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
5280 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
5282 if (sym
->ts
.type
== BT_CHARACTER
5283 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
5285 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
5286 gfc_trans_vla_type_sizes (sym
, &fnblock
);
5289 /* Dummy and use associated variables don't need anything special. */
5290 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
5292 gfc_add_expr_to_block (&fnblock
, body
);
5294 return gfc_finish_block (&fnblock
);
5297 gfc_get_backend_locus (&loc
);
5298 gfc_set_backend_locus (&sym
->declared_at
);
5299 descriptor
= sym
->backend_decl
;
5301 /* Although static, derived types with default initializers and
5302 allocatable components must not be nulled wholesale; instead they
5303 are treated component by component. */
5304 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
5306 /* SAVEd variables are not freed on exit. */
5307 gfc_trans_static_array_pointer (sym
);
5311 /* Get the descriptor type. */
5312 type
= TREE_TYPE (sym
->backend_decl
);
5314 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5316 if (!sym
->attr
.save
)
5318 rank
= sym
->as
? sym
->as
->rank
: 0;
5319 tmp
= gfc_nullify_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5320 gfc_add_expr_to_block (&fnblock
, tmp
);
5323 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
5325 /* If the backend_decl is not a descriptor, we must have a pointer
5327 descriptor
= build_fold_indirect_ref (sym
->backend_decl
);
5328 type
= TREE_TYPE (descriptor
);
5331 /* NULLIFY the data pointer. */
5332 if (GFC_DESCRIPTOR_TYPE_P (type
))
5333 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
5335 gfc_add_expr_to_block (&fnblock
, body
);
5337 gfc_set_backend_locus (&loc
);
5339 /* Allocatable arrays need to be freed when they go out of scope.
5340 The allocatable components of pointers must not be touched. */
5341 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
5342 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
5345 rank
= sym
->as
? sym
->as
->rank
: 0;
5346 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5347 gfc_add_expr_to_block (&fnblock
, tmp
);
5350 if (sym
->attr
.allocatable
)
5352 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
5353 gfc_add_expr_to_block (&fnblock
, tmp
);
5356 return gfc_finish_block (&fnblock
);
5359 /************ Expression Walking Functions ******************/
5361 /* Walk a variable reference.
5363 Possible extension - multiple component subscripts.
5364 x(:,:) = foo%a(:)%b(:)
5366 forall (i=..., j=...)
5367 x(i,j) = foo%a(j)%b(i)
5369 This adds a fair amount of complexity because you need to deal with more
5370 than one ref. Maybe handle in a similar manner to vector subscripts.
5371 Maybe not worth the effort. */
5375 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5383 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5384 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
5387 for (; ref
; ref
= ref
->next
)
5389 if (ref
->type
== REF_SUBSTRING
)
5391 newss
= gfc_get_ss ();
5392 newss
->type
= GFC_SS_SCALAR
;
5393 newss
->expr
= ref
->u
.ss
.start
;
5397 newss
= gfc_get_ss ();
5398 newss
->type
= GFC_SS_SCALAR
;
5399 newss
->expr
= ref
->u
.ss
.end
;
5404 /* We're only interested in array sections from now on. */
5405 if (ref
->type
!= REF_ARRAY
)
5412 for (n
= 0; n
< ar
->dimen
; n
++)
5414 newss
= gfc_get_ss ();
5415 newss
->type
= GFC_SS_SCALAR
;
5416 newss
->expr
= ar
->start
[n
];
5423 newss
= gfc_get_ss ();
5424 newss
->type
= GFC_SS_SECTION
;
5427 newss
->data
.info
.dimen
= ar
->as
->rank
;
5428 newss
->data
.info
.ref
= ref
;
5430 /* Make sure array is the same as array(:,:), this way
5431 we don't need to special case all the time. */
5432 ar
->dimen
= ar
->as
->rank
;
5433 for (n
= 0; n
< ar
->dimen
; n
++)
5435 newss
->data
.info
.dim
[n
] = n
;
5436 ar
->dimen_type
[n
] = DIMEN_RANGE
;
5438 gcc_assert (ar
->start
[n
] == NULL
);
5439 gcc_assert (ar
->end
[n
] == NULL
);
5440 gcc_assert (ar
->stride
[n
] == NULL
);
5446 newss
= gfc_get_ss ();
5447 newss
->type
= GFC_SS_SECTION
;
5450 newss
->data
.info
.dimen
= 0;
5451 newss
->data
.info
.ref
= ref
;
5455 /* We add SS chains for all the subscripts in the section. */
5456 for (n
= 0; n
< ar
->dimen
; n
++)
5460 switch (ar
->dimen_type
[n
])
5463 /* Add SS for elemental (scalar) subscripts. */
5464 gcc_assert (ar
->start
[n
]);
5465 indexss
= gfc_get_ss ();
5466 indexss
->type
= GFC_SS_SCALAR
;
5467 indexss
->expr
= ar
->start
[n
];
5468 indexss
->next
= gfc_ss_terminator
;
5469 indexss
->loop_chain
= gfc_ss_terminator
;
5470 newss
->data
.info
.subscript
[n
] = indexss
;
5474 /* We don't add anything for sections, just remember this
5475 dimension for later. */
5476 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5477 newss
->data
.info
.dimen
++;
5481 /* Create a GFC_SS_VECTOR index in which we can store
5482 the vector's descriptor. */
5483 indexss
= gfc_get_ss ();
5484 indexss
->type
= GFC_SS_VECTOR
;
5485 indexss
->expr
= ar
->start
[n
];
5486 indexss
->next
= gfc_ss_terminator
;
5487 indexss
->loop_chain
= gfc_ss_terminator
;
5488 newss
->data
.info
.subscript
[n
] = indexss
;
5489 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5490 newss
->data
.info
.dimen
++;
5494 /* We should know what sort of section it is by now. */
5498 /* We should have at least one non-elemental dimension. */
5499 gcc_assert (newss
->data
.info
.dimen
> 0);
5504 /* We should know what sort of section it is by now. */
5513 /* Walk an expression operator. If only one operand of a binary expression is
5514 scalar, we must also add the scalar term to the SS chain. */
5517 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5523 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
5524 if (expr
->value
.op
.op2
== NULL
)
5527 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
5529 /* All operands are scalar. Pass back and let the caller deal with it. */
5533 /* All operands require scalarization. */
5534 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
5537 /* One of the operands needs scalarization, the other is scalar.
5538 Create a gfc_ss for the scalar expression. */
5539 newss
= gfc_get_ss ();
5540 newss
->type
= GFC_SS_SCALAR
;
5543 /* First operand is scalar. We build the chain in reverse order, so
5544 add the scarar SS after the second operand. */
5546 while (head
&& head
->next
!= ss
)
5548 /* Check we haven't somehow broken the chain. */
5552 newss
->expr
= expr
->value
.op
.op1
;
5554 else /* head2 == head */
5556 gcc_assert (head2
== head
);
5557 /* Second operand is scalar. */
5558 newss
->next
= head2
;
5560 newss
->expr
= expr
->value
.op
.op2
;
5567 /* Reverse a SS chain. */
5570 gfc_reverse_ss (gfc_ss
* ss
)
5575 gcc_assert (ss
!= NULL
);
5577 head
= gfc_ss_terminator
;
5578 while (ss
!= gfc_ss_terminator
)
5581 /* Check we didn't somehow break the chain. */
5582 gcc_assert (next
!= NULL
);
5592 /* Walk the arguments of an elemental function. */
5595 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
5603 head
= gfc_ss_terminator
;
5606 for (; arg
; arg
= arg
->next
)
5611 newss
= gfc_walk_subexpr (head
, arg
->expr
);
5614 /* Scalar argument. */
5615 newss
= gfc_get_ss ();
5617 newss
->expr
= arg
->expr
;
5627 while (tail
->next
!= gfc_ss_terminator
)
5634 /* If all the arguments are scalar we don't need the argument SS. */
5635 gfc_free_ss_chain (head
);
5640 /* Add it onto the existing chain. */
5646 /* Walk a function call. Scalar functions are passed back, and taken out of
5647 scalarization loops. For elemental functions we walk their arguments.
5648 The result of functions returning arrays is stored in a temporary outside
5649 the loop, so that the function is only called once. Hence we do not need
5650 to walk their arguments. */
5653 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5656 gfc_intrinsic_sym
*isym
;
5659 isym
= expr
->value
.function
.isym
;
5661 /* Handle intrinsic functions separately. */
5663 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
5665 sym
= expr
->value
.function
.esym
;
5667 sym
= expr
->symtree
->n
.sym
;
5669 /* A function that returns arrays. */
5670 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
5672 newss
= gfc_get_ss ();
5673 newss
->type
= GFC_SS_FUNCTION
;
5676 newss
->data
.info
.dimen
= expr
->rank
;
5680 /* Walk the parameters of an elemental function. For now we always pass
5682 if (sym
->attr
.elemental
)
5683 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
5686 /* Scalar functions are OK as these are evaluated outside the scalarization
5687 loop. Pass back and let the caller deal with it. */
5692 /* An array temporary is constructed for array constructors. */
5695 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
5700 newss
= gfc_get_ss ();
5701 newss
->type
= GFC_SS_CONSTRUCTOR
;
5704 newss
->data
.info
.dimen
= expr
->rank
;
5705 for (n
= 0; n
< expr
->rank
; n
++)
5706 newss
->data
.info
.dim
[n
] = n
;
5712 /* Walk an expression. Add walked expressions to the head of the SS chain.
5713 A wholly scalar expression will not be added. */
5716 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
5720 switch (expr
->expr_type
)
5723 head
= gfc_walk_variable_expr (ss
, expr
);
5727 head
= gfc_walk_op_expr (ss
, expr
);
5731 head
= gfc_walk_function_expr (ss
, expr
);
5736 case EXPR_STRUCTURE
:
5737 /* Pass back and let the caller deal with it. */
5741 head
= gfc_walk_array_constructor (ss
, expr
);
5744 case EXPR_SUBSTRING
:
5745 /* Pass back and let the caller deal with it. */
5749 internal_error ("bad expression type during walk (%d)",
5756 /* Entry point for expression walking.
5757 A return value equal to the passed chain means this is
5758 a scalar expression. It is up to the caller to take whatever action is
5759 necessary to translate these. */
5762 gfc_walk_expr (gfc_expr
* expr
)
5766 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
5767 return gfc_reverse_ss (res
);