1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subscripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
89 #include "constructor.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_base
);
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
= fold_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. */
168 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
172 type
= TREE_TYPE (desc
);
173 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
175 field
= TYPE_FIELDS (type
);
176 gcc_assert (DATA_FIELD
== 0);
178 t
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
179 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
183 /* This provides address access to the data field. This should only be
184 used by array allocation, passing this on to the runtime. */
187 gfc_conv_descriptor_data_addr (tree desc
)
191 type
= TREE_TYPE (desc
);
192 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
194 field
= TYPE_FIELDS (type
);
195 gcc_assert (DATA_FIELD
== 0);
197 t
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
198 return gfc_build_addr_expr (NULL_TREE
, t
);
202 gfc_conv_descriptor_offset (tree desc
)
207 type
= TREE_TYPE (desc
);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
210 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
211 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
213 return fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
214 desc
, field
, NULL_TREE
);
218 gfc_conv_descriptor_offset_get (tree desc
)
220 return gfc_conv_descriptor_offset (desc
);
224 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
227 tree t
= gfc_conv_descriptor_offset (desc
);
228 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
233 gfc_conv_descriptor_dtype (tree desc
)
238 type
= TREE_TYPE (desc
);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
241 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
242 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
244 return fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
245 desc
, field
, NULL_TREE
);
249 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
255 type
= TREE_TYPE (desc
);
256 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
258 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
259 gcc_assert (field
!= NULL_TREE
260 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
261 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
263 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
264 desc
, field
, NULL_TREE
);
265 tmp
= gfc_build_array_ref (tmp
, dim
, NULL
);
270 gfc_conv_descriptor_stride (tree desc
, tree dim
)
275 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
276 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
277 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
278 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
280 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
281 tmp
, field
, NULL_TREE
);
286 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
288 tree type
= TREE_TYPE (desc
);
289 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
290 if (integer_zerop (dim
)
291 && GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
292 return gfc_index_one_node
;
294 return gfc_conv_descriptor_stride (desc
, dim
);
298 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
299 tree dim
, tree value
)
301 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
302 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
306 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
311 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
312 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
313 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
314 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
316 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
317 tmp
, field
, NULL_TREE
);
322 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
324 return gfc_conv_descriptor_lbound (desc
, dim
);
328 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
329 tree dim
, tree value
)
331 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
332 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
336 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
341 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
342 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
343 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
344 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
346 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
347 tmp
, field
, NULL_TREE
);
352 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
354 return gfc_conv_descriptor_ubound (desc
, dim
);
358 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
359 tree dim
, tree value
)
361 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
362 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
365 /* Build a null array descriptor constructor. */
368 gfc_build_null_descriptor (tree type
)
373 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
374 gcc_assert (DATA_FIELD
== 0);
375 field
= TYPE_FIELDS (type
);
377 /* Set a NULL data pointer. */
378 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
379 TREE_CONSTANT (tmp
) = 1;
380 /* All other fields are ignored. */
386 /* Cleanup those #defines. */
391 #undef DIMENSION_FIELD
392 #undef STRIDE_SUBFIELD
393 #undef LBOUND_SUBFIELD
394 #undef UBOUND_SUBFIELD
397 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
398 flags & 1 = Main loop body.
399 flags & 2 = temp copy loop. */
402 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
404 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
405 ss
->useflags
= flags
;
408 static void gfc_free_ss (gfc_ss
*);
411 /* Free a gfc_ss chain. */
414 gfc_free_ss_chain (gfc_ss
* ss
)
418 while (ss
!= gfc_ss_terminator
)
420 gcc_assert (ss
!= NULL
);
431 gfc_free_ss (gfc_ss
* ss
)
438 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
440 if (ss
->data
.info
.subscript
[n
])
441 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
453 /* Free all the SS associated with a loop. */
456 gfc_cleanup_loop (gfc_loopinfo
* loop
)
462 while (ss
!= gfc_ss_terminator
)
464 gcc_assert (ss
!= NULL
);
465 next
= ss
->loop_chain
;
472 /* Associate a SS chain with a loop. */
475 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
479 if (head
== gfc_ss_terminator
)
483 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
485 if (ss
->next
== gfc_ss_terminator
)
486 ss
->loop_chain
= loop
->ss
;
488 ss
->loop_chain
= ss
->next
;
490 gcc_assert (ss
== gfc_ss_terminator
);
495 /* Generate an initializer for a static pointer or allocatable array. */
498 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
502 gcc_assert (TREE_STATIC (sym
->backend_decl
));
503 /* Just zero the data member. */
504 type
= TREE_TYPE (sym
->backend_decl
);
505 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
509 /* If the bounds of SE's loop have not yet been set, see if they can be
510 determined from array spec AS, which is the array spec of a called
511 function. MAPPING maps the callee's dummy arguments to the values
512 that the caller is passing. Add any initialization and finalization
516 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
517 gfc_se
* se
, gfc_array_spec
* as
)
525 if (as
&& as
->type
== AS_EXPLICIT
)
526 for (dim
= 0; dim
< se
->loop
->dimen
; dim
++)
528 n
= se
->loop
->order
[dim
];
529 if (se
->loop
->to
[n
] == NULL_TREE
)
531 /* Evaluate the lower bound. */
532 gfc_init_se (&tmpse
, NULL
);
533 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
534 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
535 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
536 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
538 /* ...and the upper bound. */
539 gfc_init_se (&tmpse
, NULL
);
540 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
541 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
542 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
543 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
545 /* Set the upper bound of the loop to UPPER - LOWER. */
546 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
547 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
548 se
->loop
->to
[n
] = tmp
;
554 /* Generate code to allocate an array temporary, or create a variable to
555 hold the data. If size is NULL, zero the descriptor so that the
556 callee will allocate the array. If DEALLOC is true, also generate code to
557 free the array afterwards.
559 If INITIAL is not NULL, it is packed using internal_pack and the result used
560 as data instead of allocating a fresh, unitialized area of memory.
562 Initialization code is added to PRE and finalization code to POST.
563 DYNAMIC is true if the caller may want to extend the array later
564 using realloc. This prevents us from putting the array on the stack. */
567 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
568 gfc_ss_info
* info
, tree size
, tree nelem
,
569 tree initial
, bool dynamic
, bool dealloc
)
575 desc
= info
->descriptor
;
576 info
->offset
= gfc_index_zero_node
;
577 if (size
== NULL_TREE
|| integer_zerop (size
))
579 /* A callee allocated array. */
580 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
585 /* Allocate the temporary. */
586 onstack
= !dynamic
&& initial
== NULL_TREE
587 && gfc_can_put_var_on_stack (size
);
591 /* Make a temporary variable to hold the data. */
592 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
594 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
596 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
598 tmp
= gfc_create_var (tmp
, "A");
599 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
600 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
604 /* Allocate memory to hold the data or call internal_pack. */
605 if (initial
== NULL_TREE
)
607 tmp
= gfc_call_malloc (pre
, NULL
, size
);
608 tmp
= gfc_evaluate_now (tmp
, pre
);
615 stmtblock_t do_copying
;
617 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
618 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
619 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
620 tmp
= gfc_get_element_type (tmp
);
621 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
622 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
624 tmp
= build_call_expr_loc (input_location
,
625 gfor_fndecl_in_pack
, 1, initial
);
626 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
627 gfc_add_modify (pre
, packed
, tmp
);
629 tmp
= build_fold_indirect_ref_loc (input_location
,
631 source_data
= gfc_conv_descriptor_data_get (tmp
);
633 /* internal_pack may return source->data without any allocation
634 or copying if it is already packed. If that's the case, we
635 need to allocate and copy manually. */
637 gfc_start_block (&do_copying
);
638 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
639 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
640 gfc_add_modify (&do_copying
, packed
, tmp
);
641 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
642 gfc_add_expr_to_block (&do_copying
, tmp
);
644 was_packed
= fold_build2 (EQ_EXPR
, boolean_type_node
,
645 packed
, source_data
);
646 tmp
= gfc_finish_block (&do_copying
);
647 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
648 build_empty_stmt (input_location
));
649 gfc_add_expr_to_block (pre
, tmp
);
651 tmp
= fold_convert (pvoid_type_node
, packed
);
654 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
657 info
->data
= gfc_conv_descriptor_data_get (desc
);
659 /* The offset is zero because we create temporaries with a zero
661 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
663 if (dealloc
&& !onstack
)
665 /* Free the temporary. */
666 tmp
= gfc_conv_descriptor_data_get (desc
);
667 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
668 gfc_add_expr_to_block (post
, tmp
);
673 /* Generate code to create and initialize the descriptor for a temporary
674 array. This is used for both temporaries needed by the scalarizer, and
675 functions returning arrays. Adjusts the loop variables to be
676 zero-based, and calculates the loop bounds for callee allocated arrays.
677 Allocate the array unless it's callee allocated (we have a callee
678 allocated array if 'callee_alloc' is true, or if loop->to[n] is
679 NULL_TREE for any n). Also fills in the descriptor, data and offset
680 fields of info if known. Returns the size of the array, or NULL for a
681 callee allocated array.
683 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
684 gfc_trans_allocate_array_storage.
688 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
689 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
690 tree eltype
, tree initial
, bool dynamic
,
691 bool dealloc
, bool callee_alloc
, locus
* where
)
703 gcc_assert (info
->dimen
> 0);
705 if (gfc_option
.warn_array_temp
&& where
)
706 gfc_warning ("Creating array temporary at %L", where
);
708 /* Set the lower bound to zero. */
709 for (dim
= 0; dim
< info
->dimen
; dim
++)
711 n
= loop
->order
[dim
];
712 /* Callee allocated arrays may not have a known bound yet. */
714 loop
->to
[n
] = gfc_evaluate_now (fold_build2 (MINUS_EXPR
,
715 gfc_array_index_type
,
716 loop
->to
[n
], loop
->from
[n
]), pre
);
717 loop
->from
[n
] = gfc_index_zero_node
;
719 info
->delta
[dim
] = gfc_index_zero_node
;
720 info
->start
[dim
] = gfc_index_zero_node
;
721 info
->end
[dim
] = gfc_index_zero_node
;
722 info
->stride
[dim
] = gfc_index_one_node
;
723 info
->dim
[dim
] = dim
;
726 /* Initialize the descriptor. */
728 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1,
729 GFC_ARRAY_UNKNOWN
, true);
730 desc
= gfc_create_var (type
, "atmp");
731 GFC_DECL_PACKED_ARRAY (desc
) = 1;
733 info
->descriptor
= desc
;
734 size
= gfc_index_one_node
;
736 /* Fill in the array dtype. */
737 tmp
= gfc_conv_descriptor_dtype (desc
);
738 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
741 Fill in the bounds and stride. This is a packed array, so:
744 for (n = 0; n < rank; n++)
747 delta = ubound[n] + 1 - lbound[n];
750 size = size * sizeof(element);
755 /* If there is at least one null loop->to[n], it is a callee allocated
757 for (n
= 0; n
< info
->dimen
; n
++)
758 if (loop
->to
[n
] == NULL_TREE
)
764 for (n
= 0; n
< info
->dimen
; n
++)
766 if (size
== NULL_TREE
)
768 /* For a callee allocated array express the loop bounds in terms
769 of the descriptor fields. */
771 fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
772 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]),
773 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]));
778 /* Store the stride and bound components in the descriptor. */
779 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
781 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
782 gfc_index_zero_node
);
784 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], loop
->to
[n
]);
786 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
787 loop
->to
[n
], gfc_index_one_node
);
789 /* Check whether the size for this dimension is negative. */
790 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
791 gfc_index_zero_node
);
792 cond
= gfc_evaluate_now (cond
, pre
);
797 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
799 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
800 size
= gfc_evaluate_now (size
, pre
);
803 /* Get the size of the array. */
805 if (size
&& !callee_alloc
)
807 /* If or_expr is true, then the extent in at least one
808 dimension is zero and the size is set to zero. */
809 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
,
810 or_expr
, gfc_index_zero_node
, size
);
813 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
814 fold_convert (gfc_array_index_type
,
815 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
823 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
826 if (info
->dimen
> loop
->temp_dim
)
827 loop
->temp_dim
= info
->dimen
;
833 /* Generate code to transpose array EXPR by creating a new descriptor
834 in which the dimension specifications have been reversed. */
837 gfc_conv_array_transpose (gfc_se
* se
, gfc_expr
* expr
)
839 tree dest
, src
, dest_index
, src_index
;
841 gfc_ss_info
*dest_info
;
842 gfc_ss
*dest_ss
, *src_ss
;
848 src_ss
= gfc_walk_expr (expr
);
851 dest_info
= &dest_ss
->data
.info
;
852 gcc_assert (dest_info
->dimen
== 2);
854 /* Get a descriptor for EXPR. */
855 gfc_init_se (&src_se
, NULL
);
856 gfc_conv_expr_descriptor (&src_se
, expr
, src_ss
);
857 gfc_add_block_to_block (&se
->pre
, &src_se
.pre
);
858 gfc_add_block_to_block (&se
->post
, &src_se
.post
);
861 /* Allocate a new descriptor for the return value. */
862 dest
= gfc_create_var (TREE_TYPE (src
), "atmp");
863 dest_info
->descriptor
= dest
;
866 /* Copy across the dtype field. */
867 gfc_add_modify (&se
->pre
,
868 gfc_conv_descriptor_dtype (dest
),
869 gfc_conv_descriptor_dtype (src
));
871 /* Copy the dimension information, renumbering dimension 1 to 0 and
873 for (n
= 0; n
< 2; n
++)
875 dest_info
->delta
[n
] = gfc_index_zero_node
;
876 dest_info
->start
[n
] = gfc_index_zero_node
;
877 dest_info
->end
[n
] = gfc_index_zero_node
;
878 dest_info
->stride
[n
] = gfc_index_one_node
;
879 dest_info
->dim
[n
] = n
;
881 dest_index
= gfc_rank_cst
[n
];
882 src_index
= gfc_rank_cst
[1 - n
];
884 gfc_conv_descriptor_stride_set (&se
->pre
, dest
, dest_index
,
885 gfc_conv_descriptor_stride_get (src
, src_index
));
887 gfc_conv_descriptor_lbound_set (&se
->pre
, dest
, dest_index
,
888 gfc_conv_descriptor_lbound_get (src
, src_index
));
890 gfc_conv_descriptor_ubound_set (&se
->pre
, dest
, dest_index
,
891 gfc_conv_descriptor_ubound_get (src
, src_index
));
895 gcc_assert (integer_zerop (loop
->from
[n
]));
897 fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
898 gfc_conv_descriptor_ubound_get (dest
, dest_index
),
899 gfc_conv_descriptor_lbound_get (dest
, dest_index
));
903 /* Copy the data pointer. */
904 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
905 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
907 /* Copy the offset. This is not changed by transposition; the top-left
908 element is still at the same offset as before, except where the loop
910 if (!integer_zerop (loop
->from
[0]))
911 dest_info
->offset
= gfc_conv_descriptor_offset_get (src
);
913 dest_info
->offset
= gfc_index_zero_node
;
915 gfc_conv_descriptor_offset_set (&se
->pre
, dest
,
918 if (dest_info
->dimen
> loop
->temp_dim
)
919 loop
->temp_dim
= dest_info
->dimen
;
923 /* Return the number of iterations in a loop that starts at START,
924 ends at END, and has step STEP. */
927 gfc_get_iteration_count (tree start
, tree end
, tree step
)
932 type
= TREE_TYPE (step
);
933 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
934 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
935 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
936 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
937 return fold_convert (gfc_array_index_type
, tmp
);
941 /* Extend the data in array DESC by EXTRA elements. */
944 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
951 if (integer_zerop (extra
))
954 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
956 /* Add EXTRA to the upper bound. */
957 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
958 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
960 /* Get the value of the current data pointer. */
961 arg0
= gfc_conv_descriptor_data_get (desc
);
963 /* Calculate the new array size. */
964 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
965 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
966 ubound
, gfc_index_one_node
);
967 arg1
= fold_build2 (MULT_EXPR
, size_type_node
,
968 fold_convert (size_type_node
, tmp
),
969 fold_convert (size_type_node
, size
));
971 /* Call the realloc() function. */
972 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
973 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
977 /* Return true if the bounds of iterator I can only be determined
981 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
983 return (i
->start
->expr_type
!= EXPR_CONSTANT
984 || i
->end
->expr_type
!= EXPR_CONSTANT
985 || i
->step
->expr_type
!= EXPR_CONSTANT
);
989 /* Split the size of constructor element EXPR into the sum of two terms,
990 one of which can be determined at compile time and one of which must
991 be calculated at run time. Set *SIZE to the former and return true
992 if the latter might be nonzero. */
995 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
997 if (expr
->expr_type
== EXPR_ARRAY
)
998 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
999 else if (expr
->rank
> 0)
1001 /* Calculate everything at run time. */
1002 mpz_set_ui (*size
, 0);
1007 /* A single element. */
1008 mpz_set_ui (*size
, 1);
1014 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1015 of array constructor C. */
1018 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1026 mpz_set_ui (*size
, 0);
1031 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1034 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1038 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1041 /* Multiply the static part of the element size by the
1042 number of iterations. */
1043 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1044 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1045 mpz_add_ui (val
, val
, 1);
1046 if (mpz_sgn (val
) > 0)
1047 mpz_mul (len
, len
, val
);
1049 mpz_set_ui (len
, 0);
1051 mpz_add (*size
, *size
, len
);
1060 /* Make sure offset is a variable. */
1063 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1066 /* We should have already created the offset variable. We cannot
1067 create it here because we may be in an inner scope. */
1068 gcc_assert (*offsetvar
!= NULL_TREE
);
1069 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1070 *poffset
= *offsetvar
;
1071 TREE_USED (*offsetvar
) = 1;
1075 /* Variables needed for bounds-checking. */
1076 static bool first_len
;
1077 static tree first_len_val
;
1078 static bool typespec_chararray_ctor
;
1081 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1082 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1086 gfc_conv_expr (se
, expr
);
1088 /* Store the value. */
1089 tmp
= build_fold_indirect_ref_loc (input_location
,
1090 gfc_conv_descriptor_data_get (desc
));
1091 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1093 if (expr
->ts
.type
== BT_CHARACTER
)
1095 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1098 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1099 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1100 esize
= fold_build2 (TRUNC_DIV_EXPR
, gfc_charlen_type_node
, esize
,
1101 build_int_cst (gfc_charlen_type_node
,
1102 gfc_character_kinds
[i
].bit_size
/ 8));
1104 gfc_conv_string_parameter (se
);
1105 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1107 /* The temporary is an array of pointers. */
1108 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1109 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1113 /* The temporary is an array of string values. */
1114 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1115 /* We know the temporary and the value will be the same length,
1116 so can use memcpy. */
1117 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1118 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1120 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1124 gfc_add_modify (&se
->pre
, first_len_val
,
1130 /* Verify that all constructor elements are of the same
1132 tree cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
1133 first_len_val
, se
->string_length
);
1134 gfc_trans_runtime_check
1135 (true, false, cond
, &se
->pre
, &expr
->where
,
1136 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1137 fold_convert (long_integer_type_node
, first_len_val
),
1138 fold_convert (long_integer_type_node
, se
->string_length
));
1144 /* TODO: Should the frontend already have done this conversion? */
1145 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1146 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1149 gfc_add_block_to_block (pblock
, &se
->pre
);
1150 gfc_add_block_to_block (pblock
, &se
->post
);
1154 /* Add the contents of an array to the constructor. DYNAMIC is as for
1155 gfc_trans_array_constructor_value. */
1158 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1159 tree type ATTRIBUTE_UNUSED
,
1160 tree desc
, gfc_expr
* expr
,
1161 tree
* poffset
, tree
* offsetvar
,
1172 /* We need this to be a variable so we can increment it. */
1173 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1175 gfc_init_se (&se
, NULL
);
1177 /* Walk the array expression. */
1178 ss
= gfc_walk_expr (expr
);
1179 gcc_assert (ss
!= gfc_ss_terminator
);
1181 /* Initialize the scalarizer. */
1182 gfc_init_loopinfo (&loop
);
1183 gfc_add_ss_to_loop (&loop
, ss
);
1185 /* Initialize the loop. */
1186 gfc_conv_ss_startstride (&loop
);
1187 gfc_conv_loop_setup (&loop
, &expr
->where
);
1189 /* Make sure the constructed array has room for the new data. */
1192 /* Set SIZE to the total number of elements in the subarray. */
1193 size
= gfc_index_one_node
;
1194 for (n
= 0; n
< loop
.dimen
; n
++)
1196 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1197 gfc_index_one_node
);
1198 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1201 /* Grow the constructed array by SIZE elements. */
1202 gfc_grow_array (&loop
.pre
, desc
, size
);
1205 /* Make the loop body. */
1206 gfc_mark_ss_chain_used (ss
, 1);
1207 gfc_start_scalarized_body (&loop
, &body
);
1208 gfc_copy_loopinfo_to_se (&se
, &loop
);
1211 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1212 gcc_assert (se
.ss
== gfc_ss_terminator
);
1214 /* Increment the offset. */
1215 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1216 *poffset
, gfc_index_one_node
);
1217 gfc_add_modify (&body
, *poffset
, tmp
);
1219 /* Finish the loop. */
1220 gfc_trans_scalarizing_loops (&loop
, &body
);
1221 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1222 tmp
= gfc_finish_block (&loop
.pre
);
1223 gfc_add_expr_to_block (pblock
, tmp
);
1225 gfc_cleanup_loop (&loop
);
1229 /* Assign the values to the elements of an array constructor. DYNAMIC
1230 is true if descriptor DESC only contains enough data for the static
1231 size calculated by gfc_get_array_constructor_size. When true, memory
1232 for the dynamic parts must be allocated using realloc. */
1235 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1236 tree desc
, gfc_constructor_base base
,
1237 tree
* poffset
, tree
* offsetvar
,
1246 tree shadow_loopvar
= NULL_TREE
;
1247 gfc_saved_var saved_loopvar
;
1250 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1252 /* If this is an iterator or an array, the offset must be a variable. */
1253 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1254 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1256 /* Shadowing the iterator avoids changing its value and saves us from
1257 keeping track of it. Further, it makes sure that there's always a
1258 backend-decl for the symbol, even if there wasn't one before,
1259 e.g. in the case of an iterator that appears in a specification
1260 expression in an interface mapping. */
1263 gfc_symbol
*sym
= c
->iterator
->var
->symtree
->n
.sym
;
1264 tree type
= gfc_typenode_for_spec (&sym
->ts
);
1266 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1267 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1270 gfc_start_block (&body
);
1272 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1274 /* Array constructors can be nested. */
1275 gfc_trans_array_constructor_value (&body
, type
, desc
,
1276 c
->expr
->value
.constructor
,
1277 poffset
, offsetvar
, dynamic
);
1279 else if (c
->expr
->rank
> 0)
1281 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1282 poffset
, offsetvar
, dynamic
);
1286 /* This code really upsets the gimplifier so don't bother for now. */
1293 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1295 p
= gfc_constructor_next (p
);
1300 /* Scalar values. */
1301 gfc_init_se (&se
, NULL
);
1302 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1305 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1306 *poffset
, gfc_index_one_node
);
1310 /* Collect multiple scalar constants into a constructor. */
1315 HOST_WIDE_INT idx
= 0;
1319 /* Count the number of consecutive scalar constants. */
1320 while (p
&& !(p
->iterator
1321 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1323 gfc_init_se (&se
, NULL
);
1324 gfc_conv_constant (&se
, p
->expr
);
1326 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1327 se
.expr
= fold_convert (type
, se
.expr
);
1328 /* For constant character array constructors we build
1329 an array of pointers. */
1330 else if (POINTER_TYPE_P (type
))
1331 se
.expr
= gfc_build_addr_expr
1332 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1335 list
= tree_cons (build_int_cst (gfc_array_index_type
,
1336 idx
++), se
.expr
, list
);
1338 p
= gfc_constructor_next (p
);
1341 bound
= build_int_cst (NULL_TREE
, n
- 1);
1342 /* Create an array type to hold them. */
1343 tmptype
= build_range_type (gfc_array_index_type
,
1344 gfc_index_zero_node
, bound
);
1345 tmptype
= build_array_type (type
, tmptype
);
1347 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1348 TREE_CONSTANT (init
) = 1;
1349 TREE_STATIC (init
) = 1;
1350 /* Create a static variable to hold the data. */
1351 tmp
= gfc_create_var (tmptype
, "data");
1352 TREE_STATIC (tmp
) = 1;
1353 TREE_CONSTANT (tmp
) = 1;
1354 TREE_READONLY (tmp
) = 1;
1355 DECL_INITIAL (tmp
) = init
;
1358 /* Use BUILTIN_MEMCPY to assign the values. */
1359 tmp
= gfc_conv_descriptor_data_get (desc
);
1360 tmp
= build_fold_indirect_ref_loc (input_location
,
1362 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1363 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1364 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1366 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1367 bound
= build_int_cst (NULL_TREE
, n
* size
);
1368 tmp
= build_call_expr_loc (input_location
,
1369 built_in_decls
[BUILT_IN_MEMCPY
], 3,
1371 gfc_add_expr_to_block (&body
, tmp
);
1373 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1375 build_int_cst (gfc_array_index_type
, n
));
1377 if (!INTEGER_CST_P (*poffset
))
1379 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1380 *poffset
= *offsetvar
;
1384 /* The frontend should already have done any expansions
1388 /* Pass the code as is. */
1389 tmp
= gfc_finish_block (&body
);
1390 gfc_add_expr_to_block (pblock
, tmp
);
1394 /* Build the implied do-loop. */
1395 stmtblock_t implied_do_block
;
1403 loopbody
= gfc_finish_block (&body
);
1405 /* Create a new block that holds the implied-do loop. A temporary
1406 loop-variable is used. */
1407 gfc_start_block(&implied_do_block
);
1409 /* Initialize the loop. */
1410 gfc_init_se (&se
, NULL
);
1411 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1412 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1413 gfc_add_modify (&implied_do_block
, shadow_loopvar
, se
.expr
);
1415 gfc_init_se (&se
, NULL
);
1416 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1417 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1418 end
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1420 gfc_init_se (&se
, NULL
);
1421 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1422 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1423 step
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1425 /* If this array expands dynamically, and the number of iterations
1426 is not constant, we won't have allocated space for the static
1427 part of C->EXPR's size. Do that now. */
1428 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1430 /* Get the number of iterations. */
1431 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1433 /* Get the static part of C->EXPR's size. */
1434 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1435 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1437 /* Grow the array by TMP * TMP2 elements. */
1438 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1439 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1442 /* Generate the loop body. */
1443 exit_label
= gfc_build_label_decl (NULL_TREE
);
1444 gfc_start_block (&body
);
1446 /* Generate the exit condition. Depending on the sign of
1447 the step variable we have to generate the correct
1449 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1450 build_int_cst (TREE_TYPE (step
), 0));
1451 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1452 fold_build2 (GT_EXPR
, boolean_type_node
,
1453 shadow_loopvar
, end
),
1454 fold_build2 (LT_EXPR
, boolean_type_node
,
1455 shadow_loopvar
, end
));
1456 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1457 TREE_USED (exit_label
) = 1;
1458 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1459 build_empty_stmt (input_location
));
1460 gfc_add_expr_to_block (&body
, tmp
);
1462 /* The main loop body. */
1463 gfc_add_expr_to_block (&body
, loopbody
);
1465 /* Increase loop variable by step. */
1466 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (shadow_loopvar
), shadow_loopvar
, step
);
1467 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1469 /* Finish the loop. */
1470 tmp
= gfc_finish_block (&body
);
1471 tmp
= build1_v (LOOP_EXPR
, tmp
);
1472 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1474 /* Add the exit label. */
1475 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1476 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1478 /* Finishe the implied-do loop. */
1479 tmp
= gfc_finish_block(&implied_do_block
);
1480 gfc_add_expr_to_block(pblock
, tmp
);
1482 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1489 /* Figure out the string length of a variable reference expression.
1490 Used by get_array_ctor_strlen. */
1493 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1499 /* Don't bother if we already know the length is a constant. */
1500 if (*len
&& INTEGER_CST_P (*len
))
1503 ts
= &expr
->symtree
->n
.sym
->ts
;
1504 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1509 /* Array references don't change the string length. */
1513 /* Use the length of the component. */
1514 ts
= &ref
->u
.c
.component
->ts
;
1518 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1519 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1521 mpz_init_set_ui (char_len
, 1);
1522 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1523 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1524 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1525 *len
= convert (gfc_charlen_type_node
, *len
);
1526 mpz_clear (char_len
);
1530 /* TODO: Substrings are tricky because we can't evaluate the
1531 expression more than once. For now we just give up, and hope
1532 we can figure it out elsewhere. */
1537 *len
= ts
->u
.cl
->backend_decl
;
1541 /* A catch-all to obtain the string length for anything that is not a
1542 constant, array or variable. */
1544 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1549 /* Don't bother if we already know the length is a constant. */
1550 if (*len
&& INTEGER_CST_P (*len
))
1553 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1554 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1557 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1558 *len
= e
->ts
.u
.cl
->backend_decl
;
1562 /* Otherwise, be brutal even if inefficient. */
1563 ss
= gfc_walk_expr (e
);
1564 gfc_init_se (&se
, NULL
);
1566 /* No function call, in case of side effects. */
1567 se
.no_function_call
= 1;
1568 if (ss
== gfc_ss_terminator
)
1569 gfc_conv_expr (&se
, e
);
1571 gfc_conv_expr_descriptor (&se
, e
, ss
);
1573 /* Fix the value. */
1574 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1576 gfc_add_block_to_block (block
, &se
.pre
);
1577 gfc_add_block_to_block (block
, &se
.post
);
1579 e
->ts
.u
.cl
->backend_decl
= *len
;
1584 /* Figure out the string length of a character array constructor.
1585 If len is NULL, don't calculate the length; this happens for recursive calls
1586 when a sub-array-constructor is an element but not at the first position,
1587 so when we're not interested in the length.
1588 Returns TRUE if all elements are character constants. */
1591 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1598 if (gfc_constructor_first (base
) == NULL
)
1601 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1605 /* Loop over all constructor elements to find out is_const, but in len we
1606 want to store the length of the first, not the last, element. We can
1607 of course exit the loop as soon as is_const is found to be false. */
1608 for (c
= gfc_constructor_first (base
);
1609 c
&& is_const
; c
= gfc_constructor_next (c
))
1611 switch (c
->expr
->expr_type
)
1614 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1615 *len
= build_int_cstu (gfc_charlen_type_node
,
1616 c
->expr
->value
.character
.length
);
1620 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1627 get_array_ctor_var_strlen (c
->expr
, len
);
1633 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1637 /* After the first iteration, we don't want the length modified. */
1644 /* Check whether the array constructor C consists entirely of constant
1645 elements, and if so returns the number of those elements, otherwise
1646 return zero. Note, an empty or NULL array constructor returns zero. */
1648 unsigned HOST_WIDE_INT
1649 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1651 unsigned HOST_WIDE_INT nelem
= 0;
1653 gfc_constructor
*c
= gfc_constructor_first (base
);
1657 || c
->expr
->rank
> 0
1658 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1660 c
= gfc_constructor_next (c
);
1667 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1668 and the tree type of it's elements, TYPE, return a static constant
1669 variable that is compile-time initialized. */
1672 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1674 tree tmptype
, list
, init
, tmp
;
1675 HOST_WIDE_INT nelem
;
1681 /* First traverse the constructor list, converting the constants
1682 to tree to build an initializer. */
1685 c
= gfc_constructor_first (expr
->value
.constructor
);
1688 gfc_init_se (&se
, NULL
);
1689 gfc_conv_constant (&se
, c
->expr
);
1690 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1691 se
.expr
= fold_convert (type
, se
.expr
);
1692 else if (POINTER_TYPE_P (type
))
1693 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
1695 list
= tree_cons (build_int_cst (gfc_array_index_type
, nelem
),
1697 c
= gfc_constructor_next (c
);
1701 /* Next determine the tree type for the array. We use the gfortran
1702 front-end's gfc_get_nodesc_array_type in order to create a suitable
1703 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1705 memset (&as
, 0, sizeof (gfc_array_spec
));
1707 as
.rank
= expr
->rank
;
1708 as
.type
= AS_EXPLICIT
;
1711 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1712 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
1716 for (i
= 0; i
< expr
->rank
; i
++)
1718 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1719 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1720 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1724 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
1726 init
= build_constructor_from_list (tmptype
, nreverse (list
));
1728 TREE_CONSTANT (init
) = 1;
1729 TREE_STATIC (init
) = 1;
1731 tmp
= gfc_create_var (tmptype
, "A");
1732 TREE_STATIC (tmp
) = 1;
1733 TREE_CONSTANT (tmp
) = 1;
1734 TREE_READONLY (tmp
) = 1;
1735 DECL_INITIAL (tmp
) = init
;
1741 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1742 This mostly initializes the scalarizer state info structure with the
1743 appropriate values to directly use the array created by the function
1744 gfc_build_constant_array_constructor. */
1747 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1748 gfc_ss
* ss
, tree type
)
1754 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1756 info
= &ss
->data
.info
;
1758 info
->descriptor
= tmp
;
1759 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1760 info
->offset
= gfc_index_zero_node
;
1762 for (i
= 0; i
< info
->dimen
; i
++)
1764 info
->delta
[i
] = gfc_index_zero_node
;
1765 info
->start
[i
] = gfc_index_zero_node
;
1766 info
->end
[i
] = gfc_index_zero_node
;
1767 info
->stride
[i
] = gfc_index_one_node
;
1771 if (info
->dimen
> loop
->temp_dim
)
1772 loop
->temp_dim
= info
->dimen
;
1775 /* Helper routine of gfc_trans_array_constructor to determine if the
1776 bounds of the loop specified by LOOP are constant and simple enough
1777 to use with gfc_trans_constant_array_constructor. Returns the
1778 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1781 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1783 tree size
= gfc_index_one_node
;
1787 for (i
= 0; i
< loop
->dimen
; i
++)
1789 /* If the bounds aren't constant, return NULL_TREE. */
1790 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1792 if (!integer_zerop (loop
->from
[i
]))
1794 /* Only allow nonzero "from" in one-dimensional arrays. */
1795 if (loop
->dimen
!= 1)
1797 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1798 loop
->to
[i
], loop
->from
[i
]);
1802 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1803 tmp
, gfc_index_one_node
);
1804 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1811 /* Array constructors are handled by constructing a temporary, then using that
1812 within the scalarization loop. This is not optimal, but seems by far the
1816 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
, locus
* where
)
1818 gfc_constructor_base c
;
1824 bool old_first_len
, old_typespec_chararray_ctor
;
1825 tree old_first_len_val
;
1827 /* Save the old values for nested checking. */
1828 old_first_len
= first_len
;
1829 old_first_len_val
= first_len_val
;
1830 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
1832 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1833 typespec was given for the array constructor. */
1834 typespec_chararray_ctor
= (ss
->expr
->ts
.u
.cl
1835 && ss
->expr
->ts
.u
.cl
->length_from_typespec
);
1837 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1838 && ss
->expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
1840 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
1844 ss
->data
.info
.dimen
= loop
->dimen
;
1846 c
= ss
->expr
->value
.constructor
;
1847 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1851 /* get_array_ctor_strlen walks the elements of the constructor, if a
1852 typespec was given, we already know the string length and want the one
1854 if (typespec_chararray_ctor
&& ss
->expr
->ts
.u
.cl
->length
1855 && ss
->expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1859 const_string
= false;
1860 gfc_init_se (&length_se
, NULL
);
1861 gfc_conv_expr_type (&length_se
, ss
->expr
->ts
.u
.cl
->length
,
1862 gfc_charlen_type_node
);
1863 ss
->string_length
= length_se
.expr
;
1864 gfc_add_block_to_block (&loop
->pre
, &length_se
.pre
);
1865 gfc_add_block_to_block (&loop
->post
, &length_se
.post
);
1868 const_string
= get_array_ctor_strlen (&loop
->pre
, c
,
1869 &ss
->string_length
);
1871 /* Complex character array constructors should have been taken care of
1872 and not end up here. */
1873 gcc_assert (ss
->string_length
);
1875 ss
->expr
->ts
.u
.cl
->backend_decl
= ss
->string_length
;
1877 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1879 type
= build_pointer_type (type
);
1882 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1884 /* See if the constructor determines the loop bounds. */
1887 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1889 /* We have a multidimensional parameter. */
1891 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1893 loop
->from
[n
] = gfc_index_zero_node
;
1894 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1895 gfc_index_integer_kind
);
1896 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1897 loop
->to
[n
], gfc_index_one_node
);
1901 if (loop
->to
[0] == NULL_TREE
)
1905 /* We should have a 1-dimensional, zero-based loop. */
1906 gcc_assert (loop
->dimen
== 1);
1907 gcc_assert (integer_zerop (loop
->from
[0]));
1909 /* Split the constructor size into a static part and a dynamic part.
1910 Allocate the static size up-front and record whether the dynamic
1911 size might be nonzero. */
1913 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1914 mpz_sub_ui (size
, size
, 1);
1915 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1919 /* Special case constant array constructors. */
1922 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1925 tree size
= constant_array_constructor_loop_size (loop
);
1926 if (size
&& compare_tree_int (size
, nelem
) == 0)
1928 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1934 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1935 type
, NULL_TREE
, dynamic
, true, false, where
);
1937 desc
= ss
->data
.info
.descriptor
;
1938 offset
= gfc_index_zero_node
;
1939 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1940 TREE_NO_WARNING (offsetvar
) = 1;
1941 TREE_USED (offsetvar
) = 0;
1942 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1943 &offset
, &offsetvar
, dynamic
);
1945 /* If the array grows dynamically, the upper bound of the loop variable
1946 is determined by the array's final upper bound. */
1948 loop
->to
[0] = gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1950 if (TREE_USED (offsetvar
))
1951 pushdecl (offsetvar
);
1953 gcc_assert (INTEGER_CST_P (offset
));
1955 /* Disable bound checking for now because it's probably broken. */
1956 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1963 /* Restore old values of globals. */
1964 first_len
= old_first_len
;
1965 first_len_val
= old_first_len_val
;
1966 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
1970 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1971 called after evaluating all of INFO's vector dimensions. Go through
1972 each such vector dimension and see if we can now fill in any missing
1976 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1985 for (n
= 0; n
< loop
->dimen
; n
++)
1988 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1989 && loop
->to
[n
] == NULL
)
1991 /* Loop variable N indexes vector dimension DIM, and we don't
1992 yet know the upper bound of loop variable N. Set it to the
1993 difference between the vector's upper and lower bounds. */
1994 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1995 gcc_assert (info
->subscript
[dim
]
1996 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
1998 gfc_init_se (&se
, NULL
);
1999 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2000 zero
= gfc_rank_cst
[0];
2001 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2002 gfc_conv_descriptor_ubound_get (desc
, zero
),
2003 gfc_conv_descriptor_lbound_get (desc
, zero
));
2004 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
2011 /* Add the pre and post chains for all the scalar expressions in a SS chain
2012 to loop. This is called after the loop parameters have been calculated,
2013 but before the actual scalarizing loops. */
2016 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2022 /* TODO: This can generate bad code if there are ordering dependencies,
2023 e.g., a callee allocated function and an unknown size constructor. */
2024 gcc_assert (ss
!= NULL
);
2026 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2033 /* Scalar expression. Evaluate this now. This includes elemental
2034 dimension indices, but not array section bounds. */
2035 gfc_init_se (&se
, NULL
);
2036 gfc_conv_expr (&se
, ss
->expr
);
2037 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2039 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
2041 /* Move the evaluation of scalar expressions outside the
2042 scalarization loop, except for WHERE assignments. */
2044 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2046 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2047 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
2050 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2052 ss
->data
.scalar
.expr
= se
.expr
;
2053 ss
->string_length
= se
.string_length
;
2056 case GFC_SS_REFERENCE
:
2057 /* Scalar reference. Evaluate this now. */
2058 gfc_init_se (&se
, NULL
);
2059 gfc_conv_expr_reference (&se
, ss
->expr
);
2060 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2061 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2063 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2064 ss
->string_length
= se
.string_length
;
2067 case GFC_SS_SECTION
:
2068 /* Add the expressions for scalar and vector subscripts. */
2069 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2070 if (ss
->data
.info
.subscript
[n
])
2071 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true,
2074 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
2078 /* Get the vector's descriptor and store it in SS. */
2079 gfc_init_se (&se
, NULL
);
2080 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
2081 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2082 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2083 ss
->data
.info
.descriptor
= se
.expr
;
2086 case GFC_SS_INTRINSIC
:
2087 gfc_add_intrinsic_ss_code (loop
, ss
);
2090 case GFC_SS_FUNCTION
:
2091 /* Array function return value. We call the function and save its
2092 result in a temporary for use inside the loop. */
2093 gfc_init_se (&se
, NULL
);
2096 gfc_conv_expr (&se
, ss
->expr
);
2097 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2098 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2099 ss
->string_length
= se
.string_length
;
2102 case GFC_SS_CONSTRUCTOR
:
2103 if (ss
->expr
->ts
.type
== BT_CHARACTER
2104 && ss
->string_length
== NULL
2105 && ss
->expr
->ts
.u
.cl
2106 && ss
->expr
->ts
.u
.cl
->length
)
2108 gfc_init_se (&se
, NULL
);
2109 gfc_conv_expr_type (&se
, ss
->expr
->ts
.u
.cl
->length
,
2110 gfc_charlen_type_node
);
2111 ss
->string_length
= se
.expr
;
2112 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2113 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2115 gfc_trans_array_constructor (loop
, ss
, where
);
2119 case GFC_SS_COMPONENT
:
2120 /* Do nothing. These are handled elsewhere. */
2130 /* Translate expressions for the descriptor and data pointer of a SS. */
2134 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2139 /* Get the descriptor for the array to be scalarized. */
2140 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
2141 gfc_init_se (&se
, NULL
);
2142 se
.descriptor_only
= 1;
2143 gfc_conv_expr_lhs (&se
, ss
->expr
);
2144 gfc_add_block_to_block (block
, &se
.pre
);
2145 ss
->data
.info
.descriptor
= se
.expr
;
2146 ss
->string_length
= se
.string_length
;
2150 /* Also the data pointer. */
2151 tmp
= gfc_conv_array_data (se
.expr
);
2152 /* If this is a variable or address of a variable we use it directly.
2153 Otherwise we must evaluate it now to avoid breaking dependency
2154 analysis by pulling the expressions for elemental array indices
2157 || (TREE_CODE (tmp
) == ADDR_EXPR
2158 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2159 tmp
= gfc_evaluate_now (tmp
, block
);
2160 ss
->data
.info
.data
= tmp
;
2162 tmp
= gfc_conv_array_offset (se
.expr
);
2163 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
2168 /* Initialize a gfc_loopinfo structure. */
2171 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2175 memset (loop
, 0, sizeof (gfc_loopinfo
));
2176 gfc_init_block (&loop
->pre
);
2177 gfc_init_block (&loop
->post
);
2179 /* Initially scalarize in order. */
2180 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2183 loop
->ss
= gfc_ss_terminator
;
2187 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2191 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2197 /* Return an expression for the data pointer of an array. */
2200 gfc_conv_array_data (tree descriptor
)
2204 type
= TREE_TYPE (descriptor
);
2205 if (GFC_ARRAY_TYPE_P (type
))
2207 if (TREE_CODE (type
) == POINTER_TYPE
)
2211 /* Descriptorless arrays. */
2212 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2216 return gfc_conv_descriptor_data_get (descriptor
);
2220 /* Return an expression for the base offset of an array. */
2223 gfc_conv_array_offset (tree descriptor
)
2227 type
= TREE_TYPE (descriptor
);
2228 if (GFC_ARRAY_TYPE_P (type
))
2229 return GFC_TYPE_ARRAY_OFFSET (type
);
2231 return gfc_conv_descriptor_offset_get (descriptor
);
2235 /* Get an expression for the array stride. */
2238 gfc_conv_array_stride (tree descriptor
, int dim
)
2243 type
= TREE_TYPE (descriptor
);
2245 /* For descriptorless arrays use the array size. */
2246 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2247 if (tmp
!= NULL_TREE
)
2250 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2255 /* Like gfc_conv_array_stride, but for the lower bound. */
2258 gfc_conv_array_lbound (tree descriptor
, int dim
)
2263 type
= TREE_TYPE (descriptor
);
2265 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2266 if (tmp
!= NULL_TREE
)
2269 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2274 /* Like gfc_conv_array_stride, but for the upper bound. */
2277 gfc_conv_array_ubound (tree descriptor
, int dim
)
2282 type
= TREE_TYPE (descriptor
);
2284 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2285 if (tmp
!= NULL_TREE
)
2288 /* This should only ever happen when passing an assumed shape array
2289 as an actual parameter. The value will never be used. */
2290 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2291 return gfc_index_zero_node
;
2293 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2298 /* Generate code to perform an array index bound check. */
2301 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2302 locus
* where
, bool check_upper
)
2305 tree tmp_lo
, tmp_up
;
2307 const char * name
= NULL
;
2309 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2312 index
= gfc_evaluate_now (index
, &se
->pre
);
2314 /* We find a name for the error message. */
2316 name
= se
->ss
->expr
->symtree
->name
;
2318 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2319 && se
->loop
->ss
->expr
->symtree
)
2320 name
= se
->loop
->ss
->expr
->symtree
->name
;
2322 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2323 && se
->loop
->ss
->loop_chain
->expr
2324 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2325 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2327 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2329 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2330 && se
->loop
->ss
->expr
->value
.function
.name
)
2331 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2333 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2334 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2335 name
= "unnamed constant";
2338 if (descriptor
->base
.code
!= COMPONENT_REF
)
2339 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2341 /* If upper bound is present, include both bounds in the error message. */
2344 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2345 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2348 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2349 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2351 asprintf (&msg
, "Index '%%ld' of dimension %d "
2352 "outside of expected range (%%ld:%%ld)", n
+1);
2354 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp_lo
);
2355 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2356 fold_convert (long_integer_type_node
, index
),
2357 fold_convert (long_integer_type_node
, tmp_lo
),
2358 fold_convert (long_integer_type_node
, tmp_up
));
2359 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp_up
);
2360 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2361 fold_convert (long_integer_type_node
, index
),
2362 fold_convert (long_integer_type_node
, tmp_lo
),
2363 fold_convert (long_integer_type_node
, tmp_up
));
2368 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2371 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2372 "below lower bound of %%ld", n
+1, name
);
2374 asprintf (&msg
, "Index '%%ld' of dimension %d "
2375 "below lower bound of %%ld", n
+1);
2377 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp_lo
);
2378 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2379 fold_convert (long_integer_type_node
, index
),
2380 fold_convert (long_integer_type_node
, tmp_lo
));
2388 /* Return the offset for an index. Performs bound checking for elemental
2389 dimensions. Single element references are processed separately. */
2392 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2393 gfc_array_ref
* ar
, tree stride
)
2399 /* Get the index into the array for this dimension. */
2402 gcc_assert (ar
->type
!= AR_ELEMENT
);
2403 switch (ar
->dimen_type
[dim
])
2406 /* Elemental dimension. */
2407 gcc_assert (info
->subscript
[dim
]
2408 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2409 /* We've already translated this value outside the loop. */
2410 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2412 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2413 index
, dim
, &ar
->where
,
2414 ar
->as
->type
!= AS_ASSUMED_SIZE
2415 || dim
< ar
->dimen
- 1);
2419 gcc_assert (info
&& se
->loop
);
2420 gcc_assert (info
->subscript
[dim
]
2421 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2422 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2424 /* Get a zero-based index into the vector. */
2425 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2426 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2428 /* Multiply the index by the stride. */
2429 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2430 index
, gfc_conv_array_stride (desc
, 0));
2432 /* Read the vector to get an index into info->descriptor. */
2433 data
= build_fold_indirect_ref_loc (input_location
,
2434 gfc_conv_array_data (desc
));
2435 index
= gfc_build_array_ref (data
, index
, NULL
);
2436 index
= gfc_evaluate_now (index
, &se
->pre
);
2438 /* Do any bounds checking on the final info->descriptor index. */
2439 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2440 index
, dim
, &ar
->where
,
2441 ar
->as
->type
!= AS_ASSUMED_SIZE
2442 || dim
< ar
->dimen
- 1);
2446 /* Scalarized dimension. */
2447 gcc_assert (info
&& se
->loop
);
2449 /* Multiply the loop variable by the stride and delta. */
2450 index
= se
->loop
->loopvar
[i
];
2451 if (!integer_onep (info
->stride
[i
]))
2452 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2454 if (!integer_zerop (info
->delta
[i
]))
2455 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2465 /* Temporary array or derived type component. */
2466 gcc_assert (se
->loop
);
2467 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2468 if (!integer_zerop (info
->delta
[i
]))
2469 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2470 index
, info
->delta
[i
]);
2473 /* Multiply by the stride. */
2474 if (!integer_onep (stride
))
2475 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2481 /* Build a scalarized reference to an array. */
2484 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2487 tree decl
= NULL_TREE
;
2492 info
= &se
->ss
->data
.info
;
2494 n
= se
->loop
->order
[0];
2498 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2500 /* Add the offset for this dimension to the stored offset for all other
2502 if (!integer_zerop (info
->offset
))
2503 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2505 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2506 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2508 tmp
= build_fold_indirect_ref_loc (input_location
,
2510 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2514 /* Translate access of temporary array. */
2517 gfc_conv_tmp_array_ref (gfc_se
* se
)
2519 se
->string_length
= se
->ss
->string_length
;
2520 gfc_conv_scalarized_array_ref (se
, NULL
);
2524 /* Build an array reference. se->expr already holds the array descriptor.
2525 This should be either a variable, indirect variable reference or component
2526 reference. For arrays which do not have a descriptor, se->expr will be
2528 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2531 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2544 /* Handle scalarized references separately. */
2545 if (ar
->type
!= AR_ELEMENT
)
2547 gfc_conv_scalarized_array_ref (se
, ar
);
2548 gfc_advance_se_ss_chain (se
);
2552 index
= gfc_index_zero_node
;
2554 /* Calculate the offsets from all the dimensions. */
2555 for (n
= 0; n
< ar
->dimen
; n
++)
2557 /* Calculate the index for this dimension. */
2558 gfc_init_se (&indexse
, se
);
2559 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2560 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2562 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2564 /* Check array bounds. */
2568 /* Evaluate the indexse.expr only once. */
2569 indexse
.expr
= save_expr (indexse
.expr
);
2572 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2573 if (sym
->attr
.temporary
)
2575 gfc_init_se (&tmpse
, se
);
2576 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
2577 gfc_array_index_type
);
2578 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2582 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2584 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2585 "below lower bound of %%ld", n
+1, sym
->name
);
2586 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2587 fold_convert (long_integer_type_node
,
2589 fold_convert (long_integer_type_node
, tmp
));
2592 /* Upper bound, but not for the last dimension of assumed-size
2594 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
2596 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2597 if (sym
->attr
.temporary
)
2599 gfc_init_se (&tmpse
, se
);
2600 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
2601 gfc_array_index_type
);
2602 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2606 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2608 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2609 "above upper bound of %%ld", n
+1, sym
->name
);
2610 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2611 fold_convert (long_integer_type_node
,
2613 fold_convert (long_integer_type_node
, tmp
));
2618 /* Multiply the index by the stride. */
2619 stride
= gfc_conv_array_stride (se
->expr
, n
);
2620 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2623 /* And add it to the total. */
2624 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2627 tmp
= gfc_conv_array_offset (se
->expr
);
2628 if (!integer_zerop (tmp
))
2629 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2631 /* Access the calculated element. */
2632 tmp
= gfc_conv_array_data (se
->expr
);
2633 tmp
= build_fold_indirect_ref (tmp
);
2634 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2638 /* Generate the code to be executed immediately before entering a
2639 scalarization loop. */
2642 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2643 stmtblock_t
* pblock
)
2652 /* This code will be executed before entering the scalarization loop
2653 for this dimension. */
2654 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2656 if ((ss
->useflags
& flag
) == 0)
2659 if (ss
->type
!= GFC_SS_SECTION
2660 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2661 && ss
->type
!= GFC_SS_COMPONENT
)
2664 info
= &ss
->data
.info
;
2666 if (dim
>= info
->dimen
)
2669 if (dim
== info
->dimen
- 1)
2671 /* For the outermost loop calculate the offset due to any
2672 elemental dimensions. It will have been initialized with the
2673 base offset of the array. */
2676 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2678 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2681 gfc_init_se (&se
, NULL
);
2683 se
.expr
= info
->descriptor
;
2684 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2685 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2688 gfc_add_block_to_block (pblock
, &se
.pre
);
2690 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2691 info
->offset
, index
);
2692 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2696 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2699 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2701 /* Calculate the stride of the innermost loop. Hopefully this will
2702 allow the backend optimizers to do their stuff more effectively.
2704 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2708 /* Add the offset for the previous loop dimension. */
2713 ar
= &info
->ref
->u
.ar
;
2714 i
= loop
->order
[dim
+ 1];
2722 gfc_init_se (&se
, NULL
);
2724 se
.expr
= info
->descriptor
;
2725 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2726 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2728 gfc_add_block_to_block (pblock
, &se
.pre
);
2729 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2730 info
->offset
, index
);
2731 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2734 /* Remember this offset for the second loop. */
2735 if (dim
== loop
->temp_dim
- 1)
2736 info
->saved_offset
= info
->offset
;
2741 /* Start a scalarized expression. Creates a scope and declares loop
2745 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2751 gcc_assert (!loop
->array_parameter
);
2753 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2755 n
= loop
->order
[dim
];
2757 gfc_start_block (&loop
->code
[n
]);
2759 /* Create the loop variable. */
2760 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2762 if (dim
< loop
->temp_dim
)
2766 /* Calculate values that will be constant within this loop. */
2767 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2769 gfc_start_block (pbody
);
2773 /* Generates the actual loop code for a scalarization loop. */
2776 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2777 stmtblock_t
* pbody
)
2788 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
2789 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
2790 && n
== loop
->dimen
- 1)
2792 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2793 init
= make_tree_vec (1);
2794 cond
= make_tree_vec (1);
2795 incr
= make_tree_vec (1);
2797 /* Cycle statement is implemented with a goto. Exit statement must not
2798 be present for this loop. */
2799 exit_label
= gfc_build_label_decl (NULL_TREE
);
2800 TREE_USED (exit_label
) = 1;
2802 /* Label for cycle statements (if needed). */
2803 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2804 gfc_add_expr_to_block (pbody
, tmp
);
2806 stmt
= make_node (OMP_FOR
);
2808 TREE_TYPE (stmt
) = void_type_node
;
2809 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
2811 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
2812 OMP_CLAUSE_SCHEDULE
);
2813 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
2814 = OMP_CLAUSE_SCHEDULE_STATIC
;
2815 if (ompws_flags
& OMPWS_NOWAIT
)
2816 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
2817 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
2819 /* Initialize the loopvar. */
2820 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
2822 OMP_FOR_INIT (stmt
) = init
;
2823 /* The exit condition. */
2824 TREE_VEC_ELT (cond
, 0) = build2 (LE_EXPR
, boolean_type_node
,
2825 loop
->loopvar
[n
], loop
->to
[n
]);
2826 OMP_FOR_COND (stmt
) = cond
;
2827 /* Increment the loopvar. */
2828 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2829 loop
->loopvar
[n
], gfc_index_one_node
);
2830 TREE_VEC_ELT (incr
, 0) = fold_build2 (MODIFY_EXPR
,
2831 void_type_node
, loop
->loopvar
[n
], tmp
);
2832 OMP_FOR_INCR (stmt
) = incr
;
2834 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
2835 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
2839 loopbody
= gfc_finish_block (pbody
);
2841 /* Initialize the loopvar. */
2842 if (loop
->loopvar
[n
] != loop
->from
[n
])
2843 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2845 exit_label
= gfc_build_label_decl (NULL_TREE
);
2847 /* Generate the loop body. */
2848 gfc_init_block (&block
);
2850 /* The exit condition. */
2851 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2852 loop
->loopvar
[n
], loop
->to
[n
]);
2853 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2854 TREE_USED (exit_label
) = 1;
2855 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2856 gfc_add_expr_to_block (&block
, tmp
);
2858 /* The main body. */
2859 gfc_add_expr_to_block (&block
, loopbody
);
2861 /* Increment the loopvar. */
2862 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2863 loop
->loopvar
[n
], gfc_index_one_node
);
2864 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
2866 /* Build the loop. */
2867 tmp
= gfc_finish_block (&block
);
2868 tmp
= build1_v (LOOP_EXPR
, tmp
);
2869 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2871 /* Add the exit label. */
2872 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2873 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2879 /* Finishes and generates the loops for a scalarized expression. */
2882 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2887 stmtblock_t
*pblock
;
2891 /* Generate the loops. */
2892 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2894 n
= loop
->order
[dim
];
2895 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2896 loop
->loopvar
[n
] = NULL_TREE
;
2897 pblock
= &loop
->code
[n
];
2900 tmp
= gfc_finish_block (pblock
);
2901 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2903 /* Clear all the used flags. */
2904 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2909 /* Finish the main body of a scalarized expression, and start the secondary
2913 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2917 stmtblock_t
*pblock
;
2921 /* We finish as many loops as are used by the temporary. */
2922 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2924 n
= loop
->order
[dim
];
2925 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2926 loop
->loopvar
[n
] = NULL_TREE
;
2927 pblock
= &loop
->code
[n
];
2930 /* We don't want to finish the outermost loop entirely. */
2931 n
= loop
->order
[loop
->temp_dim
- 1];
2932 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2934 /* Restore the initial offsets. */
2935 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2937 if ((ss
->useflags
& 2) == 0)
2940 if (ss
->type
!= GFC_SS_SECTION
2941 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2942 && ss
->type
!= GFC_SS_COMPONENT
)
2945 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2948 /* Restart all the inner loops we just finished. */
2949 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2951 n
= loop
->order
[dim
];
2953 gfc_start_block (&loop
->code
[n
]);
2955 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2957 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2960 /* Start a block for the secondary copying code. */
2961 gfc_start_block (body
);
2965 /* Calculate the upper bound of an array section. */
2968 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2977 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2979 info
= &ss
->data
.info
;
2982 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2983 /* We'll calculate the upper bound once we have access to the
2984 vector's descriptor. */
2987 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2988 desc
= info
->descriptor
;
2989 end
= info
->ref
->u
.ar
.end
[dim
];
2993 /* The upper bound was specified. */
2994 gfc_init_se (&se
, NULL
);
2995 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2996 gfc_add_block_to_block (pblock
, &se
.pre
);
3001 /* No upper bound was specified, so use the bound of the array. */
3002 bound
= gfc_conv_array_ubound (desc
, dim
);
3009 /* Calculate the lower bound of an array section. */
3012 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
3022 gcc_assert (ss
->type
== GFC_SS_SECTION
);
3024 info
= &ss
->data
.info
;
3027 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3029 /* We use a zero-based index to access the vector. */
3030 info
->start
[n
] = gfc_index_zero_node
;
3031 info
->end
[n
] = gfc_index_zero_node
;
3032 info
->stride
[n
] = gfc_index_one_node
;
3036 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
3037 desc
= info
->descriptor
;
3038 start
= info
->ref
->u
.ar
.start
[dim
];
3039 end
= info
->ref
->u
.ar
.end
[dim
];
3040 stride
= info
->ref
->u
.ar
.stride
[dim
];
3042 /* Calculate the start of the range. For vector subscripts this will
3043 be the range of the vector. */
3046 /* Specified section start. */
3047 gfc_init_se (&se
, NULL
);
3048 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
3049 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3050 info
->start
[n
] = se
.expr
;
3054 /* No lower bound specified so use the bound of the array. */
3055 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
3057 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
3059 /* Similarly calculate the end. Although this is not used in the
3060 scalarizer, it is needed when checking bounds and where the end
3061 is an expression with side-effects. */
3064 /* Specified section start. */
3065 gfc_init_se (&se
, NULL
);
3066 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
3067 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3068 info
->end
[n
] = se
.expr
;
3072 /* No upper bound specified so use the bound of the array. */
3073 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
3075 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
3077 /* Calculate the stride. */
3079 info
->stride
[n
] = gfc_index_one_node
;
3082 gfc_init_se (&se
, NULL
);
3083 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3084 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3085 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3090 /* Calculates the range start and stride for a SS chain. Also gets the
3091 descriptor and data pointer. The range of vector subscripts is the size
3092 of the vector. Array bounds are also checked. */
3095 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3103 /* Determine the rank of the loop. */
3105 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
3109 case GFC_SS_SECTION
:
3110 case GFC_SS_CONSTRUCTOR
:
3111 case GFC_SS_FUNCTION
:
3112 case GFC_SS_COMPONENT
:
3113 loop
->dimen
= ss
->data
.info
.dimen
;
3116 /* As usual, lbound and ubound are exceptions!. */
3117 case GFC_SS_INTRINSIC
:
3118 switch (ss
->expr
->value
.function
.isym
->id
)
3120 case GFC_ISYM_LBOUND
:
3121 case GFC_ISYM_UBOUND
:
3122 loop
->dimen
= ss
->data
.info
.dimen
;
3133 /* We should have determined the rank of the expression by now. If
3134 not, that's bad news. */
3135 gcc_assert (loop
->dimen
!= 0);
3137 /* Loop over all the SS in the chain. */
3138 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3140 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
3141 ss
->shape
= ss
->expr
->shape
;
3145 case GFC_SS_SECTION
:
3146 /* Get the descriptor for the array. */
3147 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3149 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3150 gfc_conv_section_startstride (loop
, ss
, n
);
3153 case GFC_SS_INTRINSIC
:
3154 switch (ss
->expr
->value
.function
.isym
->id
)
3156 /* Fall through to supply start and stride. */
3157 case GFC_ISYM_LBOUND
:
3158 case GFC_ISYM_UBOUND
:
3164 case GFC_SS_CONSTRUCTOR
:
3165 case GFC_SS_FUNCTION
:
3166 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3168 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
3169 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
3170 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3179 /* The rest is just runtime bound checking. */
3180 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3183 tree lbound
, ubound
;
3185 tree size
[GFC_MAX_DIMENSIONS
];
3186 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3191 gfc_start_block (&block
);
3193 for (n
= 0; n
< loop
->dimen
; n
++)
3194 size
[n
] = NULL_TREE
;
3196 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3200 if (ss
->type
!= GFC_SS_SECTION
)
3203 gfc_start_block (&inner
);
3205 /* TODO: range checking for mapped dimensions. */
3206 info
= &ss
->data
.info
;
3208 /* This code only checks ranges. Elemental and vector
3209 dimensions are checked later. */
3210 for (n
= 0; n
< loop
->dimen
; n
++)
3215 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3218 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3219 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3220 check_upper
= false;
3224 /* Zero stride is not allowed. */
3225 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
3226 gfc_index_zero_node
);
3227 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3228 "of array '%s'", info
->dim
[n
]+1,
3229 ss
->expr
->symtree
->name
);
3230 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3231 &ss
->expr
->where
, msg
);
3234 desc
= ss
->data
.info
.descriptor
;
3236 /* This is the run-time equivalent of resolve.c's
3237 check_dimension(). The logical is more readable there
3238 than it is here, with all the trees. */
3239 lbound
= gfc_conv_array_lbound (desc
, dim
);
3242 ubound
= gfc_conv_array_ubound (desc
, dim
);
3246 /* non_zerosized is true when the selected range is not
3248 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
3249 info
->stride
[n
], gfc_index_zero_node
);
3250 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
3252 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3255 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
3256 info
->stride
[n
], gfc_index_zero_node
);
3257 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
3259 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3261 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
3262 stride_pos
, stride_neg
);
3264 /* Check the start of the range against the lower and upper
3265 bounds of the array, if the range is not empty.
3266 If upper bound is present, include both bounds in the
3270 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
3271 info
->start
[n
], lbound
);
3272 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3273 non_zerosized
, tmp
);
3274 tmp2
= fold_build2 (GT_EXPR
, boolean_type_node
,
3275 info
->start
[n
], ubound
);
3276 tmp2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3277 non_zerosized
, tmp2
);
3278 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3279 "outside of expected range (%%ld:%%ld)",
3280 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3281 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3282 &ss
->expr
->where
, msg
,
3283 fold_convert (long_integer_type_node
, info
->start
[n
]),
3284 fold_convert (long_integer_type_node
, lbound
),
3285 fold_convert (long_integer_type_node
, ubound
));
3286 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3287 &ss
->expr
->where
, msg
,
3288 fold_convert (long_integer_type_node
, info
->start
[n
]),
3289 fold_convert (long_integer_type_node
, lbound
),
3290 fold_convert (long_integer_type_node
, ubound
));
3295 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
3296 info
->start
[n
], lbound
);
3297 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3298 non_zerosized
, tmp
);
3299 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3300 "below lower bound of %%ld",
3301 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3302 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3303 &ss
->expr
->where
, msg
,
3304 fold_convert (long_integer_type_node
, info
->start
[n
]),
3305 fold_convert (long_integer_type_node
, lbound
));
3309 /* Compute the last element of the range, which is not
3310 necessarily "end" (think 0:5:3, which doesn't contain 5)
3311 and check it against both lower and upper bounds. */
3313 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3315 tmp
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp
,
3317 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3319 tmp2
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, lbound
);
3320 tmp2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3321 non_zerosized
, tmp2
);
3324 tmp3
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp
, ubound
);
3325 tmp3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3326 non_zerosized
, tmp3
);
3327 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3328 "outside of expected range (%%ld:%%ld)",
3329 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3330 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3331 &ss
->expr
->where
, msg
,
3332 fold_convert (long_integer_type_node
, tmp
),
3333 fold_convert (long_integer_type_node
, ubound
),
3334 fold_convert (long_integer_type_node
, lbound
));
3335 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3336 &ss
->expr
->where
, msg
,
3337 fold_convert (long_integer_type_node
, tmp
),
3338 fold_convert (long_integer_type_node
, ubound
),
3339 fold_convert (long_integer_type_node
, lbound
));
3344 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3345 "below lower bound of %%ld",
3346 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3347 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3348 &ss
->expr
->where
, msg
,
3349 fold_convert (long_integer_type_node
, tmp
),
3350 fold_convert (long_integer_type_node
, lbound
));
3354 /* Check the section sizes match. */
3355 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3357 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
3359 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3360 gfc_index_one_node
, tmp
);
3361 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3362 build_int_cst (gfc_array_index_type
, 0));
3363 /* We remember the size of the first section, and check all the
3364 others against this. */
3367 tmp3
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
3368 asprintf (&msg
, "%s, size mismatch for dimension %d "
3369 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds
,
3370 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3371 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3372 &ss
->expr
->where
, msg
,
3373 fold_convert (long_integer_type_node
, tmp
),
3374 fold_convert (long_integer_type_node
, size
[n
]));
3378 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
3381 tmp
= gfc_finish_block (&inner
);
3383 /* For optional arguments, only check bounds if the argument is
3385 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3386 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3387 tmp
= build3_v (COND_EXPR
,
3388 gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
),
3389 tmp
, build_empty_stmt (input_location
));
3391 gfc_add_expr_to_block (&block
, tmp
);
3395 tmp
= gfc_finish_block (&block
);
3396 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3401 /* Return true if the two SS could be aliased, i.e. both point to the same data
3403 /* TODO: resolve aliases based on frontend expressions. */
3406 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3413 lsym
= lss
->expr
->symtree
->n
.sym
;
3414 rsym
= rss
->expr
->symtree
->n
.sym
;
3415 if (gfc_symbols_could_alias (lsym
, rsym
))
3418 if (rsym
->ts
.type
!= BT_DERIVED
3419 && lsym
->ts
.type
!= BT_DERIVED
)
3422 /* For derived types we must check all the component types. We can ignore
3423 array references as these will have the same base type as the previous
3425 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3427 if (lref
->type
!= REF_COMPONENT
)
3430 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3433 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3436 if (rref
->type
!= REF_COMPONENT
)
3439 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3444 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3446 if (rref
->type
!= REF_COMPONENT
)
3449 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3457 /* Resolve array data dependencies. Creates a temporary if required. */
3458 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3462 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3470 loop
->temp_ss
= NULL
;
3472 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3474 if (ss
->type
!= GFC_SS_SECTION
)
3477 if (dest
->expr
->symtree
->n
.sym
!= ss
->expr
->symtree
->n
.sym
)
3479 if (gfc_could_be_alias (dest
, ss
)
3480 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3488 lref
= dest
->expr
->ref
;
3489 rref
= ss
->expr
->ref
;
3491 nDepend
= gfc_dep_resolver (lref
, rref
);
3495 /* TODO : loop shifting. */
3498 /* Mark the dimensions for LOOP SHIFTING */
3499 for (n
= 0; n
< loop
->dimen
; n
++)
3501 int dim
= dest
->data
.info
.dim
[n
];
3503 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3505 else if (! gfc_is_same_range (&lref
->u
.ar
,
3506 &rref
->u
.ar
, dim
, 0))
3510 /* Put all the dimensions with dependencies in the
3513 for (n
= 0; n
< loop
->dimen
; n
++)
3515 gcc_assert (loop
->order
[n
] == n
);
3517 loop
->order
[dim
++] = n
;
3519 for (n
= 0; n
< loop
->dimen
; n
++)
3522 loop
->order
[dim
++] = n
;
3525 gcc_assert (dim
== loop
->dimen
);
3534 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3535 if (GFC_ARRAY_TYPE_P (base_type
)
3536 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3537 base_type
= gfc_get_element_type (base_type
);
3538 loop
->temp_ss
= gfc_get_ss ();
3539 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3540 loop
->temp_ss
->data
.temp
.type
= base_type
;
3541 loop
->temp_ss
->string_length
= dest
->string_length
;
3542 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3543 loop
->temp_ss
->next
= gfc_ss_terminator
;
3544 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3547 loop
->temp_ss
= NULL
;
3551 /* Initialize the scalarization loop. Creates the loop variables. Determines
3552 the range of the loop variables. Creates a temporary if required.
3553 Calculates how to transform from loop variables to array indices for each
3554 expression. Also generates code for scalar expressions which have been
3555 moved outside the loop. */
3558 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
3562 gfc_ss_info
*specinfo
;
3565 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3566 bool dynamic
[GFC_MAX_DIMENSIONS
];
3571 for (n
= 0; n
< loop
->dimen
; n
++)
3575 /* We use one SS term, and use that to determine the bounds of the
3576 loop for this dimension. We try to pick the simplest term. */
3577 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3581 /* The frontend has worked out the size for us. */
3582 if (!loopspec
[n
] || !loopspec
[n
]->shape
3583 || !integer_zerop (loopspec
[n
]->data
.info
.start
[n
]))
3584 /* Prefer zero-based descriptors if possible. */
3589 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3591 gfc_constructor_base base
;
3592 /* An unknown size constructor will always be rank one.
3593 Higher rank constructors will either have known shape,
3594 or still be wrapped in a call to reshape. */
3595 gcc_assert (loop
->dimen
== 1);
3597 /* Always prefer to use the constructor bounds if the size
3598 can be determined at compile time. Prefer not to otherwise,
3599 since the general case involves realloc, and it's better to
3600 avoid that overhead if possible. */
3601 base
= ss
->expr
->value
.constructor
;
3602 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
3603 if (!dynamic
[n
] || !loopspec
[n
])
3608 /* TODO: Pick the best bound if we have a choice between a
3609 function and something else. */
3610 if (ss
->type
== GFC_SS_FUNCTION
)
3616 if (ss
->type
!= GFC_SS_SECTION
)
3620 specinfo
= &loopspec
[n
]->data
.info
;
3623 info
= &ss
->data
.info
;
3627 /* Criteria for choosing a loop specifier (most important first):
3628 doesn't need realloc
3634 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3636 else if (integer_onep (info
->stride
[n
])
3637 && !integer_onep (specinfo
->stride
[n
]))
3639 else if (INTEGER_CST_P (info
->stride
[n
])
3640 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3642 else if (INTEGER_CST_P (info
->start
[n
])
3643 && !INTEGER_CST_P (specinfo
->start
[n
]))
3645 /* We don't work out the upper bound.
3646 else if (INTEGER_CST_P (info->finish[n])
3647 && ! INTEGER_CST_P (specinfo->finish[n]))
3648 loopspec[n] = ss; */
3651 /* We should have found the scalarization loop specifier. If not,
3653 gcc_assert (loopspec
[n
]);
3655 info
= &loopspec
[n
]->data
.info
;
3657 /* Set the extents of this range. */
3658 cshape
= loopspec
[n
]->shape
;
3659 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3660 && INTEGER_CST_P (info
->stride
[n
]))
3662 loop
->from
[n
] = info
->start
[n
];
3663 mpz_set (i
, cshape
[n
]);
3664 mpz_sub_ui (i
, i
, 1);
3665 /* To = from + (size - 1) * stride. */
3666 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3667 if (!integer_onep (info
->stride
[n
]))
3668 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3669 tmp
, info
->stride
[n
]);
3670 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3671 loop
->from
[n
], tmp
);
3675 loop
->from
[n
] = info
->start
[n
];
3676 switch (loopspec
[n
]->type
)
3678 case GFC_SS_CONSTRUCTOR
:
3679 /* The upper bound is calculated when we expand the
3681 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3684 case GFC_SS_SECTION
:
3685 /* Use the end expression if it exists and is not constant,
3686 so that it is only evaluated once. */
3687 if (info
->end
[n
] && !INTEGER_CST_P (info
->end
[n
]))
3688 loop
->to
[n
] = info
->end
[n
];
3690 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3694 case GFC_SS_FUNCTION
:
3695 /* The loop bound will be set when we generate the call. */
3696 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3704 /* Transform everything so we have a simple incrementing variable. */
3705 if (integer_onep (info
->stride
[n
]))
3706 info
->delta
[n
] = gfc_index_zero_node
;
3709 /* Set the delta for this section. */
3710 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3711 /* Number of iterations is (end - start + step) / step.
3712 with start = 0, this simplifies to
3714 for (i = 0; i<=last; i++){...}; */
3715 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3716 loop
->to
[n
], loop
->from
[n
]);
3717 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
,
3718 tmp
, info
->stride
[n
]);
3719 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3720 build_int_cst (gfc_array_index_type
, -1));
3721 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3722 /* Make the loop variable start at 0. */
3723 loop
->from
[n
] = gfc_index_zero_node
;
3727 /* Add all the scalar code that can be taken out of the loops.
3728 This may include calculating the loop bounds, so do it before
3729 allocating the temporary. */
3730 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
3732 /* If we want a temporary then create it. */
3733 if (loop
->temp_ss
!= NULL
)
3735 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3737 /* Make absolutely sure that this is a complete type. */
3738 if (loop
->temp_ss
->string_length
)
3739 loop
->temp_ss
->data
.temp
.type
3740 = gfc_get_character_type_len_for_eltype
3741 (TREE_TYPE (loop
->temp_ss
->data
.temp
.type
),
3742 loop
->temp_ss
->string_length
);
3744 tmp
= loop
->temp_ss
->data
.temp
.type
;
3745 n
= loop
->temp_ss
->data
.temp
.dimen
;
3746 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3747 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3748 loop
->temp_ss
->data
.info
.dimen
= n
;
3749 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3750 &loop
->temp_ss
->data
.info
, tmp
, NULL_TREE
,
3751 false, true, false, where
);
3754 for (n
= 0; n
< loop
->temp_dim
; n
++)
3755 loopspec
[loop
->order
[n
]] = NULL
;
3759 /* For array parameters we don't have loop variables, so don't calculate the
3761 if (loop
->array_parameter
)
3764 /* Calculate the translation from loop variables to array indices. */
3765 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3767 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
3768 && ss
->type
!= GFC_SS_CONSTRUCTOR
)
3772 info
= &ss
->data
.info
;
3774 for (n
= 0; n
< info
->dimen
; n
++)
3776 /* If we are specifying the range the delta is already set. */
3777 if (loopspec
[n
] != ss
)
3779 /* Calculate the offset relative to the loop variable.
3780 First multiply by the stride. */
3781 tmp
= loop
->from
[n
];
3782 if (!integer_onep (info
->stride
[n
]))
3783 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3784 tmp
, info
->stride
[n
]);
3786 /* Then subtract this from our starting value. */
3787 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3788 info
->start
[n
], tmp
);
3790 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3797 /* Fills in an array descriptor, and returns the size of the array. The size
3798 will be a simple_val, ie a variable or a constant. Also calculates the
3799 offset of the base. Returns the size of the array.
3803 for (n = 0; n < rank; n++)
3805 a.lbound[n] = specified_lower_bound;
3806 offset = offset + a.lbond[n] * stride;
3808 a.ubound[n] = specified_upper_bound;
3809 a.stride[n] = stride;
3810 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3811 stride = stride * size;
3818 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
3819 gfc_expr
** lower
, gfc_expr
** upper
,
3820 stmtblock_t
* pblock
)
3832 stmtblock_t thenblock
;
3833 stmtblock_t elseblock
;
3838 type
= TREE_TYPE (descriptor
);
3840 stride
= gfc_index_one_node
;
3841 offset
= gfc_index_zero_node
;
3843 /* Set the dtype. */
3844 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3845 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3847 or_expr
= NULL_TREE
;
3849 for (n
= 0; n
< rank
; n
++)
3851 /* We have 3 possibilities for determining the size of the array:
3852 lower == NULL => lbound = 1, ubound = upper[n]
3853 upper[n] = NULL => lbound = 1, ubound = lower[n]
3854 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3857 /* Set lower bound. */
3858 gfc_init_se (&se
, NULL
);
3860 se
.expr
= gfc_index_one_node
;
3863 gcc_assert (lower
[n
]);
3866 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3867 gfc_add_block_to_block (pblock
, &se
.pre
);
3871 se
.expr
= gfc_index_one_node
;
3875 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
3878 /* Work out the offset for this component. */
3879 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3880 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3882 /* Start the calculation for the size of this dimension. */
3883 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3884 gfc_index_one_node
, se
.expr
);
3886 /* Set upper bound. */
3887 gfc_init_se (&se
, NULL
);
3888 gcc_assert (ubound
);
3889 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3890 gfc_add_block_to_block (pblock
, &se
.pre
);
3892 gfc_conv_descriptor_ubound_set (pblock
, descriptor
, gfc_rank_cst
[n
], se
.expr
);
3894 /* Store the stride. */
3895 gfc_conv_descriptor_stride_set (pblock
, descriptor
, gfc_rank_cst
[n
], stride
);
3897 /* Calculate the size of this dimension. */
3898 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3900 /* Check whether the size for this dimension is negative. */
3901 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3902 gfc_index_zero_node
);
3906 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3908 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
3909 gfc_index_zero_node
, size
);
3911 /* Multiply the stride by the number of elements in this dimension. */
3912 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3913 stride
= gfc_evaluate_now (stride
, pblock
);
3916 /* The stride is the number of elements in the array, so multiply by the
3917 size of an element to get the total size. */
3918 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3919 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3920 fold_convert (gfc_array_index_type
, tmp
));
3922 if (poffset
!= NULL
)
3924 offset
= gfc_evaluate_now (offset
, pblock
);
3928 if (integer_zerop (or_expr
))
3930 if (integer_onep (or_expr
))
3931 return gfc_index_zero_node
;
3933 var
= gfc_create_var (TREE_TYPE (size
), "size");
3934 gfc_start_block (&thenblock
);
3935 gfc_add_modify (&thenblock
, var
, gfc_index_zero_node
);
3936 thencase
= gfc_finish_block (&thenblock
);
3938 gfc_start_block (&elseblock
);
3939 gfc_add_modify (&elseblock
, var
, size
);
3940 elsecase
= gfc_finish_block (&elseblock
);
3942 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3943 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3944 gfc_add_expr_to_block (pblock
, tmp
);
3950 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3951 the work for an ALLOCATE statement. */
3955 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3963 gfc_ref
*ref
, *prev_ref
= NULL
;
3964 bool allocatable_array
;
3968 /* Find the last reference in the chain. */
3969 while (ref
&& ref
->next
!= NULL
)
3971 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
3972 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
3977 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3980 /* Return if this is a scalar coarray. */
3981 if (!prev_ref
&& !expr
->symtree
->n
.sym
->attr
.dimension
)
3983 gcc_assert (expr
->symtree
->n
.sym
->attr
.codimension
);
3986 else if (prev_ref
&& !prev_ref
->u
.c
.component
->attr
.dimension
)
3988 gcc_assert (prev_ref
->u
.c
.component
->attr
.codimension
);
3993 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3995 allocatable_array
= prev_ref
->u
.c
.component
->attr
.allocatable
;
3997 /* Figure out the size of the array. */
3998 switch (ref
->u
.ar
.type
)
4002 upper
= ref
->u
.ar
.start
;
4006 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
4008 lower
= ref
->u
.ar
.as
->lower
;
4009 upper
= ref
->u
.ar
.as
->upper
;
4013 lower
= ref
->u
.ar
.start
;
4014 upper
= ref
->u
.ar
.end
;
4022 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
4023 lower
, upper
, &se
->pre
);
4025 /* Allocate memory to store the data. */
4026 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
4027 STRIP_NOPS (pointer
);
4029 /* The allocate_array variants take the old pointer as first argument. */
4030 if (allocatable_array
)
4031 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
, expr
);
4033 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
4034 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
4035 gfc_add_expr_to_block (&se
->pre
, tmp
);
4037 gfc_conv_descriptor_offset_set (&se
->pre
, se
->expr
, offset
);
4039 if (expr
->ts
.type
== BT_DERIVED
4040 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
4042 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
4043 ref
->u
.ar
.as
->rank
);
4044 gfc_add_expr_to_block (&se
->pre
, tmp
);
4051 /* Deallocate an array variable. Also used when an allocated variable goes
4056 gfc_array_deallocate (tree descriptor
, tree pstat
, gfc_expr
* expr
)
4062 gfc_start_block (&block
);
4063 /* Get a pointer to the data. */
4064 var
= gfc_conv_descriptor_data_get (descriptor
);
4067 /* Parameter is the address of the data component. */
4068 tmp
= gfc_deallocate_with_status (var
, pstat
, false, expr
);
4069 gfc_add_expr_to_block (&block
, tmp
);
4071 /* Zero the data pointer. */
4072 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
4073 var
, build_int_cst (TREE_TYPE (var
), 0));
4074 gfc_add_expr_to_block (&block
, tmp
);
4076 return gfc_finish_block (&block
);
4080 /* Create an array constructor from an initialization expression.
4081 We assume the frontend already did any expansions and conversions. */
4084 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
4091 unsigned HOST_WIDE_INT lo
;
4093 VEC(constructor_elt
,gc
) *v
= NULL
;
4095 switch (expr
->expr_type
)
4098 case EXPR_STRUCTURE
:
4099 /* A single scalar or derived type value. Create an array with all
4100 elements equal to that value. */
4101 gfc_init_se (&se
, NULL
);
4103 if (expr
->expr_type
== EXPR_CONSTANT
)
4104 gfc_conv_constant (&se
, expr
);
4106 gfc_conv_structure (&se
, expr
, 1);
4108 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
4109 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
4110 hi
= TREE_INT_CST_HIGH (tmp
);
4111 lo
= TREE_INT_CST_LOW (tmp
);
4115 /* This will probably eat buckets of memory for large arrays. */
4116 while (hi
!= 0 || lo
!= 0)
4118 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
4126 /* Create a vector of all the elements. */
4127 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4128 c
; c
= gfc_constructor_next (c
))
4132 /* Problems occur when we get something like
4133 integer :: a(lots) = (/(i, i=1, lots)/) */
4134 gfc_fatal_error ("The number of elements in the array constructor "
4135 "at %L requires an increase of the allowed %d "
4136 "upper limit. See -fmax-array-constructor "
4137 "option", &expr
->where
,
4138 gfc_option
.flag_max_array_constructor
);
4141 if (mpz_cmp_si (c
->offset
, 0) != 0)
4142 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
4146 if (mpz_cmp_si (c
->repeat
, 0) != 0)
4150 mpz_set (maxval
, c
->repeat
);
4151 mpz_add (maxval
, c
->offset
, maxval
);
4152 mpz_sub_ui (maxval
, maxval
, 1);
4153 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
4154 if (mpz_cmp_si (c
->offset
, 0) != 0)
4156 mpz_add_ui (maxval
, c
->offset
, 1);
4157 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
4160 tmp1
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
4162 range
= fold_build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
4168 gfc_init_se (&se
, NULL
);
4169 switch (c
->expr
->expr_type
)
4172 gfc_conv_constant (&se
, c
->expr
);
4173 if (range
== NULL_TREE
)
4174 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4177 if (index
!= NULL_TREE
)
4178 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4179 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
4183 case EXPR_STRUCTURE
:
4184 gfc_conv_structure (&se
, c
->expr
, 1);
4185 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4190 /* Catch those occasional beasts that do not simplify
4191 for one reason or another, assuming that if they are
4192 standard defying the frontend will catch them. */
4193 gfc_conv_expr (&se
, c
->expr
);
4194 if (range
== NULL_TREE
)
4195 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4198 if (index
!= NULL_TREE
)
4199 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4200 CONSTRUCTOR_APPEND_ELT (v
, range
, se
.expr
);
4208 return gfc_build_null_descriptor (type
);
4214 /* Create a constructor from the list of elements. */
4215 tmp
= build_constructor (type
, v
);
4216 TREE_CONSTANT (tmp
) = 1;
4221 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4222 returns the size (in elements) of the array. */
4225 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
4226 stmtblock_t
* pblock
)
4241 size
= gfc_index_one_node
;
4242 offset
= gfc_index_zero_node
;
4243 for (dim
= 0; dim
< as
->rank
; dim
++)
4245 /* Evaluate non-constant array bound expressions. */
4246 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
4247 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
4249 gfc_init_se (&se
, NULL
);
4250 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
4251 gfc_add_block_to_block (pblock
, &se
.pre
);
4252 gfc_add_modify (pblock
, lbound
, se
.expr
);
4254 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
4255 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
4257 gfc_init_se (&se
, NULL
);
4258 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
4259 gfc_add_block_to_block (pblock
, &se
.pre
);
4260 gfc_add_modify (pblock
, ubound
, se
.expr
);
4262 /* The offset of this dimension. offset = offset - lbound * stride. */
4263 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
4264 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4266 /* The size of this dimension, and the stride of the next. */
4267 if (dim
+ 1 < as
->rank
)
4268 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
4270 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4272 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
4274 /* Calculate stride = size * (ubound + 1 - lbound). */
4275 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4276 gfc_index_one_node
, lbound
);
4277 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
4278 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
4280 gfc_add_modify (pblock
, stride
, tmp
);
4282 stride
= gfc_evaluate_now (tmp
, pblock
);
4284 /* Make sure that negative size arrays are translated
4285 to being zero size. */
4286 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
,
4287 stride
, gfc_index_zero_node
);
4288 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4289 stride
, gfc_index_zero_node
);
4290 gfc_add_modify (pblock
, stride
, tmp
);
4296 gfc_trans_vla_type_sizes (sym
, pblock
);
4303 /* Generate code to initialize/allocate an array variable. */
4306 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
4315 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
4317 /* Do nothing for USEd variables. */
4318 if (sym
->attr
.use_assoc
)
4321 type
= TREE_TYPE (decl
);
4322 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4323 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
4325 gfc_start_block (&block
);
4327 /* Evaluate character string length. */
4328 if (sym
->ts
.type
== BT_CHARACTER
4329 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4331 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &block
);
4333 gfc_trans_vla_type_sizes (sym
, &block
);
4335 /* Emit a DECL_EXPR for this variable, which will cause the
4336 gimplifier to allocate storage, and all that good stuff. */
4337 tmp
= fold_build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
4338 gfc_add_expr_to_block (&block
, tmp
);
4343 gfc_add_expr_to_block (&block
, fnbody
);
4344 return gfc_finish_block (&block
);
4347 type
= TREE_TYPE (type
);
4349 gcc_assert (!sym
->attr
.use_assoc
);
4350 gcc_assert (!TREE_STATIC (decl
));
4351 gcc_assert (!sym
->module
);
4353 if (sym
->ts
.type
== BT_CHARACTER
4354 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4355 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &block
);
4357 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4359 /* Don't actually allocate space for Cray Pointees. */
4360 if (sym
->attr
.cray_pointee
)
4362 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4363 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4364 gfc_add_expr_to_block (&block
, fnbody
);
4365 return gfc_finish_block (&block
);
4368 /* The size is the number of elements in the array, so multiply by the
4369 size of an element to get the total size. */
4370 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4371 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
4372 fold_convert (gfc_array_index_type
, tmp
));
4374 /* Allocate memory to hold the data. */
4375 tmp
= gfc_call_malloc (&block
, TREE_TYPE (decl
), size
);
4376 gfc_add_modify (&block
, decl
, tmp
);
4378 /* Set offset of the array. */
4379 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4380 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4383 /* Automatic arrays should not have initializers. */
4384 gcc_assert (!sym
->value
);
4386 gfc_add_expr_to_block (&block
, fnbody
);
4388 /* Free the temporary. */
4389 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
4390 gfc_add_expr_to_block (&block
, tmp
);
4392 return gfc_finish_block (&block
);
4396 /* Generate entry and exit code for g77 calling convention arrays. */
4399 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
4409 gfc_get_backend_locus (&loc
);
4410 gfc_set_backend_locus (&sym
->declared_at
);
4412 /* Descriptor type. */
4413 parm
= sym
->backend_decl
;
4414 type
= TREE_TYPE (parm
);
4415 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4417 gfc_start_block (&block
);
4419 if (sym
->ts
.type
== BT_CHARACTER
4420 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4421 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &block
);
4423 /* Evaluate the bounds of the array. */
4424 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4426 /* Set the offset. */
4427 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4428 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4430 /* Set the pointer itself if we aren't using the parameter directly. */
4431 if (TREE_CODE (parm
) != PARM_DECL
)
4433 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4434 gfc_add_modify (&block
, parm
, tmp
);
4436 stmt
= gfc_finish_block (&block
);
4438 gfc_set_backend_locus (&loc
);
4440 gfc_start_block (&block
);
4442 /* Add the initialization code to the start of the function. */
4444 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4446 tmp
= gfc_conv_expr_present (sym
);
4447 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4450 gfc_add_expr_to_block (&block
, stmt
);
4451 gfc_add_expr_to_block (&block
, body
);
4453 return gfc_finish_block (&block
);
4457 /* Modify the descriptor of an array parameter so that it has the
4458 correct lower bound. Also move the upper bound accordingly.
4459 If the array is not packed, it will be copied into a temporary.
4460 For each dimension we set the new lower and upper bounds. Then we copy the
4461 stride and calculate the offset for this dimension. We also work out
4462 what the stride of a packed array would be, and see it the two match.
4463 If the array need repacking, we set the stride to the values we just
4464 calculated, recalculate the offset and copy the array data.
4465 Code is also added to copy the data back at the end of the function.
4469 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
4476 stmtblock_t cleanup
;
4484 tree stride
, stride2
;
4494 /* Do nothing for pointer and allocatable arrays. */
4495 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4498 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4499 return gfc_trans_g77_array (sym
, body
);
4501 gfc_get_backend_locus (&loc
);
4502 gfc_set_backend_locus (&sym
->declared_at
);
4504 /* Descriptor type. */
4505 type
= TREE_TYPE (tmpdesc
);
4506 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4507 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4508 dumdesc
= build_fold_indirect_ref_loc (input_location
,
4510 gfc_start_block (&block
);
4512 if (sym
->ts
.type
== BT_CHARACTER
4513 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4514 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &block
);
4516 checkparm
= (sym
->as
->type
== AS_EXPLICIT
4517 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
4519 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4520 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4522 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4524 /* For non-constant shape arrays we only check if the first dimension
4525 is contiguous. Repacking higher dimensions wouldn't gain us
4526 anything as we still don't know the array stride. */
4527 partial
= gfc_create_var (boolean_type_node
, "partial");
4528 TREE_USED (partial
) = 1;
4529 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4530 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4531 gfc_add_modify (&block
, partial
, tmp
);
4535 partial
= NULL_TREE
;
4538 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4539 here, however I think it does the right thing. */
4542 /* Set the first stride. */
4543 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4544 stride
= gfc_evaluate_now (stride
, &block
);
4546 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4547 stride
, gfc_index_zero_node
);
4548 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4549 gfc_index_one_node
, stride
);
4550 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4551 gfc_add_modify (&block
, stride
, tmp
);
4553 /* Allow the user to disable array repacking. */
4554 stmt_unpacked
= NULL_TREE
;
4558 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4559 /* A library call to repack the array if necessary. */
4560 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4561 stmt_unpacked
= build_call_expr_loc (input_location
,
4562 gfor_fndecl_in_pack
, 1, tmp
);
4564 stride
= gfc_index_one_node
;
4566 if (gfc_option
.warn_array_temp
)
4567 gfc_warning ("Creating array temporary at %L", &loc
);
4570 /* This is for the case where the array data is used directly without
4571 calling the repack function. */
4572 if (no_repack
|| partial
!= NULL_TREE
)
4573 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4575 stmt_packed
= NULL_TREE
;
4577 /* Assign the data pointer. */
4578 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4580 /* Don't repack unknown shape arrays when the first stride is 1. */
4581 tmp
= fold_build3 (COND_EXPR
, TREE_TYPE (stmt_packed
),
4582 partial
, stmt_packed
, stmt_unpacked
);
4585 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4586 gfc_add_modify (&block
, tmpdesc
, fold_convert (type
, tmp
));
4588 offset
= gfc_index_zero_node
;
4589 size
= gfc_index_one_node
;
4591 /* Evaluate the bounds of the array. */
4592 for (n
= 0; n
< sym
->as
->rank
; n
++)
4594 if (checkparm
|| !sym
->as
->upper
[n
])
4596 /* Get the bounds of the actual parameter. */
4597 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
4598 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
4602 dubound
= NULL_TREE
;
4603 dlbound
= NULL_TREE
;
4606 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4607 if (!INTEGER_CST_P (lbound
))
4609 gfc_init_se (&se
, NULL
);
4610 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4611 gfc_array_index_type
);
4612 gfc_add_block_to_block (&block
, &se
.pre
);
4613 gfc_add_modify (&block
, lbound
, se
.expr
);
4616 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4617 /* Set the desired upper bound. */
4618 if (sym
->as
->upper
[n
])
4620 /* We know what we want the upper bound to be. */
4621 if (!INTEGER_CST_P (ubound
))
4623 gfc_init_se (&se
, NULL
);
4624 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4625 gfc_array_index_type
);
4626 gfc_add_block_to_block (&block
, &se
.pre
);
4627 gfc_add_modify (&block
, ubound
, se
.expr
);
4630 /* Check the sizes match. */
4633 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4636 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4638 stride2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4640 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride2
);
4641 asprintf (&msg
, "%s for dimension %d of array '%s'",
4642 gfc_msg_bounds
, n
+1, sym
->name
);
4643 gfc_trans_runtime_check (true, false, tmp
, &block
, &loc
, msg
);
4649 /* For assumed shape arrays move the upper bound by the same amount
4650 as the lower bound. */
4651 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4653 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4654 gfc_add_modify (&block
, ubound
, tmp
);
4656 /* The offset of this dimension. offset = offset - lbound * stride. */
4657 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4658 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4660 /* The size of this dimension, and the stride of the next. */
4661 if (n
+ 1 < sym
->as
->rank
)
4663 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4665 if (no_repack
|| partial
!= NULL_TREE
)
4668 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
4671 /* Figure out the stride if not a known constant. */
4672 if (!INTEGER_CST_P (stride
))
4675 stmt_packed
= NULL_TREE
;
4678 /* Calculate stride = size * (ubound + 1 - lbound). */
4679 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4680 gfc_index_one_node
, lbound
);
4681 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4683 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4688 /* Assign the stride. */
4689 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4690 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4691 stmt_unpacked
, stmt_packed
);
4693 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4694 gfc_add_modify (&block
, stride
, tmp
);
4699 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4701 if (stride
&& !INTEGER_CST_P (stride
))
4703 /* Calculate size = stride * (ubound + 1 - lbound). */
4704 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4705 gfc_index_one_node
, lbound
);
4706 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4708 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4709 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4710 gfc_add_modify (&block
, stride
, tmp
);
4715 /* Set the offset. */
4716 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4717 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4719 gfc_trans_vla_type_sizes (sym
, &block
);
4721 stmt
= gfc_finish_block (&block
);
4723 gfc_start_block (&block
);
4725 /* Only do the entry/initialization code if the arg is present. */
4726 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4727 optional_arg
= (sym
->attr
.optional
4728 || (sym
->ns
->proc_name
->attr
.entry_master
4729 && sym
->attr
.dummy
));
4732 tmp
= gfc_conv_expr_present (sym
);
4733 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4735 gfc_add_expr_to_block (&block
, stmt
);
4737 /* Add the main function body. */
4738 gfc_add_expr_to_block (&block
, body
);
4743 gfc_start_block (&cleanup
);
4745 if (sym
->attr
.intent
!= INTENT_IN
)
4747 /* Copy the data back. */
4748 tmp
= build_call_expr_loc (input_location
,
4749 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4750 gfc_add_expr_to_block (&cleanup
, tmp
);
4753 /* Free the temporary. */
4754 tmp
= gfc_call_free (tmpdesc
);
4755 gfc_add_expr_to_block (&cleanup
, tmp
);
4757 stmt
= gfc_finish_block (&cleanup
);
4759 /* Only do the cleanup if the array was repacked. */
4760 tmp
= build_fold_indirect_ref_loc (input_location
,
4762 tmp
= gfc_conv_descriptor_data_get (tmp
);
4763 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4764 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4768 tmp
= gfc_conv_expr_present (sym
);
4769 stmt
= build3_v (COND_EXPR
, tmp
, stmt
,
4770 build_empty_stmt (input_location
));
4772 gfc_add_expr_to_block (&block
, stmt
);
4774 /* We don't need to free any memory allocated by internal_pack as it will
4775 be freed at the end of the function by pop_context. */
4776 return gfc_finish_block (&block
);
4780 /* Calculate the overall offset, including subreferences. */
4782 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4783 bool subref
, gfc_expr
*expr
)
4793 /* If offset is NULL and this is not a subreferenced array, there is
4795 if (offset
== NULL_TREE
)
4798 offset
= gfc_index_zero_node
;
4803 tmp
= gfc_conv_array_data (desc
);
4804 tmp
= build_fold_indirect_ref_loc (input_location
,
4806 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4808 /* Offset the data pointer for pointer assignments from arrays with
4809 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4812 /* Go past the array reference. */
4813 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4814 if (ref
->type
== REF_ARRAY
&&
4815 ref
->u
.ar
.type
!= AR_ELEMENT
)
4821 /* Calculate the offset for each subsequent subreference. */
4822 for (; ref
; ref
= ref
->next
)
4827 field
= ref
->u
.c
.component
->backend_decl
;
4828 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
4829 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4830 tmp
, field
, NULL_TREE
);
4834 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
4835 gfc_init_se (&start
, NULL
);
4836 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
4837 gfc_add_block_to_block (block
, &start
.pre
);
4838 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
4842 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
4843 && ref
->u
.ar
.type
== AR_ELEMENT
);
4845 /* TODO - Add bounds checking. */
4846 stride
= gfc_index_one_node
;
4847 index
= gfc_index_zero_node
;
4848 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4853 /* Update the index. */
4854 gfc_init_se (&start
, NULL
);
4855 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
4856 itmp
= gfc_evaluate_now (start
.expr
, block
);
4857 gfc_init_se (&start
, NULL
);
4858 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
4859 jtmp
= gfc_evaluate_now (start
.expr
, block
);
4860 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, itmp
, jtmp
);
4861 itmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, itmp
, stride
);
4862 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, itmp
, index
);
4863 index
= gfc_evaluate_now (index
, block
);
4865 /* Update the stride. */
4866 gfc_init_se (&start
, NULL
);
4867 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
4868 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, start
.expr
, jtmp
);
4869 itmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4870 gfc_index_one_node
, itmp
);
4871 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, itmp
);
4872 stride
= gfc_evaluate_now (stride
, block
);
4875 /* Apply the index to obtain the array element. */
4876 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
4886 /* Set the target data pointer. */
4887 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4888 gfc_conv_descriptor_data_set (block
, parm
, offset
);
4892 /* gfc_conv_expr_descriptor needs the string length an expression
4893 so that the size of the temporary can be obtained. This is done
4894 by adding up the string lengths of all the elements in the
4895 expression. Function with non-constant expressions have their
4896 string lengths mapped onto the actual arguments using the
4897 interface mapping machinery in trans-expr.c. */
4899 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
4901 gfc_interface_mapping mapping
;
4902 gfc_formal_arglist
*formal
;
4903 gfc_actual_arglist
*arg
;
4906 if (expr
->ts
.u
.cl
->length
4907 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
4909 if (!expr
->ts
.u
.cl
->backend_decl
)
4910 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
4914 switch (expr
->expr_type
)
4917 get_array_charlen (expr
->value
.op
.op1
, se
);
4919 /* For parentheses the expression ts.u.cl is identical. */
4920 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
4923 expr
->ts
.u
.cl
->backend_decl
=
4924 gfc_create_var (gfc_charlen_type_node
, "sln");
4926 if (expr
->value
.op
.op2
)
4928 get_array_charlen (expr
->value
.op
.op2
, se
);
4930 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
4932 /* Add the string lengths and assign them to the expression
4933 string length backend declaration. */
4934 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
4935 fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
,
4936 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
4937 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
4940 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
4941 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
4945 if (expr
->value
.function
.esym
== NULL
4946 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4948 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
4952 /* Map expressions involving the dummy arguments onto the actual
4953 argument expressions. */
4954 gfc_init_interface_mapping (&mapping
);
4955 formal
= expr
->symtree
->n
.sym
->formal
;
4956 arg
= expr
->value
.function
.actual
;
4958 /* Set se = NULL in the calls to the interface mapping, to suppress any
4960 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4965 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
4968 gfc_init_se (&tse
, NULL
);
4970 /* Build the expression for the character length and convert it. */
4971 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
4973 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
4974 gfc_add_block_to_block (&se
->post
, &tse
.post
);
4975 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
4976 tse
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tse
.expr
,
4977 build_int_cst (gfc_charlen_type_node
, 0));
4978 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4979 gfc_free_interface_mapping (&mapping
);
4983 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
4990 /* Convert an array for passing as an actual argument. Expressions and
4991 vector subscripts are evaluated and stored in a temporary, which is then
4992 passed. For whole arrays the descriptor is passed. For array sections
4993 a modified copy of the descriptor is passed, but using the original data.
4995 This function is also used for array pointer assignments, and there
4998 - se->want_pointer && !se->direct_byref
4999 EXPR is an actual argument. On exit, se->expr contains a
5000 pointer to the array descriptor.
5002 - !se->want_pointer && !se->direct_byref
5003 EXPR is an actual argument to an intrinsic function or the
5004 left-hand side of a pointer assignment. On exit, se->expr
5005 contains the descriptor for EXPR.
5007 - !se->want_pointer && se->direct_byref
5008 EXPR is the right-hand side of a pointer assignment and
5009 se->expr is the descriptor for the previously-evaluated
5010 left-hand side. The function creates an assignment from
5011 EXPR to se->expr. */
5014 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
5027 bool subref_array_target
= false;
5029 gcc_assert (ss
!= gfc_ss_terminator
);
5031 /* Special case things we know we can pass easily. */
5032 switch (expr
->expr_type
)
5035 /* If we have a linear array section, we can pass it directly.
5036 Otherwise we need to copy it into a temporary. */
5038 /* Find the SS for the array section. */
5040 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
5041 secss
= secss
->next
;
5043 gcc_assert (secss
!= gfc_ss_terminator
);
5044 info
= &secss
->data
.info
;
5046 /* Get the descriptor for the array. */
5047 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
5048 desc
= info
->descriptor
;
5050 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
5051 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
5052 && !subref_array_target
;
5056 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5058 /* Create a new descriptor if the array doesn't have one. */
5061 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
5063 else if (se
->direct_byref
)
5066 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
5070 if (se
->direct_byref
)
5072 /* Copy the descriptor for pointer assignments. */
5073 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
5075 /* Add any offsets from subreferences. */
5076 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
5077 subref_array_target
, expr
);
5079 else if (se
->want_pointer
)
5081 /* We pass full arrays directly. This means that pointers and
5082 allocatable arrays should also work. */
5083 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5090 if (expr
->ts
.type
== BT_CHARACTER
)
5091 se
->string_length
= gfc_get_expr_charlen (expr
);
5098 /* A transformational function return value will be a temporary
5099 array descriptor. We still need to go through the scalarizer
5100 to create the descriptor. Elemental functions ar handled as
5101 arbitrary expressions, i.e. copy to a temporary. */
5103 /* Look for the SS for this function. */
5104 while (secss
!= gfc_ss_terminator
5105 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
5106 secss
= secss
->next
;
5108 if (se
->direct_byref
)
5110 gcc_assert (secss
!= gfc_ss_terminator
);
5112 /* For pointer assignments pass the descriptor directly. */
5114 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5115 gfc_conv_expr (se
, expr
);
5119 if (secss
== gfc_ss_terminator
)
5121 /* Elemental function. */
5123 if (expr
->ts
.type
== BT_CHARACTER
5124 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5125 get_array_charlen (expr
, se
);
5131 /* Transformational function. */
5132 info
= &secss
->data
.info
;
5138 /* Constant array constructors don't need a temporary. */
5139 if (ss
->type
== GFC_SS_CONSTRUCTOR
5140 && expr
->ts
.type
!= BT_CHARACTER
5141 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
5144 info
= &ss
->data
.info
;
5156 /* Something complicated. Copy it into a temporary. */
5163 gfc_init_loopinfo (&loop
);
5165 /* Associate the SS with the loop. */
5166 gfc_add_ss_to_loop (&loop
, ss
);
5168 /* Tell the scalarizer not to bother creating loop variables, etc. */
5170 loop
.array_parameter
= 1;
5172 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5173 gcc_assert (!se
->direct_byref
);
5175 /* Setup the scalarizing loops and bounds. */
5176 gfc_conv_ss_startstride (&loop
);
5180 /* Tell the scalarizer to make a temporary. */
5181 loop
.temp_ss
= gfc_get_ss ();
5182 loop
.temp_ss
->type
= GFC_SS_TEMP
;
5183 loop
.temp_ss
->next
= gfc_ss_terminator
;
5185 if (expr
->ts
.type
== BT_CHARACTER
5186 && !expr
->ts
.u
.cl
->backend_decl
)
5187 get_array_charlen (expr
, se
);
5189 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
5191 if (expr
->ts
.type
== BT_CHARACTER
)
5192 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5194 loop
.temp_ss
->string_length
= NULL
;
5196 se
->string_length
= loop
.temp_ss
->string_length
;
5197 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
5198 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
5201 gfc_conv_loop_setup (&loop
, & expr
->where
);
5205 /* Copy into a temporary and pass that. We don't need to copy the data
5206 back because expressions and vector subscripts must be INTENT_IN. */
5207 /* TODO: Optimize passing function return values. */
5211 /* Start the copying loops. */
5212 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
5213 gfc_mark_ss_chain_used (ss
, 1);
5214 gfc_start_scalarized_body (&loop
, &block
);
5216 /* Copy each data element. */
5217 gfc_init_se (&lse
, NULL
);
5218 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5219 gfc_init_se (&rse
, NULL
);
5220 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5222 lse
.ss
= loop
.temp_ss
;
5225 gfc_conv_scalarized_array_ref (&lse
, NULL
);
5226 if (expr
->ts
.type
== BT_CHARACTER
)
5228 gfc_conv_expr (&rse
, expr
);
5229 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
5230 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
5234 gfc_conv_expr_val (&rse
, expr
);
5236 gfc_add_block_to_block (&block
, &rse
.pre
);
5237 gfc_add_block_to_block (&block
, &lse
.pre
);
5239 lse
.string_length
= rse
.string_length
;
5240 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
5241 expr
->expr_type
== EXPR_VARIABLE
, true);
5242 gfc_add_expr_to_block (&block
, tmp
);
5244 /* Finish the copying loops. */
5245 gfc_trans_scalarizing_loops (&loop
, &block
);
5247 desc
= loop
.temp_ss
->data
.info
.descriptor
;
5249 gcc_assert (is_gimple_lvalue (desc
));
5251 else if (expr
->expr_type
== EXPR_FUNCTION
)
5253 desc
= info
->descriptor
;
5254 se
->string_length
= ss
->string_length
;
5258 /* We pass sections without copying to a temporary. Make a new
5259 descriptor and point it at the section we want. The loop variable
5260 limits will be the limits of the section.
5261 A function may decide to repack the array to speed up access, but
5262 we're not bothered about that here. */
5271 /* Set the string_length for a character array. */
5272 if (expr
->ts
.type
== BT_CHARACTER
)
5273 se
->string_length
= gfc_get_expr_charlen (expr
);
5275 desc
= info
->descriptor
;
5276 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
5277 if (se
->direct_byref
)
5279 /* For pointer assignments we fill in the destination. */
5281 parmtype
= TREE_TYPE (parm
);
5285 /* Otherwise make a new one. */
5286 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
5287 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
5288 loop
.from
, loop
.to
, 0,
5289 GFC_ARRAY_UNKNOWN
, false);
5290 parm
= gfc_create_var (parmtype
, "parm");
5293 offset
= gfc_index_zero_node
;
5296 /* The following can be somewhat confusing. We have two
5297 descriptors, a new one and the original array.
5298 {parm, parmtype, dim} refer to the new one.
5299 {desc, type, n, secss, loop} refer to the original, which maybe
5300 a descriptorless array.
5301 The bounds of the scalarization are the bounds of the section.
5302 We don't have to worry about numeric overflows when calculating
5303 the offsets because all elements are within the array data. */
5305 /* Set the dtype. */
5306 tmp
= gfc_conv_descriptor_dtype (parm
);
5307 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
5309 /* Set offset for assignments to pointer only to zero if it is not
5311 if (se
->direct_byref
5312 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
5313 base
= gfc_index_zero_node
;
5314 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5315 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
5319 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
5320 for (n
= 0; n
< ndim
; n
++)
5322 stride
= gfc_conv_array_stride (desc
, n
);
5324 /* Work out the offset. */
5326 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5328 gcc_assert (info
->subscript
[n
]
5329 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
5330 start
= info
->subscript
[n
]->data
.scalar
.expr
;
5334 /* Check we haven't somehow got out of sync. */
5335 gcc_assert (info
->dim
[dim
] == n
);
5337 /* Evaluate and remember the start of the section. */
5338 start
= info
->start
[dim
];
5339 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
5342 tmp
= gfc_conv_array_lbound (desc
, n
);
5343 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
5345 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
5346 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
5349 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5351 /* For elemental dimensions, we only need the offset. */
5355 /* Vector subscripts need copying and are handled elsewhere. */
5357 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
5359 /* Set the new lower bound. */
5360 from
= loop
.from
[dim
];
5363 /* If we have an array section or are assigning make sure that
5364 the lower bound is 1. References to the full
5365 array should otherwise keep the original bounds. */
5367 || info
->ref
->u
.ar
.type
!= AR_FULL
)
5368 && !integer_onep (from
))
5370 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5371 gfc_index_one_node
, from
);
5372 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
5373 from
= gfc_index_one_node
;
5375 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
5376 gfc_rank_cst
[dim
], from
);
5378 /* Set the new upper bound. */
5379 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
5380 gfc_rank_cst
[dim
], to
);
5382 /* Multiply the stride by the section stride to get the
5384 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
5385 stride
, info
->stride
[dim
]);
5387 if (se
->direct_byref
5389 && info
->ref
->u
.ar
.type
!= AR_FULL
)
5391 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5394 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5396 tmp
= gfc_conv_array_lbound (desc
, n
);
5397 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5398 tmp
, loop
.from
[dim
]);
5399 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
5400 tmp
, gfc_conv_array_stride (desc
, n
));
5401 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
5405 /* Store the new stride. */
5406 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
5407 gfc_rank_cst
[dim
], stride
);
5412 if (se
->data_not_needed
)
5413 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
5414 gfc_index_zero_node
);
5416 /* Point the data pointer at the 1st element in the section. */
5417 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
5418 subref_array_target
, expr
);
5420 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5421 && !se
->data_not_needed
)
5423 /* Set the offset. */
5424 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
5428 /* Only the callee knows what the correct offset it, so just set
5430 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
5435 if (!se
->direct_byref
)
5437 /* Get a pointer to the new descriptor. */
5438 if (se
->want_pointer
)
5439 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5444 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5445 gfc_add_block_to_block (&se
->post
, &loop
.post
);
5447 /* Cleanup the scalarizer. */
5448 gfc_cleanup_loop (&loop
);
5451 /* Helper function for gfc_conv_array_parameter if array size needs to be
5455 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
5458 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5459 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
5460 else if (expr
->rank
> 1)
5461 *size
= build_call_expr_loc (input_location
,
5462 gfor_fndecl_size0
, 1,
5463 gfc_build_addr_expr (NULL
, desc
));
5466 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
5467 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
5469 *size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
5470 *size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, *size
,
5471 gfc_index_one_node
);
5472 *size
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, *size
,
5473 gfc_index_zero_node
);
5475 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
5476 *size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, *size
,
5477 fold_convert (gfc_array_index_type
, elem
));
5480 /* Convert an array for passing as an actual parameter. */
5481 /* TODO: Optimize passing g77 arrays. */
5484 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, bool g77
,
5485 const gfc_symbol
*fsym
, const char *proc_name
,
5490 tree tmp
= NULL_TREE
;
5492 tree parent
= DECL_CONTEXT (current_function_decl
);
5493 bool full_array_var
;
5494 bool this_array_result
;
5497 bool array_constructor
;
5498 bool good_allocatable
;
5499 bool ultimate_ptr_comp
;
5500 bool ultimate_alloc_comp
;
5505 ultimate_ptr_comp
= false;
5506 ultimate_alloc_comp
= false;
5507 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5509 if (ref
->next
== NULL
)
5512 if (ref
->type
== REF_COMPONENT
)
5514 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
5515 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
5519 full_array_var
= false;
5522 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
5523 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
5525 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
5527 /* The symbol should have an array specification. */
5528 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
5530 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
5532 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
5533 expr
->ts
.u
.cl
->backend_decl
= tmp
;
5534 se
->string_length
= tmp
;
5537 /* Is this the result of the enclosing procedure? */
5538 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
5539 if (this_array_result
5540 && (sym
->backend_decl
!= current_function_decl
)
5541 && (sym
->backend_decl
!= parent
))
5542 this_array_result
= false;
5544 /* Passing address of the array if it is not pointer or assumed-shape. */
5545 if (full_array_var
&& g77
&& !this_array_result
)
5547 tmp
= gfc_get_symbol_decl (sym
);
5549 if (sym
->ts
.type
== BT_CHARACTER
)
5550 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5552 if (sym
->ts
.type
== BT_DERIVED
)
5554 gfc_conv_expr_descriptor (se
, expr
, ss
);
5555 se
->expr
= gfc_conv_array_data (se
->expr
);
5559 if (!sym
->attr
.pointer
5561 && sym
->as
->type
!= AS_ASSUMED_SHAPE
5562 && !sym
->attr
.allocatable
)
5564 /* Some variables are declared directly, others are declared as
5565 pointers and allocated on the heap. */
5566 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
5569 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5571 array_parameter_size (tmp
, expr
, size
);
5575 if (sym
->attr
.allocatable
)
5577 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5579 gfc_conv_expr_descriptor (se
, expr
, ss
);
5583 array_parameter_size (tmp
, expr
, size
);
5584 se
->expr
= gfc_conv_array_data (tmp
);
5589 /* A convenient reduction in scope. */
5590 contiguous
= g77
&& !this_array_result
&& contiguous
;
5592 /* There is no need to pack and unpack the array, if it is contiguous
5593 and not deferred or assumed shape. */
5594 no_pack
= ((sym
&& sym
->as
5595 && !sym
->attr
.pointer
5596 && sym
->as
->type
!= AS_DEFERRED
5597 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
5599 (ref
&& ref
->u
.ar
.as
5600 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
5601 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
));
5603 no_pack
= contiguous
&& no_pack
;
5605 /* Array constructors are always contiguous and do not need packing. */
5606 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
5608 /* Same is true of contiguous sections from allocatable variables. */
5609 good_allocatable
= contiguous
5611 && expr
->symtree
->n
.sym
->attr
.allocatable
;
5613 /* Or ultimate allocatable components. */
5614 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
5616 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
5618 gfc_conv_expr_descriptor (se
, expr
, ss
);
5619 if (expr
->ts
.type
== BT_CHARACTER
)
5620 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5622 array_parameter_size (se
->expr
, expr
, size
);
5623 se
->expr
= gfc_conv_array_data (se
->expr
);
5627 if (this_array_result
)
5629 /* Result of the enclosing function. */
5630 gfc_conv_expr_descriptor (se
, expr
, ss
);
5632 array_parameter_size (se
->expr
, expr
, size
);
5633 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5635 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
5636 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
5637 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
5644 /* Every other type of array. */
5645 se
->want_pointer
= 1;
5646 gfc_conv_expr_descriptor (se
, expr
, ss
);
5648 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
5653 /* Deallocate the allocatable components of structures that are
5655 if (expr
->ts
.type
== BT_DERIVED
5656 && expr
->ts
.u
.derived
->attr
.alloc_comp
5657 && expr
->expr_type
!= EXPR_VARIABLE
)
5659 tmp
= build_fold_indirect_ref_loc (input_location
,
5661 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
5662 gfc_add_expr_to_block (&se
->post
, tmp
);
5668 /* Repack the array. */
5669 if (gfc_option
.warn_array_temp
)
5672 gfc_warning ("Creating array temporary at %L for argument '%s'",
5673 &expr
->where
, fsym
->name
);
5675 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5678 ptr
= build_call_expr_loc (input_location
,
5679 gfor_fndecl_in_pack
, 1, desc
);
5681 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5683 tmp
= gfc_conv_expr_present (sym
);
5684 ptr
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), tmp
,
5685 fold_convert (TREE_TYPE (se
->expr
), ptr
),
5686 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
5689 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5693 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
5697 if (fsym
&& proc_name
)
5698 asprintf (&msg
, "An array temporary was created for argument "
5699 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
5701 asprintf (&msg
, "An array temporary was created");
5703 tmp
= build_fold_indirect_ref_loc (input_location
,
5705 tmp
= gfc_conv_array_data (tmp
);
5706 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
5707 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5709 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5710 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
5711 gfc_conv_expr_present (sym
), tmp
);
5713 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
5718 gfc_start_block (&block
);
5720 /* Copy the data back. */
5721 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
5723 tmp
= build_call_expr_loc (input_location
,
5724 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5725 gfc_add_expr_to_block (&block
, tmp
);
5728 /* Free the temporary. */
5729 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5730 gfc_add_expr_to_block (&block
, tmp
);
5732 stmt
= gfc_finish_block (&block
);
5734 gfc_init_block (&block
);
5735 /* Only if it was repacked. This code needs to be executed before the
5736 loop cleanup code. */
5737 tmp
= build_fold_indirect_ref_loc (input_location
,
5739 tmp
= gfc_conv_array_data (tmp
);
5740 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
5741 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5743 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5744 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
5745 gfc_conv_expr_present (sym
), tmp
);
5747 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5749 gfc_add_expr_to_block (&block
, tmp
);
5750 gfc_add_block_to_block (&block
, &se
->post
);
5752 gfc_init_block (&se
->post
);
5753 gfc_add_block_to_block (&se
->post
, &block
);
5758 /* Generate code to deallocate an array, if it is allocated. */
5761 gfc_trans_dealloc_allocated (tree descriptor
)
5767 gfc_start_block (&block
);
5769 var
= gfc_conv_descriptor_data_get (descriptor
);
5772 /* Call array_deallocate with an int * present in the second argument.
5773 Although it is ignored here, it's presence ensures that arrays that
5774 are already deallocated are ignored. */
5775 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true, NULL
);
5776 gfc_add_expr_to_block (&block
, tmp
);
5778 /* Zero the data pointer. */
5779 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5780 var
, build_int_cst (TREE_TYPE (var
), 0));
5781 gfc_add_expr_to_block (&block
, tmp
);
5783 return gfc_finish_block (&block
);
5787 /* This helper function calculates the size in words of a full array. */
5790 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
5795 idx
= gfc_rank_cst
[rank
- 1];
5796 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
5797 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
5798 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5799 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
5800 tmp
, gfc_index_one_node
);
5801 tmp
= gfc_evaluate_now (tmp
, block
);
5803 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
5804 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5805 return gfc_evaluate_now (tmp
, block
);
5809 /* Allocate dest to the same size as src, and copy src -> dest.
5810 If no_malloc is set, only the copy is done. */
5813 duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
,
5823 /* If the source is null, set the destination to null. Then,
5824 allocate memory to the destination. */
5825 gfc_init_block (&block
);
5829 tmp
= null_pointer_node
;
5830 tmp
= fold_build2 (MODIFY_EXPR
, type
, dest
, tmp
);
5831 gfc_add_expr_to_block (&block
, tmp
);
5832 null_data
= gfc_finish_block (&block
);
5834 gfc_init_block (&block
);
5835 size
= TYPE_SIZE_UNIT (type
);
5838 tmp
= gfc_call_malloc (&block
, type
, size
);
5839 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, dest
,
5840 fold_convert (type
, tmp
));
5841 gfc_add_expr_to_block (&block
, tmp
);
5844 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5845 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
5850 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5851 null_data
= gfc_finish_block (&block
);
5853 gfc_init_block (&block
);
5854 nelems
= get_full_array_size (&block
, src
, rank
);
5855 tmp
= fold_convert (gfc_array_index_type
,
5856 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
5857 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5860 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
5861 tmp
= gfc_call_malloc (&block
, tmp
, size
);
5862 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5865 /* We know the temporary and the value will be the same length,
5866 so can use memcpy. */
5867 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5868 tmp
= build_call_expr_loc (input_location
,
5869 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5870 gfc_conv_descriptor_data_get (src
), size
);
5873 gfc_add_expr_to_block (&block
, tmp
);
5874 tmp
= gfc_finish_block (&block
);
5876 /* Null the destination if the source is null; otherwise do
5877 the allocate and copy. */
5881 null_cond
= gfc_conv_descriptor_data_get (src
);
5883 null_cond
= convert (pvoid_type_node
, null_cond
);
5884 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
5885 null_cond
, null_pointer_node
);
5886 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5890 /* Allocate dest to the same size as src, and copy data src -> dest. */
5893 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
5895 return duplicate_allocatable(dest
, src
, type
, rank
, false);
5899 /* Copy data src -> dest. */
5902 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
5904 return duplicate_allocatable(dest
, src
, type
, rank
, true);
5908 /* Recursively traverse an object of derived type, generating code to
5909 deallocate, nullify or copy allocatable components. This is the work horse
5910 function for the functions named in this enum. */
5912 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
5913 COPY_ONLY_ALLOC_COMP
};
5916 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5917 tree dest
, int rank
, int purpose
)
5921 stmtblock_t fnblock
;
5922 stmtblock_t loopbody
;
5932 tree null_cond
= NULL_TREE
;
5934 gfc_init_block (&fnblock
);
5936 if (POINTER_TYPE_P (TREE_TYPE (decl
)) && rank
!= 0)
5937 decl
= build_fold_indirect_ref_loc (input_location
,
5940 /* If this an array of derived types with allocatable components
5941 build a loop and recursively call this function. */
5942 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
5943 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5945 tmp
= gfc_conv_array_data (decl
);
5946 var
= build_fold_indirect_ref_loc (input_location
,
5949 /* Get the number of elements - 1 and set the counter. */
5950 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
5952 /* Use the descriptor for an allocatable array. Since this
5953 is a full array reference, we only need the descriptor
5954 information from dimension = rank. */
5955 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
5956 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5957 tmp
, gfc_index_one_node
);
5959 null_cond
= gfc_conv_descriptor_data_get (decl
);
5960 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5961 build_int_cst (TREE_TYPE (null_cond
), 0));
5965 /* Otherwise use the TYPE_DOMAIN information. */
5966 tmp
= array_type_nelts (TREE_TYPE (decl
));
5967 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5970 /* Remember that this is, in fact, the no. of elements - 1. */
5971 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5972 index
= gfc_create_var (gfc_array_index_type
, "S");
5974 /* Build the body of the loop. */
5975 gfc_init_block (&loopbody
);
5977 vref
= gfc_build_array_ref (var
, index
, NULL
);
5979 if (purpose
== COPY_ALLOC_COMP
)
5981 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
5983 tmp
= gfc_duplicate_allocatable (dest
, decl
, TREE_TYPE(decl
), rank
);
5984 gfc_add_expr_to_block (&fnblock
, tmp
);
5986 tmp
= build_fold_indirect_ref_loc (input_location
,
5987 gfc_conv_array_data (dest
));
5988 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
5989 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
5991 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
5993 tmp
= build_fold_indirect_ref_loc (input_location
,
5994 gfc_conv_array_data (dest
));
5995 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
5996 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
6000 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
6002 gfc_add_expr_to_block (&loopbody
, tmp
);
6004 /* Build the loop and return. */
6005 gfc_init_loopinfo (&loop
);
6007 loop
.from
[0] = gfc_index_zero_node
;
6008 loop
.loopvar
[0] = index
;
6009 loop
.to
[0] = nelems
;
6010 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
6011 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
6013 tmp
= gfc_finish_block (&fnblock
);
6014 if (null_cond
!= NULL_TREE
)
6015 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
6016 build_empty_stmt (input_location
));
6021 /* Otherwise, act on the components or recursively call self to
6022 act on a chain of components. */
6023 for (c
= der_type
->components
; c
; c
= c
->next
)
6025 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
6026 && c
->ts
.u
.derived
->attr
.alloc_comp
;
6027 cdecl = c
->backend_decl
;
6028 ctype
= TREE_TYPE (cdecl);
6032 case DEALLOCATE_ALLOC_COMP
:
6033 /* Do not deallocate the components of ultimate pointer
6035 if (cmp_has_alloc_comps
&& !c
->attr
.pointer
)
6037 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6038 decl
, cdecl, NULL_TREE
);
6039 rank
= c
->as
? c
->as
->rank
: 0;
6040 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6042 gfc_add_expr_to_block (&fnblock
, tmp
);
6045 if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6047 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6048 decl
, cdecl, NULL_TREE
);
6049 tmp
= gfc_trans_dealloc_allocated (comp
);
6050 gfc_add_expr_to_block (&fnblock
, tmp
);
6052 else if (c
->attr
.allocatable
)
6054 /* Allocatable scalar components. */
6055 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6057 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, true, NULL
);
6058 gfc_add_expr_to_block (&fnblock
, tmp
);
6060 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6061 build_int_cst (TREE_TYPE (comp
), 0));
6062 gfc_add_expr_to_block (&fnblock
, tmp
);
6064 else if (c
->ts
.type
== BT_CLASS
6065 && c
->ts
.u
.derived
->components
->attr
.allocatable
)
6067 /* Allocatable scalar CLASS components. */
6068 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6070 /* Add reference to '$data' component. */
6071 tmp
= c
->ts
.u
.derived
->components
->backend_decl
;
6072 comp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
6073 comp
, tmp
, NULL_TREE
);
6075 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, true, NULL
);
6076 gfc_add_expr_to_block (&fnblock
, tmp
);
6078 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6079 build_int_cst (TREE_TYPE (comp
), 0));
6080 gfc_add_expr_to_block (&fnblock
, tmp
);
6084 case NULLIFY_ALLOC_COMP
:
6085 if (c
->attr
.pointer
)
6087 else if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6089 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6090 decl
, cdecl, NULL_TREE
);
6091 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
6093 else if (c
->attr
.allocatable
)
6095 /* Allocatable scalar components. */
6096 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6097 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6098 build_int_cst (TREE_TYPE (comp
), 0));
6099 gfc_add_expr_to_block (&fnblock
, tmp
);
6101 else if (c
->ts
.type
== BT_CLASS
6102 && c
->ts
.u
.derived
->components
->attr
.allocatable
)
6104 /* Allocatable scalar CLASS components. */
6105 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6106 /* Add reference to '$data' component. */
6107 tmp
= c
->ts
.u
.derived
->components
->backend_decl
;
6108 comp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
6109 comp
, tmp
, NULL_TREE
);
6110 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6111 build_int_cst (TREE_TYPE (comp
), 0));
6112 gfc_add_expr_to_block (&fnblock
, tmp
);
6114 else if (cmp_has_alloc_comps
)
6116 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6117 decl
, cdecl, NULL_TREE
);
6118 rank
= c
->as
? c
->as
->rank
: 0;
6119 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6121 gfc_add_expr_to_block (&fnblock
, tmp
);
6125 case COPY_ALLOC_COMP
:
6126 if (c
->attr
.pointer
)
6129 /* We need source and destination components. */
6130 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6131 dcmp
= fold_build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
6132 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
6134 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
6136 rank
= c
->as
? c
->as
->rank
: 0;
6137 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, rank
);
6138 gfc_add_expr_to_block (&fnblock
, tmp
);
6141 if (cmp_has_alloc_comps
)
6143 rank
= c
->as
? c
->as
->rank
: 0;
6144 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
6145 gfc_add_modify (&fnblock
, dcmp
, tmp
);
6146 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
6148 gfc_add_expr_to_block (&fnblock
, tmp
);
6158 return gfc_finish_block (&fnblock
);
6161 /* Recursively traverse an object of derived type, generating code to
6162 nullify allocatable components. */
6165 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6167 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6168 NULLIFY_ALLOC_COMP
);
6172 /* Recursively traverse an object of derived type, generating code to
6173 deallocate allocatable components. */
6176 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6178 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6179 DEALLOCATE_ALLOC_COMP
);
6183 /* Recursively traverse an object of derived type, generating code to
6184 copy it and its allocatable components. */
6187 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6189 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
6193 /* Recursively traverse an object of derived type, generating code to
6194 copy only its allocatable components. */
6197 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6199 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
6203 /* Check for default initializer; sym->value is not enough as it is also
6204 set for EXPR_NULL of allocatables. */
6207 has_default_initializer (gfc_symbol
*der
)
6211 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
6212 for (c
= der
->components
; c
; c
= c
->next
)
6213 if ((c
->ts
.type
!= BT_DERIVED
&& c
->initializer
)
6214 || (c
->ts
.type
== BT_DERIVED
6215 && (!c
->attr
.pointer
&& has_default_initializer (c
->ts
.u
.derived
))))
6222 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6223 Do likewise, recursively if necessary, with the allocatable components of
6227 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
6232 stmtblock_t fnblock
;
6235 bool sym_has_alloc_comp
;
6237 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
6238 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
6240 /* Make sure the frontend gets these right. */
6241 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
6242 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6243 "allocatable attribute or derived type without allocatable "
6246 gfc_init_block (&fnblock
);
6248 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
6249 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
6251 if (sym
->ts
.type
== BT_CHARACTER
6252 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6254 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &fnblock
);
6255 gfc_trans_vla_type_sizes (sym
, &fnblock
);
6258 /* Dummy, use associated and result variables don't need anything special. */
6259 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
6261 gfc_add_expr_to_block (&fnblock
, body
);
6263 return gfc_finish_block (&fnblock
);
6266 gfc_get_backend_locus (&loc
);
6267 gfc_set_backend_locus (&sym
->declared_at
);
6268 descriptor
= sym
->backend_decl
;
6270 /* Although static, derived types with default initializers and
6271 allocatable components must not be nulled wholesale; instead they
6272 are treated component by component. */
6273 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
6275 /* SAVEd variables are not freed on exit. */
6276 gfc_trans_static_array_pointer (sym
);
6280 /* Get the descriptor type. */
6281 type
= TREE_TYPE (sym
->backend_decl
);
6283 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6286 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
6288 if (sym
->value
== NULL
|| !has_default_initializer (sym
->ts
.u
.derived
))
6290 rank
= sym
->as
? sym
->as
->rank
: 0;
6291 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
6292 gfc_add_expr_to_block (&fnblock
, tmp
);
6296 tmp
= gfc_init_default_dt (sym
, NULL
, false);
6297 gfc_add_expr_to_block (&fnblock
, tmp
);
6301 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
6303 /* If the backend_decl is not a descriptor, we must have a pointer
6305 descriptor
= build_fold_indirect_ref_loc (input_location
,
6307 type
= TREE_TYPE (descriptor
);
6310 /* NULLIFY the data pointer. */
6311 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
6312 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
6314 gfc_add_expr_to_block (&fnblock
, body
);
6316 gfc_set_backend_locus (&loc
);
6318 /* Allocatable arrays need to be freed when they go out of scope.
6319 The allocatable components of pointers must not be touched. */
6320 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
6321 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
6324 rank
= sym
->as
? sym
->as
->rank
: 0;
6325 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
6326 gfc_add_expr_to_block (&fnblock
, tmp
);
6329 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
6330 && !sym
->attr
.save
&& !sym
->attr
.result
)
6332 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
6333 gfc_add_expr_to_block (&fnblock
, tmp
);
6336 return gfc_finish_block (&fnblock
);
6339 /************ Expression Walking Functions ******************/
6341 /* Walk a variable reference.
6343 Possible extension - multiple component subscripts.
6344 x(:,:) = foo%a(:)%b(:)
6346 forall (i=..., j=...)
6347 x(i,j) = foo%a(j)%b(i)
6349 This adds a fair amount of complexity because you need to deal with more
6350 than one ref. Maybe handle in a similar manner to vector subscripts.
6351 Maybe not worth the effort. */
6355 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6362 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6363 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
6366 for (; ref
; ref
= ref
->next
)
6368 if (ref
->type
== REF_SUBSTRING
)
6370 newss
= gfc_get_ss ();
6371 newss
->type
= GFC_SS_SCALAR
;
6372 newss
->expr
= ref
->u
.ss
.start
;
6376 newss
= gfc_get_ss ();
6377 newss
->type
= GFC_SS_SCALAR
;
6378 newss
->expr
= ref
->u
.ss
.end
;
6383 /* We're only interested in array sections from now on. */
6384 if (ref
->type
!= REF_ARRAY
)
6389 if (ar
->as
->rank
== 0)
6391 /* Scalar coarray. */
6398 for (n
= 0; n
< ar
->dimen
; n
++)
6400 newss
= gfc_get_ss ();
6401 newss
->type
= GFC_SS_SCALAR
;
6402 newss
->expr
= ar
->start
[n
];
6409 newss
= gfc_get_ss ();
6410 newss
->type
= GFC_SS_SECTION
;
6413 newss
->data
.info
.dimen
= ar
->as
->rank
;
6414 newss
->data
.info
.ref
= ref
;
6416 /* Make sure array is the same as array(:,:), this way
6417 we don't need to special case all the time. */
6418 ar
->dimen
= ar
->as
->rank
;
6419 for (n
= 0; n
< ar
->dimen
; n
++)
6421 newss
->data
.info
.dim
[n
] = n
;
6422 ar
->dimen_type
[n
] = DIMEN_RANGE
;
6424 gcc_assert (ar
->start
[n
] == NULL
);
6425 gcc_assert (ar
->end
[n
] == NULL
);
6426 gcc_assert (ar
->stride
[n
] == NULL
);
6432 newss
= gfc_get_ss ();
6433 newss
->type
= GFC_SS_SECTION
;
6436 newss
->data
.info
.dimen
= 0;
6437 newss
->data
.info
.ref
= ref
;
6439 /* We add SS chains for all the subscripts in the section. */
6440 for (n
= 0; n
< ar
->dimen
; n
++)
6444 switch (ar
->dimen_type
[n
])
6447 /* Add SS for elemental (scalar) subscripts. */
6448 gcc_assert (ar
->start
[n
]);
6449 indexss
= gfc_get_ss ();
6450 indexss
->type
= GFC_SS_SCALAR
;
6451 indexss
->expr
= ar
->start
[n
];
6452 indexss
->next
= gfc_ss_terminator
;
6453 indexss
->loop_chain
= gfc_ss_terminator
;
6454 newss
->data
.info
.subscript
[n
] = indexss
;
6458 /* We don't add anything for sections, just remember this
6459 dimension for later. */
6460 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
6461 newss
->data
.info
.dimen
++;
6465 /* Create a GFC_SS_VECTOR index in which we can store
6466 the vector's descriptor. */
6467 indexss
= gfc_get_ss ();
6468 indexss
->type
= GFC_SS_VECTOR
;
6469 indexss
->expr
= ar
->start
[n
];
6470 indexss
->next
= gfc_ss_terminator
;
6471 indexss
->loop_chain
= gfc_ss_terminator
;
6472 newss
->data
.info
.subscript
[n
] = indexss
;
6473 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
6474 newss
->data
.info
.dimen
++;
6478 /* We should know what sort of section it is by now. */
6482 /* We should have at least one non-elemental dimension. */
6483 gcc_assert (newss
->data
.info
.dimen
> 0);
6488 /* We should know what sort of section it is by now. */
6497 /* Walk an expression operator. If only one operand of a binary expression is
6498 scalar, we must also add the scalar term to the SS chain. */
6501 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6507 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
6508 if (expr
->value
.op
.op2
== NULL
)
6511 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
6513 /* All operands are scalar. Pass back and let the caller deal with it. */
6517 /* All operands require scalarization. */
6518 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
6521 /* One of the operands needs scalarization, the other is scalar.
6522 Create a gfc_ss for the scalar expression. */
6523 newss
= gfc_get_ss ();
6524 newss
->type
= GFC_SS_SCALAR
;
6527 /* First operand is scalar. We build the chain in reverse order, so
6528 add the scalar SS after the second operand. */
6530 while (head
&& head
->next
!= ss
)
6532 /* Check we haven't somehow broken the chain. */
6536 newss
->expr
= expr
->value
.op
.op1
;
6538 else /* head2 == head */
6540 gcc_assert (head2
== head
);
6541 /* Second operand is scalar. */
6542 newss
->next
= head2
;
6544 newss
->expr
= expr
->value
.op
.op2
;
6551 /* Reverse a SS chain. */
6554 gfc_reverse_ss (gfc_ss
* ss
)
6559 gcc_assert (ss
!= NULL
);
6561 head
= gfc_ss_terminator
;
6562 while (ss
!= gfc_ss_terminator
)
6565 /* Check we didn't somehow break the chain. */
6566 gcc_assert (next
!= NULL
);
6576 /* Walk the arguments of an elemental function. */
6579 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
6587 head
= gfc_ss_terminator
;
6590 for (; arg
; arg
= arg
->next
)
6595 newss
= gfc_walk_subexpr (head
, arg
->expr
);
6598 /* Scalar argument. */
6599 newss
= gfc_get_ss ();
6601 newss
->expr
= arg
->expr
;
6611 while (tail
->next
!= gfc_ss_terminator
)
6618 /* If all the arguments are scalar we don't need the argument SS. */
6619 gfc_free_ss_chain (head
);
6624 /* Add it onto the existing chain. */
6630 /* Walk a function call. Scalar functions are passed back, and taken out of
6631 scalarization loops. For elemental functions we walk their arguments.
6632 The result of functions returning arrays is stored in a temporary outside
6633 the loop, so that the function is only called once. Hence we do not need
6634 to walk their arguments. */
6637 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6640 gfc_intrinsic_sym
*isym
;
6642 gfc_component
*comp
= NULL
;
6644 isym
= expr
->value
.function
.isym
;
6646 /* Handle intrinsic functions separately. */
6648 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
6650 sym
= expr
->value
.function
.esym
;
6652 sym
= expr
->symtree
->n
.sym
;
6654 /* A function that returns arrays. */
6655 gfc_is_proc_ptr_comp (expr
, &comp
);
6656 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
6657 || (comp
&& comp
->attr
.dimension
))
6659 newss
= gfc_get_ss ();
6660 newss
->type
= GFC_SS_FUNCTION
;
6663 newss
->data
.info
.dimen
= expr
->rank
;
6667 /* Walk the parameters of an elemental function. For now we always pass
6669 if (sym
->attr
.elemental
)
6670 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
6673 /* Scalar functions are OK as these are evaluated outside the scalarization
6674 loop. Pass back and let the caller deal with it. */
6679 /* An array temporary is constructed for array constructors. */
6682 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
6687 newss
= gfc_get_ss ();
6688 newss
->type
= GFC_SS_CONSTRUCTOR
;
6691 newss
->data
.info
.dimen
= expr
->rank
;
6692 for (n
= 0; n
< expr
->rank
; n
++)
6693 newss
->data
.info
.dim
[n
] = n
;
6699 /* Walk an expression. Add walked expressions to the head of the SS chain.
6700 A wholly scalar expression will not be added. */
6703 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
6707 switch (expr
->expr_type
)
6710 head
= gfc_walk_variable_expr (ss
, expr
);
6714 head
= gfc_walk_op_expr (ss
, expr
);
6718 head
= gfc_walk_function_expr (ss
, expr
);
6723 case EXPR_STRUCTURE
:
6724 /* Pass back and let the caller deal with it. */
6728 head
= gfc_walk_array_constructor (ss
, expr
);
6731 case EXPR_SUBSTRING
:
6732 /* Pass back and let the caller deal with it. */
6736 internal_error ("bad expression type during walk (%d)",
6743 /* Entry point for expression walking.
6744 A return value equal to the passed chain means this is
6745 a scalar expression. It is up to the caller to take whatever action is
6746 necessary to translate these. */
6749 gfc_walk_expr (gfc_expr
* expr
)
6753 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
6754 return gfc_reverse_ss (res
);