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 nonzero "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. */
1660 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1662 /* We have a multidimensional parameter. */
1664 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1666 loop
->from
[n
] = gfc_index_zero_node
;
1667 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1668 gfc_index_integer_kind
);
1669 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1670 loop
->to
[n
], gfc_index_one_node
);
1674 if (loop
->to
[0] == NULL_TREE
)
1678 /* We should have a 1-dimensional, zero-based loop. */
1679 gcc_assert (loop
->dimen
== 1);
1680 gcc_assert (integer_zerop (loop
->from
[0]));
1682 /* Split the constructor size into a static part and a dynamic part.
1683 Allocate the static size up-front and record whether the dynamic
1684 size might be nonzero. */
1686 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1687 mpz_sub_ui (size
, size
, 1);
1688 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1692 /* Special case constant array constructors. */
1695 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1698 tree size
= constant_array_constructor_loop_size (loop
);
1699 if (size
&& compare_tree_int (size
, nelem
) == 0)
1701 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1707 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1708 type
, dynamic
, true, false);
1710 desc
= ss
->data
.info
.descriptor
;
1711 offset
= gfc_index_zero_node
;
1712 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1713 TREE_NO_WARNING (offsetvar
) = 1;
1714 TREE_USED (offsetvar
) = 0;
1715 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1716 &offset
, &offsetvar
, dynamic
);
1718 /* If the array grows dynamically, the upper bound of the loop variable
1719 is determined by the array's final upper bound. */
1721 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1723 if (TREE_USED (offsetvar
))
1724 pushdecl (offsetvar
);
1726 gcc_assert (INTEGER_CST_P (offset
));
1728 /* Disable bound checking for now because it's probably broken. */
1729 if (flag_bounds_check
)
1737 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1738 called after evaluating all of INFO's vector dimensions. Go through
1739 each such vector dimension and see if we can now fill in any missing
1743 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1752 for (n
= 0; n
< loop
->dimen
; n
++)
1755 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1756 && loop
->to
[n
] == NULL
)
1758 /* Loop variable N indexes vector dimension DIM, and we don't
1759 yet know the upper bound of loop variable N. Set it to the
1760 difference between the vector's upper and lower bounds. */
1761 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1762 gcc_assert (info
->subscript
[dim
]
1763 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1765 gfc_init_se (&se
, NULL
);
1766 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1767 zero
= gfc_rank_cst
[0];
1768 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1769 gfc_conv_descriptor_ubound (desc
, zero
),
1770 gfc_conv_descriptor_lbound (desc
, zero
));
1771 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1778 /* Add the pre and post chains for all the scalar expressions in a SS chain
1779 to loop. This is called after the loop parameters have been calculated,
1780 but before the actual scalarizing loops. */
1783 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1788 /* TODO: This can generate bad code if there are ordering dependencies.
1789 eg. a callee allocated function and an unknown size constructor. */
1790 gcc_assert (ss
!= NULL
);
1792 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1799 /* Scalar expression. Evaluate this now. This includes elemental
1800 dimension indices, but not array section bounds. */
1801 gfc_init_se (&se
, NULL
);
1802 gfc_conv_expr (&se
, ss
->expr
);
1803 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1805 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1807 /* Move the evaluation of scalar expressions outside the
1808 scalarization loop. */
1810 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1811 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1812 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1815 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1817 ss
->data
.scalar
.expr
= se
.expr
;
1818 ss
->string_length
= se
.string_length
;
1821 case GFC_SS_REFERENCE
:
1822 /* Scalar reference. Evaluate this now. */
1823 gfc_init_se (&se
, NULL
);
1824 gfc_conv_expr_reference (&se
, ss
->expr
);
1825 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1826 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1828 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1829 ss
->string_length
= se
.string_length
;
1832 case GFC_SS_SECTION
:
1833 /* Add the expressions for scalar and vector subscripts. */
1834 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1835 if (ss
->data
.info
.subscript
[n
])
1836 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1838 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1842 /* Get the vector's descriptor and store it in SS. */
1843 gfc_init_se (&se
, NULL
);
1844 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1845 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1846 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1847 ss
->data
.info
.descriptor
= se
.expr
;
1850 case GFC_SS_INTRINSIC
:
1851 gfc_add_intrinsic_ss_code (loop
, ss
);
1854 case GFC_SS_FUNCTION
:
1855 /* Array function return value. We call the function and save its
1856 result in a temporary for use inside the loop. */
1857 gfc_init_se (&se
, NULL
);
1860 gfc_conv_expr (&se
, ss
->expr
);
1861 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1862 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1863 ss
->string_length
= se
.string_length
;
1866 case GFC_SS_CONSTRUCTOR
:
1867 gfc_trans_array_constructor (loop
, ss
);
1871 case GFC_SS_COMPONENT
:
1872 /* Do nothing. These are handled elsewhere. */
1882 /* Translate expressions for the descriptor and data pointer of a SS. */
1886 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1891 /* Get the descriptor for the array to be scalarized. */
1892 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1893 gfc_init_se (&se
, NULL
);
1894 se
.descriptor_only
= 1;
1895 gfc_conv_expr_lhs (&se
, ss
->expr
);
1896 gfc_add_block_to_block (block
, &se
.pre
);
1897 ss
->data
.info
.descriptor
= se
.expr
;
1898 ss
->string_length
= se
.string_length
;
1902 /* Also the data pointer. */
1903 tmp
= gfc_conv_array_data (se
.expr
);
1904 /* If this is a variable or address of a variable we use it directly.
1905 Otherwise we must evaluate it now to avoid breaking dependency
1906 analysis by pulling the expressions for elemental array indices
1909 || (TREE_CODE (tmp
) == ADDR_EXPR
1910 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1911 tmp
= gfc_evaluate_now (tmp
, block
);
1912 ss
->data
.info
.data
= tmp
;
1914 tmp
= gfc_conv_array_offset (se
.expr
);
1915 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1920 /* Initialize a gfc_loopinfo structure. */
1923 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1927 memset (loop
, 0, sizeof (gfc_loopinfo
));
1928 gfc_init_block (&loop
->pre
);
1929 gfc_init_block (&loop
->post
);
1931 /* Initially scalarize in order. */
1932 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1935 loop
->ss
= gfc_ss_terminator
;
1939 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1943 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1949 /* Return an expression for the data pointer of an array. */
1952 gfc_conv_array_data (tree descriptor
)
1956 type
= TREE_TYPE (descriptor
);
1957 if (GFC_ARRAY_TYPE_P (type
))
1959 if (TREE_CODE (type
) == POINTER_TYPE
)
1963 /* Descriptorless arrays. */
1964 return build_fold_addr_expr (descriptor
);
1968 return gfc_conv_descriptor_data_get (descriptor
);
1972 /* Return an expression for the base offset of an array. */
1975 gfc_conv_array_offset (tree descriptor
)
1979 type
= TREE_TYPE (descriptor
);
1980 if (GFC_ARRAY_TYPE_P (type
))
1981 return GFC_TYPE_ARRAY_OFFSET (type
);
1983 return gfc_conv_descriptor_offset (descriptor
);
1987 /* Get an expression for the array stride. */
1990 gfc_conv_array_stride (tree descriptor
, int dim
)
1995 type
= TREE_TYPE (descriptor
);
1997 /* For descriptorless arrays use the array size. */
1998 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1999 if (tmp
!= NULL_TREE
)
2002 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
2007 /* Like gfc_conv_array_stride, but for the lower bound. */
2010 gfc_conv_array_lbound (tree descriptor
, int dim
)
2015 type
= TREE_TYPE (descriptor
);
2017 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2018 if (tmp
!= NULL_TREE
)
2021 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
2026 /* Like gfc_conv_array_stride, but for the upper bound. */
2029 gfc_conv_array_ubound (tree descriptor
, int dim
)
2034 type
= TREE_TYPE (descriptor
);
2036 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2037 if (tmp
!= NULL_TREE
)
2040 /* This should only ever happen when passing an assumed shape array
2041 as an actual parameter. The value will never be used. */
2042 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2043 return gfc_index_zero_node
;
2045 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
2050 /* Generate code to perform an array index bound check. */
2053 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2054 locus
* where
, bool check_upper
)
2059 const char * name
= NULL
;
2061 if (!flag_bounds_check
)
2064 index
= gfc_evaluate_now (index
, &se
->pre
);
2066 /* We find a name for the error message. */
2068 name
= se
->ss
->expr
->symtree
->name
;
2070 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2071 && se
->loop
->ss
->expr
->symtree
)
2072 name
= se
->loop
->ss
->expr
->symtree
->name
;
2074 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2075 && se
->loop
->ss
->loop_chain
->expr
2076 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2077 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2079 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2080 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2081 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2083 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2085 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2086 && se
->loop
->ss
->expr
->value
.function
.name
)
2087 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2089 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2090 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2091 name
= "unnamed constant";
2094 /* Check lower bound. */
2095 tmp
= gfc_conv_array_lbound (descriptor
, n
);
2096 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
2098 asprintf (&msg
, "%s for array '%s', lower bound of dimension %d exceeded",
2099 gfc_msg_fault
, name
, n
+1);
2101 asprintf (&msg
, "%s, lower bound of dimension %d exceeded",
2102 gfc_msg_fault
, n
+1);
2103 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
2106 /* Check upper bound. */
2109 tmp
= gfc_conv_array_ubound (descriptor
, n
);
2110 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
2112 asprintf (&msg
, "%s for array '%s', upper bound of dimension %d "
2113 " exceeded", gfc_msg_fault
, name
, n
+1);
2115 asprintf (&msg
, "%s, upper bound of dimension %d exceeded",
2116 gfc_msg_fault
, n
+1);
2117 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
2125 /* Return the offset for an index. Performs bound checking for elemental
2126 dimensions. Single element references are processed separately. */
2129 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2130 gfc_array_ref
* ar
, tree stride
)
2136 /* Get the index into the array for this dimension. */
2139 gcc_assert (ar
->type
!= AR_ELEMENT
);
2140 switch (ar
->dimen_type
[dim
])
2143 gcc_assert (i
== -1);
2144 /* Elemental dimension. */
2145 gcc_assert (info
->subscript
[dim
]
2146 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2147 /* We've already translated this value outside the loop. */
2148 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2150 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2151 index
, dim
, &ar
->where
,
2152 (ar
->as
->type
!= AS_ASSUMED_SIZE
2153 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2157 gcc_assert (info
&& se
->loop
);
2158 gcc_assert (info
->subscript
[dim
]
2159 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2160 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2162 /* Get a zero-based index into the vector. */
2163 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2164 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2166 /* Multiply the index by the stride. */
2167 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2168 index
, gfc_conv_array_stride (desc
, 0));
2170 /* Read the vector to get an index into info->descriptor. */
2171 data
= build_fold_indirect_ref (gfc_conv_array_data (desc
));
2172 index
= gfc_build_array_ref (data
, index
);
2173 index
= gfc_evaluate_now (index
, &se
->pre
);
2175 /* Do any bounds checking on the final info->descriptor index. */
2176 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2177 index
, dim
, &ar
->where
,
2178 (ar
->as
->type
!= AS_ASSUMED_SIZE
2179 && !ar
->as
->cp_was_assumed
) || dim
< ar
->dimen
- 1);
2183 /* Scalarized dimension. */
2184 gcc_assert (info
&& se
->loop
);
2186 /* Multiply the loop variable by the stride and delta. */
2187 index
= se
->loop
->loopvar
[i
];
2188 if (!integer_onep (info
->stride
[i
]))
2189 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2191 if (!integer_zerop (info
->delta
[i
]))
2192 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2202 /* Temporary array or derived type component. */
2203 gcc_assert (se
->loop
);
2204 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2205 if (!integer_zerop (info
->delta
[i
]))
2206 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2207 index
, info
->delta
[i
]);
2210 /* Multiply by the stride. */
2211 if (!integer_onep (stride
))
2212 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2218 /* Build a scalarized reference to an array. */
2221 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2228 info
= &se
->ss
->data
.info
;
2230 n
= se
->loop
->order
[0];
2234 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2236 /* Add the offset for this dimension to the stored offset for all other
2238 if (!integer_zerop (info
->offset
))
2239 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2241 tmp
= build_fold_indirect_ref (info
->data
);
2242 se
->expr
= gfc_build_array_ref (tmp
, index
);
2246 /* Translate access of temporary array. */
2249 gfc_conv_tmp_array_ref (gfc_se
* se
)
2251 se
->string_length
= se
->ss
->string_length
;
2252 gfc_conv_scalarized_array_ref (se
, NULL
);
2256 /* Build an array reference. se->expr already holds the array descriptor.
2257 This should be either a variable, indirect variable reference or component
2258 reference. For arrays which do not have a descriptor, se->expr will be
2260 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2263 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2272 /* Handle scalarized references separately. */
2273 if (ar
->type
!= AR_ELEMENT
)
2275 gfc_conv_scalarized_array_ref (se
, ar
);
2276 gfc_advance_se_ss_chain (se
);
2280 index
= gfc_index_zero_node
;
2282 /* Calculate the offsets from all the dimensions. */
2283 for (n
= 0; n
< ar
->dimen
; n
++)
2285 /* Calculate the index for this dimension. */
2286 gfc_init_se (&indexse
, se
);
2287 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2288 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2290 if (flag_bounds_check
)
2292 /* Check array bounds. */
2296 /* Evaluate the indexse.expr only once. */
2297 indexse
.expr
= save_expr (indexse
.expr
);
2300 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2301 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2303 asprintf (&msg
, "%s for array '%s', "
2304 "lower bound of dimension %d exceeded", gfc_msg_fault
,
2306 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, where
);
2309 /* Upper bound, but not for the last dimension of assumed-size
2311 if (n
< ar
->dimen
- 1
2312 || (ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
))
2314 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2315 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2317 asprintf (&msg
, "%s for array '%s', "
2318 "upper bound of dimension %d exceeded", gfc_msg_fault
,
2320 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, where
);
2325 /* Multiply the index by the stride. */
2326 stride
= gfc_conv_array_stride (se
->expr
, n
);
2327 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2330 /* And add it to the total. */
2331 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2334 tmp
= gfc_conv_array_offset (se
->expr
);
2335 if (!integer_zerop (tmp
))
2336 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2338 /* Access the calculated element. */
2339 tmp
= gfc_conv_array_data (se
->expr
);
2340 tmp
= build_fold_indirect_ref (tmp
);
2341 se
->expr
= gfc_build_array_ref (tmp
, index
);
2345 /* Generate the code to be executed immediately before entering a
2346 scalarization loop. */
2349 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2350 stmtblock_t
* pblock
)
2359 /* This code will be executed before entering the scalarization loop
2360 for this dimension. */
2361 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2363 if ((ss
->useflags
& flag
) == 0)
2366 if (ss
->type
!= GFC_SS_SECTION
2367 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2368 && ss
->type
!= GFC_SS_COMPONENT
)
2371 info
= &ss
->data
.info
;
2373 if (dim
>= info
->dimen
)
2376 if (dim
== info
->dimen
- 1)
2378 /* For the outermost loop calculate the offset due to any
2379 elemental dimensions. It will have been initialized with the
2380 base offset of the array. */
2383 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2385 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2388 gfc_init_se (&se
, NULL
);
2390 se
.expr
= info
->descriptor
;
2391 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2392 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2395 gfc_add_block_to_block (pblock
, &se
.pre
);
2397 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2398 info
->offset
, index
);
2399 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2403 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2406 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2408 /* Calculate the stride of the innermost loop. Hopefully this will
2409 allow the backend optimizers to do their stuff more effectively.
2411 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2415 /* Add the offset for the previous loop dimension. */
2420 ar
= &info
->ref
->u
.ar
;
2421 i
= loop
->order
[dim
+ 1];
2429 gfc_init_se (&se
, NULL
);
2431 se
.expr
= info
->descriptor
;
2432 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2433 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2435 gfc_add_block_to_block (pblock
, &se
.pre
);
2436 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2437 info
->offset
, index
);
2438 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2441 /* Remember this offset for the second loop. */
2442 if (dim
== loop
->temp_dim
- 1)
2443 info
->saved_offset
= info
->offset
;
2448 /* Start a scalarized expression. Creates a scope and declares loop
2452 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2458 gcc_assert (!loop
->array_parameter
);
2460 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2462 n
= loop
->order
[dim
];
2464 gfc_start_block (&loop
->code
[n
]);
2466 /* Create the loop variable. */
2467 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2469 if (dim
< loop
->temp_dim
)
2473 /* Calculate values that will be constant within this loop. */
2474 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2476 gfc_start_block (pbody
);
2480 /* Generates the actual loop code for a scalarization loop. */
2483 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2484 stmtblock_t
* pbody
)
2492 loopbody
= gfc_finish_block (pbody
);
2494 /* Initialize the loopvar. */
2495 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2497 exit_label
= gfc_build_label_decl (NULL_TREE
);
2499 /* Generate the loop body. */
2500 gfc_init_block (&block
);
2502 /* The exit condition. */
2503 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2504 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2505 TREE_USED (exit_label
) = 1;
2506 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2507 gfc_add_expr_to_block (&block
, tmp
);
2509 /* The main body. */
2510 gfc_add_expr_to_block (&block
, loopbody
);
2512 /* Increment the loopvar. */
2513 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2514 loop
->loopvar
[n
], gfc_index_one_node
);
2515 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2517 /* Build the loop. */
2518 tmp
= gfc_finish_block (&block
);
2519 tmp
= build1_v (LOOP_EXPR
, tmp
);
2520 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2522 /* Add the exit label. */
2523 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2524 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2528 /* Finishes and generates the loops for a scalarized expression. */
2531 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2536 stmtblock_t
*pblock
;
2540 /* Generate the loops. */
2541 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2543 n
= loop
->order
[dim
];
2544 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2545 loop
->loopvar
[n
] = NULL_TREE
;
2546 pblock
= &loop
->code
[n
];
2549 tmp
= gfc_finish_block (pblock
);
2550 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2552 /* Clear all the used flags. */
2553 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2558 /* Finish the main body of a scalarized expression, and start the secondary
2562 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2566 stmtblock_t
*pblock
;
2570 /* We finish as many loops as are used by the temporary. */
2571 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2573 n
= loop
->order
[dim
];
2574 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2575 loop
->loopvar
[n
] = NULL_TREE
;
2576 pblock
= &loop
->code
[n
];
2579 /* We don't want to finish the outermost loop entirely. */
2580 n
= loop
->order
[loop
->temp_dim
- 1];
2581 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2583 /* Restore the initial offsets. */
2584 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2586 if ((ss
->useflags
& 2) == 0)
2589 if (ss
->type
!= GFC_SS_SECTION
2590 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2591 && ss
->type
!= GFC_SS_COMPONENT
)
2594 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2597 /* Restart all the inner loops we just finished. */
2598 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2600 n
= loop
->order
[dim
];
2602 gfc_start_block (&loop
->code
[n
]);
2604 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2606 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2609 /* Start a block for the secondary copying code. */
2610 gfc_start_block (body
);
2614 /* Calculate the upper bound of an array section. */
2617 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2626 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2628 info
= &ss
->data
.info
;
2631 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2632 /* We'll calculate the upper bound once we have access to the
2633 vector's descriptor. */
2636 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2637 desc
= info
->descriptor
;
2638 end
= info
->ref
->u
.ar
.end
[dim
];
2642 /* The upper bound was specified. */
2643 gfc_init_se (&se
, NULL
);
2644 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2645 gfc_add_block_to_block (pblock
, &se
.pre
);
2650 /* No upper bound was specified, so use the bound of the array. */
2651 bound
= gfc_conv_array_ubound (desc
, dim
);
2658 /* Calculate the lower bound of an array section. */
2661 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2671 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2673 info
= &ss
->data
.info
;
2676 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2678 /* We use a zero-based index to access the vector. */
2679 info
->start
[n
] = gfc_index_zero_node
;
2680 info
->end
[n
] = gfc_index_zero_node
;
2681 info
->stride
[n
] = gfc_index_one_node
;
2685 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2686 desc
= info
->descriptor
;
2687 start
= info
->ref
->u
.ar
.start
[dim
];
2688 end
= info
->ref
->u
.ar
.end
[dim
];
2689 stride
= info
->ref
->u
.ar
.stride
[dim
];
2691 /* Calculate the start of the range. For vector subscripts this will
2692 be the range of the vector. */
2695 /* Specified section start. */
2696 gfc_init_se (&se
, NULL
);
2697 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2698 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2699 info
->start
[n
] = se
.expr
;
2703 /* No lower bound specified so use the bound of the array. */
2704 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2706 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2708 /* Similarly calculate the end. Although this is not used in the
2709 scalarizer, it is needed when checking bounds and where the end
2710 is an expression with side-effects. */
2713 /* Specified section start. */
2714 gfc_init_se (&se
, NULL
);
2715 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2716 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2717 info
->end
[n
] = se
.expr
;
2721 /* No upper bound specified so use the bound of the array. */
2722 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
2724 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
2726 /* Calculate the stride. */
2728 info
->stride
[n
] = gfc_index_one_node
;
2731 gfc_init_se (&se
, NULL
);
2732 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2733 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2734 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2739 /* Calculates the range start and stride for a SS chain. Also gets the
2740 descriptor and data pointer. The range of vector subscripts is the size
2741 of the vector. Array bounds are also checked. */
2744 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2752 /* Determine the rank of the loop. */
2754 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2758 case GFC_SS_SECTION
:
2759 case GFC_SS_CONSTRUCTOR
:
2760 case GFC_SS_FUNCTION
:
2761 case GFC_SS_COMPONENT
:
2762 loop
->dimen
= ss
->data
.info
.dimen
;
2765 /* As usual, lbound and ubound are exceptions!. */
2766 case GFC_SS_INTRINSIC
:
2767 switch (ss
->expr
->value
.function
.isym
->id
)
2769 case GFC_ISYM_LBOUND
:
2770 case GFC_ISYM_UBOUND
:
2771 loop
->dimen
= ss
->data
.info
.dimen
;
2782 if (loop
->dimen
== 0)
2783 gfc_todo_error ("Unable to determine rank of expression");
2786 /* Loop over all the SS in the chain. */
2787 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2789 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2790 ss
->shape
= ss
->expr
->shape
;
2794 case GFC_SS_SECTION
:
2795 /* Get the descriptor for the array. */
2796 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2798 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2799 gfc_conv_section_startstride (loop
, ss
, n
);
2802 case GFC_SS_INTRINSIC
:
2803 switch (ss
->expr
->value
.function
.isym
->id
)
2805 /* Fall through to supply start and stride. */
2806 case GFC_ISYM_LBOUND
:
2807 case GFC_ISYM_UBOUND
:
2813 case GFC_SS_CONSTRUCTOR
:
2814 case GFC_SS_FUNCTION
:
2815 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2817 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2818 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
2819 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2828 /* The rest is just runtime bound checking. */
2829 if (flag_bounds_check
)
2832 tree lbound
, ubound
;
2834 tree size
[GFC_MAX_DIMENSIONS
];
2835 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
;
2840 gfc_start_block (&block
);
2842 for (n
= 0; n
< loop
->dimen
; n
++)
2843 size
[n
] = NULL_TREE
;
2845 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2847 if (ss
->type
!= GFC_SS_SECTION
)
2850 /* TODO: range checking for mapped dimensions. */
2851 info
= &ss
->data
.info
;
2853 /* This code only checks ranges. Elemental and vector
2854 dimensions are checked later. */
2855 for (n
= 0; n
< loop
->dimen
; n
++)
2860 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
2863 if (n
== info
->ref
->u
.ar
.dimen
- 1
2864 && (info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
2865 || info
->ref
->u
.ar
.as
->cp_was_assumed
))
2866 check_upper
= false;
2870 /* Zero stride is not allowed. */
2871 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
2872 gfc_index_zero_node
);
2873 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
2874 "of array '%s'", info
->dim
[n
]+1,
2875 ss
->expr
->symtree
->name
);
2876 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2879 desc
= ss
->data
.info
.descriptor
;
2881 /* This is the run-time equivalent of resolve.c's
2882 check_dimension(). The logical is more readable there
2883 than it is here, with all the trees. */
2884 lbound
= gfc_conv_array_lbound (desc
, dim
);
2887 ubound
= gfc_conv_array_ubound (desc
, dim
);
2891 /* non_zerosized is true when the selected range is not
2893 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
2894 info
->stride
[n
], gfc_index_zero_node
);
2895 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
2897 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2900 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
2901 info
->stride
[n
], gfc_index_zero_node
);
2902 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
2904 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2906 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2907 stride_pos
, stride_neg
);
2909 /* Check the start of the range against the lower and upper
2910 bounds of the array, if the range is not empty. */
2911 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, info
->start
[n
],
2913 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2914 non_zerosized
, tmp
);
2915 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2916 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2917 ss
->expr
->symtree
->name
);
2918 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2923 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
,
2924 info
->start
[n
], ubound
);
2925 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2926 non_zerosized
, tmp
);
2927 asprintf (&msg
, "%s, upper bound of dimension %d of array "
2928 "'%s' exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2929 ss
->expr
->symtree
->name
);
2930 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2934 /* Compute the last element of the range, which is not
2935 necessarily "end" (think 0:5:3, which doesn't contain 5)
2936 and check it against both lower and upper bounds. */
2937 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2939 tmp2
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp2
,
2941 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2944 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp2
, lbound
);
2945 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2946 non_zerosized
, tmp
);
2947 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2948 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2949 ss
->expr
->symtree
->name
);
2950 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2955 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp2
, ubound
);
2956 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2957 non_zerosized
, tmp
);
2958 asprintf (&msg
, "%s, upper bound of dimension %d of array "
2959 "'%s' exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2960 ss
->expr
->symtree
->name
);
2961 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2965 /* Check the section sizes match. */
2966 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2968 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2970 /* We remember the size of the first section, and check all the
2971 others against this. */
2975 fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
2976 asprintf (&msg
, "%s, size mismatch for dimension %d "
2977 "of array '%s'", gfc_msg_bounds
, info
->dim
[n
]+1,
2978 ss
->expr
->symtree
->name
);
2979 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2983 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2987 tmp
= gfc_finish_block (&block
);
2988 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2993 /* Return true if the two SS could be aliased, i.e. both point to the same data
2995 /* TODO: resolve aliases based on frontend expressions. */
2998 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3005 lsym
= lss
->expr
->symtree
->n
.sym
;
3006 rsym
= rss
->expr
->symtree
->n
.sym
;
3007 if (gfc_symbols_could_alias (lsym
, rsym
))
3010 if (rsym
->ts
.type
!= BT_DERIVED
3011 && lsym
->ts
.type
!= BT_DERIVED
)
3014 /* For derived types we must check all the component types. We can ignore
3015 array references as these will have the same base type as the previous
3017 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3019 if (lref
->type
!= REF_COMPONENT
)
3022 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3025 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3028 if (rref
->type
!= REF_COMPONENT
)
3031 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3036 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3038 if (rref
->type
!= REF_COMPONENT
)
3041 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3049 /* Resolve array data dependencies. Creates a temporary if required. */
3050 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3054 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3064 loop
->temp_ss
= NULL
;
3065 aref
= dest
->data
.info
.ref
;
3068 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3070 if (ss
->type
!= GFC_SS_SECTION
)
3073 if (gfc_could_be_alias (dest
, ss
)
3074 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3080 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
3082 lref
= dest
->expr
->ref
;
3083 rref
= ss
->expr
->ref
;
3085 nDepend
= gfc_dep_resolver (lref
, rref
);
3089 /* TODO : loop shifting. */
3092 /* Mark the dimensions for LOOP SHIFTING */
3093 for (n
= 0; n
< loop
->dimen
; n
++)
3095 int dim
= dest
->data
.info
.dim
[n
];
3097 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3099 else if (! gfc_is_same_range (&lref
->u
.ar
,
3100 &rref
->u
.ar
, dim
, 0))
3104 /* Put all the dimensions with dependencies in the
3107 for (n
= 0; n
< loop
->dimen
; n
++)
3109 gcc_assert (loop
->order
[n
] == n
);
3111 loop
->order
[dim
++] = n
;
3114 for (n
= 0; n
< loop
->dimen
; n
++)
3117 loop
->order
[dim
++] = n
;
3120 gcc_assert (dim
== loop
->dimen
);
3129 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3130 if (GFC_ARRAY_TYPE_P (base_type
)
3131 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3132 base_type
= gfc_get_element_type (base_type
);
3133 loop
->temp_ss
= gfc_get_ss ();
3134 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3135 loop
->temp_ss
->data
.temp
.type
= base_type
;
3136 loop
->temp_ss
->string_length
= dest
->string_length
;
3137 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3138 loop
->temp_ss
->next
= gfc_ss_terminator
;
3139 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3142 loop
->temp_ss
= NULL
;
3146 /* Initialize the scalarization loop. Creates the loop variables. Determines
3147 the range of the loop variables. Creates a temporary if required.
3148 Calculates how to transform from loop variables to array indices for each
3149 expression. Also generates code for scalar expressions which have been
3150 moved outside the loop. */
3153 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
3158 gfc_ss_info
*specinfo
;
3162 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3163 bool dynamic
[GFC_MAX_DIMENSIONS
];
3169 for (n
= 0; n
< loop
->dimen
; n
++)
3173 /* We use one SS term, and use that to determine the bounds of the
3174 loop for this dimension. We try to pick the simplest term. */
3175 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3179 /* The frontend has worked out the size for us. */
3184 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3186 /* An unknown size constructor will always be rank one.
3187 Higher rank constructors will either have known shape,
3188 or still be wrapped in a call to reshape. */
3189 gcc_assert (loop
->dimen
== 1);
3191 /* Always prefer to use the constructor bounds if the size
3192 can be determined at compile time. Prefer not to otherwise,
3193 since the general case involves realloc, and it's better to
3194 avoid that overhead if possible. */
3195 c
= ss
->expr
->value
.constructor
;
3196 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
3197 if (!dynamic
[n
] || !loopspec
[n
])
3202 /* TODO: Pick the best bound if we have a choice between a
3203 function and something else. */
3204 if (ss
->type
== GFC_SS_FUNCTION
)
3210 if (ss
->type
!= GFC_SS_SECTION
)
3214 specinfo
= &loopspec
[n
]->data
.info
;
3217 info
= &ss
->data
.info
;
3221 /* Criteria for choosing a loop specifier (most important first):
3222 doesn't need realloc
3228 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3230 else if (integer_onep (info
->stride
[n
])
3231 && !integer_onep (specinfo
->stride
[n
]))
3233 else if (INTEGER_CST_P (info
->stride
[n
])
3234 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3236 else if (INTEGER_CST_P (info
->start
[n
])
3237 && !INTEGER_CST_P (specinfo
->start
[n
]))
3239 /* We don't work out the upper bound.
3240 else if (INTEGER_CST_P (info->finish[n])
3241 && ! INTEGER_CST_P (specinfo->finish[n]))
3242 loopspec[n] = ss; */
3246 gfc_todo_error ("Unable to find scalarization loop specifier");
3248 info
= &loopspec
[n
]->data
.info
;
3250 /* Set the extents of this range. */
3251 cshape
= loopspec
[n
]->shape
;
3252 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3253 && INTEGER_CST_P (info
->stride
[n
]))
3255 loop
->from
[n
] = info
->start
[n
];
3256 mpz_set (i
, cshape
[n
]);
3257 mpz_sub_ui (i
, i
, 1);
3258 /* To = from + (size - 1) * stride. */
3259 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3260 if (!integer_onep (info
->stride
[n
]))
3261 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3262 tmp
, info
->stride
[n
]);
3263 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3264 loop
->from
[n
], tmp
);
3268 loop
->from
[n
] = info
->start
[n
];
3269 switch (loopspec
[n
]->type
)
3271 case GFC_SS_CONSTRUCTOR
:
3272 /* The upper bound is calculated when we expand the
3274 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3277 case GFC_SS_SECTION
:
3278 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3282 case GFC_SS_FUNCTION
:
3283 /* The loop bound will be set when we generate the call. */
3284 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3292 /* Transform everything so we have a simple incrementing variable. */
3293 if (integer_onep (info
->stride
[n
]))
3294 info
->delta
[n
] = gfc_index_zero_node
;
3297 /* Set the delta for this section. */
3298 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3299 /* Number of iterations is (end - start + step) / step.
3300 with start = 0, this simplifies to
3302 for (i = 0; i<=last; i++){...}; */
3303 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3304 loop
->to
[n
], loop
->from
[n
]);
3305 tmp
= fold_build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
3306 tmp
, info
->stride
[n
]);
3307 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3308 /* Make the loop variable start at 0. */
3309 loop
->from
[n
] = gfc_index_zero_node
;
3313 /* Add all the scalar code that can be taken out of the loops.
3314 This may include calculating the loop bounds, so do it before
3315 allocating the temporary. */
3316 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
3318 /* If we want a temporary then create it. */
3319 if (loop
->temp_ss
!= NULL
)
3321 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3322 tmp
= loop
->temp_ss
->data
.temp
.type
;
3323 len
= loop
->temp_ss
->string_length
;
3324 n
= loop
->temp_ss
->data
.temp
.dimen
;
3325 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3326 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3327 loop
->temp_ss
->data
.info
.dimen
= n
;
3328 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3329 &loop
->temp_ss
->data
.info
, tmp
, false, true,
3333 for (n
= 0; n
< loop
->temp_dim
; n
++)
3334 loopspec
[loop
->order
[n
]] = NULL
;
3338 /* For array parameters we don't have loop variables, so don't calculate the
3340 if (loop
->array_parameter
)
3343 /* Calculate the translation from loop variables to array indices. */
3344 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3346 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
3349 info
= &ss
->data
.info
;
3351 for (n
= 0; n
< info
->dimen
; n
++)
3355 /* If we are specifying the range the delta is already set. */
3356 if (loopspec
[n
] != ss
)
3358 /* Calculate the offset relative to the loop variable.
3359 First multiply by the stride. */
3360 tmp
= loop
->from
[n
];
3361 if (!integer_onep (info
->stride
[n
]))
3362 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3363 tmp
, info
->stride
[n
]);
3365 /* Then subtract this from our starting value. */
3366 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3367 info
->start
[n
], tmp
);
3369 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3376 /* Fills in an array descriptor, and returns the size of the array. The size
3377 will be a simple_val, ie a variable or a constant. Also calculates the
3378 offset of the base. Returns the size of the array.
3382 for (n = 0; n < rank; n++)
3384 a.lbound[n] = specified_lower_bound;
3385 offset = offset + a.lbond[n] * stride;
3387 a.ubound[n] = specified_upper_bound;
3388 a.stride[n] = stride;
3389 size = ubound + size; //size = ubound + 1 - lbound
3390 stride = stride * size;
3397 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3398 gfc_expr
** lower
, gfc_expr
** upper
,
3399 stmtblock_t
* pblock
)
3411 stmtblock_t thenblock
;
3412 stmtblock_t elseblock
;
3417 type
= TREE_TYPE (descriptor
);
3419 stride
= gfc_index_one_node
;
3420 offset
= gfc_index_zero_node
;
3422 /* Set the dtype. */
3423 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3424 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3426 or_expr
= NULL_TREE
;
3428 for (n
= 0; n
< rank
; n
++)
3430 /* We have 3 possibilities for determining the size of the array:
3431 lower == NULL => lbound = 1, ubound = upper[n]
3432 upper[n] = NULL => lbound = 1, ubound = lower[n]
3433 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3436 /* Set lower bound. */
3437 gfc_init_se (&se
, NULL
);
3439 se
.expr
= gfc_index_one_node
;
3442 gcc_assert (lower
[n
]);
3445 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3446 gfc_add_block_to_block (pblock
, &se
.pre
);
3450 se
.expr
= gfc_index_one_node
;
3454 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
3455 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3457 /* Work out the offset for this component. */
3458 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3459 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3461 /* Start the calculation for the size of this dimension. */
3462 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3463 gfc_index_one_node
, se
.expr
);
3465 /* Set upper bound. */
3466 gfc_init_se (&se
, NULL
);
3467 gcc_assert (ubound
);
3468 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3469 gfc_add_block_to_block (pblock
, &se
.pre
);
3471 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
3472 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3474 /* Store the stride. */
3475 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
3476 gfc_add_modify_expr (pblock
, tmp
, stride
);
3478 /* Calculate the size of this dimension. */
3479 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3481 /* Check whether the size for this dimension is negative. */
3482 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3483 gfc_index_zero_node
);
3487 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3489 /* Multiply the stride by the number of elements in this dimension. */
3490 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3491 stride
= gfc_evaluate_now (stride
, pblock
);
3494 /* The stride is the number of elements in the array, so multiply by the
3495 size of an element to get the total size. */
3496 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3497 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3498 fold_convert (gfc_array_index_type
, tmp
));
3500 if (poffset
!= NULL
)
3502 offset
= gfc_evaluate_now (offset
, pblock
);
3506 if (integer_zerop (or_expr
))
3508 if (integer_onep (or_expr
))
3509 return gfc_index_zero_node
;
3511 var
= gfc_create_var (TREE_TYPE (size
), "size");
3512 gfc_start_block (&thenblock
);
3513 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
3514 thencase
= gfc_finish_block (&thenblock
);
3516 gfc_start_block (&elseblock
);
3517 gfc_add_modify_expr (&elseblock
, var
, size
);
3518 elsecase
= gfc_finish_block (&elseblock
);
3520 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3521 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3522 gfc_add_expr_to_block (pblock
, tmp
);
3528 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3529 the work for an ALLOCATE statement. */
3533 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3542 gfc_ref
*ref
, *prev_ref
= NULL
;
3543 bool allocatable_array
;
3547 /* Find the last reference in the chain. */
3548 while (ref
&& ref
->next
!= NULL
)
3550 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3555 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3559 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3561 allocatable_array
= prev_ref
->u
.c
.component
->allocatable
;
3563 /* Figure out the size of the array. */
3564 switch (ref
->u
.ar
.type
)
3568 upper
= ref
->u
.ar
.start
;
3572 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
3574 lower
= ref
->u
.ar
.as
->lower
;
3575 upper
= ref
->u
.ar
.as
->upper
;
3579 lower
= ref
->u
.ar
.start
;
3580 upper
= ref
->u
.ar
.end
;
3588 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
3589 lower
, upper
, &se
->pre
);
3591 /* Allocate memory to store the data. */
3592 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
3593 STRIP_NOPS (pointer
);
3595 if (TYPE_PRECISION (gfc_array_index_type
) == 32 ||
3596 TYPE_PRECISION (gfc_array_index_type
) == 64)
3598 if (allocatable_array
)
3599 allocate
= gfor_fndecl_allocate_array
;
3601 allocate
= gfor_fndecl_allocate
;
3606 /* The allocate_array variants take the old pointer as first argument. */
3607 if (allocatable_array
)
3608 tmp
= build_call_expr (allocate
, 3, pointer
, size
, pstat
);
3610 tmp
= build_call_expr (allocate
, 2, size
, pstat
);
3611 tmp
= build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
3612 gfc_add_expr_to_block (&se
->pre
, tmp
);
3614 tmp
= gfc_conv_descriptor_offset (se
->expr
);
3615 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
3617 if (expr
->ts
.type
== BT_DERIVED
3618 && expr
->ts
.derived
->attr
.alloc_comp
)
3620 tmp
= gfc_nullify_alloc_comp (expr
->ts
.derived
, se
->expr
,
3621 ref
->u
.ar
.as
->rank
);
3622 gfc_add_expr_to_block (&se
->pre
, tmp
);
3629 /* Deallocate an array variable. Also used when an allocated variable goes
3634 gfc_array_deallocate (tree descriptor
, tree pstat
)
3640 gfc_start_block (&block
);
3641 /* Get a pointer to the data. */
3642 var
= gfc_conv_descriptor_data_get (descriptor
);
3645 /* Parameter is the address of the data component. */
3646 tmp
= build_call_expr (gfor_fndecl_deallocate
, 2, var
, pstat
);
3647 gfc_add_expr_to_block (&block
, tmp
);
3649 /* Zero the data pointer. */
3650 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
3651 var
, build_int_cst (TREE_TYPE (var
), 0));
3652 gfc_add_expr_to_block (&block
, tmp
);
3654 return gfc_finish_block (&block
);
3658 /* Create an array constructor from an initialization expression.
3659 We assume the frontend already did any expansions and conversions. */
3662 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3669 unsigned HOST_WIDE_INT lo
;
3671 VEC(constructor_elt
,gc
) *v
= NULL
;
3673 switch (expr
->expr_type
)
3676 case EXPR_STRUCTURE
:
3677 /* A single scalar or derived type value. Create an array with all
3678 elements equal to that value. */
3679 gfc_init_se (&se
, NULL
);
3681 if (expr
->expr_type
== EXPR_CONSTANT
)
3682 gfc_conv_constant (&se
, expr
);
3684 gfc_conv_structure (&se
, expr
, 1);
3686 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3687 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3688 hi
= TREE_INT_CST_HIGH (tmp
);
3689 lo
= TREE_INT_CST_LOW (tmp
);
3693 /* This will probably eat buckets of memory for large arrays. */
3694 while (hi
!= 0 || lo
!= 0)
3696 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3704 /* Create a vector of all the elements. */
3705 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3709 /* Problems occur when we get something like
3710 integer :: a(lots) = (/(i, i=1,lots)/) */
3711 /* TODO: Unexpanded array initializers. */
3713 ("Possible frontend bug: array constructor not expanded");
3715 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3716 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3720 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3724 mpz_set (maxval
, c
->repeat
);
3725 mpz_add (maxval
, c
->n
.offset
, maxval
);
3726 mpz_sub_ui (maxval
, maxval
, 1);
3727 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3728 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3730 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3731 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3734 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3736 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3742 gfc_init_se (&se
, NULL
);
3743 switch (c
->expr
->expr_type
)
3746 gfc_conv_constant (&se
, c
->expr
);
3747 if (range
== NULL_TREE
)
3748 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3751 if (index
!= NULL_TREE
)
3752 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3753 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3757 case EXPR_STRUCTURE
:
3758 gfc_conv_structure (&se
, c
->expr
, 1);
3759 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3769 return gfc_build_null_descriptor (type
);
3775 /* Create a constructor from the list of elements. */
3776 tmp
= build_constructor (type
, v
);
3777 TREE_CONSTANT (tmp
) = 1;
3778 TREE_INVARIANT (tmp
) = 1;
3783 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3784 returns the size (in elements) of the array. */
3787 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3788 stmtblock_t
* pblock
)
3803 size
= gfc_index_one_node
;
3804 offset
= gfc_index_zero_node
;
3805 for (dim
= 0; dim
< as
->rank
; dim
++)
3807 /* Evaluate non-constant array bound expressions. */
3808 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3809 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3811 gfc_init_se (&se
, NULL
);
3812 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3813 gfc_add_block_to_block (pblock
, &se
.pre
);
3814 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3816 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3817 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3819 gfc_init_se (&se
, NULL
);
3820 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3821 gfc_add_block_to_block (pblock
, &se
.pre
);
3822 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
3824 /* The offset of this dimension. offset = offset - lbound * stride. */
3825 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
3826 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3828 /* The size of this dimension, and the stride of the next. */
3829 if (dim
+ 1 < as
->rank
)
3830 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3832 stride
= GFC_TYPE_ARRAY_SIZE (type
);
3834 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3836 /* Calculate stride = size * (ubound + 1 - lbound). */
3837 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3838 gfc_index_one_node
, lbound
);
3839 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
3840 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3842 gfc_add_modify_expr (pblock
, stride
, tmp
);
3844 stride
= gfc_evaluate_now (tmp
, pblock
);
3846 /* Make sure that negative size arrays are translated
3847 to being zero size. */
3848 tmp
= build2 (GE_EXPR
, boolean_type_node
,
3849 stride
, gfc_index_zero_node
);
3850 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3851 stride
, gfc_index_zero_node
);
3852 gfc_add_modify_expr (pblock
, stride
, tmp
);
3858 gfc_trans_vla_type_sizes (sym
, pblock
);
3865 /* Generate code to initialize/allocate an array variable. */
3868 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3877 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3879 /* Do nothing for USEd variables. */
3880 if (sym
->attr
.use_assoc
)
3883 type
= TREE_TYPE (decl
);
3884 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3885 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3887 gfc_start_block (&block
);
3889 /* Evaluate character string length. */
3890 if (sym
->ts
.type
== BT_CHARACTER
3891 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3893 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3895 gfc_trans_vla_type_sizes (sym
, &block
);
3897 /* Emit a DECL_EXPR for this variable, which will cause the
3898 gimplifier to allocate storage, and all that good stuff. */
3899 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3900 gfc_add_expr_to_block (&block
, tmp
);
3905 gfc_add_expr_to_block (&block
, fnbody
);
3906 return gfc_finish_block (&block
);
3909 type
= TREE_TYPE (type
);
3911 gcc_assert (!sym
->attr
.use_assoc
);
3912 gcc_assert (!TREE_STATIC (decl
));
3913 gcc_assert (!sym
->module
);
3915 if (sym
->ts
.type
== BT_CHARACTER
3916 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3917 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3919 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3921 /* Don't actually allocate space for Cray Pointees. */
3922 if (sym
->attr
.cray_pointee
)
3924 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3925 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3926 gfc_add_expr_to_block (&block
, fnbody
);
3927 return gfc_finish_block (&block
);
3930 /* The size is the number of elements in the array, so multiply by the
3931 size of an element to get the total size. */
3932 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3933 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
3934 fold_convert (gfc_array_index_type
, tmp
));
3936 /* Allocate memory to hold the data. */
3937 tmp
= gfc_call_malloc (&block
, TREE_TYPE (decl
), size
);
3938 gfc_add_modify_expr (&block
, decl
, tmp
);
3940 /* Set offset of the array. */
3941 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3942 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3945 /* Automatic arrays should not have initializers. */
3946 gcc_assert (!sym
->value
);
3948 gfc_add_expr_to_block (&block
, fnbody
);
3950 /* Free the temporary. */
3951 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
3952 gfc_add_expr_to_block (&block
, tmp
);
3954 return gfc_finish_block (&block
);
3958 /* Generate entry and exit code for g77 calling convention arrays. */
3961 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3971 gfc_get_backend_locus (&loc
);
3972 gfc_set_backend_locus (&sym
->declared_at
);
3974 /* Descriptor type. */
3975 parm
= sym
->backend_decl
;
3976 type
= TREE_TYPE (parm
);
3977 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3979 gfc_start_block (&block
);
3981 if (sym
->ts
.type
== BT_CHARACTER
3982 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3983 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3985 /* Evaluate the bounds of the array. */
3986 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3988 /* Set the offset. */
3989 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3990 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3992 /* Set the pointer itself if we aren't using the parameter directly. */
3993 if (TREE_CODE (parm
) != PARM_DECL
)
3995 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3996 gfc_add_modify_expr (&block
, parm
, tmp
);
3998 stmt
= gfc_finish_block (&block
);
4000 gfc_set_backend_locus (&loc
);
4002 gfc_start_block (&block
);
4004 /* Add the initialization code to the start of the function. */
4006 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4008 tmp
= gfc_conv_expr_present (sym
);
4009 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4012 gfc_add_expr_to_block (&block
, stmt
);
4013 gfc_add_expr_to_block (&block
, body
);
4015 return gfc_finish_block (&block
);
4019 /* Modify the descriptor of an array parameter so that it has the
4020 correct lower bound. Also move the upper bound accordingly.
4021 If the array is not packed, it will be copied into a temporary.
4022 For each dimension we set the new lower and upper bounds. Then we copy the
4023 stride and calculate the offset for this dimension. We also work out
4024 what the stride of a packed array would be, and see it the two match.
4025 If the array need repacking, we set the stride to the values we just
4026 calculated, recalculate the offset and copy the array data.
4027 Code is also added to copy the data back at the end of the function.
4031 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
4038 stmtblock_t cleanup
;
4046 tree stride
, stride2
;
4056 /* Do nothing for pointer and allocatable arrays. */
4057 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4060 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4061 return gfc_trans_g77_array (sym
, body
);
4063 gfc_get_backend_locus (&loc
);
4064 gfc_set_backend_locus (&sym
->declared_at
);
4066 /* Descriptor type. */
4067 type
= TREE_TYPE (tmpdesc
);
4068 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4069 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4070 dumdesc
= build_fold_indirect_ref (dumdesc
);
4071 gfc_start_block (&block
);
4073 if (sym
->ts
.type
== BT_CHARACTER
4074 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
4075 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
4077 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
4079 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4080 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4082 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4084 /* For non-constant shape arrays we only check if the first dimension
4085 is contiguous. Repacking higher dimensions wouldn't gain us
4086 anything as we still don't know the array stride. */
4087 partial
= gfc_create_var (boolean_type_node
, "partial");
4088 TREE_USED (partial
) = 1;
4089 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4090 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4091 gfc_add_modify_expr (&block
, partial
, tmp
);
4095 partial
= NULL_TREE
;
4098 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4099 here, however I think it does the right thing. */
4102 /* Set the first stride. */
4103 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
4104 stride
= gfc_evaluate_now (stride
, &block
);
4106 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, gfc_index_zero_node
);
4107 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4108 gfc_index_one_node
, stride
);
4109 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4110 gfc_add_modify_expr (&block
, stride
, tmp
);
4112 /* Allow the user to disable array repacking. */
4113 stmt_unpacked
= NULL_TREE
;
4117 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4118 /* A library call to repack the array if necessary. */
4119 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4120 stmt_unpacked
= build_call_expr (gfor_fndecl_in_pack
, 1, tmp
);
4122 stride
= gfc_index_one_node
;
4125 /* This is for the case where the array data is used directly without
4126 calling the repack function. */
4127 if (no_repack
|| partial
!= NULL_TREE
)
4128 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4130 stmt_packed
= NULL_TREE
;
4132 /* Assign the data pointer. */
4133 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4135 /* Don't repack unknown shape arrays when the first stride is 1. */
4136 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
4137 stmt_packed
, stmt_unpacked
);
4140 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4141 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
4143 offset
= gfc_index_zero_node
;
4144 size
= gfc_index_one_node
;
4146 /* Evaluate the bounds of the array. */
4147 for (n
= 0; n
< sym
->as
->rank
; n
++)
4149 if (checkparm
|| !sym
->as
->upper
[n
])
4151 /* Get the bounds of the actual parameter. */
4152 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
4153 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
4157 dubound
= NULL_TREE
;
4158 dlbound
= NULL_TREE
;
4161 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4162 if (!INTEGER_CST_P (lbound
))
4164 gfc_init_se (&se
, NULL
);
4165 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4166 gfc_array_index_type
);
4167 gfc_add_block_to_block (&block
, &se
.pre
);
4168 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
4171 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4172 /* Set the desired upper bound. */
4173 if (sym
->as
->upper
[n
])
4175 /* We know what we want the upper bound to be. */
4176 if (!INTEGER_CST_P (ubound
))
4178 gfc_init_se (&se
, NULL
);
4179 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4180 gfc_array_index_type
);
4181 gfc_add_block_to_block (&block
, &se
.pre
);
4182 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
4185 /* Check the sizes match. */
4188 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4191 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4193 stride2
= build2 (MINUS_EXPR
, gfc_array_index_type
,
4195 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
4196 asprintf (&msg
, "%s for dimension %d of array '%s'",
4197 gfc_msg_bounds
, n
+1, sym
->name
);
4198 gfc_trans_runtime_check (tmp
, msg
, &block
, &loc
);
4204 /* For assumed shape arrays move the upper bound by the same amount
4205 as the lower bound. */
4206 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
4207 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4208 gfc_add_modify_expr (&block
, ubound
, tmp
);
4210 /* The offset of this dimension. offset = offset - lbound * stride. */
4211 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4212 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4214 /* The size of this dimension, and the stride of the next. */
4215 if (n
+ 1 < sym
->as
->rank
)
4217 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4219 if (no_repack
|| partial
!= NULL_TREE
)
4222 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
4225 /* Figure out the stride if not a known constant. */
4226 if (!INTEGER_CST_P (stride
))
4229 stmt_packed
= NULL_TREE
;
4232 /* Calculate stride = size * (ubound + 1 - lbound). */
4233 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4234 gfc_index_one_node
, lbound
);
4235 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4237 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4242 /* Assign the stride. */
4243 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4244 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4245 stmt_unpacked
, stmt_packed
);
4247 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4248 gfc_add_modify_expr (&block
, stride
, tmp
);
4253 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4255 if (stride
&& !INTEGER_CST_P (stride
))
4257 /* Calculate size = stride * (ubound + 1 - lbound). */
4258 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4259 gfc_index_one_node
, lbound
);
4260 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4262 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4263 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4264 gfc_add_modify_expr (&block
, stride
, tmp
);
4269 /* Set the offset. */
4270 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4271 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4273 gfc_trans_vla_type_sizes (sym
, &block
);
4275 stmt
= gfc_finish_block (&block
);
4277 gfc_start_block (&block
);
4279 /* Only do the entry/initialization code if the arg is present. */
4280 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4281 optional_arg
= (sym
->attr
.optional
4282 || (sym
->ns
->proc_name
->attr
.entry_master
4283 && sym
->attr
.dummy
));
4286 tmp
= gfc_conv_expr_present (sym
);
4287 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4289 gfc_add_expr_to_block (&block
, stmt
);
4291 /* Add the main function body. */
4292 gfc_add_expr_to_block (&block
, body
);
4297 gfc_start_block (&cleanup
);
4299 if (sym
->attr
.intent
!= INTENT_IN
)
4301 /* Copy the data back. */
4302 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4303 gfc_add_expr_to_block (&cleanup
, tmp
);
4306 /* Free the temporary. */
4307 tmp
= gfc_call_free (tmpdesc
);
4308 gfc_add_expr_to_block (&cleanup
, tmp
);
4310 stmt
= gfc_finish_block (&cleanup
);
4312 /* Only do the cleanup if the array was repacked. */
4313 tmp
= build_fold_indirect_ref (dumdesc
);
4314 tmp
= gfc_conv_descriptor_data_get (tmp
);
4315 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4316 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4320 tmp
= gfc_conv_expr_present (sym
);
4321 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4323 gfc_add_expr_to_block (&block
, stmt
);
4325 /* We don't need to free any memory allocated by internal_pack as it will
4326 be freed at the end of the function by pop_context. */
4327 return gfc_finish_block (&block
);
4331 /* Convert an array for passing as an actual argument. Expressions and
4332 vector subscripts are evaluated and stored in a temporary, which is then
4333 passed. For whole arrays the descriptor is passed. For array sections
4334 a modified copy of the descriptor is passed, but using the original data.
4336 This function is also used for array pointer assignments, and there
4339 - se->want_pointer && !se->direct_byref
4340 EXPR is an actual argument. On exit, se->expr contains a
4341 pointer to the array descriptor.
4343 - !se->want_pointer && !se->direct_byref
4344 EXPR is an actual argument to an intrinsic function or the
4345 left-hand side of a pointer assignment. On exit, se->expr
4346 contains the descriptor for EXPR.
4348 - !se->want_pointer && se->direct_byref
4349 EXPR is the right-hand side of a pointer assignment and
4350 se->expr is the descriptor for the previously-evaluated
4351 left-hand side. The function creates an assignment from
4352 EXPR to se->expr. */
4355 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
4369 gcc_assert (ss
!= gfc_ss_terminator
);
4371 /* Special case things we know we can pass easily. */
4372 switch (expr
->expr_type
)
4375 /* If we have a linear array section, we can pass it directly.
4376 Otherwise we need to copy it into a temporary. */
4378 /* Find the SS for the array section. */
4380 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
4381 secss
= secss
->next
;
4383 gcc_assert (secss
!= gfc_ss_terminator
);
4384 info
= &secss
->data
.info
;
4386 /* Get the descriptor for the array. */
4387 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
4388 desc
= info
->descriptor
;
4390 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
);
4393 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4395 /* Create a new descriptor if the array doesn't have one. */
4398 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
4400 else if (se
->direct_byref
)
4403 full
= gfc_full_array_ref_p (info
->ref
);
4407 if (se
->direct_byref
)
4409 /* Copy the descriptor for pointer assignments. */
4410 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
4412 else if (se
->want_pointer
)
4414 /* We pass full arrays directly. This means that pointers and
4415 allocatable arrays should also work. */
4416 se
->expr
= build_fold_addr_expr (desc
);
4423 if (expr
->ts
.type
== BT_CHARACTER
)
4424 se
->string_length
= gfc_get_expr_charlen (expr
);
4431 /* A transformational function return value will be a temporary
4432 array descriptor. We still need to go through the scalarizer
4433 to create the descriptor. Elemental functions ar handled as
4434 arbitrary expressions, i.e. copy to a temporary. */
4436 /* Look for the SS for this function. */
4437 while (secss
!= gfc_ss_terminator
4438 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
4439 secss
= secss
->next
;
4441 if (se
->direct_byref
)
4443 gcc_assert (secss
!= gfc_ss_terminator
);
4445 /* For pointer assignments pass the descriptor directly. */
4447 se
->expr
= build_fold_addr_expr (se
->expr
);
4448 gfc_conv_expr (se
, expr
);
4452 if (secss
== gfc_ss_terminator
)
4454 /* Elemental function. */
4460 /* Transformational function. */
4461 info
= &secss
->data
.info
;
4467 /* Constant array constructors don't need a temporary. */
4468 if (ss
->type
== GFC_SS_CONSTRUCTOR
4469 && expr
->ts
.type
!= BT_CHARACTER
4470 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
4473 info
= &ss
->data
.info
;
4485 /* Something complicated. Copy it into a temporary. */
4493 gfc_init_loopinfo (&loop
);
4495 /* Associate the SS with the loop. */
4496 gfc_add_ss_to_loop (&loop
, ss
);
4498 /* Tell the scalarizer not to bother creating loop variables, etc. */
4500 loop
.array_parameter
= 1;
4502 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4503 gcc_assert (!se
->direct_byref
);
4505 /* Setup the scalarizing loops and bounds. */
4506 gfc_conv_ss_startstride (&loop
);
4510 /* Tell the scalarizer to make a temporary. */
4511 loop
.temp_ss
= gfc_get_ss ();
4512 loop
.temp_ss
->type
= GFC_SS_TEMP
;
4513 loop
.temp_ss
->next
= gfc_ss_terminator
;
4514 if (expr
->ts
.type
== BT_CHARACTER
)
4516 if (expr
->ts
.cl
== NULL
)
4518 /* This had better be a substring reference! */
4519 gfc_ref
*char_ref
= expr
->ref
;
4520 for (; char_ref
; char_ref
= char_ref
->next
)
4521 if (char_ref
->type
== REF_SUBSTRING
)
4524 expr
->ts
.cl
= gfc_get_charlen ();
4525 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
4526 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
4528 mpz_init_set_ui (char_len
, 1);
4529 mpz_add (char_len
, char_len
,
4530 char_ref
->u
.ss
.end
->value
.integer
);
4531 mpz_sub (char_len
, char_len
,
4532 char_ref
->u
.ss
.start
->value
.integer
);
4533 expr
->ts
.cl
->backend_decl
4534 = gfc_conv_mpz_to_tree (char_len
,
4535 gfc_default_character_kind
);
4536 /* Cast is necessary for *-charlen refs. */
4537 expr
->ts
.cl
->backend_decl
4538 = convert (gfc_charlen_type_node
,
4539 expr
->ts
.cl
->backend_decl
);
4540 mpz_clear (char_len
);
4543 gcc_assert (char_ref
!= NULL
);
4544 loop
.temp_ss
->data
.temp
.type
4545 = gfc_typenode_for_spec (&expr
->ts
);
4546 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4548 else if (expr
->ts
.cl
->length
4549 && expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4551 expr
->ts
.cl
->backend_decl
4552 = gfc_conv_mpz_to_tree (expr
->ts
.cl
->length
->value
.integer
,
4553 expr
->ts
.cl
->length
->ts
.kind
);
4554 loop
.temp_ss
->data
.temp
.type
4555 = gfc_typenode_for_spec (&expr
->ts
);
4556 loop
.temp_ss
->string_length
4557 = TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
4561 loop
.temp_ss
->data
.temp
.type
4562 = gfc_typenode_for_spec (&expr
->ts
);
4563 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4565 se
->string_length
= loop
.temp_ss
->string_length
;
4569 loop
.temp_ss
->data
.temp
.type
4570 = gfc_typenode_for_spec (&expr
->ts
);
4571 loop
.temp_ss
->string_length
= NULL
;
4573 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
4574 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4577 gfc_conv_loop_setup (&loop
);
4581 /* Copy into a temporary and pass that. We don't need to copy the data
4582 back because expressions and vector subscripts must be INTENT_IN. */
4583 /* TODO: Optimize passing function return values. */
4587 /* Start the copying loops. */
4588 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4589 gfc_mark_ss_chain_used (ss
, 1);
4590 gfc_start_scalarized_body (&loop
, &block
);
4592 /* Copy each data element. */
4593 gfc_init_se (&lse
, NULL
);
4594 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4595 gfc_init_se (&rse
, NULL
);
4596 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4598 lse
.ss
= loop
.temp_ss
;
4601 gfc_conv_scalarized_array_ref (&lse
, NULL
);
4602 if (expr
->ts
.type
== BT_CHARACTER
)
4604 gfc_conv_expr (&rse
, expr
);
4605 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
4606 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4609 gfc_conv_expr_val (&rse
, expr
);
4611 gfc_add_block_to_block (&block
, &rse
.pre
);
4612 gfc_add_block_to_block (&block
, &lse
.pre
);
4614 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
4616 /* Finish the copying loops. */
4617 gfc_trans_scalarizing_loops (&loop
, &block
);
4619 desc
= loop
.temp_ss
->data
.info
.descriptor
;
4621 gcc_assert (is_gimple_lvalue (desc
));
4623 else if (expr
->expr_type
== EXPR_FUNCTION
)
4625 desc
= info
->descriptor
;
4626 se
->string_length
= ss
->string_length
;
4630 /* We pass sections without copying to a temporary. Make a new
4631 descriptor and point it at the section we want. The loop variable
4632 limits will be the limits of the section.
4633 A function may decide to repack the array to speed up access, but
4634 we're not bothered about that here. */
4643 /* Set the string_length for a character array. */
4644 if (expr
->ts
.type
== BT_CHARACTER
)
4645 se
->string_length
= gfc_get_expr_charlen (expr
);
4647 desc
= info
->descriptor
;
4648 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
4649 if (se
->direct_byref
)
4651 /* For pointer assignments we fill in the destination. */
4653 parmtype
= TREE_TYPE (parm
);
4657 /* Otherwise make a new one. */
4658 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4659 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
4660 loop
.from
, loop
.to
, 0);
4661 parm
= gfc_create_var (parmtype
, "parm");
4664 offset
= gfc_index_zero_node
;
4667 /* The following can be somewhat confusing. We have two
4668 descriptors, a new one and the original array.
4669 {parm, parmtype, dim} refer to the new one.
4670 {desc, type, n, secss, loop} refer to the original, which maybe
4671 a descriptorless array.
4672 The bounds of the scalarization are the bounds of the section.
4673 We don't have to worry about numeric overflows when calculating
4674 the offsets because all elements are within the array data. */
4676 /* Set the dtype. */
4677 tmp
= gfc_conv_descriptor_dtype (parm
);
4678 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
4680 if (se
->direct_byref
)
4681 base
= gfc_index_zero_node
;
4682 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4683 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
4687 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
4688 for (n
= 0; n
< ndim
; n
++)
4690 stride
= gfc_conv_array_stride (desc
, n
);
4692 /* Work out the offset. */
4694 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4696 gcc_assert (info
->subscript
[n
]
4697 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
4698 start
= info
->subscript
[n
]->data
.scalar
.expr
;
4702 /* Check we haven't somehow got out of sync. */
4703 gcc_assert (info
->dim
[dim
] == n
);
4705 /* Evaluate and remember the start of the section. */
4706 start
= info
->start
[dim
];
4707 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
4710 tmp
= gfc_conv_array_lbound (desc
, n
);
4711 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
4713 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
4714 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
4717 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4719 /* For elemental dimensions, we only need the offset. */
4723 /* Vector subscripts need copying and are handled elsewhere. */
4725 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
4727 /* Set the new lower bound. */
4728 from
= loop
.from
[dim
];
4731 /* If we have an array section or are assigning to a pointer,
4732 make sure that the lower bound is 1. References to the full
4733 array should otherwise keep the original bounds. */
4735 || info
->ref
->u
.ar
.type
!= AR_FULL
4736 || se
->direct_byref
)
4737 && !integer_onep (from
))
4739 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4740 gfc_index_one_node
, from
);
4741 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
4742 from
= gfc_index_one_node
;
4744 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
4745 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
4747 /* Set the new upper bound. */
4748 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
4749 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
4751 /* Multiply the stride by the section stride to get the
4753 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4754 stride
, info
->stride
[dim
]);
4756 if (se
->direct_byref
)
4758 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4761 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4763 tmp
= gfc_conv_array_lbound (desc
, n
);
4764 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4765 tmp
, loop
.from
[dim
]);
4766 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
4767 tmp
, gfc_conv_array_stride (desc
, n
));
4768 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
4772 /* Store the new stride. */
4773 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
4774 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
4779 if (se
->data_not_needed
)
4780 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, gfc_index_zero_node
);
4783 /* Point the data pointer at the first element in the section. */
4784 tmp
= gfc_conv_array_data (desc
);
4785 tmp
= build_fold_indirect_ref (tmp
);
4786 tmp
= gfc_build_array_ref (tmp
, offset
);
4787 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4788 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, offset
);
4791 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4792 && !se
->data_not_needed
)
4794 /* Set the offset. */
4795 tmp
= gfc_conv_descriptor_offset (parm
);
4796 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
4800 /* Only the callee knows what the correct offset it, so just set
4802 tmp
= gfc_conv_descriptor_offset (parm
);
4803 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
4808 if (!se
->direct_byref
)
4810 /* Get a pointer to the new descriptor. */
4811 if (se
->want_pointer
)
4812 se
->expr
= build_fold_addr_expr (desc
);
4817 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4818 gfc_add_block_to_block (&se
->post
, &loop
.post
);
4820 /* Cleanup the scalarizer. */
4821 gfc_cleanup_loop (&loop
);
4825 /* Convert an array for passing as an actual parameter. */
4826 /* TODO: Optimize passing g77 arrays. */
4829 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
4833 tree tmp
= NULL_TREE
;
4835 tree parent
= DECL_CONTEXT (current_function_decl
);
4836 bool full_array_var
, this_array_result
;
4840 full_array_var
= (expr
->expr_type
== EXPR_VARIABLE
4841 && expr
->ref
->u
.ar
.type
== AR_FULL
);
4842 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
4844 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
4846 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
4847 expr
->ts
.cl
->backend_decl
= gfc_evaluate_now (tmp
, &se
->pre
);
4848 se
->string_length
= expr
->ts
.cl
->backend_decl
;
4851 /* Is this the result of the enclosing procedure? */
4852 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
4853 if (this_array_result
4854 && (sym
->backend_decl
!= current_function_decl
)
4855 && (sym
->backend_decl
!= parent
))
4856 this_array_result
= false;
4858 /* Passing address of the array if it is not pointer or assumed-shape. */
4859 if (full_array_var
&& g77
&& !this_array_result
)
4861 tmp
= gfc_get_symbol_decl (sym
);
4863 if (sym
->ts
.type
== BT_CHARACTER
)
4864 se
->string_length
= sym
->ts
.cl
->backend_decl
;
4865 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
4866 && !sym
->attr
.allocatable
)
4868 /* Some variables are declared directly, others are declared as
4869 pointers and allocated on the heap. */
4870 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
4873 se
->expr
= build_fold_addr_expr (tmp
);
4876 if (sym
->attr
.allocatable
)
4878 if (sym
->attr
.dummy
)
4880 gfc_conv_expr_descriptor (se
, expr
, ss
);
4881 se
->expr
= gfc_conv_array_data (se
->expr
);
4884 se
->expr
= gfc_conv_array_data (tmp
);
4889 if (this_array_result
)
4891 /* Result of the enclosing function. */
4892 gfc_conv_expr_descriptor (se
, expr
, ss
);
4893 se
->expr
= build_fold_addr_expr (se
->expr
);
4895 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
4896 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4897 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref (se
->expr
));
4903 /* Every other type of array. */
4904 se
->want_pointer
= 1;
4905 gfc_conv_expr_descriptor (se
, expr
, ss
);
4909 /* Deallocate the allocatable components of structures that are
4911 if (expr
->ts
.type
== BT_DERIVED
4912 && expr
->ts
.derived
->attr
.alloc_comp
4913 && expr
->expr_type
!= EXPR_VARIABLE
)
4915 tmp
= build_fold_indirect_ref (se
->expr
);
4916 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.derived
, tmp
, expr
->rank
);
4917 gfc_add_expr_to_block (&se
->post
, tmp
);
4923 /* Repack the array. */
4924 ptr
= build_call_expr (gfor_fndecl_in_pack
, 1, desc
);
4925 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
4928 gfc_start_block (&block
);
4930 /* Copy the data back. */
4931 tmp
= build_call_expr (gfor_fndecl_in_unpack
, 2, desc
, ptr
);
4932 gfc_add_expr_to_block (&block
, tmp
);
4934 /* Free the temporary. */
4935 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
4936 gfc_add_expr_to_block (&block
, tmp
);
4938 stmt
= gfc_finish_block (&block
);
4940 gfc_init_block (&block
);
4941 /* Only if it was repacked. This code needs to be executed before the
4942 loop cleanup code. */
4943 tmp
= build_fold_indirect_ref (desc
);
4944 tmp
= gfc_conv_array_data (tmp
);
4945 tmp
= build2 (NE_EXPR
, boolean_type_node
,
4946 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
4947 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4949 gfc_add_expr_to_block (&block
, tmp
);
4950 gfc_add_block_to_block (&block
, &se
->post
);
4952 gfc_init_block (&se
->post
);
4953 gfc_add_block_to_block (&se
->post
, &block
);
4958 /* Generate code to deallocate an array, if it is allocated. */
4961 gfc_trans_dealloc_allocated (tree descriptor
)
4968 gfc_start_block (&block
);
4970 var
= gfc_conv_descriptor_data_get (descriptor
);
4972 tmp
= gfc_create_var (gfc_array_index_type
, NULL
);
4973 ptr
= build_fold_addr_expr (tmp
);
4975 /* Call array_deallocate with an int* present in the second argument.
4976 Although it is ignored here, it's presence ensures that arrays that
4977 are already deallocated are ignored. */
4978 tmp
= build_call_expr (gfor_fndecl_deallocate
, 2, var
, ptr
);
4979 gfc_add_expr_to_block (&block
, tmp
);
4981 /* Zero the data pointer. */
4982 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
4983 var
, build_int_cst (TREE_TYPE (var
), 0));
4984 gfc_add_expr_to_block (&block
, tmp
);
4986 return gfc_finish_block (&block
);
4990 /* This helper function calculates the size in words of a full array. */
4993 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
4998 idx
= gfc_rank_cst
[rank
- 1];
4999 nelems
= gfc_conv_descriptor_ubound (decl
, idx
);
5000 tmp
= gfc_conv_descriptor_lbound (decl
, idx
);
5001 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5002 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
5003 tmp
, gfc_index_one_node
);
5004 tmp
= gfc_evaluate_now (tmp
, block
);
5006 nelems
= gfc_conv_descriptor_stride (decl
, idx
);
5007 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5008 return gfc_evaluate_now (tmp
, block
);
5012 /* Allocate dest to the same size as src, and copy src -> dest. */
5015 gfc_duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
)
5024 /* If the source is null, set the destination to null. */
5025 gfc_init_block (&block
);
5026 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5027 null_data
= gfc_finish_block (&block
);
5029 gfc_init_block (&block
);
5031 nelems
= get_full_array_size (&block
, src
, rank
);
5032 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
,
5033 fold_convert (gfc_array_index_type
,
5034 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
5036 /* Allocate memory to the destination. */
5037 tmp
= gfc_call_malloc (&block
, TREE_TYPE (gfc_conv_descriptor_data_get (src
)),
5039 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5041 /* We know the temporary and the value will be the same length,
5042 so can use memcpy. */
5043 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5044 tmp
= build_call_expr (tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5045 gfc_conv_descriptor_data_get (src
), size
);
5046 gfc_add_expr_to_block (&block
, tmp
);
5047 tmp
= gfc_finish_block (&block
);
5049 /* Null the destination if the source is null; otherwise do
5050 the allocate and copy. */
5051 null_cond
= gfc_conv_descriptor_data_get (src
);
5052 null_cond
= convert (pvoid_type_node
, null_cond
);
5053 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5055 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5059 /* Recursively traverse an object of derived type, generating code to
5060 deallocate, nullify or copy allocatable components. This is the work horse
5061 function for the functions named in this enum. */
5063 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
};
5066 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5067 tree dest
, int rank
, int purpose
)
5071 stmtblock_t fnblock
;
5072 stmtblock_t loopbody
;
5082 tree null_cond
= NULL_TREE
;
5084 gfc_init_block (&fnblock
);
5086 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
5087 decl
= build_fold_indirect_ref (decl
);
5089 /* If this an array of derived types with allocatable components
5090 build a loop and recursively call this function. */
5091 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
5092 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5094 tmp
= gfc_conv_array_data (decl
);
5095 var
= build_fold_indirect_ref (tmp
);
5097 /* Get the number of elements - 1 and set the counter. */
5098 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5100 /* Use the descriptor for an allocatable array. Since this
5101 is a full array reference, we only need the descriptor
5102 information from dimension = rank. */
5103 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
5104 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
5105 tmp
, gfc_index_one_node
);
5107 null_cond
= gfc_conv_descriptor_data_get (decl
);
5108 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5109 build_int_cst (TREE_TYPE (null_cond
), 0));
5113 /* Otherwise use the TYPE_DOMAIN information. */
5114 tmp
= array_type_nelts (TREE_TYPE (decl
));
5115 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5118 /* Remember that this is, in fact, the no. of elements - 1. */
5119 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5120 index
= gfc_create_var (gfc_array_index_type
, "S");
5122 /* Build the body of the loop. */
5123 gfc_init_block (&loopbody
);
5125 vref
= gfc_build_array_ref (var
, index
);
5127 if (purpose
== COPY_ALLOC_COMP
)
5129 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
5130 gfc_add_expr_to_block (&fnblock
, tmp
);
5132 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest
));
5133 dref
= gfc_build_array_ref (tmp
, index
);
5134 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
5137 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
5139 gfc_add_expr_to_block (&loopbody
, tmp
);
5141 /* Build the loop and return. */
5142 gfc_init_loopinfo (&loop
);
5144 loop
.from
[0] = gfc_index_zero_node
;
5145 loop
.loopvar
[0] = index
;
5146 loop
.to
[0] = nelems
;
5147 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
5148 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
5150 tmp
= gfc_finish_block (&fnblock
);
5151 if (null_cond
!= NULL_TREE
)
5152 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
, build_empty_stmt ());
5157 /* Otherwise, act on the components or recursively call self to
5158 act on a chain of components. */
5159 for (c
= der_type
->components
; c
; c
= c
->next
)
5161 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
5162 && c
->ts
.derived
->attr
.alloc_comp
;
5163 cdecl = c
->backend_decl
;
5164 ctype
= TREE_TYPE (cdecl);
5168 case DEALLOCATE_ALLOC_COMP
:
5169 /* Do not deallocate the components of ultimate pointer
5171 if (cmp_has_alloc_comps
&& !c
->pointer
)
5173 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5174 rank
= c
->as
? c
->as
->rank
: 0;
5175 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5177 gfc_add_expr_to_block (&fnblock
, tmp
);
5182 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5183 tmp
= gfc_trans_dealloc_allocated (comp
);
5184 gfc_add_expr_to_block (&fnblock
, tmp
);
5188 case NULLIFY_ALLOC_COMP
:
5191 else if (c
->allocatable
)
5193 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5194 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
5196 else if (cmp_has_alloc_comps
)
5198 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5199 rank
= c
->as
? c
->as
->rank
: 0;
5200 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
5202 gfc_add_expr_to_block (&fnblock
, tmp
);
5206 case COPY_ALLOC_COMP
:
5210 /* We need source and destination components. */
5211 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
5212 dcmp
= build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
5213 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
5215 if (c
->allocatable
&& !cmp_has_alloc_comps
)
5217 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, c
->as
->rank
);
5218 gfc_add_expr_to_block (&fnblock
, tmp
);
5221 if (cmp_has_alloc_comps
)
5223 rank
= c
->as
? c
->as
->rank
: 0;
5224 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
5225 gfc_add_modify_expr (&fnblock
, dcmp
, tmp
);
5226 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, dcmp
,
5228 gfc_add_expr_to_block (&fnblock
, tmp
);
5238 return gfc_finish_block (&fnblock
);
5241 /* Recursively traverse an object of derived type, generating code to
5242 nullify allocatable components. */
5245 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5247 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5248 NULLIFY_ALLOC_COMP
);
5252 /* Recursively traverse an object of derived type, generating code to
5253 deallocate allocatable components. */
5256 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
5258 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
5259 DEALLOCATE_ALLOC_COMP
);
5263 /* Recursively traverse an object of derived type, generating code to
5264 copy its allocatable components. */
5267 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
5269 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
5273 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5274 Do likewise, recursively if necessary, with the allocatable components of
5278 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
5283 stmtblock_t fnblock
;
5286 bool sym_has_alloc_comp
;
5288 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
5289 && sym
->ts
.derived
->attr
.alloc_comp
;
5291 /* Make sure the frontend gets these right. */
5292 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
5293 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5294 "allocatable attribute or derived type without allocatable "
5297 gfc_init_block (&fnblock
);
5299 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
5300 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
5302 if (sym
->ts
.type
== BT_CHARACTER
5303 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
5305 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
5306 gfc_trans_vla_type_sizes (sym
, &fnblock
);
5309 /* Dummy and use associated variables don't need anything special. */
5310 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
5312 gfc_add_expr_to_block (&fnblock
, body
);
5314 return gfc_finish_block (&fnblock
);
5317 gfc_get_backend_locus (&loc
);
5318 gfc_set_backend_locus (&sym
->declared_at
);
5319 descriptor
= sym
->backend_decl
;
5321 /* Although static, derived types with default initializers and
5322 allocatable components must not be nulled wholesale; instead they
5323 are treated component by component. */
5324 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
5326 /* SAVEd variables are not freed on exit. */
5327 gfc_trans_static_array_pointer (sym
);
5331 /* Get the descriptor type. */
5332 type
= TREE_TYPE (sym
->backend_decl
);
5334 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5336 if (!sym
->attr
.save
)
5338 rank
= sym
->as
? sym
->as
->rank
: 0;
5339 tmp
= gfc_nullify_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5340 gfc_add_expr_to_block (&fnblock
, tmp
);
5343 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
5345 /* If the backend_decl is not a descriptor, we must have a pointer
5347 descriptor
= build_fold_indirect_ref (sym
->backend_decl
);
5348 type
= TREE_TYPE (descriptor
);
5351 /* NULLIFY the data pointer. */
5352 if (GFC_DESCRIPTOR_TYPE_P (type
))
5353 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
5355 gfc_add_expr_to_block (&fnblock
, body
);
5357 gfc_set_backend_locus (&loc
);
5359 /* Allocatable arrays need to be freed when they go out of scope.
5360 The allocatable components of pointers must not be touched. */
5361 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
5362 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
5365 rank
= sym
->as
? sym
->as
->rank
: 0;
5366 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5367 gfc_add_expr_to_block (&fnblock
, tmp
);
5370 if (sym
->attr
.allocatable
)
5372 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
5373 gfc_add_expr_to_block (&fnblock
, tmp
);
5376 return gfc_finish_block (&fnblock
);
5379 /************ Expression Walking Functions ******************/
5381 /* Walk a variable reference.
5383 Possible extension - multiple component subscripts.
5384 x(:,:) = foo%a(:)%b(:)
5386 forall (i=..., j=...)
5387 x(i,j) = foo%a(j)%b(i)
5389 This adds a fair amount of complexity because you need to deal with more
5390 than one ref. Maybe handle in a similar manner to vector subscripts.
5391 Maybe not worth the effort. */
5395 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5403 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5404 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
5407 for (; ref
; ref
= ref
->next
)
5409 if (ref
->type
== REF_SUBSTRING
)
5411 newss
= gfc_get_ss ();
5412 newss
->type
= GFC_SS_SCALAR
;
5413 newss
->expr
= ref
->u
.ss
.start
;
5417 newss
= gfc_get_ss ();
5418 newss
->type
= GFC_SS_SCALAR
;
5419 newss
->expr
= ref
->u
.ss
.end
;
5424 /* We're only interested in array sections from now on. */
5425 if (ref
->type
!= REF_ARRAY
)
5432 for (n
= 0; n
< ar
->dimen
; n
++)
5434 newss
= gfc_get_ss ();
5435 newss
->type
= GFC_SS_SCALAR
;
5436 newss
->expr
= ar
->start
[n
];
5443 newss
= gfc_get_ss ();
5444 newss
->type
= GFC_SS_SECTION
;
5447 newss
->data
.info
.dimen
= ar
->as
->rank
;
5448 newss
->data
.info
.ref
= ref
;
5450 /* Make sure array is the same as array(:,:), this way
5451 we don't need to special case all the time. */
5452 ar
->dimen
= ar
->as
->rank
;
5453 for (n
= 0; n
< ar
->dimen
; n
++)
5455 newss
->data
.info
.dim
[n
] = n
;
5456 ar
->dimen_type
[n
] = DIMEN_RANGE
;
5458 gcc_assert (ar
->start
[n
] == NULL
);
5459 gcc_assert (ar
->end
[n
] == NULL
);
5460 gcc_assert (ar
->stride
[n
] == NULL
);
5466 newss
= gfc_get_ss ();
5467 newss
->type
= GFC_SS_SECTION
;
5470 newss
->data
.info
.dimen
= 0;
5471 newss
->data
.info
.ref
= ref
;
5475 /* We add SS chains for all the subscripts in the section. */
5476 for (n
= 0; n
< ar
->dimen
; n
++)
5480 switch (ar
->dimen_type
[n
])
5483 /* Add SS for elemental (scalar) subscripts. */
5484 gcc_assert (ar
->start
[n
]);
5485 indexss
= gfc_get_ss ();
5486 indexss
->type
= GFC_SS_SCALAR
;
5487 indexss
->expr
= ar
->start
[n
];
5488 indexss
->next
= gfc_ss_terminator
;
5489 indexss
->loop_chain
= gfc_ss_terminator
;
5490 newss
->data
.info
.subscript
[n
] = indexss
;
5494 /* We don't add anything for sections, just remember this
5495 dimension for later. */
5496 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5497 newss
->data
.info
.dimen
++;
5501 /* Create a GFC_SS_VECTOR index in which we can store
5502 the vector's descriptor. */
5503 indexss
= gfc_get_ss ();
5504 indexss
->type
= GFC_SS_VECTOR
;
5505 indexss
->expr
= ar
->start
[n
];
5506 indexss
->next
= gfc_ss_terminator
;
5507 indexss
->loop_chain
= gfc_ss_terminator
;
5508 newss
->data
.info
.subscript
[n
] = indexss
;
5509 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5510 newss
->data
.info
.dimen
++;
5514 /* We should know what sort of section it is by now. */
5518 /* We should have at least one non-elemental dimension. */
5519 gcc_assert (newss
->data
.info
.dimen
> 0);
5524 /* We should know what sort of section it is by now. */
5533 /* Walk an expression operator. If only one operand of a binary expression is
5534 scalar, we must also add the scalar term to the SS chain. */
5537 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5543 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
5544 if (expr
->value
.op
.op2
== NULL
)
5547 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
5549 /* All operands are scalar. Pass back and let the caller deal with it. */
5553 /* All operands require scalarization. */
5554 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
5557 /* One of the operands needs scalarization, the other is scalar.
5558 Create a gfc_ss for the scalar expression. */
5559 newss
= gfc_get_ss ();
5560 newss
->type
= GFC_SS_SCALAR
;
5563 /* First operand is scalar. We build the chain in reverse order, so
5564 add the scarar SS after the second operand. */
5566 while (head
&& head
->next
!= ss
)
5568 /* Check we haven't somehow broken the chain. */
5572 newss
->expr
= expr
->value
.op
.op1
;
5574 else /* head2 == head */
5576 gcc_assert (head2
== head
);
5577 /* Second operand is scalar. */
5578 newss
->next
= head2
;
5580 newss
->expr
= expr
->value
.op
.op2
;
5587 /* Reverse a SS chain. */
5590 gfc_reverse_ss (gfc_ss
* ss
)
5595 gcc_assert (ss
!= NULL
);
5597 head
= gfc_ss_terminator
;
5598 while (ss
!= gfc_ss_terminator
)
5601 /* Check we didn't somehow break the chain. */
5602 gcc_assert (next
!= NULL
);
5612 /* Walk the arguments of an elemental function. */
5615 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
5623 head
= gfc_ss_terminator
;
5626 for (; arg
; arg
= arg
->next
)
5631 newss
= gfc_walk_subexpr (head
, arg
->expr
);
5634 /* Scalar argument. */
5635 newss
= gfc_get_ss ();
5637 newss
->expr
= arg
->expr
;
5647 while (tail
->next
!= gfc_ss_terminator
)
5654 /* If all the arguments are scalar we don't need the argument SS. */
5655 gfc_free_ss_chain (head
);
5660 /* Add it onto the existing chain. */
5666 /* Walk a function call. Scalar functions are passed back, and taken out of
5667 scalarization loops. For elemental functions we walk their arguments.
5668 The result of functions returning arrays is stored in a temporary outside
5669 the loop, so that the function is only called once. Hence we do not need
5670 to walk their arguments. */
5673 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5676 gfc_intrinsic_sym
*isym
;
5679 isym
= expr
->value
.function
.isym
;
5681 /* Handle intrinsic functions separately. */
5683 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
5685 sym
= expr
->value
.function
.esym
;
5687 sym
= expr
->symtree
->n
.sym
;
5689 /* A function that returns arrays. */
5690 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
5692 newss
= gfc_get_ss ();
5693 newss
->type
= GFC_SS_FUNCTION
;
5696 newss
->data
.info
.dimen
= expr
->rank
;
5700 /* Walk the parameters of an elemental function. For now we always pass
5702 if (sym
->attr
.elemental
)
5703 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
5706 /* Scalar functions are OK as these are evaluated outside the scalarization
5707 loop. Pass back and let the caller deal with it. */
5712 /* An array temporary is constructed for array constructors. */
5715 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
5720 newss
= gfc_get_ss ();
5721 newss
->type
= GFC_SS_CONSTRUCTOR
;
5724 newss
->data
.info
.dimen
= expr
->rank
;
5725 for (n
= 0; n
< expr
->rank
; n
++)
5726 newss
->data
.info
.dim
[n
] = n
;
5732 /* Walk an expression. Add walked expressions to the head of the SS chain.
5733 A wholly scalar expression will not be added. */
5736 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
5740 switch (expr
->expr_type
)
5743 head
= gfc_walk_variable_expr (ss
, expr
);
5747 head
= gfc_walk_op_expr (ss
, expr
);
5751 head
= gfc_walk_function_expr (ss
, expr
);
5756 case EXPR_STRUCTURE
:
5757 /* Pass back and let the caller deal with it. */
5761 head
= gfc_walk_array_constructor (ss
, expr
);
5764 case EXPR_SUBSTRING
:
5765 /* Pass back and let the caller deal with it. */
5769 internal_error ("bad expression type during walk (%d)",
5776 /* Entry point for expression walking.
5777 A return value equal to the passed chain means this is
5778 a scalar expression. It is up to the caller to take whatever action is
5779 necessary to translate these. */
5782 gfc_walk_expr (gfc_expr
* expr
)
5786 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
5787 return gfc_reverse_ss (res
);