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"
83 #include "toplev.h" /* For internal_error/fatal_error. */
86 #include "constructor.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static gfc_ss
*gfc_walk_subexpr (gfc_ss
*, gfc_expr
*);
95 static bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
97 /* The contents of this structure aren't actually used, just the address. */
98 static gfc_ss gfc_ss_terminator_var
;
99 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
103 gfc_array_dataptr_type (tree desc
)
105 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
109 /* Build expressions to access the members of an array descriptor.
110 It's surprisingly easy to mess up here, so never access
111 an array descriptor by "brute force", always use these
112 functions. This also avoids problems if we change the format
113 of an array descriptor.
115 To understand these magic numbers, look at the comments
116 before gfc_build_array_type() in trans-types.c.
118 The code within these defines should be the only code which knows the format
119 of an array descriptor.
121 Any code just needing to read obtain the bounds of an array should use
122 gfc_conv_array_* rather than the following functions as these will return
123 know constant values, and work with arrays which do not have descriptors.
125 Don't forget to #undef these! */
128 #define OFFSET_FIELD 1
129 #define DTYPE_FIELD 2
130 #define DIMENSION_FIELD 3
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc
)
144 type
= TREE_TYPE (desc
);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
147 field
= TYPE_FIELDS (type
);
148 gcc_assert (DATA_FIELD
== 0);
150 t
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
151 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
156 /* This provides WRITE access to the data field.
158 TUPLES_P is true if we are generating tuples.
160 This function gets called through the following macros:
161 gfc_conv_descriptor_data_set
162 gfc_conv_descriptor_data_set. */
165 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
169 type
= TREE_TYPE (desc
);
170 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
172 field
= TYPE_FIELDS (type
);
173 gcc_assert (DATA_FIELD
== 0);
175 t
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
176 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
180 /* This provides address access to the data field. This should only be
181 used by array allocation, passing this on to the runtime. */
184 gfc_conv_descriptor_data_addr (tree desc
)
188 type
= TREE_TYPE (desc
);
189 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
191 field
= TYPE_FIELDS (type
);
192 gcc_assert (DATA_FIELD
== 0);
194 t
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
195 return gfc_build_addr_expr (NULL_TREE
, t
);
199 gfc_conv_descriptor_offset (tree desc
)
204 type
= TREE_TYPE (desc
);
205 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
207 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
208 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
210 return fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
211 desc
, field
, NULL_TREE
);
215 gfc_conv_descriptor_offset_get (tree desc
)
217 return gfc_conv_descriptor_offset (desc
);
221 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
224 tree t
= gfc_conv_descriptor_offset (desc
);
225 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
230 gfc_conv_descriptor_dtype (tree desc
)
235 type
= TREE_TYPE (desc
);
236 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
238 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
239 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
241 return fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
242 desc
, field
, NULL_TREE
);
246 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
252 type
= TREE_TYPE (desc
);
253 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
255 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
256 gcc_assert (field
!= NULL_TREE
257 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
258 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
260 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
261 desc
, field
, NULL_TREE
);
262 tmp
= gfc_build_array_ref (tmp
, dim
, NULL
);
267 gfc_conv_descriptor_stride (tree desc
, tree dim
)
272 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
273 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
274 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
275 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
277 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
278 tmp
, field
, NULL_TREE
);
283 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
285 tree type
= TREE_TYPE (desc
);
286 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
287 if (integer_zerop (dim
)
288 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
289 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
290 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
291 return gfc_index_one_node
;
293 return gfc_conv_descriptor_stride (desc
, dim
);
297 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
298 tree dim
, tree value
)
300 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
301 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
305 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
310 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
311 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
312 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
313 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
315 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
316 tmp
, field
, NULL_TREE
);
321 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
323 return gfc_conv_descriptor_lbound (desc
, dim
);
327 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
328 tree dim
, tree value
)
330 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
331 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
335 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
340 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
341 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
342 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
343 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
345 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
346 tmp
, field
, NULL_TREE
);
351 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
353 return gfc_conv_descriptor_ubound (desc
, dim
);
357 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
358 tree dim
, tree value
)
360 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
361 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
364 /* Build a null array descriptor constructor. */
367 gfc_build_null_descriptor (tree type
)
372 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
373 gcc_assert (DATA_FIELD
== 0);
374 field
= TYPE_FIELDS (type
);
376 /* Set a NULL data pointer. */
377 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
378 TREE_CONSTANT (tmp
) = 1;
379 /* All other fields are ignored. */
385 /* Cleanup those #defines. */
390 #undef DIMENSION_FIELD
391 #undef STRIDE_SUBFIELD
392 #undef LBOUND_SUBFIELD
393 #undef UBOUND_SUBFIELD
396 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
397 flags & 1 = Main loop body.
398 flags & 2 = temp copy loop. */
401 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
403 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
404 ss
->useflags
= flags
;
407 static void gfc_free_ss (gfc_ss
*);
410 /* Free a gfc_ss chain. */
413 gfc_free_ss_chain (gfc_ss
* ss
)
417 while (ss
!= gfc_ss_terminator
)
419 gcc_assert (ss
!= NULL
);
430 gfc_free_ss (gfc_ss
* ss
)
437 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
439 if (ss
->data
.info
.subscript
[n
])
440 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
452 /* Free all the SS associated with a loop. */
455 gfc_cleanup_loop (gfc_loopinfo
* loop
)
461 while (ss
!= gfc_ss_terminator
)
463 gcc_assert (ss
!= NULL
);
464 next
= ss
->loop_chain
;
471 /* Associate a SS chain with a loop. */
474 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
478 if (head
== gfc_ss_terminator
)
482 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
484 if (ss
->next
== gfc_ss_terminator
)
485 ss
->loop_chain
= loop
->ss
;
487 ss
->loop_chain
= ss
->next
;
489 gcc_assert (ss
== gfc_ss_terminator
);
494 /* Generate an initializer for a static pointer or allocatable array. */
497 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
501 gcc_assert (TREE_STATIC (sym
->backend_decl
));
502 /* Just zero the data member. */
503 type
= TREE_TYPE (sym
->backend_decl
);
504 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
508 /* If the bounds of SE's loop have not yet been set, see if they can be
509 determined from array spec AS, which is the array spec of a called
510 function. MAPPING maps the callee's dummy arguments to the values
511 that the caller is passing. Add any initialization and finalization
515 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
516 gfc_se
* se
, gfc_array_spec
* as
)
524 if (as
&& as
->type
== AS_EXPLICIT
)
525 for (dim
= 0; dim
< se
->loop
->dimen
; dim
++)
527 n
= se
->loop
->order
[dim
];
528 if (se
->loop
->to
[n
] == NULL_TREE
)
530 /* Evaluate the lower bound. */
531 gfc_init_se (&tmpse
, NULL
);
532 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
533 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
534 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
535 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
537 /* ...and the upper bound. */
538 gfc_init_se (&tmpse
, NULL
);
539 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
540 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
541 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
542 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
544 /* Set the upper bound of the loop to UPPER - LOWER. */
545 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
546 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
547 se
->loop
->to
[n
] = tmp
;
553 /* Generate code to allocate an array temporary, or create a variable to
554 hold the data. If size is NULL, zero the descriptor so that the
555 callee will allocate the array. If DEALLOC is true, also generate code to
556 free the array afterwards.
558 If INITIAL is not NULL, it is packed using internal_pack and the result used
559 as data instead of allocating a fresh, unitialized area of memory.
561 Initialization code is added to PRE and finalization code to POST.
562 DYNAMIC is true if the caller may want to extend the array later
563 using realloc. This prevents us from putting the array on the stack. */
566 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
567 gfc_ss_info
* info
, tree size
, tree nelem
,
568 tree initial
, bool dynamic
, bool dealloc
)
574 desc
= info
->descriptor
;
575 info
->offset
= gfc_index_zero_node
;
576 if (size
== NULL_TREE
|| integer_zerop (size
))
578 /* A callee allocated array. */
579 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
584 /* Allocate the temporary. */
585 onstack
= !dynamic
&& initial
== NULL_TREE
586 && gfc_can_put_var_on_stack (size
);
590 /* Make a temporary variable to hold the data. */
591 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
593 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
595 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
597 tmp
= gfc_create_var (tmp
, "A");
598 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
599 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
603 /* Allocate memory to hold the data or call internal_pack. */
604 if (initial
== NULL_TREE
)
606 tmp
= gfc_call_malloc (pre
, NULL
, size
);
607 tmp
= gfc_evaluate_now (tmp
, pre
);
614 stmtblock_t do_copying
;
616 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
617 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
618 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
619 tmp
= gfc_get_element_type (tmp
);
620 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
621 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
623 tmp
= build_call_expr_loc (input_location
,
624 gfor_fndecl_in_pack
, 1, initial
);
625 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
626 gfc_add_modify (pre
, packed
, tmp
);
628 tmp
= build_fold_indirect_ref_loc (input_location
,
630 source_data
= gfc_conv_descriptor_data_get (tmp
);
632 /* internal_pack may return source->data without any allocation
633 or copying if it is already packed. If that's the case, we
634 need to allocate and copy manually. */
636 gfc_start_block (&do_copying
);
637 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
638 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
639 gfc_add_modify (&do_copying
, packed
, tmp
);
640 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
641 gfc_add_expr_to_block (&do_copying
, tmp
);
643 was_packed
= fold_build2 (EQ_EXPR
, boolean_type_node
,
644 packed
, source_data
);
645 tmp
= gfc_finish_block (&do_copying
);
646 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
647 build_empty_stmt (input_location
));
648 gfc_add_expr_to_block (pre
, tmp
);
650 tmp
= fold_convert (pvoid_type_node
, packed
);
653 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
656 info
->data
= gfc_conv_descriptor_data_get (desc
);
658 /* The offset is zero because we create temporaries with a zero
660 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
662 if (dealloc
&& !onstack
)
664 /* Free the temporary. */
665 tmp
= gfc_conv_descriptor_data_get (desc
);
666 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
667 gfc_add_expr_to_block (post
, tmp
);
672 /* Generate code to create and initialize the descriptor for a temporary
673 array. This is used for both temporaries needed by the scalarizer, and
674 functions returning arrays. Adjusts the loop variables to be
675 zero-based, and calculates the loop bounds for callee allocated arrays.
676 Allocate the array unless it's callee allocated (we have a callee
677 allocated array if 'callee_alloc' is true, or if loop->to[n] is
678 NULL_TREE for any n). Also fills in the descriptor, data and offset
679 fields of info if known. Returns the size of the array, or NULL for a
680 callee allocated array.
682 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
683 gfc_trans_allocate_array_storage.
687 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
688 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
689 tree eltype
, tree initial
, bool dynamic
,
690 bool dealloc
, bool callee_alloc
, locus
* where
)
702 gcc_assert (info
->dimen
> 0);
704 if (gfc_option
.warn_array_temp
&& where
)
705 gfc_warning ("Creating array temporary at %L", where
);
707 /* Set the lower bound to zero. */
708 for (dim
= 0; dim
< info
->dimen
; dim
++)
710 n
= loop
->order
[dim
];
711 /* Callee allocated arrays may not have a known bound yet. */
713 loop
->to
[n
] = gfc_evaluate_now (fold_build2 (MINUS_EXPR
,
714 gfc_array_index_type
,
715 loop
->to
[n
], loop
->from
[n
]), pre
);
716 loop
->from
[n
] = gfc_index_zero_node
;
718 info
->delta
[dim
] = gfc_index_zero_node
;
719 info
->start
[dim
] = gfc_index_zero_node
;
720 info
->end
[dim
] = gfc_index_zero_node
;
721 info
->stride
[dim
] = gfc_index_one_node
;
722 info
->dim
[dim
] = dim
;
725 /* Initialize the descriptor. */
727 gfc_get_array_type_bounds (eltype
, info
->dimen
, 0, loop
->from
, loop
->to
, 1,
728 GFC_ARRAY_UNKNOWN
, true);
729 desc
= gfc_create_var (type
, "atmp");
730 GFC_DECL_PACKED_ARRAY (desc
) = 1;
732 info
->descriptor
= desc
;
733 size
= gfc_index_one_node
;
735 /* Fill in the array dtype. */
736 tmp
= gfc_conv_descriptor_dtype (desc
);
737 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
740 Fill in the bounds and stride. This is a packed array, so:
743 for (n = 0; n < rank; n++)
746 delta = ubound[n] + 1 - lbound[n];
749 size = size * sizeof(element);
754 /* If there is at least one null loop->to[n], it is a callee allocated
756 for (n
= 0; n
< info
->dimen
; n
++)
757 if (loop
->to
[n
] == NULL_TREE
)
763 for (n
= 0; n
< info
->dimen
; n
++)
765 if (size
== NULL_TREE
)
767 /* For a callee allocated array express the loop bounds in terms
768 of the descriptor fields. */
770 fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
771 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]),
772 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]));
777 /* Store the stride and bound components in the descriptor. */
778 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
780 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
781 gfc_index_zero_node
);
783 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
], loop
->to
[n
]);
785 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
786 loop
->to
[n
], gfc_index_one_node
);
788 /* Check whether the size for this dimension is negative. */
789 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
790 gfc_index_zero_node
);
791 cond
= gfc_evaluate_now (cond
, pre
);
796 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
798 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
799 size
= gfc_evaluate_now (size
, pre
);
802 /* Get the size of the array. */
804 if (size
&& !callee_alloc
)
806 /* If or_expr is true, then the extent in at least one
807 dimension is zero and the size is set to zero. */
808 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
,
809 or_expr
, gfc_index_zero_node
, size
);
812 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
813 fold_convert (gfc_array_index_type
,
814 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
822 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
825 if (info
->dimen
> loop
->temp_dim
)
826 loop
->temp_dim
= info
->dimen
;
832 /* Generate code to transpose array EXPR by creating a new descriptor
833 in which the dimension specifications have been reversed. */
836 gfc_conv_array_transpose (gfc_se
* se
, gfc_expr
* expr
)
838 tree dest
, src
, dest_index
, src_index
;
840 gfc_ss_info
*dest_info
;
841 gfc_ss
*dest_ss
, *src_ss
;
847 src_ss
= gfc_walk_expr (expr
);
850 dest_info
= &dest_ss
->data
.info
;
851 gcc_assert (dest_info
->dimen
== 2);
853 /* Get a descriptor for EXPR. */
854 gfc_init_se (&src_se
, NULL
);
855 gfc_conv_expr_descriptor (&src_se
, expr
, src_ss
);
856 gfc_add_block_to_block (&se
->pre
, &src_se
.pre
);
857 gfc_add_block_to_block (&se
->post
, &src_se
.post
);
860 /* Allocate a new descriptor for the return value. */
861 dest
= gfc_create_var (TREE_TYPE (src
), "atmp");
862 dest_info
->descriptor
= dest
;
865 /* Copy across the dtype field. */
866 gfc_add_modify (&se
->pre
,
867 gfc_conv_descriptor_dtype (dest
),
868 gfc_conv_descriptor_dtype (src
));
870 /* Copy the dimension information, renumbering dimension 1 to 0 and
872 for (n
= 0; n
< 2; n
++)
874 dest_info
->delta
[n
] = gfc_index_zero_node
;
875 dest_info
->start
[n
] = gfc_index_zero_node
;
876 dest_info
->end
[n
] = gfc_index_zero_node
;
877 dest_info
->stride
[n
] = gfc_index_one_node
;
878 dest_info
->dim
[n
] = n
;
880 dest_index
= gfc_rank_cst
[n
];
881 src_index
= gfc_rank_cst
[1 - n
];
883 gfc_conv_descriptor_stride_set (&se
->pre
, dest
, dest_index
,
884 gfc_conv_descriptor_stride_get (src
, src_index
));
886 gfc_conv_descriptor_lbound_set (&se
->pre
, dest
, dest_index
,
887 gfc_conv_descriptor_lbound_get (src
, src_index
));
889 gfc_conv_descriptor_ubound_set (&se
->pre
, dest
, dest_index
,
890 gfc_conv_descriptor_ubound_get (src
, src_index
));
894 gcc_assert (integer_zerop (loop
->from
[n
]));
896 fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
897 gfc_conv_descriptor_ubound_get (dest
, dest_index
),
898 gfc_conv_descriptor_lbound_get (dest
, dest_index
));
902 /* Copy the data pointer. */
903 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
904 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
906 /* Copy the offset. This is not changed by transposition; the top-left
907 element is still at the same offset as before, except where the loop
909 if (!integer_zerop (loop
->from
[0]))
910 dest_info
->offset
= gfc_conv_descriptor_offset_get (src
);
912 dest_info
->offset
= gfc_index_zero_node
;
914 gfc_conv_descriptor_offset_set (&se
->pre
, dest
,
917 if (dest_info
->dimen
> loop
->temp_dim
)
918 loop
->temp_dim
= dest_info
->dimen
;
922 /* Return the number of iterations in a loop that starts at START,
923 ends at END, and has step STEP. */
926 gfc_get_iteration_count (tree start
, tree end
, tree step
)
931 type
= TREE_TYPE (step
);
932 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
933 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
934 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
935 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
936 return fold_convert (gfc_array_index_type
, tmp
);
940 /* Extend the data in array DESC by EXTRA elements. */
943 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
950 if (integer_zerop (extra
))
953 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
955 /* Add EXTRA to the upper bound. */
956 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
957 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
959 /* Get the value of the current data pointer. */
960 arg0
= gfc_conv_descriptor_data_get (desc
);
962 /* Calculate the new array size. */
963 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
964 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
965 ubound
, gfc_index_one_node
);
966 arg1
= fold_build2 (MULT_EXPR
, size_type_node
,
967 fold_convert (size_type_node
, tmp
),
968 fold_convert (size_type_node
, size
));
970 /* Call the realloc() function. */
971 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
972 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
976 /* Return true if the bounds of iterator I can only be determined
980 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
982 return (i
->start
->expr_type
!= EXPR_CONSTANT
983 || i
->end
->expr_type
!= EXPR_CONSTANT
984 || i
->step
->expr_type
!= EXPR_CONSTANT
);
988 /* Split the size of constructor element EXPR into the sum of two terms,
989 one of which can be determined at compile time and one of which must
990 be calculated at run time. Set *SIZE to the former and return true
991 if the latter might be nonzero. */
994 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
996 if (expr
->expr_type
== EXPR_ARRAY
)
997 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
998 else if (expr
->rank
> 0)
1000 /* Calculate everything at run time. */
1001 mpz_set_ui (*size
, 0);
1006 /* A single element. */
1007 mpz_set_ui (*size
, 1);
1013 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1014 of array constructor C. */
1017 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1025 mpz_set_ui (*size
, 0);
1030 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1033 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1037 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1040 /* Multiply the static part of the element size by the
1041 number of iterations. */
1042 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1043 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1044 mpz_add_ui (val
, val
, 1);
1045 if (mpz_sgn (val
) > 0)
1046 mpz_mul (len
, len
, val
);
1048 mpz_set_ui (len
, 0);
1050 mpz_add (*size
, *size
, len
);
1059 /* Make sure offset is a variable. */
1062 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1065 /* We should have already created the offset variable. We cannot
1066 create it here because we may be in an inner scope. */
1067 gcc_assert (*offsetvar
!= NULL_TREE
);
1068 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1069 *poffset
= *offsetvar
;
1070 TREE_USED (*offsetvar
) = 1;
1074 /* Variables needed for bounds-checking. */
1075 static bool first_len
;
1076 static tree first_len_val
;
1077 static bool typespec_chararray_ctor
;
1080 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1081 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1085 gfc_conv_expr (se
, expr
);
1087 /* Store the value. */
1088 tmp
= build_fold_indirect_ref_loc (input_location
,
1089 gfc_conv_descriptor_data_get (desc
));
1090 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1092 if (expr
->ts
.type
== BT_CHARACTER
)
1094 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1097 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1098 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1099 esize
= fold_build2 (TRUNC_DIV_EXPR
, gfc_charlen_type_node
, esize
,
1100 build_int_cst (gfc_charlen_type_node
,
1101 gfc_character_kinds
[i
].bit_size
/ 8));
1103 gfc_conv_string_parameter (se
);
1104 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1106 /* The temporary is an array of pointers. */
1107 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1108 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1112 /* The temporary is an array of string values. */
1113 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1114 /* We know the temporary and the value will be the same length,
1115 so can use memcpy. */
1116 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1117 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1119 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1123 gfc_add_modify (&se
->pre
, first_len_val
,
1129 /* Verify that all constructor elements are of the same
1131 tree cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
1132 first_len_val
, se
->string_length
);
1133 gfc_trans_runtime_check
1134 (true, false, cond
, &se
->pre
, &expr
->where
,
1135 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1136 fold_convert (long_integer_type_node
, first_len_val
),
1137 fold_convert (long_integer_type_node
, se
->string_length
));
1143 /* TODO: Should the frontend already have done this conversion? */
1144 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1145 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1148 gfc_add_block_to_block (pblock
, &se
->pre
);
1149 gfc_add_block_to_block (pblock
, &se
->post
);
1153 /* Add the contents of an array to the constructor. DYNAMIC is as for
1154 gfc_trans_array_constructor_value. */
1157 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1158 tree type ATTRIBUTE_UNUSED
,
1159 tree desc
, gfc_expr
* expr
,
1160 tree
* poffset
, tree
* offsetvar
,
1171 /* We need this to be a variable so we can increment it. */
1172 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1174 gfc_init_se (&se
, NULL
);
1176 /* Walk the array expression. */
1177 ss
= gfc_walk_expr (expr
);
1178 gcc_assert (ss
!= gfc_ss_terminator
);
1180 /* Initialize the scalarizer. */
1181 gfc_init_loopinfo (&loop
);
1182 gfc_add_ss_to_loop (&loop
, ss
);
1184 /* Initialize the loop. */
1185 gfc_conv_ss_startstride (&loop
);
1186 gfc_conv_loop_setup (&loop
, &expr
->where
);
1188 /* Make sure the constructed array has room for the new data. */
1191 /* Set SIZE to the total number of elements in the subarray. */
1192 size
= gfc_index_one_node
;
1193 for (n
= 0; n
< loop
.dimen
; n
++)
1195 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1196 gfc_index_one_node
);
1197 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1200 /* Grow the constructed array by SIZE elements. */
1201 gfc_grow_array (&loop
.pre
, desc
, size
);
1204 /* Make the loop body. */
1205 gfc_mark_ss_chain_used (ss
, 1);
1206 gfc_start_scalarized_body (&loop
, &body
);
1207 gfc_copy_loopinfo_to_se (&se
, &loop
);
1210 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1211 gcc_assert (se
.ss
== gfc_ss_terminator
);
1213 /* Increment the offset. */
1214 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1215 *poffset
, gfc_index_one_node
);
1216 gfc_add_modify (&body
, *poffset
, tmp
);
1218 /* Finish the loop. */
1219 gfc_trans_scalarizing_loops (&loop
, &body
);
1220 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1221 tmp
= gfc_finish_block (&loop
.pre
);
1222 gfc_add_expr_to_block (pblock
, tmp
);
1224 gfc_cleanup_loop (&loop
);
1228 /* Assign the values to the elements of an array constructor. DYNAMIC
1229 is true if descriptor DESC only contains enough data for the static
1230 size calculated by gfc_get_array_constructor_size. When true, memory
1231 for the dynamic parts must be allocated using realloc. */
1234 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1235 tree desc
, gfc_constructor_base base
,
1236 tree
* poffset
, tree
* offsetvar
,
1245 tree shadow_loopvar
= NULL_TREE
;
1246 gfc_saved_var saved_loopvar
;
1249 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1251 /* If this is an iterator or an array, the offset must be a variable. */
1252 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1253 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1255 /* Shadowing the iterator avoids changing its value and saves us from
1256 keeping track of it. Further, it makes sure that there's always a
1257 backend-decl for the symbol, even if there wasn't one before,
1258 e.g. in the case of an iterator that appears in a specification
1259 expression in an interface mapping. */
1262 gfc_symbol
*sym
= c
->iterator
->var
->symtree
->n
.sym
;
1263 tree type
= gfc_typenode_for_spec (&sym
->ts
);
1265 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1266 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1269 gfc_start_block (&body
);
1271 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1273 /* Array constructors can be nested. */
1274 gfc_trans_array_constructor_value (&body
, type
, desc
,
1275 c
->expr
->value
.constructor
,
1276 poffset
, offsetvar
, dynamic
);
1278 else if (c
->expr
->rank
> 0)
1280 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1281 poffset
, offsetvar
, dynamic
);
1285 /* This code really upsets the gimplifier so don't bother for now. */
1292 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1294 p
= gfc_constructor_next (p
);
1299 /* Scalar values. */
1300 gfc_init_se (&se
, NULL
);
1301 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1304 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1305 *poffset
, gfc_index_one_node
);
1309 /* Collect multiple scalar constants into a constructor. */
1310 VEC(constructor_elt
,gc
) *v
= NULL
;
1314 HOST_WIDE_INT idx
= 0;
1317 /* Count the number of consecutive scalar constants. */
1318 while (p
&& !(p
->iterator
1319 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1321 gfc_init_se (&se
, NULL
);
1322 gfc_conv_constant (&se
, p
->expr
);
1324 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1325 se
.expr
= fold_convert (type
, se
.expr
);
1326 /* For constant character array constructors we build
1327 an array of pointers. */
1328 else if (POINTER_TYPE_P (type
))
1329 se
.expr
= gfc_build_addr_expr
1330 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1333 CONSTRUCTOR_APPEND_ELT (v
,
1334 build_int_cst (gfc_array_index_type
,
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 (tmptype
, v
);
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
, init
, tmp
;
1675 HOST_WIDE_INT nelem
;
1680 VEC(constructor_elt
,gc
) *v
= NULL
;
1682 /* First traverse the constructor list, converting the constants
1683 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 CONSTRUCTOR_APPEND_ELT (v
, 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 (tmptype
, v
);
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 argument to elemental procedure. Evaluate this
2059 gfc_init_se (&se
, NULL
);
2060 gfc_conv_expr (&se
, ss
->expr
);
2061 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2062 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2064 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2065 ss
->string_length
= se
.string_length
;
2068 case GFC_SS_SECTION
:
2069 /* Add the expressions for scalar and vector subscripts. */
2070 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2071 if (ss
->data
.info
.subscript
[n
])
2072 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true,
2075 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
2079 /* Get the vector's descriptor and store it in SS. */
2080 gfc_init_se (&se
, NULL
);
2081 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
2082 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2083 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2084 ss
->data
.info
.descriptor
= se
.expr
;
2087 case GFC_SS_INTRINSIC
:
2088 gfc_add_intrinsic_ss_code (loop
, ss
);
2091 case GFC_SS_FUNCTION
:
2092 /* Array function return value. We call the function and save its
2093 result in a temporary for use inside the loop. */
2094 gfc_init_se (&se
, NULL
);
2097 gfc_conv_expr (&se
, ss
->expr
);
2098 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2099 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2100 ss
->string_length
= se
.string_length
;
2103 case GFC_SS_CONSTRUCTOR
:
2104 if (ss
->expr
->ts
.type
== BT_CHARACTER
2105 && ss
->string_length
== NULL
2106 && ss
->expr
->ts
.u
.cl
2107 && ss
->expr
->ts
.u
.cl
->length
)
2109 gfc_init_se (&se
, NULL
);
2110 gfc_conv_expr_type (&se
, ss
->expr
->ts
.u
.cl
->length
,
2111 gfc_charlen_type_node
);
2112 ss
->string_length
= se
.expr
;
2113 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2114 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2116 gfc_trans_array_constructor (loop
, ss
, where
);
2120 case GFC_SS_COMPONENT
:
2121 /* Do nothing. These are handled elsewhere. */
2131 /* Translate expressions for the descriptor and data pointer of a SS. */
2135 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2140 /* Get the descriptor for the array to be scalarized. */
2141 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
2142 gfc_init_se (&se
, NULL
);
2143 se
.descriptor_only
= 1;
2144 gfc_conv_expr_lhs (&se
, ss
->expr
);
2145 gfc_add_block_to_block (block
, &se
.pre
);
2146 ss
->data
.info
.descriptor
= se
.expr
;
2147 ss
->string_length
= se
.string_length
;
2151 /* Also the data pointer. */
2152 tmp
= gfc_conv_array_data (se
.expr
);
2153 /* If this is a variable or address of a variable we use it directly.
2154 Otherwise we must evaluate it now to avoid breaking dependency
2155 analysis by pulling the expressions for elemental array indices
2158 || (TREE_CODE (tmp
) == ADDR_EXPR
2159 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2160 tmp
= gfc_evaluate_now (tmp
, block
);
2161 ss
->data
.info
.data
= tmp
;
2163 tmp
= gfc_conv_array_offset (se
.expr
);
2164 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
2169 /* Initialize a gfc_loopinfo structure. */
2172 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2176 memset (loop
, 0, sizeof (gfc_loopinfo
));
2177 gfc_init_block (&loop
->pre
);
2178 gfc_init_block (&loop
->post
);
2180 /* Initially scalarize in order. */
2181 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2184 loop
->ss
= gfc_ss_terminator
;
2188 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2192 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2198 /* Return an expression for the data pointer of an array. */
2201 gfc_conv_array_data (tree descriptor
)
2205 type
= TREE_TYPE (descriptor
);
2206 if (GFC_ARRAY_TYPE_P (type
))
2208 if (TREE_CODE (type
) == POINTER_TYPE
)
2212 /* Descriptorless arrays. */
2213 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2217 return gfc_conv_descriptor_data_get (descriptor
);
2221 /* Return an expression for the base offset of an array. */
2224 gfc_conv_array_offset (tree descriptor
)
2228 type
= TREE_TYPE (descriptor
);
2229 if (GFC_ARRAY_TYPE_P (type
))
2230 return GFC_TYPE_ARRAY_OFFSET (type
);
2232 return gfc_conv_descriptor_offset_get (descriptor
);
2236 /* Get an expression for the array stride. */
2239 gfc_conv_array_stride (tree descriptor
, int dim
)
2244 type
= TREE_TYPE (descriptor
);
2246 /* For descriptorless arrays use the array size. */
2247 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2248 if (tmp
!= NULL_TREE
)
2251 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2256 /* Like gfc_conv_array_stride, but for the lower bound. */
2259 gfc_conv_array_lbound (tree descriptor
, int dim
)
2264 type
= TREE_TYPE (descriptor
);
2266 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2267 if (tmp
!= NULL_TREE
)
2270 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2275 /* Like gfc_conv_array_stride, but for the upper bound. */
2278 gfc_conv_array_ubound (tree descriptor
, int dim
)
2283 type
= TREE_TYPE (descriptor
);
2285 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2286 if (tmp
!= NULL_TREE
)
2289 /* This should only ever happen when passing an assumed shape array
2290 as an actual parameter. The value will never be used. */
2291 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2292 return gfc_index_zero_node
;
2294 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2299 /* Generate code to perform an array index bound check. */
2302 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2303 locus
* where
, bool check_upper
)
2306 tree tmp_lo
, tmp_up
;
2308 const char * name
= NULL
;
2310 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2313 index
= gfc_evaluate_now (index
, &se
->pre
);
2315 /* We find a name for the error message. */
2317 name
= se
->ss
->expr
->symtree
->name
;
2319 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2320 && se
->loop
->ss
->expr
->symtree
)
2321 name
= se
->loop
->ss
->expr
->symtree
->name
;
2323 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2324 && se
->loop
->ss
->loop_chain
->expr
2325 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2326 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2328 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2330 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2331 && se
->loop
->ss
->expr
->value
.function
.name
)
2332 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2334 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2335 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2336 name
= "unnamed constant";
2339 if (TREE_CODE (descriptor
) == VAR_DECL
)
2340 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2342 /* If upper bound is present, include both bounds in the error message. */
2345 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2346 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2349 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2350 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2352 asprintf (&msg
, "Index '%%ld' of dimension %d "
2353 "outside of expected range (%%ld:%%ld)", n
+1);
2355 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp_lo
);
2356 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2357 fold_convert (long_integer_type_node
, index
),
2358 fold_convert (long_integer_type_node
, tmp_lo
),
2359 fold_convert (long_integer_type_node
, tmp_up
));
2360 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp_up
);
2361 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2362 fold_convert (long_integer_type_node
, index
),
2363 fold_convert (long_integer_type_node
, tmp_lo
),
2364 fold_convert (long_integer_type_node
, tmp_up
));
2369 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2372 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2373 "below lower bound of %%ld", n
+1, name
);
2375 asprintf (&msg
, "Index '%%ld' of dimension %d "
2376 "below lower bound of %%ld", n
+1);
2378 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp_lo
);
2379 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2380 fold_convert (long_integer_type_node
, index
),
2381 fold_convert (long_integer_type_node
, tmp_lo
));
2389 /* Return the offset for an index. Performs bound checking for elemental
2390 dimensions. Single element references are processed separately. */
2393 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2394 gfc_array_ref
* ar
, tree stride
)
2400 /* Get the index into the array for this dimension. */
2403 gcc_assert (ar
->type
!= AR_ELEMENT
);
2404 switch (ar
->dimen_type
[dim
])
2407 /* Elemental dimension. */
2408 gcc_assert (info
->subscript
[dim
]
2409 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2410 /* We've already translated this value outside the loop. */
2411 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2413 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2414 index
, dim
, &ar
->where
,
2415 ar
->as
->type
!= AS_ASSUMED_SIZE
2416 || dim
< ar
->dimen
- 1);
2420 gcc_assert (info
&& se
->loop
);
2421 gcc_assert (info
->subscript
[dim
]
2422 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2423 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2425 /* Get a zero-based index into the vector. */
2426 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2427 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2429 /* Multiply the index by the stride. */
2430 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2431 index
, gfc_conv_array_stride (desc
, 0));
2433 /* Read the vector to get an index into info->descriptor. */
2434 data
= build_fold_indirect_ref_loc (input_location
,
2435 gfc_conv_array_data (desc
));
2436 index
= gfc_build_array_ref (data
, index
, NULL
);
2437 index
= gfc_evaluate_now (index
, &se
->pre
);
2438 index
= fold_convert (gfc_array_index_type
, index
);
2440 /* Do any bounds checking on the final info->descriptor index. */
2441 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2442 index
, dim
, &ar
->where
,
2443 ar
->as
->type
!= AS_ASSUMED_SIZE
2444 || dim
< ar
->dimen
- 1);
2448 /* Scalarized dimension. */
2449 gcc_assert (info
&& se
->loop
);
2451 /* Multiply the loop variable by the stride and delta. */
2452 index
= se
->loop
->loopvar
[i
];
2453 if (!integer_onep (info
->stride
[i
]))
2454 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2456 if (!integer_zerop (info
->delta
[i
]))
2457 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2467 /* Temporary array or derived type component. */
2468 gcc_assert (se
->loop
);
2469 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2470 if (!integer_zerop (info
->delta
[i
]))
2471 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2472 index
, info
->delta
[i
]);
2475 /* Multiply by the stride. */
2476 if (!integer_onep (stride
))
2477 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2483 /* Build a scalarized reference to an array. */
2486 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2489 tree decl
= NULL_TREE
;
2494 info
= &se
->ss
->data
.info
;
2496 n
= se
->loop
->order
[0];
2500 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2502 /* Add the offset for this dimension to the stored offset for all other
2504 if (!integer_zerop (info
->offset
))
2505 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2507 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2508 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2510 tmp
= build_fold_indirect_ref_loc (input_location
,
2512 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2516 /* Translate access of temporary array. */
2519 gfc_conv_tmp_array_ref (gfc_se
* se
)
2521 se
->string_length
= se
->ss
->string_length
;
2522 gfc_conv_scalarized_array_ref (se
, NULL
);
2526 /* Build an array reference. se->expr already holds the array descriptor.
2527 This should be either a variable, indirect variable reference or component
2528 reference. For arrays which do not have a descriptor, se->expr will be
2530 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2533 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2546 /* Handle scalarized references separately. */
2547 if (ar
->type
!= AR_ELEMENT
)
2549 gfc_conv_scalarized_array_ref (se
, ar
);
2550 gfc_advance_se_ss_chain (se
);
2554 index
= gfc_index_zero_node
;
2556 /* Calculate the offsets from all the dimensions. */
2557 for (n
= 0; n
< ar
->dimen
; n
++)
2559 /* Calculate the index for this dimension. */
2560 gfc_init_se (&indexse
, se
);
2561 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2562 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2564 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2566 /* Check array bounds. */
2570 /* Evaluate the indexse.expr only once. */
2571 indexse
.expr
= save_expr (indexse
.expr
);
2574 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2575 if (sym
->attr
.temporary
)
2577 gfc_init_se (&tmpse
, se
);
2578 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
2579 gfc_array_index_type
);
2580 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2584 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2586 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2587 "below lower bound of %%ld", n
+1, sym
->name
);
2588 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2589 fold_convert (long_integer_type_node
,
2591 fold_convert (long_integer_type_node
, tmp
));
2594 /* Upper bound, but not for the last dimension of assumed-size
2596 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
2598 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2599 if (sym
->attr
.temporary
)
2601 gfc_init_se (&tmpse
, se
);
2602 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
2603 gfc_array_index_type
);
2604 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2608 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2610 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2611 "above upper bound of %%ld", n
+1, sym
->name
);
2612 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2613 fold_convert (long_integer_type_node
,
2615 fold_convert (long_integer_type_node
, tmp
));
2620 /* Multiply the index by the stride. */
2621 stride
= gfc_conv_array_stride (se
->expr
, n
);
2622 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2625 /* And add it to the total. */
2626 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2629 tmp
= gfc_conv_array_offset (se
->expr
);
2630 if (!integer_zerop (tmp
))
2631 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2633 /* Access the calculated element. */
2634 tmp
= gfc_conv_array_data (se
->expr
);
2635 tmp
= build_fold_indirect_ref (tmp
);
2636 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2640 /* Generate the code to be executed immediately before entering a
2641 scalarization loop. */
2644 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2645 stmtblock_t
* pblock
)
2654 /* This code will be executed before entering the scalarization loop
2655 for this dimension. */
2656 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2658 if ((ss
->useflags
& flag
) == 0)
2661 if (ss
->type
!= GFC_SS_SECTION
2662 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2663 && ss
->type
!= GFC_SS_COMPONENT
)
2666 info
= &ss
->data
.info
;
2668 if (dim
>= info
->dimen
)
2671 if (dim
== info
->dimen
- 1)
2673 /* For the outermost loop calculate the offset due to any
2674 elemental dimensions. It will have been initialized with the
2675 base offset of the array. */
2678 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2680 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2683 gfc_init_se (&se
, NULL
);
2685 se
.expr
= info
->descriptor
;
2686 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2687 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2690 gfc_add_block_to_block (pblock
, &se
.pre
);
2692 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2693 info
->offset
, index
);
2694 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2698 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2701 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2703 /* Calculate the stride of the innermost loop. Hopefully this will
2704 allow the backend optimizers to do their stuff more effectively.
2706 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2710 /* Add the offset for the previous loop dimension. */
2715 ar
= &info
->ref
->u
.ar
;
2716 i
= loop
->order
[dim
+ 1];
2724 gfc_init_se (&se
, NULL
);
2726 se
.expr
= info
->descriptor
;
2727 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2728 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2730 gfc_add_block_to_block (pblock
, &se
.pre
);
2731 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2732 info
->offset
, index
);
2733 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2736 /* Remember this offset for the second loop. */
2737 if (dim
== loop
->temp_dim
- 1)
2738 info
->saved_offset
= info
->offset
;
2743 /* Start a scalarized expression. Creates a scope and declares loop
2747 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2753 gcc_assert (!loop
->array_parameter
);
2755 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2757 n
= loop
->order
[dim
];
2759 gfc_start_block (&loop
->code
[n
]);
2761 /* Create the loop variable. */
2762 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2764 if (dim
< loop
->temp_dim
)
2768 /* Calculate values that will be constant within this loop. */
2769 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2771 gfc_start_block (pbody
);
2775 /* Generates the actual loop code for a scalarization loop. */
2778 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2779 stmtblock_t
* pbody
)
2790 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
2791 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
2792 && n
== loop
->dimen
- 1)
2794 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2795 init
= make_tree_vec (1);
2796 cond
= make_tree_vec (1);
2797 incr
= make_tree_vec (1);
2799 /* Cycle statement is implemented with a goto. Exit statement must not
2800 be present for this loop. */
2801 exit_label
= gfc_build_label_decl (NULL_TREE
);
2802 TREE_USED (exit_label
) = 1;
2804 /* Label for cycle statements (if needed). */
2805 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2806 gfc_add_expr_to_block (pbody
, tmp
);
2808 stmt
= make_node (OMP_FOR
);
2810 TREE_TYPE (stmt
) = void_type_node
;
2811 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
2813 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
2814 OMP_CLAUSE_SCHEDULE
);
2815 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
2816 = OMP_CLAUSE_SCHEDULE_STATIC
;
2817 if (ompws_flags
& OMPWS_NOWAIT
)
2818 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
2819 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
2821 /* Initialize the loopvar. */
2822 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
2824 OMP_FOR_INIT (stmt
) = init
;
2825 /* The exit condition. */
2826 TREE_VEC_ELT (cond
, 0) = build2 (LE_EXPR
, boolean_type_node
,
2827 loop
->loopvar
[n
], loop
->to
[n
]);
2828 OMP_FOR_COND (stmt
) = cond
;
2829 /* Increment the loopvar. */
2830 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2831 loop
->loopvar
[n
], gfc_index_one_node
);
2832 TREE_VEC_ELT (incr
, 0) = fold_build2 (MODIFY_EXPR
,
2833 void_type_node
, loop
->loopvar
[n
], tmp
);
2834 OMP_FOR_INCR (stmt
) = incr
;
2836 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
2837 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
2841 loopbody
= gfc_finish_block (pbody
);
2843 /* Initialize the loopvar. */
2844 if (loop
->loopvar
[n
] != loop
->from
[n
])
2845 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2847 exit_label
= gfc_build_label_decl (NULL_TREE
);
2849 /* Generate the loop body. */
2850 gfc_init_block (&block
);
2852 /* The exit condition. */
2853 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2854 loop
->loopvar
[n
], loop
->to
[n
]);
2855 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2856 TREE_USED (exit_label
) = 1;
2857 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2858 gfc_add_expr_to_block (&block
, tmp
);
2860 /* The main body. */
2861 gfc_add_expr_to_block (&block
, loopbody
);
2863 /* Increment the loopvar. */
2864 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2865 loop
->loopvar
[n
], gfc_index_one_node
);
2866 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
2868 /* Build the loop. */
2869 tmp
= gfc_finish_block (&block
);
2870 tmp
= build1_v (LOOP_EXPR
, tmp
);
2871 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2873 /* Add the exit label. */
2874 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2875 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2881 /* Finishes and generates the loops for a scalarized expression. */
2884 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2889 stmtblock_t
*pblock
;
2893 /* Generate the loops. */
2894 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2896 n
= loop
->order
[dim
];
2897 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2898 loop
->loopvar
[n
] = NULL_TREE
;
2899 pblock
= &loop
->code
[n
];
2902 tmp
= gfc_finish_block (pblock
);
2903 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2905 /* Clear all the used flags. */
2906 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2911 /* Finish the main body of a scalarized expression, and start the secondary
2915 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2919 stmtblock_t
*pblock
;
2923 /* We finish as many loops as are used by the temporary. */
2924 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2926 n
= loop
->order
[dim
];
2927 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2928 loop
->loopvar
[n
] = NULL_TREE
;
2929 pblock
= &loop
->code
[n
];
2932 /* We don't want to finish the outermost loop entirely. */
2933 n
= loop
->order
[loop
->temp_dim
- 1];
2934 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2936 /* Restore the initial offsets. */
2937 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2939 if ((ss
->useflags
& 2) == 0)
2942 if (ss
->type
!= GFC_SS_SECTION
2943 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2944 && ss
->type
!= GFC_SS_COMPONENT
)
2947 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2950 /* Restart all the inner loops we just finished. */
2951 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2953 n
= loop
->order
[dim
];
2955 gfc_start_block (&loop
->code
[n
]);
2957 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2959 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2962 /* Start a block for the secondary copying code. */
2963 gfc_start_block (body
);
2967 /* Calculate the upper bound of an array section. */
2970 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2979 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2981 info
= &ss
->data
.info
;
2984 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2985 /* We'll calculate the upper bound once we have access to the
2986 vector's descriptor. */
2989 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2990 desc
= info
->descriptor
;
2991 end
= info
->ref
->u
.ar
.end
[dim
];
2995 /* The upper bound was specified. */
2996 gfc_init_se (&se
, NULL
);
2997 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2998 gfc_add_block_to_block (pblock
, &se
.pre
);
3003 /* No upper bound was specified, so use the bound of the array. */
3004 bound
= gfc_conv_array_ubound (desc
, dim
);
3011 /* Calculate the lower bound of an array section. */
3014 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
3024 gcc_assert (ss
->type
== GFC_SS_SECTION
);
3026 info
= &ss
->data
.info
;
3029 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3031 /* We use a zero-based index to access the vector. */
3032 info
->start
[n
] = gfc_index_zero_node
;
3033 info
->end
[n
] = gfc_index_zero_node
;
3034 info
->stride
[n
] = gfc_index_one_node
;
3038 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
3039 desc
= info
->descriptor
;
3040 start
= info
->ref
->u
.ar
.start
[dim
];
3041 end
= info
->ref
->u
.ar
.end
[dim
];
3042 stride
= info
->ref
->u
.ar
.stride
[dim
];
3044 /* Calculate the start of the range. For vector subscripts this will
3045 be the range of the vector. */
3048 /* Specified section start. */
3049 gfc_init_se (&se
, NULL
);
3050 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
3051 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3052 info
->start
[n
] = se
.expr
;
3056 /* No lower bound specified so use the bound of the array. */
3057 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
3059 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
3061 /* Similarly calculate the end. Although this is not used in the
3062 scalarizer, it is needed when checking bounds and where the end
3063 is an expression with side-effects. */
3066 /* Specified section start. */
3067 gfc_init_se (&se
, NULL
);
3068 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
3069 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3070 info
->end
[n
] = se
.expr
;
3074 /* No upper bound specified so use the bound of the array. */
3075 info
->end
[n
] = gfc_conv_array_ubound (desc
, dim
);
3077 info
->end
[n
] = gfc_evaluate_now (info
->end
[n
], &loop
->pre
);
3079 /* Calculate the stride. */
3081 info
->stride
[n
] = gfc_index_one_node
;
3084 gfc_init_se (&se
, NULL
);
3085 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3086 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3087 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3092 /* Calculates the range start and stride for a SS chain. Also gets the
3093 descriptor and data pointer. The range of vector subscripts is the size
3094 of the vector. Array bounds are also checked. */
3097 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3105 /* Determine the rank of the loop. */
3107 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
3111 case GFC_SS_SECTION
:
3112 case GFC_SS_CONSTRUCTOR
:
3113 case GFC_SS_FUNCTION
:
3114 case GFC_SS_COMPONENT
:
3115 loop
->dimen
= ss
->data
.info
.dimen
;
3118 /* As usual, lbound and ubound are exceptions!. */
3119 case GFC_SS_INTRINSIC
:
3120 switch (ss
->expr
->value
.function
.isym
->id
)
3122 case GFC_ISYM_LBOUND
:
3123 case GFC_ISYM_UBOUND
:
3124 loop
->dimen
= ss
->data
.info
.dimen
;
3135 /* We should have determined the rank of the expression by now. If
3136 not, that's bad news. */
3137 gcc_assert (loop
->dimen
!= 0);
3139 /* Loop over all the SS in the chain. */
3140 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3142 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
3143 ss
->shape
= ss
->expr
->shape
;
3147 case GFC_SS_SECTION
:
3148 /* Get the descriptor for the array. */
3149 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3151 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3152 gfc_conv_section_startstride (loop
, ss
, n
);
3155 case GFC_SS_INTRINSIC
:
3156 switch (ss
->expr
->value
.function
.isym
->id
)
3158 /* Fall through to supply start and stride. */
3159 case GFC_ISYM_LBOUND
:
3160 case GFC_ISYM_UBOUND
:
3166 case GFC_SS_CONSTRUCTOR
:
3167 case GFC_SS_FUNCTION
:
3168 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3170 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
3171 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
3172 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3181 /* The rest is just runtime bound checking. */
3182 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3185 tree lbound
, ubound
;
3187 tree size
[GFC_MAX_DIMENSIONS
];
3188 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3193 gfc_start_block (&block
);
3195 for (n
= 0; n
< loop
->dimen
; n
++)
3196 size
[n
] = NULL_TREE
;
3198 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3202 if (ss
->type
!= GFC_SS_SECTION
)
3205 gfc_start_block (&inner
);
3207 /* TODO: range checking for mapped dimensions. */
3208 info
= &ss
->data
.info
;
3210 /* This code only checks ranges. Elemental and vector
3211 dimensions are checked later. */
3212 for (n
= 0; n
< loop
->dimen
; n
++)
3217 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3220 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3221 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3222 check_upper
= false;
3226 /* Zero stride is not allowed. */
3227 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[n
],
3228 gfc_index_zero_node
);
3229 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3230 "of array '%s'", info
->dim
[n
]+1,
3231 ss
->expr
->symtree
->name
);
3232 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3233 &ss
->expr
->where
, msg
);
3236 desc
= ss
->data
.info
.descriptor
;
3238 /* This is the run-time equivalent of resolve.c's
3239 check_dimension(). The logical is more readable there
3240 than it is here, with all the trees. */
3241 lbound
= gfc_conv_array_lbound (desc
, dim
);
3244 ubound
= gfc_conv_array_ubound (desc
, dim
);
3248 /* non_zerosized is true when the selected range is not
3250 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
3251 info
->stride
[n
], gfc_index_zero_node
);
3252 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[n
],
3254 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3257 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
3258 info
->stride
[n
], gfc_index_zero_node
);
3259 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[n
],
3261 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3263 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
3264 stride_pos
, stride_neg
);
3266 /* Check the start of the range against the lower and upper
3267 bounds of the array, if the range is not empty.
3268 If upper bound is present, include both bounds in the
3272 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
3273 info
->start
[n
], lbound
);
3274 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3275 non_zerosized
, tmp
);
3276 tmp2
= fold_build2 (GT_EXPR
, boolean_type_node
,
3277 info
->start
[n
], ubound
);
3278 tmp2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3279 non_zerosized
, tmp2
);
3280 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3281 "outside of expected range (%%ld:%%ld)",
3282 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3283 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3284 &ss
->expr
->where
, msg
,
3285 fold_convert (long_integer_type_node
, info
->start
[n
]),
3286 fold_convert (long_integer_type_node
, lbound
),
3287 fold_convert (long_integer_type_node
, ubound
));
3288 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3289 &ss
->expr
->where
, msg
,
3290 fold_convert (long_integer_type_node
, info
->start
[n
]),
3291 fold_convert (long_integer_type_node
, lbound
),
3292 fold_convert (long_integer_type_node
, ubound
));
3297 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
3298 info
->start
[n
], lbound
);
3299 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3300 non_zerosized
, tmp
);
3301 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3302 "below lower bound of %%ld",
3303 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3304 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3305 &ss
->expr
->where
, msg
,
3306 fold_convert (long_integer_type_node
, info
->start
[n
]),
3307 fold_convert (long_integer_type_node
, lbound
));
3311 /* Compute the last element of the range, which is not
3312 necessarily "end" (think 0:5:3, which doesn't contain 5)
3313 and check it against both lower and upper bounds. */
3315 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3317 tmp
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp
,
3319 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3321 tmp2
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, lbound
);
3322 tmp2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3323 non_zerosized
, tmp2
);
3326 tmp3
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp
, ubound
);
3327 tmp3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3328 non_zerosized
, tmp3
);
3329 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3330 "outside of expected range (%%ld:%%ld)",
3331 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3332 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3333 &ss
->expr
->where
, msg
,
3334 fold_convert (long_integer_type_node
, tmp
),
3335 fold_convert (long_integer_type_node
, ubound
),
3336 fold_convert (long_integer_type_node
, lbound
));
3337 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3338 &ss
->expr
->where
, msg
,
3339 fold_convert (long_integer_type_node
, tmp
),
3340 fold_convert (long_integer_type_node
, ubound
),
3341 fold_convert (long_integer_type_node
, lbound
));
3346 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3347 "below lower bound of %%ld",
3348 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3349 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3350 &ss
->expr
->where
, msg
,
3351 fold_convert (long_integer_type_node
, tmp
),
3352 fold_convert (long_integer_type_node
, lbound
));
3356 /* Check the section sizes match. */
3357 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3359 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
3361 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3362 gfc_index_one_node
, tmp
);
3363 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3364 build_int_cst (gfc_array_index_type
, 0));
3365 /* We remember the size of the first section, and check all the
3366 others against this. */
3369 tmp3
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
3370 asprintf (&msg
, "Array bound mismatch for dimension %d "
3371 "of array '%s' (%%ld/%%ld)",
3372 info
->dim
[n
]+1, ss
->expr
->symtree
->name
);
3374 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3375 &ss
->expr
->where
, msg
,
3376 fold_convert (long_integer_type_node
, tmp
),
3377 fold_convert (long_integer_type_node
, size
[n
]));
3382 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
3385 tmp
= gfc_finish_block (&inner
);
3387 /* For optional arguments, only check bounds if the argument is
3389 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3390 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3391 tmp
= build3_v (COND_EXPR
,
3392 gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
),
3393 tmp
, build_empty_stmt (input_location
));
3395 gfc_add_expr_to_block (&block
, tmp
);
3399 tmp
= gfc_finish_block (&block
);
3400 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3405 /* Return true if the two SS could be aliased, i.e. both point to the same data
3407 /* TODO: resolve aliases based on frontend expressions. */
3410 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3417 lsym
= lss
->expr
->symtree
->n
.sym
;
3418 rsym
= rss
->expr
->symtree
->n
.sym
;
3419 if (gfc_symbols_could_alias (lsym
, rsym
))
3422 if (rsym
->ts
.type
!= BT_DERIVED
3423 && lsym
->ts
.type
!= BT_DERIVED
)
3426 /* For derived types we must check all the component types. We can ignore
3427 array references as these will have the same base type as the previous
3429 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3431 if (lref
->type
!= REF_COMPONENT
)
3434 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3437 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3440 if (rref
->type
!= REF_COMPONENT
)
3443 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3448 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3450 if (rref
->type
!= REF_COMPONENT
)
3453 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3461 /* Resolve array data dependencies. Creates a temporary if required. */
3462 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3466 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3474 loop
->temp_ss
= NULL
;
3476 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3478 if (ss
->type
!= GFC_SS_SECTION
)
3481 if (dest
->expr
->symtree
->n
.sym
!= ss
->expr
->symtree
->n
.sym
)
3483 if (gfc_could_be_alias (dest
, ss
)
3484 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3492 lref
= dest
->expr
->ref
;
3493 rref
= ss
->expr
->ref
;
3495 nDepend
= gfc_dep_resolver (lref
, rref
);
3499 /* TODO : loop shifting. */
3502 /* Mark the dimensions for LOOP SHIFTING */
3503 for (n
= 0; n
< loop
->dimen
; n
++)
3505 int dim
= dest
->data
.info
.dim
[n
];
3507 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3509 else if (! gfc_is_same_range (&lref
->u
.ar
,
3510 &rref
->u
.ar
, dim
, 0))
3514 /* Put all the dimensions with dependencies in the
3517 for (n
= 0; n
< loop
->dimen
; n
++)
3519 gcc_assert (loop
->order
[n
] == n
);
3521 loop
->order
[dim
++] = n
;
3523 for (n
= 0; n
< loop
->dimen
; n
++)
3526 loop
->order
[dim
++] = n
;
3529 gcc_assert (dim
== loop
->dimen
);
3538 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3539 if (GFC_ARRAY_TYPE_P (base_type
)
3540 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3541 base_type
= gfc_get_element_type (base_type
);
3542 loop
->temp_ss
= gfc_get_ss ();
3543 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3544 loop
->temp_ss
->data
.temp
.type
= base_type
;
3545 loop
->temp_ss
->string_length
= dest
->string_length
;
3546 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3547 loop
->temp_ss
->next
= gfc_ss_terminator
;
3548 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3551 loop
->temp_ss
= NULL
;
3555 /* Initialize the scalarization loop. Creates the loop variables. Determines
3556 the range of the loop variables. Creates a temporary if required.
3557 Calculates how to transform from loop variables to array indices for each
3558 expression. Also generates code for scalar expressions which have been
3559 moved outside the loop. */
3562 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
3566 gfc_ss_info
*specinfo
;
3569 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3570 bool dynamic
[GFC_MAX_DIMENSIONS
];
3575 for (n
= 0; n
< loop
->dimen
; n
++)
3579 /* We use one SS term, and use that to determine the bounds of the
3580 loop for this dimension. We try to pick the simplest term. */
3581 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3585 /* The frontend has worked out the size for us. */
3586 if (!loopspec
[n
] || !loopspec
[n
]->shape
3587 || !integer_zerop (loopspec
[n
]->data
.info
.start
[n
]))
3588 /* Prefer zero-based descriptors if possible. */
3593 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3595 gfc_constructor_base base
;
3596 /* An unknown size constructor will always be rank one.
3597 Higher rank constructors will either have known shape,
3598 or still be wrapped in a call to reshape. */
3599 gcc_assert (loop
->dimen
== 1);
3601 /* Always prefer to use the constructor bounds if the size
3602 can be determined at compile time. Prefer not to otherwise,
3603 since the general case involves realloc, and it's better to
3604 avoid that overhead if possible. */
3605 base
= ss
->expr
->value
.constructor
;
3606 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
3607 if (!dynamic
[n
] || !loopspec
[n
])
3612 /* TODO: Pick the best bound if we have a choice between a
3613 function and something else. */
3614 if (ss
->type
== GFC_SS_FUNCTION
)
3620 if (ss
->type
!= GFC_SS_SECTION
)
3624 specinfo
= &loopspec
[n
]->data
.info
;
3627 info
= &ss
->data
.info
;
3631 /* Criteria for choosing a loop specifier (most important first):
3632 doesn't need realloc
3638 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3640 else if (integer_onep (info
->stride
[n
])
3641 && !integer_onep (specinfo
->stride
[n
]))
3643 else if (INTEGER_CST_P (info
->stride
[n
])
3644 && !INTEGER_CST_P (specinfo
->stride
[n
]))
3646 else if (INTEGER_CST_P (info
->start
[n
])
3647 && !INTEGER_CST_P (specinfo
->start
[n
]))
3649 /* We don't work out the upper bound.
3650 else if (INTEGER_CST_P (info->finish[n])
3651 && ! INTEGER_CST_P (specinfo->finish[n]))
3652 loopspec[n] = ss; */
3655 /* We should have found the scalarization loop specifier. If not,
3657 gcc_assert (loopspec
[n
]);
3659 info
= &loopspec
[n
]->data
.info
;
3661 /* Set the extents of this range. */
3662 cshape
= loopspec
[n
]->shape
;
3663 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
3664 && INTEGER_CST_P (info
->stride
[n
]))
3666 loop
->from
[n
] = info
->start
[n
];
3667 mpz_set (i
, cshape
[n
]);
3668 mpz_sub_ui (i
, i
, 1);
3669 /* To = from + (size - 1) * stride. */
3670 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3671 if (!integer_onep (info
->stride
[n
]))
3672 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3673 tmp
, info
->stride
[n
]);
3674 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3675 loop
->from
[n
], tmp
);
3679 loop
->from
[n
] = info
->start
[n
];
3680 switch (loopspec
[n
]->type
)
3682 case GFC_SS_CONSTRUCTOR
:
3683 /* The upper bound is calculated when we expand the
3685 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3688 case GFC_SS_SECTION
:
3689 /* Use the end expression if it exists and is not constant,
3690 so that it is only evaluated once. */
3691 if (info
->end
[n
] && !INTEGER_CST_P (info
->end
[n
]))
3692 loop
->to
[n
] = info
->end
[n
];
3694 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
3698 case GFC_SS_FUNCTION
:
3699 /* The loop bound will be set when we generate the call. */
3700 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3708 /* Transform everything so we have a simple incrementing variable. */
3709 if (integer_onep (info
->stride
[n
]))
3710 info
->delta
[n
] = gfc_index_zero_node
;
3713 /* Set the delta for this section. */
3714 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3715 /* Number of iterations is (end - start + step) / step.
3716 with start = 0, this simplifies to
3718 for (i = 0; i<=last; i++){...}; */
3719 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3720 loop
->to
[n
], loop
->from
[n
]);
3721 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
,
3722 tmp
, info
->stride
[n
]);
3723 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3724 build_int_cst (gfc_array_index_type
, -1));
3725 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3726 /* Make the loop variable start at 0. */
3727 loop
->from
[n
] = gfc_index_zero_node
;
3731 /* Add all the scalar code that can be taken out of the loops.
3732 This may include calculating the loop bounds, so do it before
3733 allocating the temporary. */
3734 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
3736 /* If we want a temporary then create it. */
3737 if (loop
->temp_ss
!= NULL
)
3739 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3741 /* Make absolutely sure that this is a complete type. */
3742 if (loop
->temp_ss
->string_length
)
3743 loop
->temp_ss
->data
.temp
.type
3744 = gfc_get_character_type_len_for_eltype
3745 (TREE_TYPE (loop
->temp_ss
->data
.temp
.type
),
3746 loop
->temp_ss
->string_length
);
3748 tmp
= loop
->temp_ss
->data
.temp
.type
;
3749 n
= loop
->temp_ss
->data
.temp
.dimen
;
3750 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3751 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3752 loop
->temp_ss
->data
.info
.dimen
= n
;
3753 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3754 &loop
->temp_ss
->data
.info
, tmp
, NULL_TREE
,
3755 false, true, false, where
);
3758 for (n
= 0; n
< loop
->temp_dim
; n
++)
3759 loopspec
[loop
->order
[n
]] = NULL
;
3763 /* For array parameters we don't have loop variables, so don't calculate the
3765 if (loop
->array_parameter
)
3768 /* Calculate the translation from loop variables to array indices. */
3769 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3771 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
3772 && ss
->type
!= GFC_SS_CONSTRUCTOR
)
3776 info
= &ss
->data
.info
;
3778 for (n
= 0; n
< info
->dimen
; n
++)
3780 /* If we are specifying the range the delta is already set. */
3781 if (loopspec
[n
] != ss
)
3783 /* Calculate the offset relative to the loop variable.
3784 First multiply by the stride. */
3785 tmp
= loop
->from
[n
];
3786 if (!integer_onep (info
->stride
[n
]))
3787 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3788 tmp
, info
->stride
[n
]);
3790 /* Then subtract this from our starting value. */
3791 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3792 info
->start
[n
], tmp
);
3794 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3801 /* Fills in an array descriptor, and returns the size of the array. The size
3802 will be a simple_val, ie a variable or a constant. Also calculates the
3803 offset of the base. Returns the size of the array.
3807 for (n = 0; n < rank; n++)
3809 a.lbound[n] = specified_lower_bound;
3810 offset = offset + a.lbond[n] * stride;
3812 a.ubound[n] = specified_upper_bound;
3813 a.stride[n] = stride;
3814 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3815 stride = stride * size;
3822 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
3823 gfc_expr
** lower
, gfc_expr
** upper
,
3824 stmtblock_t
* pblock
)
3836 stmtblock_t thenblock
;
3837 stmtblock_t elseblock
;
3842 type
= TREE_TYPE (descriptor
);
3844 stride
= gfc_index_one_node
;
3845 offset
= gfc_index_zero_node
;
3847 /* Set the dtype. */
3848 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3849 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3851 or_expr
= NULL_TREE
;
3853 for (n
= 0; n
< rank
; n
++)
3855 /* We have 3 possibilities for determining the size of the array:
3856 lower == NULL => lbound = 1, ubound = upper[n]
3857 upper[n] = NULL => lbound = 1, ubound = lower[n]
3858 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3861 /* Set lower bound. */
3862 gfc_init_se (&se
, NULL
);
3864 se
.expr
= gfc_index_one_node
;
3867 gcc_assert (lower
[n
]);
3870 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3871 gfc_add_block_to_block (pblock
, &se
.pre
);
3875 se
.expr
= gfc_index_one_node
;
3879 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
3882 /* Work out the offset for this component. */
3883 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3884 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3886 /* Start the calculation for the size of this dimension. */
3887 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3888 gfc_index_one_node
, se
.expr
);
3890 /* Set upper bound. */
3891 gfc_init_se (&se
, NULL
);
3892 gcc_assert (ubound
);
3893 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3894 gfc_add_block_to_block (pblock
, &se
.pre
);
3896 gfc_conv_descriptor_ubound_set (pblock
, descriptor
, gfc_rank_cst
[n
], se
.expr
);
3898 /* Store the stride. */
3899 gfc_conv_descriptor_stride_set (pblock
, descriptor
, gfc_rank_cst
[n
], stride
);
3901 /* Calculate the size of this dimension. */
3902 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3904 /* Check whether the size for this dimension is negative. */
3905 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3906 gfc_index_zero_node
);
3910 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3912 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
3913 gfc_index_zero_node
, size
);
3915 /* Multiply the stride by the number of elements in this dimension. */
3916 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3917 stride
= gfc_evaluate_now (stride
, pblock
);
3920 for (n
= rank
; n
< rank
+ corank
; n
++)
3924 /* Set lower bound. */
3925 gfc_init_se (&se
, NULL
);
3926 if (lower
== NULL
|| lower
[n
] == NULL
)
3928 gcc_assert (n
== rank
+ corank
- 1);
3929 se
.expr
= gfc_index_one_node
;
3933 if (ubound
|| n
== rank
+ corank
- 1)
3935 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3936 gfc_add_block_to_block (pblock
, &se
.pre
);
3940 se
.expr
= gfc_index_one_node
;
3944 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
3947 if (n
< rank
+ corank
- 1)
3949 gfc_init_se (&se
, NULL
);
3950 gcc_assert (ubound
);
3951 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3952 gfc_add_block_to_block (pblock
, &se
.pre
);
3953 gfc_conv_descriptor_ubound_set (pblock
, descriptor
, gfc_rank_cst
[n
], se
.expr
);
3957 /* The stride is the number of elements in the array, so multiply by the
3958 size of an element to get the total size. */
3959 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3960 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3961 fold_convert (gfc_array_index_type
, tmp
));
3963 if (poffset
!= NULL
)
3965 offset
= gfc_evaluate_now (offset
, pblock
);
3969 if (integer_zerop (or_expr
))
3971 if (integer_onep (or_expr
))
3972 return gfc_index_zero_node
;
3974 var
= gfc_create_var (TREE_TYPE (size
), "size");
3975 gfc_start_block (&thenblock
);
3976 gfc_add_modify (&thenblock
, var
, gfc_index_zero_node
);
3977 thencase
= gfc_finish_block (&thenblock
);
3979 gfc_start_block (&elseblock
);
3980 gfc_add_modify (&elseblock
, var
, size
);
3981 elsecase
= gfc_finish_block (&elseblock
);
3983 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3984 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3985 gfc_add_expr_to_block (pblock
, tmp
);
3991 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3992 the work for an ALLOCATE statement. */
3996 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
4004 gfc_ref
*ref
, *prev_ref
= NULL
;
4005 bool allocatable_array
, coarray
;
4009 /* Find the last reference in the chain. */
4010 while (ref
&& ref
->next
!= NULL
)
4012 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
4013 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
4018 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
4023 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
4024 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
4028 allocatable_array
= prev_ref
->u
.c
.component
->attr
.allocatable
;
4029 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
4032 /* Return if this is a scalar coarray. */
4033 if ((!prev_ref
&& !expr
->symtree
->n
.sym
->attr
.dimension
)
4034 || (prev_ref
&& !prev_ref
->u
.c
.component
->attr
.dimension
))
4036 gcc_assert (coarray
);
4040 /* Figure out the size of the array. */
4041 switch (ref
->u
.ar
.type
)
4047 upper
= ref
->u
.ar
.start
;
4053 lower
= ref
->u
.ar
.start
;
4054 upper
= ref
->u
.ar
.end
;
4058 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
4060 lower
= ref
->u
.ar
.as
->lower
;
4061 upper
= ref
->u
.ar
.as
->upper
;
4069 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
4070 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
4073 /* Allocate memory to store the data. */
4074 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
4075 STRIP_NOPS (pointer
);
4077 /* The allocate_array variants take the old pointer as first argument. */
4078 if (allocatable_array
)
4079 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
, expr
);
4081 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
4082 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
4083 gfc_add_expr_to_block (&se
->pre
, tmp
);
4085 gfc_conv_descriptor_offset_set (&se
->pre
, se
->expr
, offset
);
4087 if (expr
->ts
.type
== BT_DERIVED
4088 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
4090 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
4091 ref
->u
.ar
.as
->rank
);
4092 gfc_add_expr_to_block (&se
->pre
, tmp
);
4099 /* Deallocate an array variable. Also used when an allocated variable goes
4104 gfc_array_deallocate (tree descriptor
, tree pstat
, gfc_expr
* expr
)
4110 gfc_start_block (&block
);
4111 /* Get a pointer to the data. */
4112 var
= gfc_conv_descriptor_data_get (descriptor
);
4115 /* Parameter is the address of the data component. */
4116 tmp
= gfc_deallocate_with_status (var
, pstat
, false, expr
);
4117 gfc_add_expr_to_block (&block
, tmp
);
4119 /* Zero the data pointer. */
4120 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
4121 var
, build_int_cst (TREE_TYPE (var
), 0));
4122 gfc_add_expr_to_block (&block
, tmp
);
4124 return gfc_finish_block (&block
);
4128 /* Create an array constructor from an initialization expression.
4129 We assume the frontend already did any expansions and conversions. */
4132 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
4138 unsigned HOST_WIDE_INT lo
;
4140 VEC(constructor_elt
,gc
) *v
= NULL
;
4142 switch (expr
->expr_type
)
4145 case EXPR_STRUCTURE
:
4146 /* A single scalar or derived type value. Create an array with all
4147 elements equal to that value. */
4148 gfc_init_se (&se
, NULL
);
4150 if (expr
->expr_type
== EXPR_CONSTANT
)
4151 gfc_conv_constant (&se
, expr
);
4153 gfc_conv_structure (&se
, expr
, 1);
4155 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
4156 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
4157 hi
= TREE_INT_CST_HIGH (tmp
);
4158 lo
= TREE_INT_CST_LOW (tmp
);
4162 /* This will probably eat buckets of memory for large arrays. */
4163 while (hi
!= 0 || lo
!= 0)
4165 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
4173 /* Create a vector of all the elements. */
4174 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4175 c
; c
= gfc_constructor_next (c
))
4179 /* Problems occur when we get something like
4180 integer :: a(lots) = (/(i, i=1, lots)/) */
4181 gfc_fatal_error ("The number of elements in the array constructor "
4182 "at %L requires an increase of the allowed %d "
4183 "upper limit. See -fmax-array-constructor "
4184 "option", &expr
->where
,
4185 gfc_option
.flag_max_array_constructor
);
4188 if (mpz_cmp_si (c
->offset
, 0) != 0)
4189 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
4193 gfc_init_se (&se
, NULL
);
4194 switch (c
->expr
->expr_type
)
4197 gfc_conv_constant (&se
, c
->expr
);
4198 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4201 case EXPR_STRUCTURE
:
4202 gfc_conv_structure (&se
, c
->expr
, 1);
4203 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4208 /* Catch those occasional beasts that do not simplify
4209 for one reason or another, assuming that if they are
4210 standard defying the frontend will catch them. */
4211 gfc_conv_expr (&se
, c
->expr
);
4212 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4219 return gfc_build_null_descriptor (type
);
4225 /* Create a constructor from the list of elements. */
4226 tmp
= build_constructor (type
, v
);
4227 TREE_CONSTANT (tmp
) = 1;
4232 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4233 returns the size (in elements) of the array. */
4236 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
4237 stmtblock_t
* pblock
)
4252 size
= gfc_index_one_node
;
4253 offset
= gfc_index_zero_node
;
4254 for (dim
= 0; dim
< as
->rank
; dim
++)
4256 /* Evaluate non-constant array bound expressions. */
4257 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
4258 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
4260 gfc_init_se (&se
, NULL
);
4261 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
4262 gfc_add_block_to_block (pblock
, &se
.pre
);
4263 gfc_add_modify (pblock
, lbound
, se
.expr
);
4265 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
4266 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
4268 gfc_init_se (&se
, NULL
);
4269 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
4270 gfc_add_block_to_block (pblock
, &se
.pre
);
4271 gfc_add_modify (pblock
, ubound
, se
.expr
);
4273 /* The offset of this dimension. offset = offset - lbound * stride. */
4274 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
4275 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4277 /* The size of this dimension, and the stride of the next. */
4278 if (dim
+ 1 < as
->rank
)
4279 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
4281 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4283 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
4285 /* Calculate stride = size * (ubound + 1 - lbound). */
4286 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4287 gfc_index_one_node
, lbound
);
4288 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
4289 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
4291 gfc_add_modify (pblock
, stride
, tmp
);
4293 stride
= gfc_evaluate_now (tmp
, pblock
);
4295 /* Make sure that negative size arrays are translated
4296 to being zero size. */
4297 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
,
4298 stride
, gfc_index_zero_node
);
4299 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4300 stride
, gfc_index_zero_node
);
4301 gfc_add_modify (pblock
, stride
, tmp
);
4307 gfc_trans_vla_type_sizes (sym
, pblock
);
4314 /* Generate code to initialize/allocate an array variable. */
4317 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
4326 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
4328 /* Do nothing for USEd variables. */
4329 if (sym
->attr
.use_assoc
)
4332 type
= TREE_TYPE (decl
);
4333 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4334 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
4336 gfc_start_block (&block
);
4338 /* Evaluate character string length. */
4339 if (sym
->ts
.type
== BT_CHARACTER
4340 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4342 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &block
);
4344 gfc_trans_vla_type_sizes (sym
, &block
);
4346 /* Emit a DECL_EXPR for this variable, which will cause the
4347 gimplifier to allocate storage, and all that good stuff. */
4348 tmp
= fold_build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
4349 gfc_add_expr_to_block (&block
, tmp
);
4354 gfc_add_expr_to_block (&block
, fnbody
);
4355 return gfc_finish_block (&block
);
4358 type
= TREE_TYPE (type
);
4360 gcc_assert (!sym
->attr
.use_assoc
);
4361 gcc_assert (!TREE_STATIC (decl
));
4362 gcc_assert (!sym
->module
);
4364 if (sym
->ts
.type
== BT_CHARACTER
4365 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4366 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &block
);
4368 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4370 /* Don't actually allocate space for Cray Pointees. */
4371 if (sym
->attr
.cray_pointee
)
4373 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4374 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4375 gfc_add_expr_to_block (&block
, fnbody
);
4376 return gfc_finish_block (&block
);
4379 /* The size is the number of elements in the array, so multiply by the
4380 size of an element to get the total size. */
4381 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4382 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
4383 fold_convert (gfc_array_index_type
, tmp
));
4385 /* Allocate memory to hold the data. */
4386 tmp
= gfc_call_malloc (&block
, TREE_TYPE (decl
), size
);
4387 gfc_add_modify (&block
, decl
, tmp
);
4389 /* Set offset of the array. */
4390 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4391 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4394 /* Automatic arrays should not have initializers. */
4395 gcc_assert (!sym
->value
);
4397 gfc_add_expr_to_block (&block
, fnbody
);
4399 /* Free the temporary. */
4400 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
4401 gfc_add_expr_to_block (&block
, tmp
);
4403 return gfc_finish_block (&block
);
4407 /* Generate entry and exit code for g77 calling convention arrays. */
4410 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
4420 gfc_get_backend_locus (&loc
);
4421 gfc_set_backend_locus (&sym
->declared_at
);
4423 /* Descriptor type. */
4424 parm
= sym
->backend_decl
;
4425 type
= TREE_TYPE (parm
);
4426 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4428 gfc_start_block (&block
);
4430 if (sym
->ts
.type
== BT_CHARACTER
4431 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4432 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &block
);
4434 /* Evaluate the bounds of the array. */
4435 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
4437 /* Set the offset. */
4438 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4439 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4441 /* Set the pointer itself if we aren't using the parameter directly. */
4442 if (TREE_CODE (parm
) != PARM_DECL
)
4444 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4445 gfc_add_modify (&block
, parm
, tmp
);
4447 stmt
= gfc_finish_block (&block
);
4449 gfc_set_backend_locus (&loc
);
4451 gfc_start_block (&block
);
4453 /* Add the initialization code to the start of the function. */
4455 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4457 tmp
= gfc_conv_expr_present (sym
);
4458 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4461 gfc_add_expr_to_block (&block
, stmt
);
4462 gfc_add_expr_to_block (&block
, body
);
4464 return gfc_finish_block (&block
);
4468 /* Modify the descriptor of an array parameter so that it has the
4469 correct lower bound. Also move the upper bound accordingly.
4470 If the array is not packed, it will be copied into a temporary.
4471 For each dimension we set the new lower and upper bounds. Then we copy the
4472 stride and calculate the offset for this dimension. We also work out
4473 what the stride of a packed array would be, and see it the two match.
4474 If the array need repacking, we set the stride to the values we just
4475 calculated, recalculate the offset and copy the array data.
4476 Code is also added to copy the data back at the end of the function.
4480 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
4487 stmtblock_t cleanup
;
4495 tree stride
, stride2
;
4505 /* Do nothing for pointer and allocatable arrays. */
4506 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4509 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4510 return gfc_trans_g77_array (sym
, body
);
4512 gfc_get_backend_locus (&loc
);
4513 gfc_set_backend_locus (&sym
->declared_at
);
4515 /* Descriptor type. */
4516 type
= TREE_TYPE (tmpdesc
);
4517 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4518 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4519 dumdesc
= build_fold_indirect_ref_loc (input_location
,
4521 gfc_start_block (&block
);
4523 if (sym
->ts
.type
== BT_CHARACTER
4524 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4525 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &block
);
4527 checkparm
= (sym
->as
->type
== AS_EXPLICIT
4528 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
4530 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4531 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4533 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4535 /* For non-constant shape arrays we only check if the first dimension
4536 is contiguous. Repacking higher dimensions wouldn't gain us
4537 anything as we still don't know the array stride. */
4538 partial
= gfc_create_var (boolean_type_node
, "partial");
4539 TREE_USED (partial
) = 1;
4540 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4541 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4542 gfc_add_modify (&block
, partial
, tmp
);
4546 partial
= NULL_TREE
;
4549 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4550 here, however I think it does the right thing. */
4553 /* Set the first stride. */
4554 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4555 stride
= gfc_evaluate_now (stride
, &block
);
4557 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4558 stride
, gfc_index_zero_node
);
4559 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4560 gfc_index_one_node
, stride
);
4561 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4562 gfc_add_modify (&block
, stride
, tmp
);
4564 /* Allow the user to disable array repacking. */
4565 stmt_unpacked
= NULL_TREE
;
4569 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4570 /* A library call to repack the array if necessary. */
4571 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4572 stmt_unpacked
= build_call_expr_loc (input_location
,
4573 gfor_fndecl_in_pack
, 1, tmp
);
4575 stride
= gfc_index_one_node
;
4577 if (gfc_option
.warn_array_temp
)
4578 gfc_warning ("Creating array temporary at %L", &loc
);
4581 /* This is for the case where the array data is used directly without
4582 calling the repack function. */
4583 if (no_repack
|| partial
!= NULL_TREE
)
4584 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4586 stmt_packed
= NULL_TREE
;
4588 /* Assign the data pointer. */
4589 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4591 /* Don't repack unknown shape arrays when the first stride is 1. */
4592 tmp
= fold_build3 (COND_EXPR
, TREE_TYPE (stmt_packed
),
4593 partial
, stmt_packed
, stmt_unpacked
);
4596 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4597 gfc_add_modify (&block
, tmpdesc
, fold_convert (type
, tmp
));
4599 offset
= gfc_index_zero_node
;
4600 size
= gfc_index_one_node
;
4602 /* Evaluate the bounds of the array. */
4603 for (n
= 0; n
< sym
->as
->rank
; n
++)
4605 if (checkparm
|| !sym
->as
->upper
[n
])
4607 /* Get the bounds of the actual parameter. */
4608 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
4609 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
4613 dubound
= NULL_TREE
;
4614 dlbound
= NULL_TREE
;
4617 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4618 if (!INTEGER_CST_P (lbound
))
4620 gfc_init_se (&se
, NULL
);
4621 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4622 gfc_array_index_type
);
4623 gfc_add_block_to_block (&block
, &se
.pre
);
4624 gfc_add_modify (&block
, lbound
, se
.expr
);
4627 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4628 /* Set the desired upper bound. */
4629 if (sym
->as
->upper
[n
])
4631 /* We know what we want the upper bound to be. */
4632 if (!INTEGER_CST_P (ubound
))
4634 gfc_init_se (&se
, NULL
);
4635 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4636 gfc_array_index_type
);
4637 gfc_add_block_to_block (&block
, &se
.pre
);
4638 gfc_add_modify (&block
, ubound
, se
.expr
);
4641 /* Check the sizes match. */
4644 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4648 temp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4650 temp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4651 gfc_index_one_node
, temp
);
4653 stride2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4655 stride2
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4656 gfc_index_one_node
, stride2
);
4658 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, temp
, stride2
);
4659 asprintf (&msg
, "Dimension %d of array '%s' has extent "
4660 "%%ld instead of %%ld", n
+1, sym
->name
);
4662 gfc_trans_runtime_check (true, false, tmp
, &block
, &loc
, msg
,
4663 fold_convert (long_integer_type_node
, temp
),
4664 fold_convert (long_integer_type_node
, stride2
));
4671 /* For assumed shape arrays move the upper bound by the same amount
4672 as the lower bound. */
4673 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4675 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4676 gfc_add_modify (&block
, ubound
, tmp
);
4678 /* The offset of this dimension. offset = offset - lbound * stride. */
4679 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4680 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4682 /* The size of this dimension, and the stride of the next. */
4683 if (n
+ 1 < sym
->as
->rank
)
4685 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4687 if (no_repack
|| partial
!= NULL_TREE
)
4690 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
4693 /* Figure out the stride if not a known constant. */
4694 if (!INTEGER_CST_P (stride
))
4697 stmt_packed
= NULL_TREE
;
4700 /* Calculate stride = size * (ubound + 1 - lbound). */
4701 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4702 gfc_index_one_node
, lbound
);
4703 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4705 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4710 /* Assign the stride. */
4711 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4712 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4713 stmt_unpacked
, stmt_packed
);
4715 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4716 gfc_add_modify (&block
, stride
, tmp
);
4721 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4723 if (stride
&& !INTEGER_CST_P (stride
))
4725 /* Calculate size = stride * (ubound + 1 - lbound). */
4726 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4727 gfc_index_one_node
, lbound
);
4728 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4730 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4731 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4732 gfc_add_modify (&block
, stride
, tmp
);
4737 /* Set the offset. */
4738 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4739 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4741 gfc_trans_vla_type_sizes (sym
, &block
);
4743 stmt
= gfc_finish_block (&block
);
4745 gfc_start_block (&block
);
4747 /* Only do the entry/initialization code if the arg is present. */
4748 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4749 optional_arg
= (sym
->attr
.optional
4750 || (sym
->ns
->proc_name
->attr
.entry_master
4751 && sym
->attr
.dummy
));
4754 tmp
= gfc_conv_expr_present (sym
);
4755 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4757 gfc_add_expr_to_block (&block
, stmt
);
4759 /* Add the main function body. */
4760 gfc_add_expr_to_block (&block
, body
);
4765 gfc_start_block (&cleanup
);
4767 if (sym
->attr
.intent
!= INTENT_IN
)
4769 /* Copy the data back. */
4770 tmp
= build_call_expr_loc (input_location
,
4771 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4772 gfc_add_expr_to_block (&cleanup
, tmp
);
4775 /* Free the temporary. */
4776 tmp
= gfc_call_free (tmpdesc
);
4777 gfc_add_expr_to_block (&cleanup
, tmp
);
4779 stmt
= gfc_finish_block (&cleanup
);
4781 /* Only do the cleanup if the array was repacked. */
4782 tmp
= build_fold_indirect_ref_loc (input_location
,
4784 tmp
= gfc_conv_descriptor_data_get (tmp
);
4785 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4786 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4790 tmp
= gfc_conv_expr_present (sym
);
4791 stmt
= build3_v (COND_EXPR
, tmp
, stmt
,
4792 build_empty_stmt (input_location
));
4794 gfc_add_expr_to_block (&block
, stmt
);
4796 /* We don't need to free any memory allocated by internal_pack as it will
4797 be freed at the end of the function by pop_context. */
4798 return gfc_finish_block (&block
);
4802 /* Calculate the overall offset, including subreferences. */
4804 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4805 bool subref
, gfc_expr
*expr
)
4815 /* If offset is NULL and this is not a subreferenced array, there is
4817 if (offset
== NULL_TREE
)
4820 offset
= gfc_index_zero_node
;
4825 tmp
= gfc_conv_array_data (desc
);
4826 tmp
= build_fold_indirect_ref_loc (input_location
,
4828 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4830 /* Offset the data pointer for pointer assignments from arrays with
4831 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4834 /* Go past the array reference. */
4835 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4836 if (ref
->type
== REF_ARRAY
&&
4837 ref
->u
.ar
.type
!= AR_ELEMENT
)
4843 /* Calculate the offset for each subsequent subreference. */
4844 for (; ref
; ref
= ref
->next
)
4849 field
= ref
->u
.c
.component
->backend_decl
;
4850 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
4851 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4852 tmp
, field
, NULL_TREE
);
4856 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
4857 gfc_init_se (&start
, NULL
);
4858 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
4859 gfc_add_block_to_block (block
, &start
.pre
);
4860 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
4864 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
4865 && ref
->u
.ar
.type
== AR_ELEMENT
);
4867 /* TODO - Add bounds checking. */
4868 stride
= gfc_index_one_node
;
4869 index
= gfc_index_zero_node
;
4870 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4875 /* Update the index. */
4876 gfc_init_se (&start
, NULL
);
4877 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
4878 itmp
= gfc_evaluate_now (start
.expr
, block
);
4879 gfc_init_se (&start
, NULL
);
4880 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
4881 jtmp
= gfc_evaluate_now (start
.expr
, block
);
4882 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, itmp
, jtmp
);
4883 itmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, itmp
, stride
);
4884 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, itmp
, index
);
4885 index
= gfc_evaluate_now (index
, block
);
4887 /* Update the stride. */
4888 gfc_init_se (&start
, NULL
);
4889 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
4890 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, start
.expr
, jtmp
);
4891 itmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4892 gfc_index_one_node
, itmp
);
4893 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, itmp
);
4894 stride
= gfc_evaluate_now (stride
, block
);
4897 /* Apply the index to obtain the array element. */
4898 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
4908 /* Set the target data pointer. */
4909 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4910 gfc_conv_descriptor_data_set (block
, parm
, offset
);
4914 /* gfc_conv_expr_descriptor needs the string length an expression
4915 so that the size of the temporary can be obtained. This is done
4916 by adding up the string lengths of all the elements in the
4917 expression. Function with non-constant expressions have their
4918 string lengths mapped onto the actual arguments using the
4919 interface mapping machinery in trans-expr.c. */
4921 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
4923 gfc_interface_mapping mapping
;
4924 gfc_formal_arglist
*formal
;
4925 gfc_actual_arglist
*arg
;
4928 if (expr
->ts
.u
.cl
->length
4929 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
4931 if (!expr
->ts
.u
.cl
->backend_decl
)
4932 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
4936 switch (expr
->expr_type
)
4939 get_array_charlen (expr
->value
.op
.op1
, se
);
4941 /* For parentheses the expression ts.u.cl is identical. */
4942 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
4945 expr
->ts
.u
.cl
->backend_decl
=
4946 gfc_create_var (gfc_charlen_type_node
, "sln");
4948 if (expr
->value
.op
.op2
)
4950 get_array_charlen (expr
->value
.op
.op2
, se
);
4952 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
4954 /* Add the string lengths and assign them to the expression
4955 string length backend declaration. */
4956 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
4957 fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
,
4958 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
4959 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
4962 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
4963 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
4967 if (expr
->value
.function
.esym
== NULL
4968 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4970 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
4974 /* Map expressions involving the dummy arguments onto the actual
4975 argument expressions. */
4976 gfc_init_interface_mapping (&mapping
);
4977 formal
= expr
->symtree
->n
.sym
->formal
;
4978 arg
= expr
->value
.function
.actual
;
4980 /* Set se = NULL in the calls to the interface mapping, to suppress any
4982 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4987 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
4990 gfc_init_se (&tse
, NULL
);
4992 /* Build the expression for the character length and convert it. */
4993 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
4995 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
4996 gfc_add_block_to_block (&se
->post
, &tse
.post
);
4997 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
4998 tse
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tse
.expr
,
4999 build_int_cst (gfc_charlen_type_node
, 0));
5000 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
5001 gfc_free_interface_mapping (&mapping
);
5005 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5012 /* Convert an array for passing as an actual argument. Expressions and
5013 vector subscripts are evaluated and stored in a temporary, which is then
5014 passed. For whole arrays the descriptor is passed. For array sections
5015 a modified copy of the descriptor is passed, but using the original data.
5017 This function is also used for array pointer assignments, and there
5020 - se->want_pointer && !se->direct_byref
5021 EXPR is an actual argument. On exit, se->expr contains a
5022 pointer to the array descriptor.
5024 - !se->want_pointer && !se->direct_byref
5025 EXPR is an actual argument to an intrinsic function or the
5026 left-hand side of a pointer assignment. On exit, se->expr
5027 contains the descriptor for EXPR.
5029 - !se->want_pointer && se->direct_byref
5030 EXPR is the right-hand side of a pointer assignment and
5031 se->expr is the descriptor for the previously-evaluated
5032 left-hand side. The function creates an assignment from
5033 EXPR to se->expr. */
5036 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
5049 bool subref_array_target
= false;
5051 gcc_assert (ss
!= gfc_ss_terminator
);
5053 /* Special case things we know we can pass easily. */
5054 switch (expr
->expr_type
)
5057 /* If we have a linear array section, we can pass it directly.
5058 Otherwise we need to copy it into a temporary. */
5060 /* Find the SS for the array section. */
5062 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
5063 secss
= secss
->next
;
5065 gcc_assert (secss
!= gfc_ss_terminator
);
5066 info
= &secss
->data
.info
;
5068 /* Get the descriptor for the array. */
5069 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
5070 desc
= info
->descriptor
;
5072 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
5073 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
5074 && !subref_array_target
;
5078 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5080 /* Create a new descriptor if the array doesn't have one. */
5083 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
5085 else if (se
->direct_byref
)
5088 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
5092 if (se
->direct_byref
)
5094 /* Copy the descriptor for pointer assignments. */
5095 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
5097 /* Add any offsets from subreferences. */
5098 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
5099 subref_array_target
, expr
);
5101 else if (se
->want_pointer
)
5103 /* We pass full arrays directly. This means that pointers and
5104 allocatable arrays should also work. */
5105 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5112 if (expr
->ts
.type
== BT_CHARACTER
)
5113 se
->string_length
= gfc_get_expr_charlen (expr
);
5120 /* A transformational function return value will be a temporary
5121 array descriptor. We still need to go through the scalarizer
5122 to create the descriptor. Elemental functions ar handled as
5123 arbitrary expressions, i.e. copy to a temporary. */
5125 /* Look for the SS for this function. */
5126 while (secss
!= gfc_ss_terminator
5127 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
5128 secss
= secss
->next
;
5130 if (se
->direct_byref
)
5132 gcc_assert (secss
!= gfc_ss_terminator
);
5134 /* For pointer assignments pass the descriptor directly. */
5136 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5137 gfc_conv_expr (se
, expr
);
5141 if (secss
== gfc_ss_terminator
)
5143 /* Elemental function. */
5145 if (expr
->ts
.type
== BT_CHARACTER
5146 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5147 get_array_charlen (expr
, se
);
5153 /* Transformational function. */
5154 info
= &secss
->data
.info
;
5160 /* Constant array constructors don't need a temporary. */
5161 if (ss
->type
== GFC_SS_CONSTRUCTOR
5162 && expr
->ts
.type
!= BT_CHARACTER
5163 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
5166 info
= &ss
->data
.info
;
5178 /* Something complicated. Copy it into a temporary. */
5185 gfc_init_loopinfo (&loop
);
5187 /* Associate the SS with the loop. */
5188 gfc_add_ss_to_loop (&loop
, ss
);
5190 /* Tell the scalarizer not to bother creating loop variables, etc. */
5192 loop
.array_parameter
= 1;
5194 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5195 gcc_assert (!se
->direct_byref
);
5197 /* Setup the scalarizing loops and bounds. */
5198 gfc_conv_ss_startstride (&loop
);
5202 /* Tell the scalarizer to make a temporary. */
5203 loop
.temp_ss
= gfc_get_ss ();
5204 loop
.temp_ss
->type
= GFC_SS_TEMP
;
5205 loop
.temp_ss
->next
= gfc_ss_terminator
;
5207 if (expr
->ts
.type
== BT_CHARACTER
5208 && !expr
->ts
.u
.cl
->backend_decl
)
5209 get_array_charlen (expr
, se
);
5211 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
5213 if (expr
->ts
.type
== BT_CHARACTER
)
5214 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5216 loop
.temp_ss
->string_length
= NULL
;
5218 se
->string_length
= loop
.temp_ss
->string_length
;
5219 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
5220 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
5223 gfc_conv_loop_setup (&loop
, & expr
->where
);
5227 /* Copy into a temporary and pass that. We don't need to copy the data
5228 back because expressions and vector subscripts must be INTENT_IN. */
5229 /* TODO: Optimize passing function return values. */
5233 /* Start the copying loops. */
5234 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
5235 gfc_mark_ss_chain_used (ss
, 1);
5236 gfc_start_scalarized_body (&loop
, &block
);
5238 /* Copy each data element. */
5239 gfc_init_se (&lse
, NULL
);
5240 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5241 gfc_init_se (&rse
, NULL
);
5242 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5244 lse
.ss
= loop
.temp_ss
;
5247 gfc_conv_scalarized_array_ref (&lse
, NULL
);
5248 if (expr
->ts
.type
== BT_CHARACTER
)
5250 gfc_conv_expr (&rse
, expr
);
5251 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
5252 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
5256 gfc_conv_expr_val (&rse
, expr
);
5258 gfc_add_block_to_block (&block
, &rse
.pre
);
5259 gfc_add_block_to_block (&block
, &lse
.pre
);
5261 lse
.string_length
= rse
.string_length
;
5262 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
5263 expr
->expr_type
== EXPR_VARIABLE
, true);
5264 gfc_add_expr_to_block (&block
, tmp
);
5266 /* Finish the copying loops. */
5267 gfc_trans_scalarizing_loops (&loop
, &block
);
5269 desc
= loop
.temp_ss
->data
.info
.descriptor
;
5271 else if (expr
->expr_type
== EXPR_FUNCTION
)
5273 desc
= info
->descriptor
;
5274 se
->string_length
= ss
->string_length
;
5278 /* We pass sections without copying to a temporary. Make a new
5279 descriptor and point it at the section we want. The loop variable
5280 limits will be the limits of the section.
5281 A function may decide to repack the array to speed up access, but
5282 we're not bothered about that here. */
5291 /* Set the string_length for a character array. */
5292 if (expr
->ts
.type
== BT_CHARACTER
)
5293 se
->string_length
= gfc_get_expr_charlen (expr
);
5295 desc
= info
->descriptor
;
5296 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
5297 if (se
->direct_byref
)
5299 /* For pointer assignments we fill in the destination. */
5301 parmtype
= TREE_TYPE (parm
);
5305 /* Otherwise make a new one. */
5306 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
5307 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
5308 loop
.from
, loop
.to
, 0,
5309 GFC_ARRAY_UNKNOWN
, false);
5310 parm
= gfc_create_var (parmtype
, "parm");
5313 offset
= gfc_index_zero_node
;
5316 /* The following can be somewhat confusing. We have two
5317 descriptors, a new one and the original array.
5318 {parm, parmtype, dim} refer to the new one.
5319 {desc, type, n, secss, loop} refer to the original, which maybe
5320 a descriptorless array.
5321 The bounds of the scalarization are the bounds of the section.
5322 We don't have to worry about numeric overflows when calculating
5323 the offsets because all elements are within the array data. */
5325 /* Set the dtype. */
5326 tmp
= gfc_conv_descriptor_dtype (parm
);
5327 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
5329 /* Set offset for assignments to pointer only to zero if it is not
5331 if (se
->direct_byref
5332 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
5333 base
= gfc_index_zero_node
;
5334 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5335 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
5339 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
5340 for (n
= 0; n
< ndim
; n
++)
5342 stride
= gfc_conv_array_stride (desc
, n
);
5344 /* Work out the offset. */
5346 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5348 gcc_assert (info
->subscript
[n
]
5349 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
5350 start
= info
->subscript
[n
]->data
.scalar
.expr
;
5354 /* Check we haven't somehow got out of sync. */
5355 gcc_assert (info
->dim
[dim
] == n
);
5357 /* Evaluate and remember the start of the section. */
5358 start
= info
->start
[dim
];
5359 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
5362 tmp
= gfc_conv_array_lbound (desc
, n
);
5363 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
5365 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
5366 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
5369 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5371 /* For elemental dimensions, we only need the offset. */
5375 /* Vector subscripts need copying and are handled elsewhere. */
5377 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
5379 /* Set the new lower bound. */
5380 from
= loop
.from
[dim
];
5383 /* If we have an array section or are assigning make sure that
5384 the lower bound is 1. References to the full
5385 array should otherwise keep the original bounds. */
5387 || info
->ref
->u
.ar
.type
!= AR_FULL
)
5388 && !integer_onep (from
))
5390 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5391 gfc_index_one_node
, from
);
5392 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
5393 from
= gfc_index_one_node
;
5395 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
5396 gfc_rank_cst
[dim
], from
);
5398 /* Set the new upper bound. */
5399 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
5400 gfc_rank_cst
[dim
], to
);
5402 /* Multiply the stride by the section stride to get the
5404 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
5405 stride
, info
->stride
[dim
]);
5407 if (se
->direct_byref
5409 && info
->ref
->u
.ar
.type
!= AR_FULL
)
5411 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5414 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5416 tmp
= gfc_conv_array_lbound (desc
, n
);
5417 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5418 tmp
, loop
.from
[dim
]);
5419 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
5420 tmp
, gfc_conv_array_stride (desc
, n
));
5421 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
5425 /* Store the new stride. */
5426 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
5427 gfc_rank_cst
[dim
], stride
);
5432 if (se
->data_not_needed
)
5433 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
5434 gfc_index_zero_node
);
5436 /* Point the data pointer at the 1st element in the section. */
5437 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
5438 subref_array_target
, expr
);
5440 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5441 && !se
->data_not_needed
)
5443 /* Set the offset. */
5444 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
5448 /* Only the callee knows what the correct offset it, so just set
5450 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
5455 if (!se
->direct_byref
)
5457 /* Get a pointer to the new descriptor. */
5458 if (se
->want_pointer
)
5459 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5464 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5465 gfc_add_block_to_block (&se
->post
, &loop
.post
);
5467 /* Cleanup the scalarizer. */
5468 gfc_cleanup_loop (&loop
);
5471 /* Helper function for gfc_conv_array_parameter if array size needs to be
5475 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
5478 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5479 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
5480 else if (expr
->rank
> 1)
5481 *size
= build_call_expr_loc (input_location
,
5482 gfor_fndecl_size0
, 1,
5483 gfc_build_addr_expr (NULL
, desc
));
5486 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
5487 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
5489 *size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
5490 *size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, *size
,
5491 gfc_index_one_node
);
5492 *size
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, *size
,
5493 gfc_index_zero_node
);
5495 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
5496 *size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, *size
,
5497 fold_convert (gfc_array_index_type
, elem
));
5500 /* Convert an array for passing as an actual parameter. */
5501 /* TODO: Optimize passing g77 arrays. */
5504 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, bool g77
,
5505 const gfc_symbol
*fsym
, const char *proc_name
,
5510 tree tmp
= NULL_TREE
;
5512 tree parent
= DECL_CONTEXT (current_function_decl
);
5513 bool full_array_var
;
5514 bool this_array_result
;
5517 bool array_constructor
;
5518 bool good_allocatable
;
5519 bool ultimate_ptr_comp
;
5520 bool ultimate_alloc_comp
;
5525 ultimate_ptr_comp
= false;
5526 ultimate_alloc_comp
= false;
5528 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5530 if (ref
->next
== NULL
)
5533 if (ref
->type
== REF_COMPONENT
)
5535 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
5536 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
5540 full_array_var
= false;
5543 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
5544 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
5546 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
5548 /* The symbol should have an array specification. */
5549 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
5551 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
5553 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
5554 expr
->ts
.u
.cl
->backend_decl
= tmp
;
5555 se
->string_length
= tmp
;
5558 /* Is this the result of the enclosing procedure? */
5559 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
5560 if (this_array_result
5561 && (sym
->backend_decl
!= current_function_decl
)
5562 && (sym
->backend_decl
!= parent
))
5563 this_array_result
= false;
5565 /* Passing address of the array if it is not pointer or assumed-shape. */
5566 if (full_array_var
&& g77
&& !this_array_result
)
5568 tmp
= gfc_get_symbol_decl (sym
);
5570 if (sym
->ts
.type
== BT_CHARACTER
)
5571 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5573 if (sym
->ts
.type
== BT_DERIVED
)
5575 gfc_conv_expr_descriptor (se
, expr
, ss
);
5576 se
->expr
= gfc_conv_array_data (se
->expr
);
5580 if (!sym
->attr
.pointer
5582 && sym
->as
->type
!= AS_ASSUMED_SHAPE
5583 && !sym
->attr
.allocatable
)
5585 /* Some variables are declared directly, others are declared as
5586 pointers and allocated on the heap. */
5587 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
5590 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5592 array_parameter_size (tmp
, expr
, size
);
5596 if (sym
->attr
.allocatable
)
5598 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5600 gfc_conv_expr_descriptor (se
, expr
, ss
);
5604 array_parameter_size (tmp
, expr
, size
);
5605 se
->expr
= gfc_conv_array_data (tmp
);
5610 /* A convenient reduction in scope. */
5611 contiguous
= g77
&& !this_array_result
&& contiguous
;
5613 /* There is no need to pack and unpack the array, if it is contiguous
5614 and not a deferred- or assumed-shape array, or if it is simply
5616 no_pack
= ((sym
&& sym
->as
5617 && !sym
->attr
.pointer
5618 && sym
->as
->type
!= AS_DEFERRED
5619 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
5621 (ref
&& ref
->u
.ar
.as
5622 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
5623 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
5625 gfc_is_simply_contiguous (expr
, false));
5627 no_pack
= contiguous
&& no_pack
;
5629 /* Array constructors are always contiguous and do not need packing. */
5630 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
5632 /* Same is true of contiguous sections from allocatable variables. */
5633 good_allocatable
= contiguous
5635 && expr
->symtree
->n
.sym
->attr
.allocatable
;
5637 /* Or ultimate allocatable components. */
5638 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
5640 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
5642 gfc_conv_expr_descriptor (se
, expr
, ss
);
5643 if (expr
->ts
.type
== BT_CHARACTER
)
5644 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5646 array_parameter_size (se
->expr
, expr
, size
);
5647 se
->expr
= gfc_conv_array_data (se
->expr
);
5651 if (this_array_result
)
5653 /* Result of the enclosing function. */
5654 gfc_conv_expr_descriptor (se
, expr
, ss
);
5656 array_parameter_size (se
->expr
, expr
, size
);
5657 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5659 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
5660 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
5661 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
5668 /* Every other type of array. */
5669 se
->want_pointer
= 1;
5670 gfc_conv_expr_descriptor (se
, expr
, ss
);
5672 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
5677 /* Deallocate the allocatable components of structures that are
5679 if (expr
->ts
.type
== BT_DERIVED
5680 && expr
->ts
.u
.derived
->attr
.alloc_comp
5681 && expr
->expr_type
!= EXPR_VARIABLE
)
5683 tmp
= build_fold_indirect_ref_loc (input_location
,
5685 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
5686 gfc_add_expr_to_block (&se
->post
, tmp
);
5689 if (g77
|| (fsym
&& fsym
->attr
.contiguous
5690 && !gfc_is_simply_contiguous (expr
, false)))
5692 tree origptr
= NULL_TREE
;
5696 /* For contiguous arrays, save the original value of the descriptor. */
5699 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
5700 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5701 tmp
= gfc_conv_array_data (tmp
);
5702 tmp
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (origptr
), origptr
,
5703 fold_convert (TREE_TYPE (origptr
), tmp
));
5704 gfc_add_expr_to_block (&se
->pre
, tmp
);
5707 /* Repack the array. */
5708 if (gfc_option
.warn_array_temp
)
5711 gfc_warning ("Creating array temporary at %L for argument '%s'",
5712 &expr
->where
, fsym
->name
);
5714 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5717 ptr
= build_call_expr_loc (input_location
,
5718 gfor_fndecl_in_pack
, 1, desc
);
5720 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5722 tmp
= gfc_conv_expr_present (sym
);
5723 ptr
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), tmp
,
5724 fold_convert (TREE_TYPE (se
->expr
), ptr
),
5725 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
5728 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5730 /* Use the packed data for the actual argument, except for contiguous arrays,
5731 where the descriptor's data component is set. */
5736 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5737 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
5740 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
5744 if (fsym
&& proc_name
)
5745 asprintf (&msg
, "An array temporary was created for argument "
5746 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
5748 asprintf (&msg
, "An array temporary was created");
5750 tmp
= build_fold_indirect_ref_loc (input_location
,
5752 tmp
= gfc_conv_array_data (tmp
);
5753 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
5754 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5756 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5757 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
5758 gfc_conv_expr_present (sym
), tmp
);
5760 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
5765 gfc_start_block (&block
);
5767 /* Copy the data back. */
5768 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
5770 tmp
= build_call_expr_loc (input_location
,
5771 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5772 gfc_add_expr_to_block (&block
, tmp
);
5775 /* Free the temporary. */
5776 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5777 gfc_add_expr_to_block (&block
, tmp
);
5779 stmt
= gfc_finish_block (&block
);
5781 gfc_init_block (&block
);
5782 /* Only if it was repacked. This code needs to be executed before the
5783 loop cleanup code. */
5784 tmp
= build_fold_indirect_ref_loc (input_location
,
5786 tmp
= gfc_conv_array_data (tmp
);
5787 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
5788 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5790 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5791 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
5792 gfc_conv_expr_present (sym
), tmp
);
5794 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5796 gfc_add_expr_to_block (&block
, tmp
);
5797 gfc_add_block_to_block (&block
, &se
->post
);
5799 gfc_init_block (&se
->post
);
5801 /* Reset the descriptor pointer. */
5804 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5805 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
5808 gfc_add_block_to_block (&se
->post
, &block
);
5813 /* Generate code to deallocate an array, if it is allocated. */
5816 gfc_trans_dealloc_allocated (tree descriptor
)
5822 gfc_start_block (&block
);
5824 var
= gfc_conv_descriptor_data_get (descriptor
);
5827 /* Call array_deallocate with an int * present in the second argument.
5828 Although it is ignored here, it's presence ensures that arrays that
5829 are already deallocated are ignored. */
5830 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true, NULL
);
5831 gfc_add_expr_to_block (&block
, tmp
);
5833 /* Zero the data pointer. */
5834 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5835 var
, build_int_cst (TREE_TYPE (var
), 0));
5836 gfc_add_expr_to_block (&block
, tmp
);
5838 return gfc_finish_block (&block
);
5842 /* This helper function calculates the size in words of a full array. */
5845 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
5850 idx
= gfc_rank_cst
[rank
- 1];
5851 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
5852 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
5853 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5854 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
5855 tmp
, gfc_index_one_node
);
5856 tmp
= gfc_evaluate_now (tmp
, block
);
5858 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
5859 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5860 return gfc_evaluate_now (tmp
, block
);
5864 /* Allocate dest to the same size as src, and copy src -> dest.
5865 If no_malloc is set, only the copy is done. */
5868 duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
,
5878 /* If the source is null, set the destination to null. Then,
5879 allocate memory to the destination. */
5880 gfc_init_block (&block
);
5884 tmp
= null_pointer_node
;
5885 tmp
= fold_build2 (MODIFY_EXPR
, type
, dest
, tmp
);
5886 gfc_add_expr_to_block (&block
, tmp
);
5887 null_data
= gfc_finish_block (&block
);
5889 gfc_init_block (&block
);
5890 size
= TYPE_SIZE_UNIT (type
);
5893 tmp
= gfc_call_malloc (&block
, type
, size
);
5894 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, dest
,
5895 fold_convert (type
, tmp
));
5896 gfc_add_expr_to_block (&block
, tmp
);
5899 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5900 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
5905 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5906 null_data
= gfc_finish_block (&block
);
5908 gfc_init_block (&block
);
5909 nelems
= get_full_array_size (&block
, src
, rank
);
5910 tmp
= fold_convert (gfc_array_index_type
,
5911 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
5912 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5915 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
5916 tmp
= gfc_call_malloc (&block
, tmp
, size
);
5917 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5920 /* We know the temporary and the value will be the same length,
5921 so can use memcpy. */
5922 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5923 tmp
= build_call_expr_loc (input_location
,
5924 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5925 gfc_conv_descriptor_data_get (src
), size
);
5928 gfc_add_expr_to_block (&block
, tmp
);
5929 tmp
= gfc_finish_block (&block
);
5931 /* Null the destination if the source is null; otherwise do
5932 the allocate and copy. */
5936 null_cond
= gfc_conv_descriptor_data_get (src
);
5938 null_cond
= convert (pvoid_type_node
, null_cond
);
5939 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
5940 null_cond
, null_pointer_node
);
5941 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5945 /* Allocate dest to the same size as src, and copy data src -> dest. */
5948 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
5950 return duplicate_allocatable(dest
, src
, type
, rank
, false);
5954 /* Copy data src -> dest. */
5957 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
5959 return duplicate_allocatable(dest
, src
, type
, rank
, true);
5963 /* Recursively traverse an object of derived type, generating code to
5964 deallocate, nullify or copy allocatable components. This is the work horse
5965 function for the functions named in this enum. */
5967 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
5968 COPY_ONLY_ALLOC_COMP
};
5971 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5972 tree dest
, int rank
, int purpose
)
5976 stmtblock_t fnblock
;
5977 stmtblock_t loopbody
;
5988 tree null_cond
= NULL_TREE
;
5990 gfc_init_block (&fnblock
);
5992 decl_type
= TREE_TYPE (decl
);
5994 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
5995 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
5997 decl
= build_fold_indirect_ref_loc (input_location
,
6000 /* Just in case in gets dereferenced. */
6001 decl_type
= TREE_TYPE (decl
);
6003 /* If this an array of derived types with allocatable components
6004 build a loop and recursively call this function. */
6005 if (TREE_CODE (decl_type
) == ARRAY_TYPE
6006 || GFC_DESCRIPTOR_TYPE_P (decl_type
))
6008 tmp
= gfc_conv_array_data (decl
);
6009 var
= build_fold_indirect_ref_loc (input_location
,
6012 /* Get the number of elements - 1 and set the counter. */
6013 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
6015 /* Use the descriptor for an allocatable array. Since this
6016 is a full array reference, we only need the descriptor
6017 information from dimension = rank. */
6018 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
6019 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
6020 tmp
, gfc_index_one_node
);
6022 null_cond
= gfc_conv_descriptor_data_get (decl
);
6023 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
, null_cond
,
6024 build_int_cst (TREE_TYPE (null_cond
), 0));
6028 /* Otherwise use the TYPE_DOMAIN information. */
6029 tmp
= array_type_nelts (decl_type
);
6030 tmp
= fold_convert (gfc_array_index_type
, tmp
);
6033 /* Remember that this is, in fact, the no. of elements - 1. */
6034 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
6035 index
= gfc_create_var (gfc_array_index_type
, "S");
6037 /* Build the body of the loop. */
6038 gfc_init_block (&loopbody
);
6040 vref
= gfc_build_array_ref (var
, index
, NULL
);
6042 if (purpose
== COPY_ALLOC_COMP
)
6044 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
6046 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
6047 gfc_add_expr_to_block (&fnblock
, tmp
);
6049 tmp
= build_fold_indirect_ref_loc (input_location
,
6050 gfc_conv_array_data (dest
));
6051 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
6052 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
6054 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
6056 tmp
= build_fold_indirect_ref_loc (input_location
,
6057 gfc_conv_array_data (dest
));
6058 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
6059 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
6063 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
6065 gfc_add_expr_to_block (&loopbody
, tmp
);
6067 /* Build the loop and return. */
6068 gfc_init_loopinfo (&loop
);
6070 loop
.from
[0] = gfc_index_zero_node
;
6071 loop
.loopvar
[0] = index
;
6072 loop
.to
[0] = nelems
;
6073 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
6074 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
6076 tmp
= gfc_finish_block (&fnblock
);
6077 if (null_cond
!= NULL_TREE
)
6078 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
6079 build_empty_stmt (input_location
));
6084 /* Otherwise, act on the components or recursively call self to
6085 act on a chain of components. */
6086 for (c
= der_type
->components
; c
; c
= c
->next
)
6088 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
6089 && c
->ts
.u
.derived
->attr
.alloc_comp
;
6090 cdecl = c
->backend_decl
;
6091 ctype
= TREE_TYPE (cdecl);
6095 case DEALLOCATE_ALLOC_COMP
:
6096 /* Do not deallocate the components of ultimate pointer
6098 if (cmp_has_alloc_comps
&& !c
->attr
.pointer
)
6100 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6101 decl
, cdecl, NULL_TREE
);
6102 rank
= c
->as
? c
->as
->rank
: 0;
6103 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6105 gfc_add_expr_to_block (&fnblock
, tmp
);
6108 if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6110 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6111 decl
, cdecl, NULL_TREE
);
6112 tmp
= gfc_trans_dealloc_allocated (comp
);
6113 gfc_add_expr_to_block (&fnblock
, tmp
);
6115 else if (c
->attr
.allocatable
)
6117 /* Allocatable scalar components. */
6118 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6120 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, true, NULL
);
6121 gfc_add_expr_to_block (&fnblock
, tmp
);
6123 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6124 build_int_cst (TREE_TYPE (comp
), 0));
6125 gfc_add_expr_to_block (&fnblock
, tmp
);
6127 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
6129 /* Allocatable scalar CLASS components. */
6130 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6132 /* Add reference to '$data' component. */
6133 tmp
= CLASS_DATA (c
)->backend_decl
;
6134 comp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
6135 comp
, tmp
, NULL_TREE
);
6137 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, true, NULL
);
6138 gfc_add_expr_to_block (&fnblock
, tmp
);
6140 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6141 build_int_cst (TREE_TYPE (comp
), 0));
6142 gfc_add_expr_to_block (&fnblock
, tmp
);
6146 case NULLIFY_ALLOC_COMP
:
6147 if (c
->attr
.pointer
)
6149 else if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6151 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6152 decl
, cdecl, NULL_TREE
);
6153 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
6155 else if (c
->attr
.allocatable
)
6157 /* Allocatable scalar components. */
6158 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6159 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6160 build_int_cst (TREE_TYPE (comp
), 0));
6161 gfc_add_expr_to_block (&fnblock
, tmp
);
6163 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
6165 /* Allocatable scalar CLASS components. */
6166 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6167 /* Add reference to '$data' component. */
6168 tmp
= CLASS_DATA (c
)->backend_decl
;
6169 comp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
6170 comp
, tmp
, NULL_TREE
);
6171 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6172 build_int_cst (TREE_TYPE (comp
), 0));
6173 gfc_add_expr_to_block (&fnblock
, tmp
);
6175 else if (cmp_has_alloc_comps
)
6177 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6178 decl
, cdecl, NULL_TREE
);
6179 rank
= c
->as
? c
->as
->rank
: 0;
6180 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6182 gfc_add_expr_to_block (&fnblock
, tmp
);
6186 case COPY_ALLOC_COMP
:
6187 if (c
->attr
.pointer
)
6190 /* We need source and destination components. */
6191 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6192 dcmp
= fold_build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
6193 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
6195 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
6197 rank
= c
->as
? c
->as
->rank
: 0;
6198 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, rank
);
6199 gfc_add_expr_to_block (&fnblock
, tmp
);
6202 if (cmp_has_alloc_comps
)
6204 rank
= c
->as
? c
->as
->rank
: 0;
6205 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
6206 gfc_add_modify (&fnblock
, dcmp
, tmp
);
6207 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
6209 gfc_add_expr_to_block (&fnblock
, tmp
);
6219 return gfc_finish_block (&fnblock
);
6222 /* Recursively traverse an object of derived type, generating code to
6223 nullify allocatable components. */
6226 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6228 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6229 NULLIFY_ALLOC_COMP
);
6233 /* Recursively traverse an object of derived type, generating code to
6234 deallocate allocatable components. */
6237 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6239 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6240 DEALLOCATE_ALLOC_COMP
);
6244 /* Recursively traverse an object of derived type, generating code to
6245 copy it and its allocatable components. */
6248 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6250 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
6254 /* Recursively traverse an object of derived type, generating code to
6255 copy only its allocatable components. */
6258 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6260 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
6264 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6265 Do likewise, recursively if necessary, with the allocatable components of
6269 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
6274 stmtblock_t fnblock
;
6277 bool sym_has_alloc_comp
;
6279 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
6280 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
6282 /* Make sure the frontend gets these right. */
6283 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
6284 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6285 "allocatable attribute or derived type without allocatable "
6288 gfc_init_block (&fnblock
);
6290 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
6291 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
6293 if (sym
->ts
.type
== BT_CHARACTER
6294 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6296 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &fnblock
);
6297 gfc_trans_vla_type_sizes (sym
, &fnblock
);
6300 /* Dummy, use associated and result variables don't need anything special. */
6301 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
6303 gfc_add_expr_to_block (&fnblock
, body
);
6305 return gfc_finish_block (&fnblock
);
6308 gfc_get_backend_locus (&loc
);
6309 gfc_set_backend_locus (&sym
->declared_at
);
6310 descriptor
= sym
->backend_decl
;
6312 /* Although static, derived types with default initializers and
6313 allocatable components must not be nulled wholesale; instead they
6314 are treated component by component. */
6315 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
6317 /* SAVEd variables are not freed on exit. */
6318 gfc_trans_static_array_pointer (sym
);
6322 /* Get the descriptor type. */
6323 type
= TREE_TYPE (sym
->backend_decl
);
6325 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6328 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
6330 if (sym
->value
== NULL
6331 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
6333 rank
= sym
->as
? sym
->as
->rank
: 0;
6334 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
6335 gfc_add_expr_to_block (&fnblock
, tmp
);
6339 tmp
= gfc_init_default_dt (sym
, NULL
, false);
6340 gfc_add_expr_to_block (&fnblock
, tmp
);
6344 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
6346 /* If the backend_decl is not a descriptor, we must have a pointer
6348 descriptor
= build_fold_indirect_ref_loc (input_location
,
6350 type
= TREE_TYPE (descriptor
);
6353 /* NULLIFY the data pointer. */
6354 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
6355 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
6357 gfc_add_expr_to_block (&fnblock
, body
);
6359 gfc_set_backend_locus (&loc
);
6361 /* Allocatable arrays need to be freed when they go out of scope.
6362 The allocatable components of pointers must not be touched. */
6363 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
6364 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
6367 rank
= sym
->as
? sym
->as
->rank
: 0;
6368 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
6369 gfc_add_expr_to_block (&fnblock
, tmp
);
6372 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
6373 && !sym
->attr
.save
&& !sym
->attr
.result
)
6375 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
6376 gfc_add_expr_to_block (&fnblock
, tmp
);
6379 return gfc_finish_block (&fnblock
);
6382 /************ Expression Walking Functions ******************/
6384 /* Walk a variable reference.
6386 Possible extension - multiple component subscripts.
6387 x(:,:) = foo%a(:)%b(:)
6389 forall (i=..., j=...)
6390 x(i,j) = foo%a(j)%b(i)
6392 This adds a fair amount of complexity because you need to deal with more
6393 than one ref. Maybe handle in a similar manner to vector subscripts.
6394 Maybe not worth the effort. */
6398 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6405 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6406 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
6409 for (; ref
; ref
= ref
->next
)
6411 if (ref
->type
== REF_SUBSTRING
)
6413 newss
= gfc_get_ss ();
6414 newss
->type
= GFC_SS_SCALAR
;
6415 newss
->expr
= ref
->u
.ss
.start
;
6419 newss
= gfc_get_ss ();
6420 newss
->type
= GFC_SS_SCALAR
;
6421 newss
->expr
= ref
->u
.ss
.end
;
6426 /* We're only interested in array sections from now on. */
6427 if (ref
->type
!= REF_ARRAY
)
6432 if (ar
->as
->rank
== 0)
6434 /* Scalar coarray. */
6441 for (n
= 0; n
< ar
->dimen
; n
++)
6443 newss
= gfc_get_ss ();
6444 newss
->type
= GFC_SS_SCALAR
;
6445 newss
->expr
= ar
->start
[n
];
6452 newss
= gfc_get_ss ();
6453 newss
->type
= GFC_SS_SECTION
;
6456 newss
->data
.info
.dimen
= ar
->as
->rank
;
6457 newss
->data
.info
.ref
= ref
;
6459 /* Make sure array is the same as array(:,:), this way
6460 we don't need to special case all the time. */
6461 ar
->dimen
= ar
->as
->rank
;
6462 for (n
= 0; n
< ar
->dimen
; n
++)
6464 newss
->data
.info
.dim
[n
] = n
;
6465 ar
->dimen_type
[n
] = DIMEN_RANGE
;
6467 gcc_assert (ar
->start
[n
] == NULL
);
6468 gcc_assert (ar
->end
[n
] == NULL
);
6469 gcc_assert (ar
->stride
[n
] == NULL
);
6475 newss
= gfc_get_ss ();
6476 newss
->type
= GFC_SS_SECTION
;
6479 newss
->data
.info
.dimen
= 0;
6480 newss
->data
.info
.ref
= ref
;
6482 /* We add SS chains for all the subscripts in the section. */
6483 for (n
= 0; n
< ar
->dimen
; n
++)
6487 switch (ar
->dimen_type
[n
])
6490 /* Add SS for elemental (scalar) subscripts. */
6491 gcc_assert (ar
->start
[n
]);
6492 indexss
= gfc_get_ss ();
6493 indexss
->type
= GFC_SS_SCALAR
;
6494 indexss
->expr
= ar
->start
[n
];
6495 indexss
->next
= gfc_ss_terminator
;
6496 indexss
->loop_chain
= gfc_ss_terminator
;
6497 newss
->data
.info
.subscript
[n
] = indexss
;
6501 /* We don't add anything for sections, just remember this
6502 dimension for later. */
6503 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
6504 newss
->data
.info
.dimen
++;
6508 /* Create a GFC_SS_VECTOR index in which we can store
6509 the vector's descriptor. */
6510 indexss
= gfc_get_ss ();
6511 indexss
->type
= GFC_SS_VECTOR
;
6512 indexss
->expr
= ar
->start
[n
];
6513 indexss
->next
= gfc_ss_terminator
;
6514 indexss
->loop_chain
= gfc_ss_terminator
;
6515 newss
->data
.info
.subscript
[n
] = indexss
;
6516 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
6517 newss
->data
.info
.dimen
++;
6521 /* We should know what sort of section it is by now. */
6525 /* We should have at least one non-elemental dimension. */
6526 gcc_assert (newss
->data
.info
.dimen
> 0);
6531 /* We should know what sort of section it is by now. */
6540 /* Walk an expression operator. If only one operand of a binary expression is
6541 scalar, we must also add the scalar term to the SS chain. */
6544 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6550 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
6551 if (expr
->value
.op
.op2
== NULL
)
6554 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
6556 /* All operands are scalar. Pass back and let the caller deal with it. */
6560 /* All operands require scalarization. */
6561 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
6564 /* One of the operands needs scalarization, the other is scalar.
6565 Create a gfc_ss for the scalar expression. */
6566 newss
= gfc_get_ss ();
6567 newss
->type
= GFC_SS_SCALAR
;
6570 /* First operand is scalar. We build the chain in reverse order, so
6571 add the scalar SS after the second operand. */
6573 while (head
&& head
->next
!= ss
)
6575 /* Check we haven't somehow broken the chain. */
6579 newss
->expr
= expr
->value
.op
.op1
;
6581 else /* head2 == head */
6583 gcc_assert (head2
== head
);
6584 /* Second operand is scalar. */
6585 newss
->next
= head2
;
6587 newss
->expr
= expr
->value
.op
.op2
;
6594 /* Reverse a SS chain. */
6597 gfc_reverse_ss (gfc_ss
* ss
)
6602 gcc_assert (ss
!= NULL
);
6604 head
= gfc_ss_terminator
;
6605 while (ss
!= gfc_ss_terminator
)
6608 /* Check we didn't somehow break the chain. */
6609 gcc_assert (next
!= NULL
);
6619 /* Walk the arguments of an elemental function. */
6622 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
6630 head
= gfc_ss_terminator
;
6633 for (; arg
; arg
= arg
->next
)
6638 newss
= gfc_walk_subexpr (head
, arg
->expr
);
6641 /* Scalar argument. */
6642 newss
= gfc_get_ss ();
6644 newss
->expr
= arg
->expr
;
6654 while (tail
->next
!= gfc_ss_terminator
)
6661 /* If all the arguments are scalar we don't need the argument SS. */
6662 gfc_free_ss_chain (head
);
6667 /* Add it onto the existing chain. */
6673 /* Walk a function call. Scalar functions are passed back, and taken out of
6674 scalarization loops. For elemental functions we walk their arguments.
6675 The result of functions returning arrays is stored in a temporary outside
6676 the loop, so that the function is only called once. Hence we do not need
6677 to walk their arguments. */
6680 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6683 gfc_intrinsic_sym
*isym
;
6685 gfc_component
*comp
= NULL
;
6687 isym
= expr
->value
.function
.isym
;
6689 /* Handle intrinsic functions separately. */
6691 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
6693 sym
= expr
->value
.function
.esym
;
6695 sym
= expr
->symtree
->n
.sym
;
6697 /* A function that returns arrays. */
6698 gfc_is_proc_ptr_comp (expr
, &comp
);
6699 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
6700 || (comp
&& comp
->attr
.dimension
))
6702 newss
= gfc_get_ss ();
6703 newss
->type
= GFC_SS_FUNCTION
;
6706 newss
->data
.info
.dimen
= expr
->rank
;
6710 /* Walk the parameters of an elemental function. For now we always pass
6712 if (sym
->attr
.elemental
)
6713 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
6716 /* Scalar functions are OK as these are evaluated outside the scalarization
6717 loop. Pass back and let the caller deal with it. */
6722 /* An array temporary is constructed for array constructors. */
6725 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
6730 newss
= gfc_get_ss ();
6731 newss
->type
= GFC_SS_CONSTRUCTOR
;
6734 newss
->data
.info
.dimen
= expr
->rank
;
6735 for (n
= 0; n
< expr
->rank
; n
++)
6736 newss
->data
.info
.dim
[n
] = n
;
6742 /* Walk an expression. Add walked expressions to the head of the SS chain.
6743 A wholly scalar expression will not be added. */
6746 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
6750 switch (expr
->expr_type
)
6753 head
= gfc_walk_variable_expr (ss
, expr
);
6757 head
= gfc_walk_op_expr (ss
, expr
);
6761 head
= gfc_walk_function_expr (ss
, expr
);
6766 case EXPR_STRUCTURE
:
6767 /* Pass back and let the caller deal with it. */
6771 head
= gfc_walk_array_constructor (ss
, expr
);
6774 case EXPR_SUBSTRING
:
6775 /* Pass back and let the caller deal with it. */
6779 internal_error ("bad expression type during walk (%d)",
6786 /* Entry point for expression walking.
6787 A return value equal to the passed chain means this is
6788 a scalar expression. It is up to the caller to take whatever action is
6789 necessary to translate these. */
6792 gfc_walk_expr (gfc_expr
* expr
)
6796 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
6797 return gfc_reverse_ss (res
);