1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
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
)
508 desc
= info
->descriptor
;
509 info
->offset
= gfc_index_zero_node
;
510 if (size
== NULL_TREE
|| integer_zerop (size
))
512 /* A callee allocated array. */
513 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
518 /* Allocate the temporary. */
519 onstack
= !dynamic
&& gfc_can_put_var_on_stack (size
);
523 /* Make a temporary variable to hold the data. */
524 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
526 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
528 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
530 tmp
= gfc_create_var (tmp
, "A");
531 tmp
= build_fold_addr_expr (tmp
);
532 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
536 /* Allocate memory to hold the data. */
537 args
= gfc_chainon_list (NULL_TREE
, size
);
539 if (gfc_index_integer_kind
== 4)
540 tmp
= gfor_fndecl_internal_malloc
;
541 else if (gfc_index_integer_kind
== 8)
542 tmp
= gfor_fndecl_internal_malloc64
;
545 tmp
= build_function_call_expr (tmp
, args
);
546 tmp
= gfc_evaluate_now (tmp
, pre
);
547 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
550 info
->data
= gfc_conv_descriptor_data_get (desc
);
552 /* The offset is zero because we create temporaries with a zero
554 tmp
= gfc_conv_descriptor_offset (desc
);
555 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
557 if (dealloc
&& !onstack
)
559 /* Free the temporary. */
560 tmp
= gfc_conv_descriptor_data_get (desc
);
561 tmp
= fold_convert (pvoid_type_node
, tmp
);
562 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
563 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, tmp
);
564 gfc_add_expr_to_block (post
, tmp
);
569 /* Generate code to create and initialize the descriptor for a temporary
570 array. This is used for both temporaries needed by the scalarizer, and
571 functions returning arrays. Adjusts the loop variables to be
572 zero-based, and calculates the loop bounds for callee allocated arrays.
573 Allocate the array unless it's callee allocated (we have a callee
574 allocated array if 'callee_alloc' is true, or if loop->to[n] is
575 NULL_TREE for any n). Also fills in the descriptor, data and offset
576 fields of info if known. Returns the size of the array, or NULL for a
577 callee allocated array.
579 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
583 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
584 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
585 tree eltype
, bool dynamic
, bool dealloc
,
586 bool callee_alloc
, bool function
)
598 stmtblock_t thenblock
;
599 stmtblock_t elseblock
;
603 gcc_assert (info
->dimen
> 0);
604 /* Set the lower bound to zero. */
605 for (dim
= 0; dim
< info
->dimen
; dim
++)
607 n
= loop
->order
[dim
];
608 if (n
< loop
->temp_dim
)
609 gcc_assert (integer_zerop (loop
->from
[n
]));
612 /* Callee allocated arrays may not have a known bound yet. */
614 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
615 loop
->to
[n
], loop
->from
[n
]);
616 loop
->from
[n
] = gfc_index_zero_node
;
619 info
->delta
[dim
] = gfc_index_zero_node
;
620 info
->start
[dim
] = gfc_index_zero_node
;
621 info
->end
[dim
] = gfc_index_zero_node
;
622 info
->stride
[dim
] = gfc_index_one_node
;
623 info
->dim
[dim
] = dim
;
626 /* Initialize the descriptor. */
628 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
629 desc
= gfc_create_var (type
, "atmp");
630 GFC_DECL_PACKED_ARRAY (desc
) = 1;
632 info
->descriptor
= desc
;
633 size
= gfc_index_one_node
;
635 /* Fill in the array dtype. */
636 tmp
= gfc_conv_descriptor_dtype (desc
);
637 gfc_add_modify_expr (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
640 Fill in the bounds and stride. This is a packed array, so:
643 for (n = 0; n < rank; n++)
646 delta = ubound[n] + 1 - lbound[n];
649 size = size * sizeof(element);
654 for (n
= 0; n
< info
->dimen
; n
++)
656 if (loop
->to
[n
] == NULL_TREE
)
658 /* For a callee allocated array express the loop bounds in terms
659 of the descriptor fields. */
660 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
661 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
662 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
668 /* Store the stride and bound components in the descriptor. */
669 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
670 gfc_add_modify_expr (pre
, tmp
, size
);
672 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
673 gfc_add_modify_expr (pre
, tmp
, gfc_index_zero_node
);
675 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
676 gfc_add_modify_expr (pre
, tmp
, loop
->to
[n
]);
678 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
679 loop
->to
[n
], gfc_index_one_node
);
683 /* Check wether the size for this dimension is negative. */
684 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
685 gfc_index_zero_node
);
687 cond
= gfc_evaluate_now (cond
, pre
);
692 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
694 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
695 size
= gfc_evaluate_now (size
, pre
);
698 /* Get the size of the array. */
700 if (size
&& !callee_alloc
)
704 var
= gfc_create_var (TREE_TYPE (size
), "size");
705 gfc_start_block (&thenblock
);
706 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
707 thencase
= gfc_finish_block (&thenblock
);
709 gfc_start_block (&elseblock
);
710 gfc_add_modify_expr (&elseblock
, var
, size
);
711 elsecase
= gfc_finish_block (&elseblock
);
713 tmp
= gfc_evaluate_now (or_expr
, pre
);
714 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
715 gfc_add_expr_to_block (pre
, tmp
);
722 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
723 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
731 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, dynamic
,
734 if (info
->dimen
> loop
->temp_dim
)
735 loop
->temp_dim
= info
->dimen
;
741 /* Generate code to transpose array EXPR by creating a new descriptor
742 in which the dimension specifications have been reversed. */
745 gfc_conv_array_transpose (gfc_se
* se
, gfc_expr
* expr
)
747 tree dest
, src
, dest_index
, src_index
;
749 gfc_ss_info
*dest_info
, *src_info
;
750 gfc_ss
*dest_ss
, *src_ss
;
756 src_ss
= gfc_walk_expr (expr
);
759 src_info
= &src_ss
->data
.info
;
760 dest_info
= &dest_ss
->data
.info
;
761 gcc_assert (dest_info
->dimen
== 2);
762 gcc_assert (src_info
->dimen
== 2);
764 /* Get a descriptor for EXPR. */
765 gfc_init_se (&src_se
, NULL
);
766 gfc_conv_expr_descriptor (&src_se
, expr
, src_ss
);
767 gfc_add_block_to_block (&se
->pre
, &src_se
.pre
);
768 gfc_add_block_to_block (&se
->post
, &src_se
.post
);
771 /* Allocate a new descriptor for the return value. */
772 dest
= gfc_create_var (TREE_TYPE (src
), "atmp");
773 dest_info
->descriptor
= dest
;
776 /* Copy across the dtype field. */
777 gfc_add_modify_expr (&se
->pre
,
778 gfc_conv_descriptor_dtype (dest
),
779 gfc_conv_descriptor_dtype (src
));
781 /* Copy the dimension information, renumbering dimension 1 to 0 and
783 for (n
= 0; n
< 2; n
++)
785 dest_info
->delta
[n
] = gfc_index_zero_node
;
786 dest_info
->start
[n
] = gfc_index_zero_node
;
787 dest_info
->end
[n
] = gfc_index_zero_node
;
788 dest_info
->stride
[n
] = gfc_index_one_node
;
789 dest_info
->dim
[n
] = n
;
791 dest_index
= gfc_rank_cst
[n
];
792 src_index
= gfc_rank_cst
[1 - n
];
794 gfc_add_modify_expr (&se
->pre
,
795 gfc_conv_descriptor_stride (dest
, dest_index
),
796 gfc_conv_descriptor_stride (src
, src_index
));
798 gfc_add_modify_expr (&se
->pre
,
799 gfc_conv_descriptor_lbound (dest
, dest_index
),
800 gfc_conv_descriptor_lbound (src
, src_index
));
802 gfc_add_modify_expr (&se
->pre
,
803 gfc_conv_descriptor_ubound (dest
, dest_index
),
804 gfc_conv_descriptor_ubound (src
, src_index
));
808 gcc_assert (integer_zerop (loop
->from
[n
]));
809 loop
->to
[n
] = build2 (MINUS_EXPR
, gfc_array_index_type
,
810 gfc_conv_descriptor_ubound (dest
, dest_index
),
811 gfc_conv_descriptor_lbound (dest
, dest_index
));
815 /* Copy the data pointer. */
816 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
817 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
819 /* Copy the offset. This is not changed by transposition: the top-left
820 element is still at the same offset as before. */
821 dest_info
->offset
= gfc_conv_descriptor_offset (src
);
822 gfc_add_modify_expr (&se
->pre
,
823 gfc_conv_descriptor_offset (dest
),
826 if (dest_info
->dimen
> loop
->temp_dim
)
827 loop
->temp_dim
= dest_info
->dimen
;
831 /* Return the number of iterations in a loop that starts at START,
832 ends at END, and has step STEP. */
835 gfc_get_iteration_count (tree start
, tree end
, tree step
)
840 type
= TREE_TYPE (step
);
841 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
842 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
843 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
844 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
845 return fold_convert (gfc_array_index_type
, tmp
);
849 /* Extend the data in array DESC by EXTRA elements. */
852 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
859 if (integer_zerop (extra
))
862 ubound
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
864 /* Add EXTRA to the upper bound. */
865 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
866 gfc_add_modify_expr (pblock
, ubound
, tmp
);
868 /* Get the value of the current data pointer. */
869 tmp
= gfc_conv_descriptor_data_get (desc
);
870 args
= gfc_chainon_list (NULL_TREE
, tmp
);
872 /* Calculate the new array size. */
873 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
874 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, gfc_index_one_node
);
875 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
876 args
= gfc_chainon_list (args
, tmp
);
878 /* Pick the appropriate realloc function. */
879 if (gfc_index_integer_kind
== 4)
880 tmp
= gfor_fndecl_internal_realloc
;
881 else if (gfc_index_integer_kind
== 8)
882 tmp
= gfor_fndecl_internal_realloc64
;
886 /* Set the new data pointer. */
887 tmp
= build_function_call_expr (tmp
, args
);
888 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
892 /* Return true if the bounds of iterator I can only be determined
896 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
898 return (i
->start
->expr_type
!= EXPR_CONSTANT
899 || i
->end
->expr_type
!= EXPR_CONSTANT
900 || i
->step
->expr_type
!= EXPR_CONSTANT
);
904 /* Split the size of constructor element EXPR into the sum of two terms,
905 one of which can be determined at compile time and one of which must
906 be calculated at run time. Set *SIZE to the former and return true
907 if the latter might be nonzero. */
910 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
912 if (expr
->expr_type
== EXPR_ARRAY
)
913 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
914 else if (expr
->rank
> 0)
916 /* Calculate everything at run time. */
917 mpz_set_ui (*size
, 0);
922 /* A single element. */
923 mpz_set_ui (*size
, 1);
929 /* Like gfc_get_array_constructor_element_size, but applied to the whole
930 of array constructor C. */
933 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor
* c
)
940 mpz_set_ui (*size
, 0);
945 for (; c
; c
= c
->next
)
948 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
952 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
955 /* Multiply the static part of the element size by the
956 number of iterations. */
957 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
958 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
959 mpz_add_ui (val
, val
, 1);
960 if (mpz_sgn (val
) > 0)
961 mpz_mul (len
, len
, val
);
965 mpz_add (*size
, *size
, len
);
974 /* Make sure offset is a variable. */
977 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
980 /* We should have already created the offset variable. We cannot
981 create it here because we may be in an inner scope. */
982 gcc_assert (*offsetvar
!= NULL_TREE
);
983 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
984 *poffset
= *offsetvar
;
985 TREE_USED (*offsetvar
) = 1;
989 /* Assign an element of an array constructor. */
992 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
993 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
998 gfc_conv_expr (se
, expr
);
1000 /* Store the value. */
1001 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc
));
1002 tmp
= gfc_build_array_ref (tmp
, offset
);
1003 if (expr
->ts
.type
== BT_CHARACTER
)
1005 gfc_conv_string_parameter (se
);
1006 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1008 /* The temporary is an array of pointers. */
1009 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1010 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
1014 /* The temporary is an array of string values. */
1015 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
1016 /* We know the temporary and the value will be the same length,
1017 so can use memcpy. */
1018 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1019 args
= gfc_chainon_list (args
, se
->expr
);
1020 args
= gfc_chainon_list (args
, se
->string_length
);
1021 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
1022 tmp
= build_function_call_expr (tmp
, args
);
1023 gfc_add_expr_to_block (&se
->pre
, tmp
);
1028 /* TODO: Should the frontend already have done this conversion? */
1029 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1030 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
1033 gfc_add_block_to_block (pblock
, &se
->pre
);
1034 gfc_add_block_to_block (pblock
, &se
->post
);
1038 /* Add the contents of an array to the constructor. DYNAMIC is as for
1039 gfc_trans_array_constructor_value. */
1042 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1043 tree type ATTRIBUTE_UNUSED
,
1044 tree desc
, gfc_expr
* expr
,
1045 tree
* poffset
, tree
* offsetvar
,
1056 /* We need this to be a variable so we can increment it. */
1057 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1059 gfc_init_se (&se
, NULL
);
1061 /* Walk the array expression. */
1062 ss
= gfc_walk_expr (expr
);
1063 gcc_assert (ss
!= gfc_ss_terminator
);
1065 /* Initialize the scalarizer. */
1066 gfc_init_loopinfo (&loop
);
1067 gfc_add_ss_to_loop (&loop
, ss
);
1069 /* Initialize the loop. */
1070 gfc_conv_ss_startstride (&loop
);
1071 gfc_conv_loop_setup (&loop
);
1073 /* Make sure the constructed array has room for the new data. */
1076 /* Set SIZE to the total number of elements in the subarray. */
1077 size
= gfc_index_one_node
;
1078 for (n
= 0; n
< loop
.dimen
; n
++)
1080 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1081 gfc_index_one_node
);
1082 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1085 /* Grow the constructed array by SIZE elements. */
1086 gfc_grow_array (&loop
.pre
, desc
, size
);
1089 /* Make the loop body. */
1090 gfc_mark_ss_chain_used (ss
, 1);
1091 gfc_start_scalarized_body (&loop
, &body
);
1092 gfc_copy_loopinfo_to_se (&se
, &loop
);
1095 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1096 gcc_assert (se
.ss
== gfc_ss_terminator
);
1098 /* Increment the offset. */
1099 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
1100 gfc_add_modify_expr (&body
, *poffset
, tmp
);
1102 /* Finish the loop. */
1103 gfc_trans_scalarizing_loops (&loop
, &body
);
1104 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1105 tmp
= gfc_finish_block (&loop
.pre
);
1106 gfc_add_expr_to_block (pblock
, tmp
);
1108 gfc_cleanup_loop (&loop
);
1112 /* Assign the values to the elements of an array constructor. DYNAMIC
1113 is true if descriptor DESC only contains enough data for the static
1114 size calculated by gfc_get_array_constructor_size. When true, memory
1115 for the dynamic parts must be allocated using realloc. */
1118 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1119 tree desc
, gfc_constructor
* c
,
1120 tree
* poffset
, tree
* offsetvar
,
1129 for (; c
; c
= c
->next
)
1131 /* If this is an iterator or an array, the offset must be a variable. */
1132 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1133 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1135 gfc_start_block (&body
);
1137 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1139 /* Array constructors can be nested. */
1140 gfc_trans_array_constructor_value (&body
, type
, desc
,
1141 c
->expr
->value
.constructor
,
1142 poffset
, offsetvar
, dynamic
);
1144 else if (c
->expr
->rank
> 0)
1146 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1147 poffset
, offsetvar
, dynamic
);
1151 /* This code really upsets the gimplifier so don't bother for now. */
1158 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1165 /* Scalar values. */
1166 gfc_init_se (&se
, NULL
);
1167 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1170 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1171 *poffset
, gfc_index_one_node
);
1175 /* Collect multiple scalar constants into a constructor. */
1183 /* Count the number of consecutive scalar constants. */
1184 while (p
&& !(p
->iterator
1185 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1187 gfc_init_se (&se
, NULL
);
1188 gfc_conv_constant (&se
, p
->expr
);
1189 if (p
->expr
->ts
.type
== BT_CHARACTER
1190 && POINTER_TYPE_P (type
))
1192 /* For constant character array constructors we build
1193 an array of pointers. */
1194 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
1198 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
1203 bound
= build_int_cst (NULL_TREE
, n
- 1);
1204 /* Create an array type to hold them. */
1205 tmptype
= build_range_type (gfc_array_index_type
,
1206 gfc_index_zero_node
, bound
);
1207 tmptype
= build_array_type (type
, tmptype
);
1209 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1210 TREE_CONSTANT (init
) = 1;
1211 TREE_INVARIANT (init
) = 1;
1212 TREE_STATIC (init
) = 1;
1213 /* Create a static variable to hold the data. */
1214 tmp
= gfc_create_var (tmptype
, "data");
1215 TREE_STATIC (tmp
) = 1;
1216 TREE_CONSTANT (tmp
) = 1;
1217 TREE_INVARIANT (tmp
) = 1;
1218 DECL_INITIAL (tmp
) = init
;
1221 /* Use BUILTIN_MEMCPY to assign the values. */
1222 tmp
= gfc_conv_descriptor_data_get (desc
);
1223 tmp
= build_fold_indirect_ref (tmp
);
1224 tmp
= gfc_build_array_ref (tmp
, *poffset
);
1225 tmp
= build_fold_addr_expr (tmp
);
1226 init
= build_fold_addr_expr (init
);
1228 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1229 bound
= build_int_cst (NULL_TREE
, n
* size
);
1230 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1231 tmp
= gfc_chainon_list (tmp
, init
);
1232 tmp
= gfc_chainon_list (tmp
, bound
);
1233 tmp
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMCPY
],
1235 gfc_add_expr_to_block (&body
, tmp
);
1237 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1238 *poffset
, build_int_cst (NULL_TREE
, n
));
1240 if (!INTEGER_CST_P (*poffset
))
1242 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
1243 *poffset
= *offsetvar
;
1247 /* The frontend should already have done any expansions possible
1251 /* Pass the code as is. */
1252 tmp
= gfc_finish_block (&body
);
1253 gfc_add_expr_to_block (pblock
, tmp
);
1257 /* Build the implied do-loop. */
1267 loopbody
= gfc_finish_block (&body
);
1269 gfc_init_se (&se
, NULL
);
1270 gfc_conv_expr (&se
, c
->iterator
->var
);
1271 gfc_add_block_to_block (pblock
, &se
.pre
);
1274 /* Make a temporary, store the current value in that
1275 and return it, once the loop is done. */
1276 tmp_loopvar
= gfc_create_var (TREE_TYPE (loopvar
), "loopvar");
1277 gfc_add_modify_expr (pblock
, tmp_loopvar
, loopvar
);
1279 /* Initialize the loop. */
1280 gfc_init_se (&se
, NULL
);
1281 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1282 gfc_add_block_to_block (pblock
, &se
.pre
);
1283 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
1285 gfc_init_se (&se
, NULL
);
1286 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1287 gfc_add_block_to_block (pblock
, &se
.pre
);
1288 end
= gfc_evaluate_now (se
.expr
, pblock
);
1290 gfc_init_se (&se
, NULL
);
1291 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1292 gfc_add_block_to_block (pblock
, &se
.pre
);
1293 step
= gfc_evaluate_now (se
.expr
, pblock
);
1295 /* If this array expands dynamically, and the number of iterations
1296 is not constant, we won't have allocated space for the static
1297 part of C->EXPR's size. Do that now. */
1298 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1300 /* Get the number of iterations. */
1301 tmp
= gfc_get_iteration_count (loopvar
, end
, step
);
1303 /* Get the static part of C->EXPR's size. */
1304 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1305 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1307 /* Grow the array by TMP * TMP2 elements. */
1308 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1309 gfc_grow_array (pblock
, desc
, tmp
);
1312 /* Generate the loop body. */
1313 exit_label
= gfc_build_label_decl (NULL_TREE
);
1314 gfc_start_block (&body
);
1316 /* Generate the exit condition. Depending on the sign of
1317 the step variable we have to generate the correct
1319 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1320 build_int_cst (TREE_TYPE (step
), 0));
1321 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1322 build2 (GT_EXPR
, boolean_type_node
,
1324 build2 (LT_EXPR
, boolean_type_node
,
1326 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1327 TREE_USED (exit_label
) = 1;
1328 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1329 gfc_add_expr_to_block (&body
, tmp
);
1331 /* The main loop body. */
1332 gfc_add_expr_to_block (&body
, loopbody
);
1334 /* Increase loop variable by step. */
1335 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
1336 gfc_add_modify_expr (&body
, loopvar
, tmp
);
1338 /* Finish the loop. */
1339 tmp
= gfc_finish_block (&body
);
1340 tmp
= build1_v (LOOP_EXPR
, tmp
);
1341 gfc_add_expr_to_block (pblock
, tmp
);
1343 /* Add the exit label. */
1344 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1345 gfc_add_expr_to_block (pblock
, tmp
);
1347 /* Restore the original value of the loop counter. */
1348 gfc_add_modify_expr (pblock
, loopvar
, tmp_loopvar
);
1355 /* Figure out the string length of a variable reference expression.
1356 Used by get_array_ctor_strlen. */
1359 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1365 /* Don't bother if we already know the length is a constant. */
1366 if (*len
&& INTEGER_CST_P (*len
))
1369 ts
= &expr
->symtree
->n
.sym
->ts
;
1370 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1375 /* Array references don't change the string length. */
1379 /* Use the length of the component. */
1380 ts
= &ref
->u
.c
.component
->ts
;
1384 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1385 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
)
1387 mpz_init_set_ui (char_len
, 1);
1388 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1389 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1390 *len
= gfc_conv_mpz_to_tree (char_len
,
1391 gfc_default_character_kind
);
1392 *len
= convert (gfc_charlen_type_node
, *len
);
1393 mpz_clear (char_len
);
1397 /* TODO: Substrings are tricky because we can't evaluate the
1398 expression more than once. For now we just give up, and hope
1399 we can figure it out elsewhere. */
1404 *len
= ts
->cl
->backend_decl
;
1408 /* Figure out the string length of a character array constructor.
1409 Returns TRUE if all elements are character constants. */
1412 get_array_ctor_strlen (gfc_constructor
* c
, tree
* len
)
1417 for (; c
; c
= c
->next
)
1419 switch (c
->expr
->expr_type
)
1422 if (!(*len
&& INTEGER_CST_P (*len
)))
1423 *len
= build_int_cstu (gfc_charlen_type_node
,
1424 c
->expr
->value
.character
.length
);
1428 if (!get_array_ctor_strlen (c
->expr
->value
.constructor
, len
))
1434 get_array_ctor_var_strlen (c
->expr
, len
);
1440 /* Hope that whatever we have possesses a constant character
1442 if (!(*len
&& INTEGER_CST_P (*len
)) && c
->expr
->ts
.cl
)
1444 gfc_conv_const_charlen (c
->expr
->ts
.cl
);
1445 *len
= c
->expr
->ts
.cl
->backend_decl
;
1447 /* TODO: For now we just ignore anything we don't know how to
1448 handle, and hope we can figure it out a different way. */
1457 /* Array constructors are handled by constructing a temporary, then using that
1458 within the scalarization loop. This is not optimal, but seems by far the
1462 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1472 ss
->data
.info
.dimen
= loop
->dimen
;
1474 c
= ss
->expr
->value
.constructor
;
1475 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1477 const_string
= get_array_ctor_strlen (c
, &ss
->string_length
);
1478 if (!ss
->string_length
)
1479 gfc_todo_error ("complex character array constructors");
1481 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1483 type
= build_pointer_type (type
);
1487 const_string
= TRUE
;
1488 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1491 /* See if the constructor determines the loop bounds. */
1493 if (loop
->to
[0] == NULL_TREE
)
1497 /* We should have a 1-dimensional, zero-based loop. */
1498 gcc_assert (loop
->dimen
== 1);
1499 gcc_assert (integer_zerop (loop
->from
[0]));
1501 /* Split the constructor size into a static part and a dynamic part.
1502 Allocate the static size up-front and record whether the dynamic
1503 size might be nonzero. */
1505 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1506 mpz_sub_ui (size
, size
, 1);
1507 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1511 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1512 type
, dynamic
, true, false, false);
1514 desc
= ss
->data
.info
.descriptor
;
1515 offset
= gfc_index_zero_node
;
1516 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1517 TREE_USED (offsetvar
) = 0;
1518 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1519 &offset
, &offsetvar
, dynamic
);
1521 /* If the array grows dynamically, the upper bound of the loop variable
1522 is determined by the array's final upper bound. */
1524 loop
->to
[0] = gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[0]);
1526 if (TREE_USED (offsetvar
))
1527 pushdecl (offsetvar
);
1529 gcc_assert (INTEGER_CST_P (offset
));
1531 /* Disable bound checking for now because it's probably broken. */
1532 if (flag_bounds_check
)
1540 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1541 called after evaluating all of INFO's vector dimensions. Go through
1542 each such vector dimension and see if we can now fill in any missing
1546 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1555 for (n
= 0; n
< loop
->dimen
; n
++)
1558 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1559 && loop
->to
[n
] == NULL
)
1561 /* Loop variable N indexes vector dimension DIM, and we don't
1562 yet know the upper bound of loop variable N. Set it to the
1563 difference between the vector's upper and lower bounds. */
1564 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1565 gcc_assert (info
->subscript
[dim
]
1566 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1568 gfc_init_se (&se
, NULL
);
1569 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1570 zero
= gfc_rank_cst
[0];
1571 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1572 gfc_conv_descriptor_ubound (desc
, zero
),
1573 gfc_conv_descriptor_lbound (desc
, zero
));
1574 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1581 /* Add the pre and post chains for all the scalar expressions in a SS chain
1582 to loop. This is called after the loop parameters have been calculated,
1583 but before the actual scalarizing loops. */
1586 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1591 /* TODO: This can generate bad code if there are ordering dependencies.
1592 eg. a callee allocated function and an unknown size constructor. */
1593 gcc_assert (ss
!= NULL
);
1595 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1602 /* Scalar expression. Evaluate this now. This includes elemental
1603 dimension indices, but not array section bounds. */
1604 gfc_init_se (&se
, NULL
);
1605 gfc_conv_expr (&se
, ss
->expr
);
1606 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1608 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1610 /* Move the evaluation of scalar expressions outside the
1611 scalarization loop. */
1613 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1614 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1615 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1618 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1620 ss
->data
.scalar
.expr
= se
.expr
;
1621 ss
->string_length
= se
.string_length
;
1624 case GFC_SS_REFERENCE
:
1625 /* Scalar reference. Evaluate this now. */
1626 gfc_init_se (&se
, NULL
);
1627 gfc_conv_expr_reference (&se
, ss
->expr
);
1628 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1629 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1631 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1632 ss
->string_length
= se
.string_length
;
1635 case GFC_SS_SECTION
:
1636 /* Add the expressions for scalar and vector subscripts. */
1637 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1638 if (ss
->data
.info
.subscript
[n
])
1639 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1641 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
1645 /* Get the vector's descriptor and store it in SS. */
1646 gfc_init_se (&se
, NULL
);
1647 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
1648 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1649 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1650 ss
->data
.info
.descriptor
= se
.expr
;
1653 case GFC_SS_INTRINSIC
:
1654 gfc_add_intrinsic_ss_code (loop
, ss
);
1657 case GFC_SS_FUNCTION
:
1658 /* Array function return value. We call the function and save its
1659 result in a temporary for use inside the loop. */
1660 gfc_init_se (&se
, NULL
);
1663 gfc_conv_expr (&se
, ss
->expr
);
1664 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1665 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1666 ss
->string_length
= se
.string_length
;
1669 case GFC_SS_CONSTRUCTOR
:
1670 gfc_trans_array_constructor (loop
, ss
);
1674 case GFC_SS_COMPONENT
:
1675 /* Do nothing. These are handled elsewhere. */
1685 /* Translate expressions for the descriptor and data pointer of a SS. */
1689 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1694 /* Get the descriptor for the array to be scalarized. */
1695 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1696 gfc_init_se (&se
, NULL
);
1697 se
.descriptor_only
= 1;
1698 gfc_conv_expr_lhs (&se
, ss
->expr
);
1699 gfc_add_block_to_block (block
, &se
.pre
);
1700 ss
->data
.info
.descriptor
= se
.expr
;
1701 ss
->string_length
= se
.string_length
;
1705 /* Also the data pointer. */
1706 tmp
= gfc_conv_array_data (se
.expr
);
1707 /* If this is a variable or address of a variable we use it directly.
1708 Otherwise we must evaluate it now to avoid breaking dependency
1709 analysis by pulling the expressions for elemental array indices
1712 || (TREE_CODE (tmp
) == ADDR_EXPR
1713 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1714 tmp
= gfc_evaluate_now (tmp
, block
);
1715 ss
->data
.info
.data
= tmp
;
1717 tmp
= gfc_conv_array_offset (se
.expr
);
1718 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1723 /* Initialize a gfc_loopinfo structure. */
1726 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1730 memset (loop
, 0, sizeof (gfc_loopinfo
));
1731 gfc_init_block (&loop
->pre
);
1732 gfc_init_block (&loop
->post
);
1734 /* Initially scalarize in order. */
1735 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1738 loop
->ss
= gfc_ss_terminator
;
1742 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1746 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1752 /* Return an expression for the data pointer of an array. */
1755 gfc_conv_array_data (tree descriptor
)
1759 type
= TREE_TYPE (descriptor
);
1760 if (GFC_ARRAY_TYPE_P (type
))
1762 if (TREE_CODE (type
) == POINTER_TYPE
)
1766 /* Descriptorless arrays. */
1767 return build_fold_addr_expr (descriptor
);
1771 return gfc_conv_descriptor_data_get (descriptor
);
1775 /* Return an expression for the base offset of an array. */
1778 gfc_conv_array_offset (tree descriptor
)
1782 type
= TREE_TYPE (descriptor
);
1783 if (GFC_ARRAY_TYPE_P (type
))
1784 return GFC_TYPE_ARRAY_OFFSET (type
);
1786 return gfc_conv_descriptor_offset (descriptor
);
1790 /* Get an expression for the array stride. */
1793 gfc_conv_array_stride (tree descriptor
, int dim
)
1798 type
= TREE_TYPE (descriptor
);
1800 /* For descriptorless arrays use the array size. */
1801 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1802 if (tmp
!= NULL_TREE
)
1805 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1810 /* Like gfc_conv_array_stride, but for the lower bound. */
1813 gfc_conv_array_lbound (tree descriptor
, int dim
)
1818 type
= TREE_TYPE (descriptor
);
1820 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1821 if (tmp
!= NULL_TREE
)
1824 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1829 /* Like gfc_conv_array_stride, but for the upper bound. */
1832 gfc_conv_array_ubound (tree descriptor
, int dim
)
1837 type
= TREE_TYPE (descriptor
);
1839 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1840 if (tmp
!= NULL_TREE
)
1843 /* This should only ever happen when passing an assumed shape array
1844 as an actual parameter. The value will never be used. */
1845 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1846 return gfc_index_zero_node
;
1848 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1853 /* Generate code to perform an array index bound check. */
1856 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
1862 const char * name
= NULL
;
1864 if (!flag_bounds_check
)
1867 index
= gfc_evaluate_now (index
, &se
->pre
);
1869 /* We find a name for the error message. */
1871 name
= se
->ss
->expr
->symtree
->name
;
1873 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
1874 && se
->loop
->ss
->expr
->symtree
)
1875 name
= se
->loop
->ss
->expr
->symtree
->name
;
1877 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
1878 && se
->loop
->ss
->loop_chain
->expr
1879 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
1880 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
1882 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
1883 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
1884 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
1886 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
1888 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
1889 && se
->loop
->ss
->expr
->value
.function
.name
)
1890 name
= se
->loop
->ss
->expr
->value
.function
.name
;
1892 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
1893 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
1894 name
= "unnamed constant";
1897 /* Check lower bound. */
1898 tmp
= gfc_conv_array_lbound (descriptor
, n
);
1899 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
1901 asprintf (&msg
, "%s for array '%s', lower bound of dimension %d exceeded",
1902 gfc_msg_fault
, name
, n
+1);
1904 asprintf (&msg
, "%s, lower bound of dimension %d exceeded",
1905 gfc_msg_fault
, n
+1);
1906 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
1909 /* Check upper bound. */
1910 tmp
= gfc_conv_array_ubound (descriptor
, n
);
1911 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
1913 asprintf (&msg
, "%s for array '%s', upper bound of dimension %d exceeded",
1914 gfc_msg_fault
, name
, n
+1);
1916 asprintf (&msg
, "%s, upper bound of dimension %d exceeded",
1917 gfc_msg_fault
, n
+1);
1918 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
1925 /* Return the offset for an index. Performs bound checking for elemental
1926 dimensions. Single element references are processed separately. */
1929 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
1930 gfc_array_ref
* ar
, tree stride
)
1936 /* Get the index into the array for this dimension. */
1939 gcc_assert (ar
->type
!= AR_ELEMENT
);
1940 switch (ar
->dimen_type
[dim
])
1943 gcc_assert (i
== -1);
1944 /* Elemental dimension. */
1945 gcc_assert (info
->subscript
[dim
]
1946 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
1947 /* We've already translated this value outside the loop. */
1948 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
1950 if ((ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
)
1951 || dim
< ar
->dimen
- 1)
1952 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
1953 index
, dim
, &ar
->where
);
1957 gcc_assert (info
&& se
->loop
);
1958 gcc_assert (info
->subscript
[dim
]
1959 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1960 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
1962 /* Get a zero-based index into the vector. */
1963 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1964 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
1966 /* Multiply the index by the stride. */
1967 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1968 index
, gfc_conv_array_stride (desc
, 0));
1970 /* Read the vector to get an index into info->descriptor. */
1971 data
= build_fold_indirect_ref (gfc_conv_array_data (desc
));
1972 index
= gfc_build_array_ref (data
, index
);
1973 index
= gfc_evaluate_now (index
, &se
->pre
);
1975 /* Do any bounds checking on the final info->descriptor index. */
1976 if ((ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
)
1977 || dim
< ar
->dimen
- 1)
1978 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
1979 index
, dim
, &ar
->where
);
1983 /* Scalarized dimension. */
1984 gcc_assert (info
&& se
->loop
);
1986 /* Multiply the loop variable by the stride and delta. */
1987 index
= se
->loop
->loopvar
[i
];
1988 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
1990 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2000 /* Temporary array or derived type component. */
2001 gcc_assert (se
->loop
);
2002 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2003 if (!integer_zerop (info
->delta
[i
]))
2004 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2005 index
, info
->delta
[i
]);
2008 /* Multiply by the stride. */
2009 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2015 /* Build a scalarized reference to an array. */
2018 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2025 info
= &se
->ss
->data
.info
;
2027 n
= se
->loop
->order
[0];
2031 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2033 /* Add the offset for this dimension to the stored offset for all other
2035 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2037 tmp
= build_fold_indirect_ref (info
->data
);
2038 se
->expr
= gfc_build_array_ref (tmp
, index
);
2042 /* Translate access of temporary array. */
2045 gfc_conv_tmp_array_ref (gfc_se
* se
)
2047 se
->string_length
= se
->ss
->string_length
;
2048 gfc_conv_scalarized_array_ref (se
, NULL
);
2052 /* Build an array reference. se->expr already holds the array descriptor.
2053 This should be either a variable, indirect variable reference or component
2054 reference. For arrays which do not have a descriptor, se->expr will be
2056 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2059 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2068 /* Handle scalarized references separately. */
2069 if (ar
->type
!= AR_ELEMENT
)
2071 gfc_conv_scalarized_array_ref (se
, ar
);
2072 gfc_advance_se_ss_chain (se
);
2076 index
= gfc_index_zero_node
;
2078 /* Calculate the offsets from all the dimensions. */
2079 for (n
= 0; n
< ar
->dimen
; n
++)
2081 /* Calculate the index for this dimension. */
2082 gfc_init_se (&indexse
, se
);
2083 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2084 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2086 if (flag_bounds_check
&&
2087 ((ar
->as
->type
!= AS_ASSUMED_SIZE
&& !ar
->as
->cp_was_assumed
)
2088 || n
< ar
->dimen
- 1))
2090 /* Check array bounds. */
2094 indexse
.expr
= gfc_evaluate_now (indexse
.expr
, &se
->pre
);
2096 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2097 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2099 asprintf (&msg
, "%s for array '%s', "
2100 "lower bound of dimension %d exceeded", gfc_msg_fault
,
2102 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, where
);
2105 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2106 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2108 asprintf (&msg
, "%s for array '%s', "
2109 "upper bound of dimension %d exceeded", gfc_msg_fault
,
2111 gfc_trans_runtime_check (cond
, msg
, &se
->pre
, where
);
2115 /* Multiply the index by the stride. */
2116 stride
= gfc_conv_array_stride (se
->expr
, n
);
2117 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2120 /* And add it to the total. */
2121 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2124 tmp
= gfc_conv_array_offset (se
->expr
);
2125 if (!integer_zerop (tmp
))
2126 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2128 /* Access the calculated element. */
2129 tmp
= gfc_conv_array_data (se
->expr
);
2130 tmp
= build_fold_indirect_ref (tmp
);
2131 se
->expr
= gfc_build_array_ref (tmp
, index
);
2135 /* Generate the code to be executed immediately before entering a
2136 scalarization loop. */
2139 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2140 stmtblock_t
* pblock
)
2149 /* This code will be executed before entering the scalarization loop
2150 for this dimension. */
2151 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2153 if ((ss
->useflags
& flag
) == 0)
2156 if (ss
->type
!= GFC_SS_SECTION
2157 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2158 && ss
->type
!= GFC_SS_COMPONENT
)
2161 info
= &ss
->data
.info
;
2163 if (dim
>= info
->dimen
)
2166 if (dim
== info
->dimen
- 1)
2168 /* For the outermost loop calculate the offset due to any
2169 elemental dimensions. It will have been initialized with the
2170 base offset of the array. */
2173 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2175 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2178 gfc_init_se (&se
, NULL
);
2180 se
.expr
= info
->descriptor
;
2181 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2182 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2185 gfc_add_block_to_block (pblock
, &se
.pre
);
2187 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2188 info
->offset
, index
);
2189 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2193 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2196 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2198 /* Calculate the stride of the innermost loop. Hopefully this will
2199 allow the backend optimizers to do their stuff more effectively.
2201 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2205 /* Add the offset for the previous loop dimension. */
2210 ar
= &info
->ref
->u
.ar
;
2211 i
= loop
->order
[dim
+ 1];
2219 gfc_init_se (&se
, NULL
);
2221 se
.expr
= info
->descriptor
;
2222 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2223 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2225 gfc_add_block_to_block (pblock
, &se
.pre
);
2226 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2227 info
->offset
, index
);
2228 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2231 /* Remember this offset for the second loop. */
2232 if (dim
== loop
->temp_dim
- 1)
2233 info
->saved_offset
= info
->offset
;
2238 /* Start a scalarized expression. Creates a scope and declares loop
2242 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2248 gcc_assert (!loop
->array_parameter
);
2250 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2252 n
= loop
->order
[dim
];
2254 gfc_start_block (&loop
->code
[n
]);
2256 /* Create the loop variable. */
2257 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2259 if (dim
< loop
->temp_dim
)
2263 /* Calculate values that will be constant within this loop. */
2264 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2266 gfc_start_block (pbody
);
2270 /* Generates the actual loop code for a scalarization loop. */
2273 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2274 stmtblock_t
* pbody
)
2282 loopbody
= gfc_finish_block (pbody
);
2284 /* Initialize the loopvar. */
2285 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2287 exit_label
= gfc_build_label_decl (NULL_TREE
);
2289 /* Generate the loop body. */
2290 gfc_init_block (&block
);
2292 /* The exit condition. */
2293 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2294 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2295 TREE_USED (exit_label
) = 1;
2296 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
2297 gfc_add_expr_to_block (&block
, tmp
);
2299 /* The main body. */
2300 gfc_add_expr_to_block (&block
, loopbody
);
2302 /* Increment the loopvar. */
2303 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2304 loop
->loopvar
[n
], gfc_index_one_node
);
2305 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
2307 /* Build the loop. */
2308 tmp
= gfc_finish_block (&block
);
2309 tmp
= build1_v (LOOP_EXPR
, tmp
);
2310 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2312 /* Add the exit label. */
2313 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2314 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2318 /* Finishes and generates the loops for a scalarized expression. */
2321 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2326 stmtblock_t
*pblock
;
2330 /* Generate the loops. */
2331 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2333 n
= loop
->order
[dim
];
2334 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2335 loop
->loopvar
[n
] = NULL_TREE
;
2336 pblock
= &loop
->code
[n
];
2339 tmp
= gfc_finish_block (pblock
);
2340 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2342 /* Clear all the used flags. */
2343 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2348 /* Finish the main body of a scalarized expression, and start the secondary
2352 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2356 stmtblock_t
*pblock
;
2360 /* We finish as many loops as are used by the temporary. */
2361 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2363 n
= loop
->order
[dim
];
2364 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2365 loop
->loopvar
[n
] = NULL_TREE
;
2366 pblock
= &loop
->code
[n
];
2369 /* We don't want to finish the outermost loop entirely. */
2370 n
= loop
->order
[loop
->temp_dim
- 1];
2371 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2373 /* Restore the initial offsets. */
2374 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2376 if ((ss
->useflags
& 2) == 0)
2379 if (ss
->type
!= GFC_SS_SECTION
2380 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2381 && ss
->type
!= GFC_SS_COMPONENT
)
2384 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2387 /* Restart all the inner loops we just finished. */
2388 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2390 n
= loop
->order
[dim
];
2392 gfc_start_block (&loop
->code
[n
]);
2394 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2396 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2399 /* Start a block for the secondary copying code. */
2400 gfc_start_block (body
);
2404 /* Calculate the upper bound of an array section. */
2407 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2416 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2418 info
= &ss
->data
.info
;
2421 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2422 /* We'll calculate the upper bound once we have access to the
2423 vector's descriptor. */
2426 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2427 desc
= info
->descriptor
;
2428 end
= info
->ref
->u
.ar
.end
[dim
];
2432 /* The upper bound was specified. */
2433 gfc_init_se (&se
, NULL
);
2434 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2435 gfc_add_block_to_block (pblock
, &se
.pre
);
2440 /* No upper bound was specified, so use the bound of the array. */
2441 bound
= gfc_conv_array_ubound (desc
, dim
);
2448 /* Calculate the lower bound of an array section. */
2451 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2461 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2463 info
= &ss
->data
.info
;
2466 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2468 /* We use a zero-based index to access the vector. */
2469 info
->start
[n
] = gfc_index_zero_node
;
2470 info
->end
[n
] = gfc_index_zero_node
;
2471 info
->stride
[n
] = gfc_index_one_node
;
2475 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2476 desc
= info
->descriptor
;
2477 start
= info
->ref
->u
.ar
.start
[dim
];
2478 end
= info
->ref
->u
.ar
.end
[dim
];
2479 stride
= info
->ref
->u
.ar
.stride
[dim
];
2481 /* Calculate the start of the range. For vector subscripts this will
2482 be the range of the vector. */
2485 /* Specified section start. */
2486 gfc_init_se (&se
, NULL
);
2487 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2488 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2489 info
->start
[n
] = se
.expr
;
2493 /* No lower bound specified so use the bound of the array. */
2494 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2496 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2498 /* Similarly calculate the end. Although this is not used in the
2499 scalarizer, it is needed when checking bounds and where the end
2500 is an expression with side-effects. */
2503 /* Specified section start. */
2504 gfc_init_se (&se
, NULL
);
2505 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2506 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2507 info
->end
[n
] = se
.expr
;
2511 /* No upper bound specified so use the bound of the array. */
2512 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
2514 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
2516 /* Calculate the stride. */
2518 info
->stride
[n
] = gfc_index_one_node
;
2521 gfc_init_se (&se
, NULL
);
2522 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2523 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2524 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2529 /* Calculates the range start and stride for a SS chain. Also gets the
2530 descriptor and data pointer. The range of vector subscripts is the size
2531 of the vector. Array bounds are also checked. */
2534 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2542 /* Determine the rank of the loop. */
2544 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2548 case GFC_SS_SECTION
:
2549 case GFC_SS_CONSTRUCTOR
:
2550 case GFC_SS_FUNCTION
:
2551 case GFC_SS_COMPONENT
:
2552 loop
->dimen
= ss
->data
.info
.dimen
;
2555 /* As usual, lbound and ubound are exceptions!. */
2556 case GFC_SS_INTRINSIC
:
2557 switch (ss
->expr
->value
.function
.isym
->generic_id
)
2559 case GFC_ISYM_LBOUND
:
2560 case GFC_ISYM_UBOUND
:
2561 loop
->dimen
= ss
->data
.info
.dimen
;
2572 if (loop
->dimen
== 0)
2573 gfc_todo_error ("Unable to determine rank of expression");
2576 /* Loop over all the SS in the chain. */
2577 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2579 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2580 ss
->shape
= ss
->expr
->shape
;
2584 case GFC_SS_SECTION
:
2585 /* Get the descriptor for the array. */
2586 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2588 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2589 gfc_conv_section_startstride (loop
, ss
, n
);
2592 case GFC_SS_INTRINSIC
:
2593 switch (ss
->expr
->value
.function
.isym
->generic_id
)
2595 /* Fall through to supply start and stride. */
2596 case GFC_ISYM_LBOUND
:
2597 case GFC_ISYM_UBOUND
:
2603 case GFC_SS_CONSTRUCTOR
:
2604 case GFC_SS_FUNCTION
:
2605 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2607 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2608 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
2609 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2618 /* The rest is just runtime bound checking. */
2619 if (flag_bounds_check
)
2622 tree lbound
, ubound
;
2624 tree size
[GFC_MAX_DIMENSIONS
];
2625 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
;
2630 gfc_start_block (&block
);
2632 for (n
= 0; n
< loop
->dimen
; n
++)
2633 size
[n
] = NULL_TREE
;
2635 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2637 if (ss
->type
!= GFC_SS_SECTION
)
2640 /* TODO: range checking for mapped dimensions. */
2641 info
= &ss
->data
.info
;
2643 /* This code only checks ranges. Elemental and vector
2644 dimensions are checked later. */
2645 for (n
= 0; n
< loop
->dimen
; n
++)
2648 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
2650 if (n
== info
->ref
->u
.ar
.dimen
- 1
2651 && (info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
2652 || info
->ref
->u
.ar
.as
->cp_was_assumed
))
2655 desc
= ss
->data
.info
.descriptor
;
2657 /* This is the run-time equivalent of resolve.c's
2658 check_dimension(). The logical is more readable there
2659 than it is here, with all the trees. */
2660 lbound
= gfc_conv_array_lbound (desc
, dim
);
2661 ubound
= gfc_conv_array_ubound (desc
, dim
);
2664 /* Zero stride is not allowed. */
2665 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
2666 gfc_index_zero_node
);
2667 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
2668 "of array '%s'", info
->dim
[n
]+1,
2669 ss
->expr
->symtree
->name
);
2670 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2673 /* non_zerosized is true when the selected range is not
2675 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
2676 info
->stride
[n
], gfc_index_zero_node
);
2677 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
2679 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2682 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
2683 info
->stride
[n
], gfc_index_zero_node
);
2684 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
2686 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2688 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
2689 stride_pos
, stride_neg
);
2691 /* Check the start of the range against the lower and upper
2692 bounds of the array, if the range is not empty. */
2693 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, info
->start
[n
],
2695 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2696 non_zerosized
, tmp
);
2697 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2698 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2699 ss
->expr
->symtree
->name
);
2700 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2703 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, info
->start
[n
],
2705 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2706 non_zerosized
, tmp
);
2707 asprintf (&msg
, "%s, upper bound of dimension %d of array '%s'"
2708 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2709 ss
->expr
->symtree
->name
);
2710 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2713 /* Compute the last element of the range, which is not
2714 necessarily "end" (think 0:5:3, which doesn't contain 5)
2715 and check it against both lower and upper bounds. */
2716 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2718 tmp2
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp2
,
2720 tmp2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2723 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp2
, lbound
);
2724 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2725 non_zerosized
, tmp
);
2726 asprintf (&msg
, "%s, lower bound of dimension %d of array '%s'"
2727 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2728 ss
->expr
->symtree
->name
);
2729 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2732 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp2
, ubound
);
2733 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2734 non_zerosized
, tmp
);
2735 asprintf (&msg
, "%s, upper bound of dimension %d of array '%s'"
2736 " exceeded", gfc_msg_fault
, info
->dim
[n
]+1,
2737 ss
->expr
->symtree
->name
);
2738 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2741 /* Check the section sizes match. */
2742 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2744 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2746 /* We remember the size of the first section, and check all the
2747 others against this. */
2751 fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
2752 asprintf (&msg
, "%s, size mismatch for dimension %d "
2753 "of array '%s'", gfc_msg_bounds
, info
->dim
[n
]+1,
2754 ss
->expr
->symtree
->name
);
2755 gfc_trans_runtime_check (tmp
, msg
, &block
, &ss
->expr
->where
);
2759 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2763 tmp
= gfc_finish_block (&block
);
2764 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2769 /* Return true if the two SS could be aliased, i.e. both point to the same data
2771 /* TODO: resolve aliases based on frontend expressions. */
2774 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2781 lsym
= lss
->expr
->symtree
->n
.sym
;
2782 rsym
= rss
->expr
->symtree
->n
.sym
;
2783 if (gfc_symbols_could_alias (lsym
, rsym
))
2786 if (rsym
->ts
.type
!= BT_DERIVED
2787 && lsym
->ts
.type
!= BT_DERIVED
)
2790 /* For derived types we must check all the component types. We can ignore
2791 array references as these will have the same base type as the previous
2793 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2795 if (lref
->type
!= REF_COMPONENT
)
2798 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2801 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2804 if (rref
->type
!= REF_COMPONENT
)
2807 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2812 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2814 if (rref
->type
!= REF_COMPONENT
)
2817 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2825 /* Resolve array data dependencies. Creates a temporary if required. */
2826 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2830 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2840 loop
->temp_ss
= NULL
;
2841 aref
= dest
->data
.info
.ref
;
2844 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2846 if (ss
->type
!= GFC_SS_SECTION
)
2849 if (gfc_could_be_alias (dest
, ss
)
2850 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
2856 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
2858 lref
= dest
->expr
->ref
;
2859 rref
= ss
->expr
->ref
;
2861 nDepend
= gfc_dep_resolver (lref
, rref
);
2863 /* TODO : loop shifting. */
2866 /* Mark the dimensions for LOOP SHIFTING */
2867 for (n
= 0; n
< loop
->dimen
; n
++)
2869 int dim
= dest
->data
.info
.dim
[n
];
2871 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2873 else if (! gfc_is_same_range (&lref
->u
.ar
,
2874 &rref
->u
.ar
, dim
, 0))
2878 /* Put all the dimensions with dependencies in the
2881 for (n
= 0; n
< loop
->dimen
; n
++)
2883 gcc_assert (loop
->order
[n
] == n
);
2885 loop
->order
[dim
++] = n
;
2888 for (n
= 0; n
< loop
->dimen
; n
++)
2891 loop
->order
[dim
++] = n
;
2894 gcc_assert (dim
== loop
->dimen
);
2903 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
2904 if (GFC_ARRAY_TYPE_P (base_type
)
2905 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2906 base_type
= gfc_get_element_type (base_type
);
2907 loop
->temp_ss
= gfc_get_ss ();
2908 loop
->temp_ss
->type
= GFC_SS_TEMP
;
2909 loop
->temp_ss
->data
.temp
.type
= base_type
;
2910 loop
->temp_ss
->string_length
= dest
->string_length
;
2911 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
2912 loop
->temp_ss
->next
= gfc_ss_terminator
;
2913 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
2916 loop
->temp_ss
= NULL
;
2920 /* Initialize the scalarization loop. Creates the loop variables. Determines
2921 the range of the loop variables. Creates a temporary if required.
2922 Calculates how to transform from loop variables to array indices for each
2923 expression. Also generates code for scalar expressions which have been
2924 moved outside the loop. */
2927 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
2932 gfc_ss_info
*specinfo
;
2936 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
2937 bool dynamic
[GFC_MAX_DIMENSIONS
];
2943 for (n
= 0; n
< loop
->dimen
; n
++)
2947 /* We use one SS term, and use that to determine the bounds of the
2948 loop for this dimension. We try to pick the simplest term. */
2949 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2953 /* The frontend has worked out the size for us. */
2958 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
2960 /* An unknown size constructor will always be rank one.
2961 Higher rank constructors will either have known shape,
2962 or still be wrapped in a call to reshape. */
2963 gcc_assert (loop
->dimen
== 1);
2965 /* Always prefer to use the constructor bounds if the size
2966 can be determined at compile time. Prefer not to otherwise,
2967 since the general case involves realloc, and it's better to
2968 avoid that overhead if possible. */
2969 c
= ss
->expr
->value
.constructor
;
2970 dynamic
[n
] = gfc_get_array_constructor_size (&i
, c
);
2971 if (!dynamic
[n
] || !loopspec
[n
])
2976 /* TODO: Pick the best bound if we have a choice between a
2977 function and something else. */
2978 if (ss
->type
== GFC_SS_FUNCTION
)
2984 if (ss
->type
!= GFC_SS_SECTION
)
2988 specinfo
= &loopspec
[n
]->data
.info
;
2991 info
= &ss
->data
.info
;
2995 /* Criteria for choosing a loop specifier (most important first):
2996 doesn't need realloc
3002 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3004 else if (integer_onep (info
->stride
[n
])
3005 && !integer_onep (specinfo
->stride
[n
]))
3007 else if (INTEGER_CST_P (info
->stride
[n
])
3008 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3010 else if (INTEGER_CST_P (info
->start
[n
])
3011 && !INTEGER_CST_P (specinfo
->start
[n
]))
3013 /* We don't work out the upper bound.
3014 else if (INTEGER_CST_P (info->finish[n])
3015 && ! INTEGER_CST_P (specinfo->finish[n]))
3016 loopspec[n] = ss; */
3020 gfc_todo_error ("Unable to find scalarization loop specifier");
3022 info
= &loopspec
[n
]->data
.info
;
3024 /* Set the extents of this range. */
3025 cshape
= loopspec
[n
]->shape
;
3026 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3027 && INTEGER_CST_P (info
->stride
[n
]))
3029 loop
->from
[n
] = info
->start
[n
];
3030 mpz_set (i
, cshape
[n
]);
3031 mpz_sub_ui (i
, i
, 1);
3032 /* To = from + (size - 1) * stride. */
3033 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3034 if (!integer_onep (info
->stride
[n
]))
3035 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3036 tmp
, info
->stride
[n
]);
3037 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3038 loop
->from
[n
], tmp
);
3042 loop
->from
[n
] = info
->start
[n
];
3043 switch (loopspec
[n
]->type
)
3045 case GFC_SS_CONSTRUCTOR
:
3046 /* The upper bound is calculated when we expand the
3048 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3051 case GFC_SS_SECTION
:
3052 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3056 case GFC_SS_FUNCTION
:
3057 /* The loop bound will be set when we generate the call. */
3058 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3066 /* Transform everything so we have a simple incrementing variable. */
3067 if (integer_onep (info
->stride
[n
]))
3068 info
->delta
[n
] = gfc_index_zero_node
;
3071 /* Set the delta for this section. */
3072 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3073 /* Number of iterations is (end - start + step) / step.
3074 with start = 0, this simplifies to
3076 for (i = 0; i<=last; i++){...}; */
3077 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3078 loop
->to
[n
], loop
->from
[n
]);
3079 tmp
= fold_build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
3080 tmp
, info
->stride
[n
]);
3081 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3082 /* Make the loop variable start at 0. */
3083 loop
->from
[n
] = gfc_index_zero_node
;
3087 /* Add all the scalar code that can be taken out of the loops.
3088 This may include calculating the loop bounds, so do it before
3089 allocating the temporary. */
3090 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
3092 /* If we want a temporary then create it. */
3093 if (loop
->temp_ss
!= NULL
)
3095 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3096 tmp
= loop
->temp_ss
->data
.temp
.type
;
3097 len
= loop
->temp_ss
->string_length
;
3098 n
= loop
->temp_ss
->data
.temp
.dimen
;
3099 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3100 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3101 loop
->temp_ss
->data
.info
.dimen
= n
;
3102 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3103 &loop
->temp_ss
->data
.info
, tmp
, false, true,
3107 for (n
= 0; n
< loop
->temp_dim
; n
++)
3108 loopspec
[loop
->order
[n
]] = NULL
;
3112 /* For array parameters we don't have loop variables, so don't calculate the
3114 if (loop
->array_parameter
)
3117 /* Calculate the translation from loop variables to array indices. */
3118 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3120 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
3123 info
= &ss
->data
.info
;
3125 for (n
= 0; n
< info
->dimen
; n
++)
3129 /* If we are specifying the range the delta is already set. */
3130 if (loopspec
[n
] != ss
)
3132 /* Calculate the offset relative to the loop variable.
3133 First multiply by the stride. */
3134 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3135 loop
->from
[n
], info
->stride
[n
]);
3137 /* Then subtract this from our starting value. */
3138 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3139 info
->start
[n
], tmp
);
3141 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3148 /* Fills in an array descriptor, and returns the size of the array. The size
3149 will be a simple_val, ie a variable or a constant. Also calculates the
3150 offset of the base. Returns the size of the array.
3154 for (n = 0; n < rank; n++)
3156 a.lbound[n] = specified_lower_bound;
3157 offset = offset + a.lbond[n] * stride;
3159 a.ubound[n] = specified_upper_bound;
3160 a.stride[n] = stride;
3161 size = ubound + size; //size = ubound + 1 - lbound
3162 stride = stride * size;
3169 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3170 gfc_expr
** lower
, gfc_expr
** upper
,
3171 stmtblock_t
* pblock
)
3183 stmtblock_t thenblock
;
3184 stmtblock_t elseblock
;
3189 type
= TREE_TYPE (descriptor
);
3191 stride
= gfc_index_one_node
;
3192 offset
= gfc_index_zero_node
;
3194 /* Set the dtype. */
3195 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3196 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3198 or_expr
= NULL_TREE
;
3200 for (n
= 0; n
< rank
; n
++)
3202 /* We have 3 possibilities for determining the size of the array:
3203 lower == NULL => lbound = 1, ubound = upper[n]
3204 upper[n] = NULL => lbound = 1, ubound = lower[n]
3205 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3208 /* Set lower bound. */
3209 gfc_init_se (&se
, NULL
);
3211 se
.expr
= gfc_index_one_node
;
3214 gcc_assert (lower
[n
]);
3217 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3218 gfc_add_block_to_block (pblock
, &se
.pre
);
3222 se
.expr
= gfc_index_one_node
;
3226 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
3227 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3229 /* Work out the offset for this component. */
3230 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3231 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3233 /* Start the calculation for the size of this dimension. */
3234 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3235 gfc_index_one_node
, se
.expr
);
3237 /* Set upper bound. */
3238 gfc_init_se (&se
, NULL
);
3239 gcc_assert (ubound
);
3240 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3241 gfc_add_block_to_block (pblock
, &se
.pre
);
3243 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
3244 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
3246 /* Store the stride. */
3247 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
3248 gfc_add_modify_expr (pblock
, tmp
, stride
);
3250 /* Calculate the size of this dimension. */
3251 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3253 /* Check wether the size for this dimension is negative. */
3254 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3255 gfc_index_zero_node
);
3259 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3261 /* Multiply the stride by the number of elements in this dimension. */
3262 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3263 stride
= gfc_evaluate_now (stride
, pblock
);
3266 /* The stride is the number of elements in the array, so multiply by the
3267 size of an element to get the total size. */
3268 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3269 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
);
3271 if (poffset
!= NULL
)
3273 offset
= gfc_evaluate_now (offset
, pblock
);
3277 var
= gfc_create_var (TREE_TYPE (size
), "size");
3278 gfc_start_block (&thenblock
);
3279 gfc_add_modify_expr (&thenblock
, var
, gfc_index_zero_node
);
3280 thencase
= gfc_finish_block (&thenblock
);
3282 gfc_start_block (&elseblock
);
3283 gfc_add_modify_expr (&elseblock
, var
, size
);
3284 elsecase
= gfc_finish_block (&elseblock
);
3286 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3287 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3288 gfc_add_expr_to_block (pblock
, tmp
);
3294 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3295 the work for an ALLOCATE statement. */
3299 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3308 gfc_ref
*ref
, *prev_ref
= NULL
;
3309 bool allocatable_array
;
3313 /* Find the last reference in the chain. */
3314 while (ref
&& ref
->next
!= NULL
)
3316 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3321 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3325 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3327 allocatable_array
= prev_ref
->u
.c
.component
->allocatable
;
3329 /* Figure out the size of the array. */
3330 switch (ref
->u
.ar
.type
)
3334 upper
= ref
->u
.ar
.start
;
3338 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
3340 lower
= ref
->u
.ar
.as
->lower
;
3341 upper
= ref
->u
.ar
.as
->upper
;
3345 lower
= ref
->u
.ar
.start
;
3346 upper
= ref
->u
.ar
.end
;
3354 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
3355 lower
, upper
, &se
->pre
);
3357 /* Allocate memory to store the data. */
3358 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
3359 STRIP_NOPS (pointer
);
3361 if (TYPE_PRECISION (gfc_array_index_type
) == 32)
3363 if (allocatable_array
)
3364 allocate
= gfor_fndecl_allocate_array
;
3366 allocate
= gfor_fndecl_allocate
;
3368 else if (TYPE_PRECISION (gfc_array_index_type
) == 64)
3370 if (allocatable_array
)
3371 allocate
= gfor_fndecl_allocate64_array
;
3373 allocate
= gfor_fndecl_allocate64
;
3379 /* The allocate_array variants take the old pointer as first argument. */
3380 if (allocatable_array
)
3381 tmp
= gfc_chainon_list (tmp
, pointer
);
3382 tmp
= gfc_chainon_list (tmp
, size
);
3383 tmp
= gfc_chainon_list (tmp
, pstat
);
3384 tmp
= build_function_call_expr (allocate
, tmp
);
3385 tmp
= build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
3386 gfc_add_expr_to_block (&se
->pre
, tmp
);
3388 tmp
= gfc_conv_descriptor_offset (se
->expr
);
3389 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
3391 if (expr
->ts
.type
== BT_DERIVED
3392 && expr
->ts
.derived
->attr
.alloc_comp
)
3394 tmp
= gfc_nullify_alloc_comp (expr
->ts
.derived
, se
->expr
,
3395 ref
->u
.ar
.as
->rank
);
3396 gfc_add_expr_to_block (&se
->pre
, tmp
);
3403 /* Deallocate an array variable. Also used when an allocated variable goes
3408 gfc_array_deallocate (tree descriptor
, tree pstat
)
3414 gfc_start_block (&block
);
3415 /* Get a pointer to the data. */
3416 var
= gfc_conv_descriptor_data_get (descriptor
);
3419 /* Parameter is the address of the data component. */
3420 tmp
= gfc_chainon_list (NULL_TREE
, var
);
3421 tmp
= gfc_chainon_list (tmp
, pstat
);
3422 tmp
= build_function_call_expr (gfor_fndecl_deallocate
, tmp
);
3423 gfc_add_expr_to_block (&block
, tmp
);
3425 /* Zero the data pointer. */
3426 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
3427 var
, build_int_cst (TREE_TYPE (var
), 0));
3428 gfc_add_expr_to_block (&block
, tmp
);
3430 return gfc_finish_block (&block
);
3434 /* Create an array constructor from an initialization expression.
3435 We assume the frontend already did any expansions and conversions. */
3438 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
3445 unsigned HOST_WIDE_INT lo
;
3447 VEC(constructor_elt
,gc
) *v
= NULL
;
3449 switch (expr
->expr_type
)
3452 case EXPR_STRUCTURE
:
3453 /* A single scalar or derived type value. Create an array with all
3454 elements equal to that value. */
3455 gfc_init_se (&se
, NULL
);
3457 if (expr
->expr_type
== EXPR_CONSTANT
)
3458 gfc_conv_constant (&se
, expr
);
3460 gfc_conv_structure (&se
, expr
, 1);
3462 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3463 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
3464 hi
= TREE_INT_CST_HIGH (tmp
);
3465 lo
= TREE_INT_CST_LOW (tmp
);
3469 /* This will probably eat buckets of memory for large arrays. */
3470 while (hi
!= 0 || lo
!= 0)
3472 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
3480 /* Create a vector of all the elements. */
3481 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3485 /* Problems occur when we get something like
3486 integer :: a(lots) = (/(i, i=1,lots)/) */
3487 /* TODO: Unexpanded array initializers. */
3489 ("Possible frontend bug: array constructor not expanded");
3491 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3492 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3496 if (mpz_cmp_si (c
->repeat
, 0) != 0)
3500 mpz_set (maxval
, c
->repeat
);
3501 mpz_add (maxval
, c
->n
.offset
, maxval
);
3502 mpz_sub_ui (maxval
, maxval
, 1);
3503 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3504 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
3506 mpz_add_ui (maxval
, c
->n
.offset
, 1);
3507 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
3510 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
3512 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
3518 gfc_init_se (&se
, NULL
);
3519 switch (c
->expr
->expr_type
)
3522 gfc_conv_constant (&se
, c
->expr
);
3523 if (range
== NULL_TREE
)
3524 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3527 if (index
!= NULL_TREE
)
3528 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3529 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
3533 case EXPR_STRUCTURE
:
3534 gfc_conv_structure (&se
, c
->expr
, 1);
3535 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
3545 return gfc_build_null_descriptor (type
);
3551 /* Create a constructor from the list of elements. */
3552 tmp
= build_constructor (type
, v
);
3553 TREE_CONSTANT (tmp
) = 1;
3554 TREE_INVARIANT (tmp
) = 1;
3559 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3560 returns the size (in elements) of the array. */
3563 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
3564 stmtblock_t
* pblock
)
3579 size
= gfc_index_one_node
;
3580 offset
= gfc_index_zero_node
;
3581 for (dim
= 0; dim
< as
->rank
; dim
++)
3583 /* Evaluate non-constant array bound expressions. */
3584 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
3585 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
3587 gfc_init_se (&se
, NULL
);
3588 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
3589 gfc_add_block_to_block (pblock
, &se
.pre
);
3590 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
3592 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
3593 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
3595 gfc_init_se (&se
, NULL
);
3596 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
3597 gfc_add_block_to_block (pblock
, &se
.pre
);
3598 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
3600 /* The offset of this dimension. offset = offset - lbound * stride. */
3601 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
3602 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3604 /* The size of this dimension, and the stride of the next. */
3605 if (dim
+ 1 < as
->rank
)
3606 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3608 stride
= GFC_TYPE_ARRAY_SIZE (type
);
3610 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3612 /* Calculate stride = size * (ubound + 1 - lbound). */
3613 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3614 gfc_index_one_node
, lbound
);
3615 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
3616 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3618 gfc_add_modify_expr (pblock
, stride
, tmp
);
3620 stride
= gfc_evaluate_now (tmp
, pblock
);
3622 /* Make sure that negative size arrays are translated
3623 to being zero size. */
3624 tmp
= build2 (GE_EXPR
, boolean_type_node
,
3625 stride
, gfc_index_zero_node
);
3626 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3627 stride
, gfc_index_zero_node
);
3628 gfc_add_modify_expr (pblock
, stride
, tmp
);
3634 gfc_trans_vla_type_sizes (sym
, pblock
);
3641 /* Generate code to initialize/allocate an array variable. */
3644 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3654 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3656 /* Do nothing for USEd variables. */
3657 if (sym
->attr
.use_assoc
)
3660 type
= TREE_TYPE (decl
);
3661 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3662 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3664 gfc_start_block (&block
);
3666 /* Evaluate character string length. */
3667 if (sym
->ts
.type
== BT_CHARACTER
3668 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3670 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3672 gfc_trans_vla_type_sizes (sym
, &block
);
3674 /* Emit a DECL_EXPR for this variable, which will cause the
3675 gimplifier to allocate storage, and all that good stuff. */
3676 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3677 gfc_add_expr_to_block (&block
, tmp
);
3682 gfc_add_expr_to_block (&block
, fnbody
);
3683 return gfc_finish_block (&block
);
3686 type
= TREE_TYPE (type
);
3688 gcc_assert (!sym
->attr
.use_assoc
);
3689 gcc_assert (!TREE_STATIC (decl
));
3690 gcc_assert (!sym
->module
);
3692 if (sym
->ts
.type
== BT_CHARACTER
3693 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3694 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3696 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3698 /* Don't actually allocate space for Cray Pointees. */
3699 if (sym
->attr
.cray_pointee
)
3701 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3702 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3703 gfc_add_expr_to_block (&block
, fnbody
);
3704 return gfc_finish_block (&block
);
3707 /* The size is the number of elements in the array, so multiply by the
3708 size of an element to get the total size. */
3709 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3710 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3712 /* Allocate memory to hold the data. */
3713 tmp
= gfc_chainon_list (NULL_TREE
, size
);
3715 if (gfc_index_integer_kind
== 4)
3716 fndecl
= gfor_fndecl_internal_malloc
;
3717 else if (gfc_index_integer_kind
== 8)
3718 fndecl
= gfor_fndecl_internal_malloc64
;
3721 tmp
= build_function_call_expr (fndecl
, tmp
);
3722 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
3723 gfc_add_modify_expr (&block
, decl
, tmp
);
3725 /* Set offset of the array. */
3726 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3727 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3730 /* Automatic arrays should not have initializers. */
3731 gcc_assert (!sym
->value
);
3733 gfc_add_expr_to_block (&block
, fnbody
);
3735 /* Free the temporary. */
3736 tmp
= convert (pvoid_type_node
, decl
);
3737 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3738 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, tmp
);
3739 gfc_add_expr_to_block (&block
, tmp
);
3741 return gfc_finish_block (&block
);
3745 /* Generate entry and exit code for g77 calling convention arrays. */
3748 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3757 gfc_get_backend_locus (&loc
);
3758 gfc_set_backend_locus (&sym
->declared_at
);
3760 /* Descriptor type. */
3761 parm
= sym
->backend_decl
;
3762 type
= TREE_TYPE (parm
);
3763 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3765 gfc_start_block (&block
);
3767 if (sym
->ts
.type
== BT_CHARACTER
3768 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3769 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3771 /* Evaluate the bounds of the array. */
3772 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3774 /* Set the offset. */
3775 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3776 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3778 /* Set the pointer itself if we aren't using the parameter directly. */
3779 if (TREE_CODE (parm
) != PARM_DECL
)
3781 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3782 gfc_add_modify_expr (&block
, parm
, tmp
);
3784 tmp
= gfc_finish_block (&block
);
3786 gfc_set_backend_locus (&loc
);
3788 gfc_start_block (&block
);
3789 /* Add the initialization code to the start of the function. */
3790 gfc_add_expr_to_block (&block
, tmp
);
3791 gfc_add_expr_to_block (&block
, body
);
3793 return gfc_finish_block (&block
);
3797 /* Modify the descriptor of an array parameter so that it has the
3798 correct lower bound. Also move the upper bound accordingly.
3799 If the array is not packed, it will be copied into a temporary.
3800 For each dimension we set the new lower and upper bounds. Then we copy the
3801 stride and calculate the offset for this dimension. We also work out
3802 what the stride of a packed array would be, and see it the two match.
3803 If the array need repacking, we set the stride to the values we just
3804 calculated, recalculate the offset and copy the array data.
3805 Code is also added to copy the data back at the end of the function.
3809 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3816 stmtblock_t cleanup
;
3824 tree stride
, stride2
;
3834 /* Do nothing for pointer and allocatable arrays. */
3835 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3838 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3839 return gfc_trans_g77_array (sym
, body
);
3841 gfc_get_backend_locus (&loc
);
3842 gfc_set_backend_locus (&sym
->declared_at
);
3844 /* Descriptor type. */
3845 type
= TREE_TYPE (tmpdesc
);
3846 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3847 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3848 dumdesc
= build_fold_indirect_ref (dumdesc
);
3849 gfc_start_block (&block
);
3851 if (sym
->ts
.type
== BT_CHARACTER
3852 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3853 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3855 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3857 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3858 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3860 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3862 /* For non-constant shape arrays we only check if the first dimension
3863 is contiguous. Repacking higher dimensions wouldn't gain us
3864 anything as we still don't know the array stride. */
3865 partial
= gfc_create_var (boolean_type_node
, "partial");
3866 TREE_USED (partial
) = 1;
3867 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3868 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
3869 gfc_add_modify_expr (&block
, partial
, tmp
);
3873 partial
= NULL_TREE
;
3876 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3877 here, however I think it does the right thing. */
3880 /* Set the first stride. */
3881 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3882 stride
= gfc_evaluate_now (stride
, &block
);
3884 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, gfc_index_zero_node
);
3885 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3886 gfc_index_one_node
, stride
);
3887 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3888 gfc_add_modify_expr (&block
, stride
, tmp
);
3890 /* Allow the user to disable array repacking. */
3891 stmt_unpacked
= NULL_TREE
;
3895 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3896 /* A library call to repack the array if necessary. */
3897 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3898 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3899 stmt_unpacked
= build_function_call_expr (gfor_fndecl_in_pack
, tmp
);
3901 stride
= gfc_index_one_node
;
3904 /* This is for the case where the array data is used directly without
3905 calling the repack function. */
3906 if (no_repack
|| partial
!= NULL_TREE
)
3907 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
3909 stmt_packed
= NULL_TREE
;
3911 /* Assign the data pointer. */
3912 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3914 /* Don't repack unknown shape arrays when the first stride is 1. */
3915 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3916 stmt_packed
, stmt_unpacked
);
3919 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3920 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
3922 offset
= gfc_index_zero_node
;
3923 size
= gfc_index_one_node
;
3925 /* Evaluate the bounds of the array. */
3926 for (n
= 0; n
< sym
->as
->rank
; n
++)
3928 if (checkparm
|| !sym
->as
->upper
[n
])
3930 /* Get the bounds of the actual parameter. */
3931 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3932 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3936 dubound
= NULL_TREE
;
3937 dlbound
= NULL_TREE
;
3940 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3941 if (!INTEGER_CST_P (lbound
))
3943 gfc_init_se (&se
, NULL
);
3944 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
3945 gfc_array_index_type
);
3946 gfc_add_block_to_block (&block
, &se
.pre
);
3947 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3950 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3951 /* Set the desired upper bound. */
3952 if (sym
->as
->upper
[n
])
3954 /* We know what we want the upper bound to be. */
3955 if (!INTEGER_CST_P (ubound
))
3957 gfc_init_se (&se
, NULL
);
3958 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3959 gfc_array_index_type
);
3960 gfc_add_block_to_block (&block
, &se
.pre
);
3961 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3964 /* Check the sizes match. */
3967 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3970 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3972 stride2
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3974 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
3975 asprintf (&msg
, "%s for dimension %d of array '%s'",
3976 gfc_msg_bounds
, n
+1, sym
->name
);
3977 gfc_trans_runtime_check (tmp
, msg
, &block
, &loc
);
3983 /* For assumed shape arrays move the upper bound by the same amount
3984 as the lower bound. */
3985 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3986 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
3987 gfc_add_modify_expr (&block
, ubound
, tmp
);
3989 /* The offset of this dimension. offset = offset - lbound * stride. */
3990 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
3991 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3993 /* The size of this dimension, and the stride of the next. */
3994 if (n
+ 1 < sym
->as
->rank
)
3996 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3998 if (no_repack
|| partial
!= NULL_TREE
)
4001 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
4004 /* Figure out the stride if not a known constant. */
4005 if (!INTEGER_CST_P (stride
))
4008 stmt_packed
= NULL_TREE
;
4011 /* Calculate stride = size * (ubound + 1 - lbound). */
4012 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4013 gfc_index_one_node
, lbound
);
4014 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4016 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4021 /* Assign the stride. */
4022 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4023 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4024 stmt_unpacked
, stmt_packed
);
4026 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4027 gfc_add_modify_expr (&block
, stride
, tmp
);
4032 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4034 if (stride
&& !INTEGER_CST_P (stride
))
4036 /* Calculate size = stride * (ubound + 1 - lbound). */
4037 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4038 gfc_index_one_node
, lbound
);
4039 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4041 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4042 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4043 gfc_add_modify_expr (&block
, stride
, tmp
);
4048 /* Set the offset. */
4049 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4050 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4052 gfc_trans_vla_type_sizes (sym
, &block
);
4054 stmt
= gfc_finish_block (&block
);
4056 gfc_start_block (&block
);
4058 /* Only do the entry/initialization code if the arg is present. */
4059 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4060 optional_arg
= (sym
->attr
.optional
4061 || (sym
->ns
->proc_name
->attr
.entry_master
4062 && sym
->attr
.dummy
));
4065 tmp
= gfc_conv_expr_present (sym
);
4066 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4068 gfc_add_expr_to_block (&block
, stmt
);
4070 /* Add the main function body. */
4071 gfc_add_expr_to_block (&block
, body
);
4076 gfc_start_block (&cleanup
);
4078 if (sym
->attr
.intent
!= INTENT_IN
)
4080 /* Copy the data back. */
4081 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
4082 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
4083 tmp
= build_function_call_expr (gfor_fndecl_in_unpack
, tmp
);
4084 gfc_add_expr_to_block (&cleanup
, tmp
);
4087 /* Free the temporary. */
4088 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
4089 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, tmp
);
4090 gfc_add_expr_to_block (&cleanup
, tmp
);
4092 stmt
= gfc_finish_block (&cleanup
);
4094 /* Only do the cleanup if the array was repacked. */
4095 tmp
= build_fold_indirect_ref (dumdesc
);
4096 tmp
= gfc_conv_descriptor_data_get (tmp
);
4097 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4098 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4102 tmp
= gfc_conv_expr_present (sym
);
4103 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4105 gfc_add_expr_to_block (&block
, stmt
);
4107 /* We don't need to free any memory allocated by internal_pack as it will
4108 be freed at the end of the function by pop_context. */
4109 return gfc_finish_block (&block
);
4113 /* Convert an array for passing as an actual argument. Expressions and
4114 vector subscripts are evaluated and stored in a temporary, which is then
4115 passed. For whole arrays the descriptor is passed. For array sections
4116 a modified copy of the descriptor is passed, but using the original data.
4118 This function is also used for array pointer assignments, and there
4121 - want_pointer && !se->direct_byref
4122 EXPR is an actual argument. On exit, se->expr contains a
4123 pointer to the array descriptor.
4125 - !want_pointer && !se->direct_byref
4126 EXPR is an actual argument to an intrinsic function or the
4127 left-hand side of a pointer assignment. On exit, se->expr
4128 contains the descriptor for EXPR.
4130 - !want_pointer && se->direct_byref
4131 EXPR is the right-hand side of a pointer assignment and
4132 se->expr is the descriptor for the previously-evaluated
4133 left-hand side. The function creates an assignment from
4134 EXPR to se->expr. */
4137 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
4151 gcc_assert (ss
!= gfc_ss_terminator
);
4153 /* TODO: Pass constant array constructors without a temporary. */
4154 /* Special case things we know we can pass easily. */
4155 switch (expr
->expr_type
)
4158 /* If we have a linear array section, we can pass it directly.
4159 Otherwise we need to copy it into a temporary. */
4161 /* Find the SS for the array section. */
4163 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
4164 secss
= secss
->next
;
4166 gcc_assert (secss
!= gfc_ss_terminator
);
4167 info
= &secss
->data
.info
;
4169 /* Get the descriptor for the array. */
4170 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
4171 desc
= info
->descriptor
;
4173 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
);
4176 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
4178 /* Create a new descriptor if the array doesn't have one. */
4181 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
4183 else if (se
->direct_byref
)
4186 full
= gfc_full_array_ref_p (info
->ref
);
4190 if (se
->direct_byref
)
4192 /* Copy the descriptor for pointer assignments. */
4193 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
4195 else if (se
->want_pointer
)
4197 /* We pass full arrays directly. This means that pointers and
4198 allocatable arrays should also work. */
4199 se
->expr
= build_fold_addr_expr (desc
);
4206 if (expr
->ts
.type
== BT_CHARACTER
)
4207 se
->string_length
= gfc_get_expr_charlen (expr
);
4214 /* A transformational function return value will be a temporary
4215 array descriptor. We still need to go through the scalarizer
4216 to create the descriptor. Elemental functions ar handled as
4217 arbitrary expressions, i.e. copy to a temporary. */
4219 /* Look for the SS for this function. */
4220 while (secss
!= gfc_ss_terminator
4221 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
4222 secss
= secss
->next
;
4224 if (se
->direct_byref
)
4226 gcc_assert (secss
!= gfc_ss_terminator
);
4228 /* For pointer assignments pass the descriptor directly. */
4230 se
->expr
= build_fold_addr_expr (se
->expr
);
4231 gfc_conv_expr (se
, expr
);
4235 if (secss
== gfc_ss_terminator
)
4237 /* Elemental function. */
4243 /* Transformational function. */
4244 info
= &secss
->data
.info
;
4250 /* Something complicated. Copy it into a temporary. */
4258 gfc_init_loopinfo (&loop
);
4260 /* Associate the SS with the loop. */
4261 gfc_add_ss_to_loop (&loop
, ss
);
4263 /* Tell the scalarizer not to bother creating loop variables, etc. */
4265 loop
.array_parameter
= 1;
4267 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4268 gcc_assert (!se
->direct_byref
);
4270 /* Setup the scalarizing loops and bounds. */
4271 gfc_conv_ss_startstride (&loop
);
4275 /* Tell the scalarizer to make a temporary. */
4276 loop
.temp_ss
= gfc_get_ss ();
4277 loop
.temp_ss
->type
= GFC_SS_TEMP
;
4278 loop
.temp_ss
->next
= gfc_ss_terminator
;
4279 if (expr
->ts
.type
== BT_CHARACTER
)
4281 if (expr
->ts
.cl
== NULL
)
4283 /* This had better be a substring reference! */
4284 gfc_ref
*char_ref
= expr
->ref
;
4285 for (; char_ref
; char_ref
= char_ref
->next
)
4286 if (char_ref
->type
== REF_SUBSTRING
)
4289 expr
->ts
.cl
= gfc_get_charlen ();
4290 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
4291 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
4293 mpz_init_set_ui (char_len
, 1);
4294 mpz_add (char_len
, char_len
,
4295 char_ref
->u
.ss
.end
->value
.integer
);
4296 mpz_sub (char_len
, char_len
,
4297 char_ref
->u
.ss
.start
->value
.integer
);
4298 expr
->ts
.cl
->backend_decl
4299 = gfc_conv_mpz_to_tree (char_len
,
4300 gfc_default_character_kind
);
4301 /* Cast is necessary for *-charlen refs. */
4302 expr
->ts
.cl
->backend_decl
4303 = convert (gfc_charlen_type_node
,
4304 expr
->ts
.cl
->backend_decl
);
4305 mpz_clear (char_len
);
4308 gcc_assert (char_ref
!= NULL
);
4309 loop
.temp_ss
->data
.temp
.type
4310 = gfc_typenode_for_spec (&expr
->ts
);
4311 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4313 else if (expr
->ts
.cl
->length
4314 && expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4316 expr
->ts
.cl
->backend_decl
4317 = gfc_conv_mpz_to_tree (expr
->ts
.cl
->length
->value
.integer
,
4318 expr
->ts
.cl
->length
->ts
.kind
);
4319 loop
.temp_ss
->data
.temp
.type
4320 = gfc_typenode_for_spec (&expr
->ts
);
4321 loop
.temp_ss
->string_length
4322 = TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
4326 loop
.temp_ss
->data
.temp
.type
4327 = gfc_typenode_for_spec (&expr
->ts
);
4328 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
4330 se
->string_length
= loop
.temp_ss
->string_length
;
4334 loop
.temp_ss
->data
.temp
.type
4335 = gfc_typenode_for_spec (&expr
->ts
);
4336 loop
.temp_ss
->string_length
= NULL
;
4338 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
4339 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4342 gfc_conv_loop_setup (&loop
);
4346 /* Copy into a temporary and pass that. We don't need to copy the data
4347 back because expressions and vector subscripts must be INTENT_IN. */
4348 /* TODO: Optimize passing function return values. */
4352 /* Start the copying loops. */
4353 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4354 gfc_mark_ss_chain_used (ss
, 1);
4355 gfc_start_scalarized_body (&loop
, &block
);
4357 /* Copy each data element. */
4358 gfc_init_se (&lse
, NULL
);
4359 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4360 gfc_init_se (&rse
, NULL
);
4361 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4363 lse
.ss
= loop
.temp_ss
;
4366 gfc_conv_scalarized_array_ref (&lse
, NULL
);
4367 if (expr
->ts
.type
== BT_CHARACTER
)
4369 gfc_conv_expr (&rse
, expr
);
4370 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
4371 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4374 gfc_conv_expr_val (&rse
, expr
);
4376 gfc_add_block_to_block (&block
, &rse
.pre
);
4377 gfc_add_block_to_block (&block
, &lse
.pre
);
4379 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
4381 /* Finish the copying loops. */
4382 gfc_trans_scalarizing_loops (&loop
, &block
);
4384 desc
= loop
.temp_ss
->data
.info
.descriptor
;
4386 gcc_assert (is_gimple_lvalue (desc
));
4388 else if (expr
->expr_type
== EXPR_FUNCTION
)
4390 desc
= info
->descriptor
;
4391 se
->string_length
= ss
->string_length
;
4395 /* We pass sections without copying to a temporary. Make a new
4396 descriptor and point it at the section we want. The loop variable
4397 limits will be the limits of the section.
4398 A function may decide to repack the array to speed up access, but
4399 we're not bothered about that here. */
4408 /* Set the string_length for a character array. */
4409 if (expr
->ts
.type
== BT_CHARACTER
)
4410 se
->string_length
= gfc_get_expr_charlen (expr
);
4412 desc
= info
->descriptor
;
4413 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
4414 if (se
->direct_byref
)
4416 /* For pointer assignments we fill in the destination. */
4418 parmtype
= TREE_TYPE (parm
);
4422 /* Otherwise make a new one. */
4423 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4424 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
4425 loop
.from
, loop
.to
, 0);
4426 parm
= gfc_create_var (parmtype
, "parm");
4429 offset
= gfc_index_zero_node
;
4432 /* The following can be somewhat confusing. We have two
4433 descriptors, a new one and the original array.
4434 {parm, parmtype, dim} refer to the new one.
4435 {desc, type, n, secss, loop} refer to the original, which maybe
4436 a descriptorless array.
4437 The bounds of the scalarization are the bounds of the section.
4438 We don't have to worry about numeric overflows when calculating
4439 the offsets because all elements are within the array data. */
4441 /* Set the dtype. */
4442 tmp
= gfc_conv_descriptor_dtype (parm
);
4443 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
4445 if (se
->direct_byref
)
4446 base
= gfc_index_zero_node
;
4450 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
4452 stride
= gfc_conv_array_stride (desc
, n
);
4454 /* Work out the offset. */
4455 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4457 gcc_assert (info
->subscript
[n
]
4458 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
4459 start
= info
->subscript
[n
]->data
.scalar
.expr
;
4463 /* Check we haven't somehow got out of sync. */
4464 gcc_assert (info
->dim
[dim
] == n
);
4466 /* Evaluate and remember the start of the section. */
4467 start
= info
->start
[dim
];
4468 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
4471 tmp
= gfc_conv_array_lbound (desc
, n
);
4472 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
4474 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
4475 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
4477 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
4479 /* For elemental dimensions, we only need the offset. */
4483 /* Vector subscripts need copying and are handled elsewhere. */
4484 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
4486 /* Set the new lower bound. */
4487 from
= loop
.from
[dim
];
4490 /* If we have an array section or are assigning to a pointer,
4491 make sure that the lower bound is 1. References to the full
4492 array should otherwise keep the original bounds. */
4493 if ((info
->ref
->u
.ar
.type
!= AR_FULL
|| se
->direct_byref
)
4494 && !integer_onep (from
))
4496 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4497 gfc_index_one_node
, from
);
4498 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
4499 from
= gfc_index_one_node
;
4501 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
4502 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
4504 /* Set the new upper bound. */
4505 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
4506 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
4508 /* Multiply the stride by the section stride to get the
4510 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4511 stride
, info
->stride
[dim
]);
4513 if (se
->direct_byref
)
4514 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
4517 /* Store the new stride. */
4518 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
4519 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
4524 if (se
->data_not_needed
)
4525 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, gfc_index_zero_node
);
4528 /* Point the data pointer at the first element in the section. */
4529 tmp
= gfc_conv_array_data (desc
);
4530 tmp
= build_fold_indirect_ref (tmp
);
4531 tmp
= gfc_build_array_ref (tmp
, offset
);
4532 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4533 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, offset
);
4536 if (se
->direct_byref
&& !se
->data_not_needed
)
4538 /* Set the offset. */
4539 tmp
= gfc_conv_descriptor_offset (parm
);
4540 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
4544 /* Only the callee knows what the correct offset it, so just set
4546 tmp
= gfc_conv_descriptor_offset (parm
);
4547 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
4552 if (!se
->direct_byref
)
4554 /* Get a pointer to the new descriptor. */
4555 if (se
->want_pointer
)
4556 se
->expr
= build_fold_addr_expr (desc
);
4561 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4562 gfc_add_block_to_block (&se
->post
, &loop
.post
);
4564 /* Cleanup the scalarizer. */
4565 gfc_cleanup_loop (&loop
);
4569 /* Convert an array for passing as an actual parameter. */
4570 /* TODO: Optimize passing g77 arrays. */
4573 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
4582 /* Passing address of the array if it is not pointer or assumed-shape. */
4583 if (expr
->expr_type
== EXPR_VARIABLE
4584 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
4586 sym
= expr
->symtree
->n
.sym
;
4587 tmp
= gfc_get_symbol_decl (sym
);
4589 if (sym
->ts
.type
== BT_CHARACTER
)
4590 se
->string_length
= sym
->ts
.cl
->backend_decl
;
4591 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
4592 && !sym
->attr
.allocatable
)
4594 /* Some variables are declared directly, others are declared as
4595 pointers and allocated on the heap. */
4596 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
4599 se
->expr
= build_fold_addr_expr (tmp
);
4602 if (sym
->attr
.allocatable
)
4604 if (sym
->attr
.dummy
)
4606 gfc_conv_expr_descriptor (se
, expr
, ss
);
4607 se
->expr
= gfc_conv_array_data (se
->expr
);
4610 se
->expr
= gfc_conv_array_data (tmp
);
4615 se
->want_pointer
= 1;
4616 gfc_conv_expr_descriptor (se
, expr
, ss
);
4618 /* Deallocate the allocatable components of structures that are
4620 if (expr
->ts
.type
== BT_DERIVED
4621 && expr
->ts
.derived
->attr
.alloc_comp
4622 && expr
->expr_type
!= EXPR_VARIABLE
)
4624 tmp
= build_fold_indirect_ref (se
->expr
);
4625 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.derived
, tmp
, expr
->rank
);
4626 gfc_add_expr_to_block (&se
->post
, tmp
);
4632 /* Repack the array. */
4633 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
4634 ptr
= build_function_call_expr (gfor_fndecl_in_pack
, tmp
);
4635 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
4638 gfc_start_block (&block
);
4640 /* Copy the data back. */
4641 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
4642 tmp
= gfc_chainon_list (tmp
, ptr
);
4643 tmp
= build_function_call_expr (gfor_fndecl_in_unpack
, tmp
);
4644 gfc_add_expr_to_block (&block
, tmp
);
4646 /* Free the temporary. */
4647 tmp
= convert (pvoid_type_node
, ptr
);
4648 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
4649 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, tmp
);
4650 gfc_add_expr_to_block (&block
, tmp
);
4652 stmt
= gfc_finish_block (&block
);
4654 gfc_init_block (&block
);
4655 /* Only if it was repacked. This code needs to be executed before the
4656 loop cleanup code. */
4657 tmp
= build_fold_indirect_ref (desc
);
4658 tmp
= gfc_conv_array_data (tmp
);
4659 tmp
= build2 (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
4660 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
4662 gfc_add_expr_to_block (&block
, tmp
);
4663 gfc_add_block_to_block (&block
, &se
->post
);
4665 gfc_init_block (&se
->post
);
4666 gfc_add_block_to_block (&se
->post
, &block
);
4671 /* Generate code to deallocate an array, if it is allocated. */
4674 gfc_trans_dealloc_allocated (tree descriptor
)
4681 gfc_start_block (&block
);
4683 var
= gfc_conv_descriptor_data_get (descriptor
);
4685 tmp
= gfc_create_var (gfc_array_index_type
, NULL
);
4686 ptr
= build_fold_addr_expr (tmp
);
4688 /* Call array_deallocate with an int* present in the second argument.
4689 Although it is ignored here, it's presence ensures that arrays that
4690 are already deallocated are ignored. */
4691 tmp
= gfc_chainon_list (NULL_TREE
, var
);
4692 tmp
= gfc_chainon_list (tmp
, ptr
);
4693 tmp
= build_function_call_expr (gfor_fndecl_deallocate
, tmp
);
4694 gfc_add_expr_to_block (&block
, tmp
);
4696 /* Zero the data pointer. */
4697 tmp
= build2 (MODIFY_EXPR
, void_type_node
,
4698 var
, build_int_cst (TREE_TYPE (var
), 0));
4699 gfc_add_expr_to_block (&block
, tmp
);
4701 return gfc_finish_block (&block
);
4705 /* This helper function calculates the size in words of a full array. */
4708 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
4713 idx
= gfc_rank_cst
[rank
- 1];
4714 nelems
= gfc_conv_descriptor_ubound (decl
, idx
);
4715 tmp
= gfc_conv_descriptor_lbound (decl
, idx
);
4716 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
4717 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
4718 tmp
, gfc_index_one_node
);
4719 tmp
= gfc_evaluate_now (tmp
, block
);
4721 nelems
= gfc_conv_descriptor_stride (decl
, idx
);
4722 tmp
= build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
4723 return gfc_evaluate_now (tmp
, block
);
4727 /* Allocate dest to the same size as src, and copy src -> dest. */
4730 gfc_duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
)
4740 /* If the source is null, set the destination to null. */
4741 gfc_init_block (&block
);
4742 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4743 null_data
= gfc_finish_block (&block
);
4745 gfc_init_block (&block
);
4747 nelems
= get_full_array_size (&block
, src
, rank
);
4748 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
,
4749 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
4751 /* Allocate memory to the destination. */
4752 tmp
= gfc_chainon_list (NULL_TREE
, size
);
4753 if (gfc_index_integer_kind
== 4)
4754 tmp
= build_function_call_expr (gfor_fndecl_internal_malloc
, tmp
);
4755 else if (gfc_index_integer_kind
== 8)
4756 tmp
= build_function_call_expr (gfor_fndecl_internal_malloc64
, tmp
);
4759 tmp
= fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (src
)),
4761 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
4763 /* We know the temporary and the value will be the same length,
4764 so can use memcpy. */
4765 tmp
= gfc_conv_descriptor_data_get (dest
);
4766 args
= gfc_chainon_list (NULL_TREE
, tmp
);
4767 tmp
= gfc_conv_descriptor_data_get (src
);
4768 args
= gfc_chainon_list (args
, tmp
);
4769 args
= gfc_chainon_list (args
, size
);
4770 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
4771 tmp
= build_function_call_expr (tmp
, args
);
4772 gfc_add_expr_to_block (&block
, tmp
);
4773 tmp
= gfc_finish_block (&block
);
4775 /* Null the destination if the source is null; otherwise do
4776 the allocate and copy. */
4777 null_cond
= gfc_conv_descriptor_data_get (src
);
4778 null_cond
= convert (pvoid_type_node
, null_cond
);
4779 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
4781 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
4785 /* Recursively traverse an object of derived type, generating code to
4786 deallocate, nullify or copy allocatable components. This is the work horse
4787 function for the functions named in this enum. */
4789 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
};
4792 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
4793 tree dest
, int rank
, int purpose
)
4797 stmtblock_t fnblock
;
4798 stmtblock_t loopbody
;
4808 tree null_cond
= NULL_TREE
;
4810 gfc_init_block (&fnblock
);
4812 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
4813 decl
= build_fold_indirect_ref (decl
);
4815 /* If this an array of derived types with allocatable components
4816 build a loop and recursively call this function. */
4817 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
4818 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
4820 tmp
= gfc_conv_array_data (decl
);
4821 var
= build_fold_indirect_ref (tmp
);
4823 /* Get the number of elements - 1 and set the counter. */
4824 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
4826 /* Use the descriptor for an allocatable array. Since this
4827 is a full array reference, we only need the descriptor
4828 information from dimension = rank. */
4829 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
4830 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
4831 tmp
, gfc_index_one_node
);
4833 null_cond
= gfc_conv_descriptor_data_get (decl
);
4834 null_cond
= build2 (NE_EXPR
, boolean_type_node
, null_cond
,
4835 build_int_cst (TREE_TYPE (tmp
), 0));
4839 /* Otherwise use the TYPE_DOMAIN information. */
4840 tmp
= array_type_nelts (TREE_TYPE (decl
));
4841 tmp
= fold_convert (gfc_array_index_type
, tmp
);
4844 /* Remember that this is, in fact, the no. of elements - 1. */
4845 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
4846 index
= gfc_create_var (gfc_array_index_type
, "S");
4848 /* Build the body of the loop. */
4849 gfc_init_block (&loopbody
);
4851 vref
= gfc_build_array_ref (var
, index
);
4853 if (purpose
== COPY_ALLOC_COMP
)
4855 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
4856 gfc_add_expr_to_block (&fnblock
, tmp
);
4858 tmp
= build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest
));
4859 dref
= gfc_build_array_ref (tmp
, index
);
4860 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
4863 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
4865 gfc_add_expr_to_block (&loopbody
, tmp
);
4867 /* Build the loop and return. */
4868 gfc_init_loopinfo (&loop
);
4870 loop
.from
[0] = gfc_index_zero_node
;
4871 loop
.loopvar
[0] = index
;
4872 loop
.to
[0] = nelems
;
4873 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
4874 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
4876 tmp
= gfc_finish_block (&fnblock
);
4877 if (null_cond
!= NULL_TREE
)
4878 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
, build_empty_stmt ());
4883 /* Otherwise, act on the components or recursively call self to
4884 act on a chain of components. */
4885 for (c
= der_type
->components
; c
; c
= c
->next
)
4887 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
4888 && c
->ts
.derived
->attr
.alloc_comp
;
4889 cdecl = c
->backend_decl
;
4890 ctype
= TREE_TYPE (cdecl);
4894 case DEALLOCATE_ALLOC_COMP
:
4895 /* Do not deallocate the components of ultimate pointer
4897 if (cmp_has_alloc_comps
&& !c
->pointer
)
4899 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
4900 rank
= c
->as
? c
->as
->rank
: 0;
4901 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
4903 gfc_add_expr_to_block (&fnblock
, tmp
);
4908 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
4909 tmp
= gfc_trans_dealloc_allocated (comp
);
4910 gfc_add_expr_to_block (&fnblock
, tmp
);
4914 case NULLIFY_ALLOC_COMP
:
4917 else if (c
->allocatable
)
4919 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
4920 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
4922 else if (cmp_has_alloc_comps
)
4924 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
4925 rank
= c
->as
? c
->as
->rank
: 0;
4926 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, NULL_TREE
,
4928 gfc_add_expr_to_block (&fnblock
, tmp
);
4932 case COPY_ALLOC_COMP
:
4936 /* We need source and destination components. */
4937 comp
= build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
4938 dcmp
= build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
4939 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
4941 if (c
->allocatable
&& !cmp_has_alloc_comps
)
4943 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, c
->as
->rank
);
4944 gfc_add_expr_to_block (&fnblock
, tmp
);
4947 if (cmp_has_alloc_comps
)
4949 rank
= c
->as
? c
->as
->rank
: 0;
4950 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
4951 gfc_add_modify_expr (&fnblock
, dcmp
, tmp
);
4952 tmp
= structure_alloc_comps (c
->ts
.derived
, comp
, dcmp
,
4954 gfc_add_expr_to_block (&fnblock
, tmp
);
4964 return gfc_finish_block (&fnblock
);
4967 /* Recursively traverse an object of derived type, generating code to
4968 nullify allocatable components. */
4971 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
4973 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
4974 NULLIFY_ALLOC_COMP
);
4978 /* Recursively traverse an object of derived type, generating code to
4979 deallocate allocatable components. */
4982 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
4984 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
4985 DEALLOCATE_ALLOC_COMP
);
4989 /* Recursively traverse an object of derived type, generating code to
4990 copy its allocatable components. */
4993 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
4995 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
4999 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5000 Do likewise, recursively if necessary, with the allocatable components of
5004 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
5009 stmtblock_t fnblock
;
5012 bool sym_has_alloc_comp
;
5014 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
5015 && sym
->ts
.derived
->attr
.alloc_comp
;
5017 /* Make sure the frontend gets these right. */
5018 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
5019 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5020 "allocatable attribute or derived type without allocatable "
5023 gfc_init_block (&fnblock
);
5025 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
5026 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
5028 if (sym
->ts
.type
== BT_CHARACTER
5029 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
5031 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
5032 gfc_trans_vla_type_sizes (sym
, &fnblock
);
5035 /* Dummy and use associated variables don't need anything special. */
5036 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
5038 gfc_add_expr_to_block (&fnblock
, body
);
5040 return gfc_finish_block (&fnblock
);
5043 gfc_get_backend_locus (&loc
);
5044 gfc_set_backend_locus (&sym
->declared_at
);
5045 descriptor
= sym
->backend_decl
;
5047 /* Although static, derived types with default initializers and
5048 allocatable components must not be nulled wholesale; instead they
5049 are treated component by component. */
5050 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
5052 /* SAVEd variables are not freed on exit. */
5053 gfc_trans_static_array_pointer (sym
);
5057 /* Get the descriptor type. */
5058 type
= TREE_TYPE (sym
->backend_decl
);
5060 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5062 rank
= sym
->as
? sym
->as
->rank
: 0;
5063 tmp
= gfc_nullify_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5064 gfc_add_expr_to_block (&fnblock
, tmp
);
5066 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
5068 /* If the backend_decl is not a descriptor, we must have a pointer
5070 descriptor
= build_fold_indirect_ref (sym
->backend_decl
);
5071 type
= TREE_TYPE (descriptor
);
5074 /* NULLIFY the data pointer. */
5075 if (GFC_DESCRIPTOR_TYPE_P (type
))
5076 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
5078 gfc_add_expr_to_block (&fnblock
, body
);
5080 gfc_set_backend_locus (&loc
);
5082 /* Allocatable arrays need to be freed when they go out of scope.
5083 The allocatable components of pointers must not be touched. */
5084 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
5085 && !sym
->attr
.pointer
)
5088 rank
= sym
->as
? sym
->as
->rank
: 0;
5089 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.derived
, descriptor
, rank
);
5090 gfc_add_expr_to_block (&fnblock
, tmp
);
5093 if (sym
->attr
.allocatable
)
5095 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
5096 gfc_add_expr_to_block (&fnblock
, tmp
);
5099 return gfc_finish_block (&fnblock
);
5102 /************ Expression Walking Functions ******************/
5104 /* Walk a variable reference.
5106 Possible extension - multiple component subscripts.
5107 x(:,:) = foo%a(:)%b(:)
5109 forall (i=..., j=...)
5110 x(i,j) = foo%a(j)%b(i)
5112 This adds a fair amout of complexity because you need to deal with more
5113 than one ref. Maybe handle in a similar manner to vector subscripts.
5114 Maybe not worth the effort. */
5118 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5126 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5127 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
5130 for (; ref
; ref
= ref
->next
)
5132 if (ref
->type
== REF_SUBSTRING
)
5134 newss
= gfc_get_ss ();
5135 newss
->type
= GFC_SS_SCALAR
;
5136 newss
->expr
= ref
->u
.ss
.start
;
5140 newss
= gfc_get_ss ();
5141 newss
->type
= GFC_SS_SCALAR
;
5142 newss
->expr
= ref
->u
.ss
.end
;
5147 /* We're only interested in array sections from now on. */
5148 if (ref
->type
!= REF_ARRAY
)
5155 for (n
= 0; n
< ar
->dimen
; n
++)
5157 newss
= gfc_get_ss ();
5158 newss
->type
= GFC_SS_SCALAR
;
5159 newss
->expr
= ar
->start
[n
];
5166 newss
= gfc_get_ss ();
5167 newss
->type
= GFC_SS_SECTION
;
5170 newss
->data
.info
.dimen
= ar
->as
->rank
;
5171 newss
->data
.info
.ref
= ref
;
5173 /* Make sure array is the same as array(:,:), this way
5174 we don't need to special case all the time. */
5175 ar
->dimen
= ar
->as
->rank
;
5176 for (n
= 0; n
< ar
->dimen
; n
++)
5178 newss
->data
.info
.dim
[n
] = n
;
5179 ar
->dimen_type
[n
] = DIMEN_RANGE
;
5181 gcc_assert (ar
->start
[n
] == NULL
);
5182 gcc_assert (ar
->end
[n
] == NULL
);
5183 gcc_assert (ar
->stride
[n
] == NULL
);
5189 newss
= gfc_get_ss ();
5190 newss
->type
= GFC_SS_SECTION
;
5193 newss
->data
.info
.dimen
= 0;
5194 newss
->data
.info
.ref
= ref
;
5198 /* We add SS chains for all the subscripts in the section. */
5199 for (n
= 0; n
< ar
->dimen
; n
++)
5203 switch (ar
->dimen_type
[n
])
5206 /* Add SS for elemental (scalar) subscripts. */
5207 gcc_assert (ar
->start
[n
]);
5208 indexss
= gfc_get_ss ();
5209 indexss
->type
= GFC_SS_SCALAR
;
5210 indexss
->expr
= ar
->start
[n
];
5211 indexss
->next
= gfc_ss_terminator
;
5212 indexss
->loop_chain
= gfc_ss_terminator
;
5213 newss
->data
.info
.subscript
[n
] = indexss
;
5217 /* We don't add anything for sections, just remember this
5218 dimension for later. */
5219 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5220 newss
->data
.info
.dimen
++;
5224 /* Create a GFC_SS_VECTOR index in which we can store
5225 the vector's descriptor. */
5226 indexss
= gfc_get_ss ();
5227 indexss
->type
= GFC_SS_VECTOR
;
5228 indexss
->expr
= ar
->start
[n
];
5229 indexss
->next
= gfc_ss_terminator
;
5230 indexss
->loop_chain
= gfc_ss_terminator
;
5231 newss
->data
.info
.subscript
[n
] = indexss
;
5232 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
5233 newss
->data
.info
.dimen
++;
5237 /* We should know what sort of section it is by now. */
5241 /* We should have at least one non-elemental dimension. */
5242 gcc_assert (newss
->data
.info
.dimen
> 0);
5247 /* We should know what sort of section it is by now. */
5256 /* Walk an expression operator. If only one operand of a binary expression is
5257 scalar, we must also add the scalar term to the SS chain. */
5260 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5266 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
5267 if (expr
->value
.op
.op2
== NULL
)
5270 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
5272 /* All operands are scalar. Pass back and let the caller deal with it. */
5276 /* All operands require scalarization. */
5277 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
5280 /* One of the operands needs scalarization, the other is scalar.
5281 Create a gfc_ss for the scalar expression. */
5282 newss
= gfc_get_ss ();
5283 newss
->type
= GFC_SS_SCALAR
;
5286 /* First operand is scalar. We build the chain in reverse order, so
5287 add the scarar SS after the second operand. */
5289 while (head
&& head
->next
!= ss
)
5291 /* Check we haven't somehow broken the chain. */
5295 newss
->expr
= expr
->value
.op
.op1
;
5297 else /* head2 == head */
5299 gcc_assert (head2
== head
);
5300 /* Second operand is scalar. */
5301 newss
->next
= head2
;
5303 newss
->expr
= expr
->value
.op
.op2
;
5310 /* Reverse a SS chain. */
5313 gfc_reverse_ss (gfc_ss
* ss
)
5318 gcc_assert (ss
!= NULL
);
5320 head
= gfc_ss_terminator
;
5321 while (ss
!= gfc_ss_terminator
)
5324 /* Check we didn't somehow break the chain. */
5325 gcc_assert (next
!= NULL
);
5335 /* Walk the arguments of an elemental function. */
5338 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
5346 head
= gfc_ss_terminator
;
5349 for (; arg
; arg
= arg
->next
)
5354 newss
= gfc_walk_subexpr (head
, arg
->expr
);
5357 /* Scalar argument. */
5358 newss
= gfc_get_ss ();
5360 newss
->expr
= arg
->expr
;
5370 while (tail
->next
!= gfc_ss_terminator
)
5377 /* If all the arguments are scalar we don't need the argument SS. */
5378 gfc_free_ss_chain (head
);
5383 /* Add it onto the existing chain. */
5389 /* Walk a function call. Scalar functions are passed back, and taken out of
5390 scalarization loops. For elemental functions we walk their arguments.
5391 The result of functions returning arrays is stored in a temporary outside
5392 the loop, so that the function is only called once. Hence we do not need
5393 to walk their arguments. */
5396 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
5399 gfc_intrinsic_sym
*isym
;
5402 isym
= expr
->value
.function
.isym
;
5404 /* Handle intrinsic functions separately. */
5406 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
5408 sym
= expr
->value
.function
.esym
;
5410 sym
= expr
->symtree
->n
.sym
;
5412 /* A function that returns arrays. */
5413 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
5415 newss
= gfc_get_ss ();
5416 newss
->type
= GFC_SS_FUNCTION
;
5419 newss
->data
.info
.dimen
= expr
->rank
;
5423 /* Walk the parameters of an elemental function. For now we always pass
5425 if (sym
->attr
.elemental
)
5426 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
5429 /* Scalar functions are OK as these are evaluated outside the scalarization
5430 loop. Pass back and let the caller deal with it. */
5435 /* An array temporary is constructed for array constructors. */
5438 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
5443 newss
= gfc_get_ss ();
5444 newss
->type
= GFC_SS_CONSTRUCTOR
;
5447 newss
->data
.info
.dimen
= expr
->rank
;
5448 for (n
= 0; n
< expr
->rank
; n
++)
5449 newss
->data
.info
.dim
[n
] = n
;
5455 /* Walk an expression. Add walked expressions to the head of the SS chain.
5456 A wholly scalar expression will not be added. */
5459 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
5463 switch (expr
->expr_type
)
5466 head
= gfc_walk_variable_expr (ss
, expr
);
5470 head
= gfc_walk_op_expr (ss
, expr
);
5474 head
= gfc_walk_function_expr (ss
, expr
);
5479 case EXPR_STRUCTURE
:
5480 /* Pass back and let the caller deal with it. */
5484 head
= gfc_walk_array_constructor (ss
, expr
);
5487 case EXPR_SUBSTRING
:
5488 /* Pass back and let the caller deal with it. */
5492 internal_error ("bad expression type during walk (%d)",
5499 /* Entry point for expression walking.
5500 A return value equal to the passed chain means this is
5501 a scalar expression. It is up to the caller to take whatever action is
5502 necessary to translate these. */
5505 gfc_walk_expr (gfc_expr
* expr
)
5509 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
5510 return gfc_reverse_ss (res
);