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 "diagnostic-core.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
< ss
->data
.info
.dimen
; n
++)
439 if (ss
->data
.info
.subscript
[ss
->data
.info
.dim
[n
]])
440 gfc_free_ss_chain (ss
->data
.info
.subscript
[ss
->data
.info
.dim
[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
++)
767 if (size
== NULL_TREE
)
769 /* For a callee allocated array express the loop bounds in terms
770 of the descriptor fields. */
772 MINUS_EXPR
, gfc_array_index_type
,
773 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]),
774 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]));
779 /* Store the stride and bound components in the descriptor. */
780 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[dim
], size
);
782 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[dim
],
783 gfc_index_zero_node
);
785 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[dim
],
788 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
789 loop
->to
[n
], gfc_index_one_node
);
791 /* Check whether the size for this dimension is negative. */
792 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, tmp
,
793 gfc_index_zero_node
);
794 cond
= gfc_evaluate_now (cond
, pre
);
799 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
801 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
802 size
= gfc_evaluate_now (size
, pre
);
805 /* Get the size of the array. */
807 if (size
&& !callee_alloc
)
809 /* If or_expr is true, then the extent in at least one
810 dimension is zero and the size is set to zero. */
811 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
,
812 or_expr
, gfc_index_zero_node
, size
);
815 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
816 fold_convert (gfc_array_index_type
,
817 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
825 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
828 if (info
->dimen
> loop
->temp_dim
)
829 loop
->temp_dim
= info
->dimen
;
835 /* Generate code to transpose array EXPR by creating a new descriptor
836 in which the dimension specifications have been reversed. */
839 gfc_conv_array_transpose (gfc_se
* se
, gfc_expr
* expr
)
841 tree dest
, src
, dest_index
, src_index
;
843 gfc_ss_info
*dest_info
;
844 gfc_ss
*dest_ss
, *src_ss
;
850 src_ss
= gfc_walk_expr (expr
);
853 dest_info
= &dest_ss
->data
.info
;
854 gcc_assert (dest_info
->dimen
== 2);
856 /* Get a descriptor for EXPR. */
857 gfc_init_se (&src_se
, NULL
);
858 gfc_conv_expr_descriptor (&src_se
, expr
, src_ss
);
859 gfc_add_block_to_block (&se
->pre
, &src_se
.pre
);
860 gfc_add_block_to_block (&se
->post
, &src_se
.post
);
863 /* Allocate a new descriptor for the return value. */
864 dest
= gfc_create_var (TREE_TYPE (src
), "atmp");
865 dest_info
->descriptor
= dest
;
868 /* Copy across the dtype field. */
869 gfc_add_modify (&se
->pre
,
870 gfc_conv_descriptor_dtype (dest
),
871 gfc_conv_descriptor_dtype (src
));
873 /* Copy the dimension information, renumbering dimension 1 to 0 and
875 for (n
= 0; n
< 2; n
++)
877 dest_info
->delta
[n
] = gfc_index_zero_node
;
878 dest_info
->start
[n
] = gfc_index_zero_node
;
879 dest_info
->end
[n
] = gfc_index_zero_node
;
880 dest_info
->stride
[n
] = gfc_index_one_node
;
881 dest_info
->dim
[n
] = n
;
883 dest_index
= gfc_rank_cst
[n
];
884 src_index
= gfc_rank_cst
[1 - n
];
886 gfc_conv_descriptor_stride_set (&se
->pre
, dest
, dest_index
,
887 gfc_conv_descriptor_stride_get (src
, src_index
));
889 gfc_conv_descriptor_lbound_set (&se
->pre
, dest
, dest_index
,
890 gfc_conv_descriptor_lbound_get (src
, src_index
));
892 gfc_conv_descriptor_ubound_set (&se
->pre
, dest
, dest_index
,
893 gfc_conv_descriptor_ubound_get (src
, src_index
));
897 gcc_assert (integer_zerop (loop
->from
[n
]));
899 fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
900 gfc_conv_descriptor_ubound_get (dest
, dest_index
),
901 gfc_conv_descriptor_lbound_get (dest
, dest_index
));
905 /* Copy the data pointer. */
906 dest_info
->data
= gfc_conv_descriptor_data_get (src
);
907 gfc_conv_descriptor_data_set (&se
->pre
, dest
, dest_info
->data
);
909 /* Copy the offset. This is not changed by transposition; the top-left
910 element is still at the same offset as before, except where the loop
912 if (!integer_zerop (loop
->from
[0]))
913 dest_info
->offset
= gfc_conv_descriptor_offset_get (src
);
915 dest_info
->offset
= gfc_index_zero_node
;
917 gfc_conv_descriptor_offset_set (&se
->pre
, dest
,
920 if (dest_info
->dimen
> loop
->temp_dim
)
921 loop
->temp_dim
= dest_info
->dimen
;
925 /* Return the number of iterations in a loop that starts at START,
926 ends at END, and has step STEP. */
929 gfc_get_iteration_count (tree start
, tree end
, tree step
)
934 type
= TREE_TYPE (step
);
935 tmp
= fold_build2 (MINUS_EXPR
, type
, end
, start
);
936 tmp
= fold_build2 (FLOOR_DIV_EXPR
, type
, tmp
, step
);
937 tmp
= fold_build2 (PLUS_EXPR
, type
, tmp
, build_int_cst (type
, 1));
938 tmp
= fold_build2 (MAX_EXPR
, type
, tmp
, build_int_cst (type
, 0));
939 return fold_convert (gfc_array_index_type
, tmp
);
943 /* Extend the data in array DESC by EXTRA elements. */
946 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
953 if (integer_zerop (extra
))
956 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
958 /* Add EXTRA to the upper bound. */
959 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, extra
);
960 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
962 /* Get the value of the current data pointer. */
963 arg0
= gfc_conv_descriptor_data_get (desc
);
965 /* Calculate the new array size. */
966 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
967 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
968 ubound
, gfc_index_one_node
);
969 arg1
= fold_build2 (MULT_EXPR
, size_type_node
,
970 fold_convert (size_type_node
, tmp
),
971 fold_convert (size_type_node
, size
));
973 /* Call the realloc() function. */
974 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
975 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
979 /* Return true if the bounds of iterator I can only be determined
983 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
985 return (i
->start
->expr_type
!= EXPR_CONSTANT
986 || i
->end
->expr_type
!= EXPR_CONSTANT
987 || i
->step
->expr_type
!= EXPR_CONSTANT
);
991 /* Split the size of constructor element EXPR into the sum of two terms,
992 one of which can be determined at compile time and one of which must
993 be calculated at run time. Set *SIZE to the former and return true
994 if the latter might be nonzero. */
997 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
999 if (expr
->expr_type
== EXPR_ARRAY
)
1000 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
1001 else if (expr
->rank
> 0)
1003 /* Calculate everything at run time. */
1004 mpz_set_ui (*size
, 0);
1009 /* A single element. */
1010 mpz_set_ui (*size
, 1);
1016 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1017 of array constructor C. */
1020 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1028 mpz_set_ui (*size
, 0);
1033 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1036 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1040 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1043 /* Multiply the static part of the element size by the
1044 number of iterations. */
1045 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1046 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1047 mpz_add_ui (val
, val
, 1);
1048 if (mpz_sgn (val
) > 0)
1049 mpz_mul (len
, len
, val
);
1051 mpz_set_ui (len
, 0);
1053 mpz_add (*size
, *size
, len
);
1062 /* Make sure offset is a variable. */
1065 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1068 /* We should have already created the offset variable. We cannot
1069 create it here because we may be in an inner scope. */
1070 gcc_assert (*offsetvar
!= NULL_TREE
);
1071 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1072 *poffset
= *offsetvar
;
1073 TREE_USED (*offsetvar
) = 1;
1077 /* Variables needed for bounds-checking. */
1078 static bool first_len
;
1079 static tree first_len_val
;
1080 static bool typespec_chararray_ctor
;
1083 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1084 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1088 gfc_conv_expr (se
, expr
);
1090 /* Store the value. */
1091 tmp
= build_fold_indirect_ref_loc (input_location
,
1092 gfc_conv_descriptor_data_get (desc
));
1093 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1095 if (expr
->ts
.type
== BT_CHARACTER
)
1097 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1100 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1101 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1102 esize
= fold_build2 (TRUNC_DIV_EXPR
, gfc_charlen_type_node
, esize
,
1103 build_int_cst (gfc_charlen_type_node
,
1104 gfc_character_kinds
[i
].bit_size
/ 8));
1106 gfc_conv_string_parameter (se
);
1107 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1109 /* The temporary is an array of pointers. */
1110 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1111 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1115 /* The temporary is an array of string values. */
1116 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1117 /* We know the temporary and the value will be the same length,
1118 so can use memcpy. */
1119 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1120 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1122 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1126 gfc_add_modify (&se
->pre
, first_len_val
,
1132 /* Verify that all constructor elements are of the same
1134 tree cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
1135 first_len_val
, se
->string_length
);
1136 gfc_trans_runtime_check
1137 (true, false, cond
, &se
->pre
, &expr
->where
,
1138 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1139 fold_convert (long_integer_type_node
, first_len_val
),
1140 fold_convert (long_integer_type_node
, se
->string_length
));
1146 /* TODO: Should the frontend already have done this conversion? */
1147 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1148 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1151 gfc_add_block_to_block (pblock
, &se
->pre
);
1152 gfc_add_block_to_block (pblock
, &se
->post
);
1156 /* Add the contents of an array to the constructor. DYNAMIC is as for
1157 gfc_trans_array_constructor_value. */
1160 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1161 tree type ATTRIBUTE_UNUSED
,
1162 tree desc
, gfc_expr
* expr
,
1163 tree
* poffset
, tree
* offsetvar
,
1174 /* We need this to be a variable so we can increment it. */
1175 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1177 gfc_init_se (&se
, NULL
);
1179 /* Walk the array expression. */
1180 ss
= gfc_walk_expr (expr
);
1181 gcc_assert (ss
!= gfc_ss_terminator
);
1183 /* Initialize the scalarizer. */
1184 gfc_init_loopinfo (&loop
);
1185 gfc_add_ss_to_loop (&loop
, ss
);
1187 /* Initialize the loop. */
1188 gfc_conv_ss_startstride (&loop
);
1189 gfc_conv_loop_setup (&loop
, &expr
->where
);
1191 /* Make sure the constructed array has room for the new data. */
1194 /* Set SIZE to the total number of elements in the subarray. */
1195 size
= gfc_index_one_node
;
1196 for (n
= 0; n
< loop
.dimen
; n
++)
1198 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1199 gfc_index_one_node
);
1200 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1203 /* Grow the constructed array by SIZE elements. */
1204 gfc_grow_array (&loop
.pre
, desc
, size
);
1207 /* Make the loop body. */
1208 gfc_mark_ss_chain_used (ss
, 1);
1209 gfc_start_scalarized_body (&loop
, &body
);
1210 gfc_copy_loopinfo_to_se (&se
, &loop
);
1213 gfc_trans_array_ctor_element (&body
, desc
, *poffset
, &se
, expr
);
1214 gcc_assert (se
.ss
== gfc_ss_terminator
);
1216 /* Increment the offset. */
1217 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1218 *poffset
, gfc_index_one_node
);
1219 gfc_add_modify (&body
, *poffset
, tmp
);
1221 /* Finish the loop. */
1222 gfc_trans_scalarizing_loops (&loop
, &body
);
1223 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1224 tmp
= gfc_finish_block (&loop
.pre
);
1225 gfc_add_expr_to_block (pblock
, tmp
);
1227 gfc_cleanup_loop (&loop
);
1231 /* Assign the values to the elements of an array constructor. DYNAMIC
1232 is true if descriptor DESC only contains enough data for the static
1233 size calculated by gfc_get_array_constructor_size. When true, memory
1234 for the dynamic parts must be allocated using realloc. */
1237 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
1238 tree desc
, gfc_constructor_base base
,
1239 tree
* poffset
, tree
* offsetvar
,
1248 tree shadow_loopvar
= NULL_TREE
;
1249 gfc_saved_var saved_loopvar
;
1252 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1254 /* If this is an iterator or an array, the offset must be a variable. */
1255 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
1256 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1258 /* Shadowing the iterator avoids changing its value and saves us from
1259 keeping track of it. Further, it makes sure that there's always a
1260 backend-decl for the symbol, even if there wasn't one before,
1261 e.g. in the case of an iterator that appears in a specification
1262 expression in an interface mapping. */
1265 gfc_symbol
*sym
= c
->iterator
->var
->symtree
->n
.sym
;
1266 tree type
= gfc_typenode_for_spec (&sym
->ts
);
1268 shadow_loopvar
= gfc_create_var (type
, "shadow_loopvar");
1269 gfc_shadow_sym (sym
, shadow_loopvar
, &saved_loopvar
);
1272 gfc_start_block (&body
);
1274 if (c
->expr
->expr_type
== EXPR_ARRAY
)
1276 /* Array constructors can be nested. */
1277 gfc_trans_array_constructor_value (&body
, type
, desc
,
1278 c
->expr
->value
.constructor
,
1279 poffset
, offsetvar
, dynamic
);
1281 else if (c
->expr
->rank
> 0)
1283 gfc_trans_array_constructor_subarray (&body
, type
, desc
, c
->expr
,
1284 poffset
, offsetvar
, dynamic
);
1288 /* This code really upsets the gimplifier so don't bother for now. */
1295 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
1297 p
= gfc_constructor_next (p
);
1302 /* Scalar values. */
1303 gfc_init_se (&se
, NULL
);
1304 gfc_trans_array_ctor_element (&body
, desc
, *poffset
,
1307 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1308 *poffset
, gfc_index_one_node
);
1312 /* Collect multiple scalar constants into a constructor. */
1313 VEC(constructor_elt
,gc
) *v
= NULL
;
1317 HOST_WIDE_INT idx
= 0;
1320 /* Count the number of consecutive scalar constants. */
1321 while (p
&& !(p
->iterator
1322 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1324 gfc_init_se (&se
, NULL
);
1325 gfc_conv_constant (&se
, p
->expr
);
1327 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1328 se
.expr
= fold_convert (type
, se
.expr
);
1329 /* For constant character array constructors we build
1330 an array of pointers. */
1331 else if (POINTER_TYPE_P (type
))
1332 se
.expr
= gfc_build_addr_expr
1333 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1336 CONSTRUCTOR_APPEND_ELT (v
,
1337 build_int_cst (gfc_array_index_type
,
1341 p
= gfc_constructor_next (p
);
1344 bound
= build_int_cst (NULL_TREE
, n
- 1);
1345 /* Create an array type to hold them. */
1346 tmptype
= build_range_type (gfc_array_index_type
,
1347 gfc_index_zero_node
, bound
);
1348 tmptype
= build_array_type (type
, tmptype
);
1350 init
= build_constructor (tmptype
, v
);
1351 TREE_CONSTANT (init
) = 1;
1352 TREE_STATIC (init
) = 1;
1353 /* Create a static variable to hold the data. */
1354 tmp
= gfc_create_var (tmptype
, "data");
1355 TREE_STATIC (tmp
) = 1;
1356 TREE_CONSTANT (tmp
) = 1;
1357 TREE_READONLY (tmp
) = 1;
1358 DECL_INITIAL (tmp
) = init
;
1361 /* Use BUILTIN_MEMCPY to assign the values. */
1362 tmp
= gfc_conv_descriptor_data_get (desc
);
1363 tmp
= build_fold_indirect_ref_loc (input_location
,
1365 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1366 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1367 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1369 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1370 bound
= build_int_cst (NULL_TREE
, n
* size
);
1371 tmp
= build_call_expr_loc (input_location
,
1372 built_in_decls
[BUILT_IN_MEMCPY
], 3,
1374 gfc_add_expr_to_block (&body
, tmp
);
1376 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1378 build_int_cst (gfc_array_index_type
, n
));
1380 if (!INTEGER_CST_P (*poffset
))
1382 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1383 *poffset
= *offsetvar
;
1387 /* The frontend should already have done any expansions
1391 /* Pass the code as is. */
1392 tmp
= gfc_finish_block (&body
);
1393 gfc_add_expr_to_block (pblock
, tmp
);
1397 /* Build the implied do-loop. */
1398 stmtblock_t implied_do_block
;
1406 loopbody
= gfc_finish_block (&body
);
1408 /* Create a new block that holds the implied-do loop. A temporary
1409 loop-variable is used. */
1410 gfc_start_block(&implied_do_block
);
1412 /* Initialize the loop. */
1413 gfc_init_se (&se
, NULL
);
1414 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1415 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1416 gfc_add_modify (&implied_do_block
, shadow_loopvar
, se
.expr
);
1418 gfc_init_se (&se
, NULL
);
1419 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1420 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1421 end
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1423 gfc_init_se (&se
, NULL
);
1424 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1425 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1426 step
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1428 /* If this array expands dynamically, and the number of iterations
1429 is not constant, we won't have allocated space for the static
1430 part of C->EXPR's size. Do that now. */
1431 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1433 /* Get the number of iterations. */
1434 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1436 /* Get the static part of C->EXPR's size. */
1437 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1438 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1440 /* Grow the array by TMP * TMP2 elements. */
1441 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, tmp2
);
1442 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1445 /* Generate the loop body. */
1446 exit_label
= gfc_build_label_decl (NULL_TREE
);
1447 gfc_start_block (&body
);
1449 /* Generate the exit condition. Depending on the sign of
1450 the step variable we have to generate the correct
1452 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
1453 build_int_cst (TREE_TYPE (step
), 0));
1454 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
1455 fold_build2 (GT_EXPR
, boolean_type_node
,
1456 shadow_loopvar
, end
),
1457 fold_build2 (LT_EXPR
, boolean_type_node
,
1458 shadow_loopvar
, end
));
1459 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1460 TREE_USED (exit_label
) = 1;
1461 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1462 build_empty_stmt (input_location
));
1463 gfc_add_expr_to_block (&body
, tmp
);
1465 /* The main loop body. */
1466 gfc_add_expr_to_block (&body
, loopbody
);
1468 /* Increase loop variable by step. */
1469 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (shadow_loopvar
), shadow_loopvar
, step
);
1470 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1472 /* Finish the loop. */
1473 tmp
= gfc_finish_block (&body
);
1474 tmp
= build1_v (LOOP_EXPR
, tmp
);
1475 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1477 /* Add the exit label. */
1478 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1479 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1481 /* Finishe the implied-do loop. */
1482 tmp
= gfc_finish_block(&implied_do_block
);
1483 gfc_add_expr_to_block(pblock
, tmp
);
1485 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1492 /* Figure out the string length of a variable reference expression.
1493 Used by get_array_ctor_strlen. */
1496 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1502 /* Don't bother if we already know the length is a constant. */
1503 if (*len
&& INTEGER_CST_P (*len
))
1506 ts
= &expr
->symtree
->n
.sym
->ts
;
1507 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1512 /* Array references don't change the string length. */
1516 /* Use the length of the component. */
1517 ts
= &ref
->u
.c
.component
->ts
;
1521 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1522 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1524 mpz_init_set_ui (char_len
, 1);
1525 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1526 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1527 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1528 *len
= convert (gfc_charlen_type_node
, *len
);
1529 mpz_clear (char_len
);
1533 /* TODO: Substrings are tricky because we can't evaluate the
1534 expression more than once. For now we just give up, and hope
1535 we can figure it out elsewhere. */
1540 *len
= ts
->u
.cl
->backend_decl
;
1544 /* A catch-all to obtain the string length for anything that is not a
1545 constant, array or variable. */
1547 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1552 /* Don't bother if we already know the length is a constant. */
1553 if (*len
&& INTEGER_CST_P (*len
))
1556 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1557 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1560 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1561 *len
= e
->ts
.u
.cl
->backend_decl
;
1565 /* Otherwise, be brutal even if inefficient. */
1566 ss
= gfc_walk_expr (e
);
1567 gfc_init_se (&se
, NULL
);
1569 /* No function call, in case of side effects. */
1570 se
.no_function_call
= 1;
1571 if (ss
== gfc_ss_terminator
)
1572 gfc_conv_expr (&se
, e
);
1574 gfc_conv_expr_descriptor (&se
, e
, ss
);
1576 /* Fix the value. */
1577 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1579 gfc_add_block_to_block (block
, &se
.pre
);
1580 gfc_add_block_to_block (block
, &se
.post
);
1582 e
->ts
.u
.cl
->backend_decl
= *len
;
1587 /* Figure out the string length of a character array constructor.
1588 If len is NULL, don't calculate the length; this happens for recursive calls
1589 when a sub-array-constructor is an element but not at the first position,
1590 so when we're not interested in the length.
1591 Returns TRUE if all elements are character constants. */
1594 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1601 if (gfc_constructor_first (base
) == NULL
)
1604 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1608 /* Loop over all constructor elements to find out is_const, but in len we
1609 want to store the length of the first, not the last, element. We can
1610 of course exit the loop as soon as is_const is found to be false. */
1611 for (c
= gfc_constructor_first (base
);
1612 c
&& is_const
; c
= gfc_constructor_next (c
))
1614 switch (c
->expr
->expr_type
)
1617 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1618 *len
= build_int_cstu (gfc_charlen_type_node
,
1619 c
->expr
->value
.character
.length
);
1623 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1630 get_array_ctor_var_strlen (c
->expr
, len
);
1636 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1640 /* After the first iteration, we don't want the length modified. */
1647 /* Check whether the array constructor C consists entirely of constant
1648 elements, and if so returns the number of those elements, otherwise
1649 return zero. Note, an empty or NULL array constructor returns zero. */
1651 unsigned HOST_WIDE_INT
1652 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1654 unsigned HOST_WIDE_INT nelem
= 0;
1656 gfc_constructor
*c
= gfc_constructor_first (base
);
1660 || c
->expr
->rank
> 0
1661 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1663 c
= gfc_constructor_next (c
);
1670 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1671 and the tree type of it's elements, TYPE, return a static constant
1672 variable that is compile-time initialized. */
1675 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1677 tree tmptype
, init
, tmp
;
1678 HOST_WIDE_INT nelem
;
1683 VEC(constructor_elt
,gc
) *v
= NULL
;
1685 /* First traverse the constructor list, converting the constants
1686 to tree to build an initializer. */
1688 c
= gfc_constructor_first (expr
->value
.constructor
);
1691 gfc_init_se (&se
, NULL
);
1692 gfc_conv_constant (&se
, c
->expr
);
1693 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1694 se
.expr
= fold_convert (type
, se
.expr
);
1695 else if (POINTER_TYPE_P (type
))
1696 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
1698 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
1700 c
= gfc_constructor_next (c
);
1704 /* Next determine the tree type for the array. We use the gfortran
1705 front-end's gfc_get_nodesc_array_type in order to create a suitable
1706 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1708 memset (&as
, 0, sizeof (gfc_array_spec
));
1710 as
.rank
= expr
->rank
;
1711 as
.type
= AS_EXPLICIT
;
1714 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1715 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
1719 for (i
= 0; i
< expr
->rank
; i
++)
1721 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1722 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1723 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1727 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
1729 init
= build_constructor (tmptype
, v
);
1731 TREE_CONSTANT (init
) = 1;
1732 TREE_STATIC (init
) = 1;
1734 tmp
= gfc_create_var (tmptype
, "A");
1735 TREE_STATIC (tmp
) = 1;
1736 TREE_CONSTANT (tmp
) = 1;
1737 TREE_READONLY (tmp
) = 1;
1738 DECL_INITIAL (tmp
) = init
;
1744 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1745 This mostly initializes the scalarizer state info structure with the
1746 appropriate values to directly use the array created by the function
1747 gfc_build_constant_array_constructor. */
1750 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1751 gfc_ss
* ss
, tree type
)
1757 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1759 info
= &ss
->data
.info
;
1761 info
->descriptor
= tmp
;
1762 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1763 info
->offset
= gfc_index_zero_node
;
1765 for (i
= 0; i
< info
->dimen
; i
++)
1767 info
->delta
[i
] = gfc_index_zero_node
;
1768 info
->start
[i
] = gfc_index_zero_node
;
1769 info
->end
[i
] = gfc_index_zero_node
;
1770 info
->stride
[i
] = gfc_index_one_node
;
1774 if (info
->dimen
> loop
->temp_dim
)
1775 loop
->temp_dim
= info
->dimen
;
1778 /* Helper routine of gfc_trans_array_constructor to determine if the
1779 bounds of the loop specified by LOOP are constant and simple enough
1780 to use with gfc_trans_constant_array_constructor. Returns the
1781 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1784 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1786 tree size
= gfc_index_one_node
;
1790 for (i
= 0; i
< loop
->dimen
; i
++)
1792 /* If the bounds aren't constant, return NULL_TREE. */
1793 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1795 if (!integer_zerop (loop
->from
[i
]))
1797 /* Only allow nonzero "from" in one-dimensional arrays. */
1798 if (loop
->dimen
!= 1)
1800 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1801 loop
->to
[i
], loop
->from
[i
]);
1805 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1806 tmp
, gfc_index_one_node
);
1807 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1814 /* Array constructors are handled by constructing a temporary, then using that
1815 within the scalarization loop. This is not optimal, but seems by far the
1819 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
, locus
* where
)
1821 gfc_constructor_base c
;
1827 bool old_first_len
, old_typespec_chararray_ctor
;
1828 tree old_first_len_val
;
1830 /* Save the old values for nested checking. */
1831 old_first_len
= first_len
;
1832 old_first_len_val
= first_len_val
;
1833 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
1835 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1836 typespec was given for the array constructor. */
1837 typespec_chararray_ctor
= (ss
->expr
->ts
.u
.cl
1838 && ss
->expr
->ts
.u
.cl
->length_from_typespec
);
1840 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1841 && ss
->expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
1843 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
1847 ss
->data
.info
.dimen
= loop
->dimen
;
1849 c
= ss
->expr
->value
.constructor
;
1850 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1854 /* get_array_ctor_strlen walks the elements of the constructor, if a
1855 typespec was given, we already know the string length and want the one
1857 if (typespec_chararray_ctor
&& ss
->expr
->ts
.u
.cl
->length
1858 && ss
->expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1862 const_string
= false;
1863 gfc_init_se (&length_se
, NULL
);
1864 gfc_conv_expr_type (&length_se
, ss
->expr
->ts
.u
.cl
->length
,
1865 gfc_charlen_type_node
);
1866 ss
->string_length
= length_se
.expr
;
1867 gfc_add_block_to_block (&loop
->pre
, &length_se
.pre
);
1868 gfc_add_block_to_block (&loop
->post
, &length_se
.post
);
1871 const_string
= get_array_ctor_strlen (&loop
->pre
, c
,
1872 &ss
->string_length
);
1874 /* Complex character array constructors should have been taken care of
1875 and not end up here. */
1876 gcc_assert (ss
->string_length
);
1878 ss
->expr
->ts
.u
.cl
->backend_decl
= ss
->string_length
;
1880 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1882 type
= build_pointer_type (type
);
1885 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1887 /* See if the constructor determines the loop bounds. */
1890 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1892 /* We have a multidimensional parameter. */
1894 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1896 loop
->from
[n
] = gfc_index_zero_node
;
1897 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1898 gfc_index_integer_kind
);
1899 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1900 loop
->to
[n
], gfc_index_one_node
);
1904 if (loop
->to
[0] == NULL_TREE
)
1908 /* We should have a 1-dimensional, zero-based loop. */
1909 gcc_assert (loop
->dimen
== 1);
1910 gcc_assert (integer_zerop (loop
->from
[0]));
1912 /* Split the constructor size into a static part and a dynamic part.
1913 Allocate the static size up-front and record whether the dynamic
1914 size might be nonzero. */
1916 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1917 mpz_sub_ui (size
, size
, 1);
1918 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1922 /* Special case constant array constructors. */
1925 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1928 tree size
= constant_array_constructor_loop_size (loop
);
1929 if (size
&& compare_tree_int (size
, nelem
) == 0)
1931 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1937 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1938 type
, NULL_TREE
, dynamic
, true, false, where
);
1940 desc
= ss
->data
.info
.descriptor
;
1941 offset
= gfc_index_zero_node
;
1942 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1943 TREE_NO_WARNING (offsetvar
) = 1;
1944 TREE_USED (offsetvar
) = 0;
1945 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1946 &offset
, &offsetvar
, dynamic
);
1948 /* If the array grows dynamically, the upper bound of the loop variable
1949 is determined by the array's final upper bound. */
1951 loop
->to
[0] = gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1953 if (TREE_USED (offsetvar
))
1954 pushdecl (offsetvar
);
1956 gcc_assert (INTEGER_CST_P (offset
));
1958 /* Disable bound checking for now because it's probably broken. */
1959 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1966 /* Restore old values of globals. */
1967 first_len
= old_first_len
;
1968 first_len_val
= old_first_len_val
;
1969 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
1973 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1974 called after evaluating all of INFO's vector dimensions. Go through
1975 each such vector dimension and see if we can now fill in any missing
1979 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
1988 for (n
= 0; n
< loop
->dimen
; n
++)
1991 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
1992 && loop
->to
[n
] == NULL
)
1994 /* Loop variable N indexes vector dimension DIM, and we don't
1995 yet know the upper bound of loop variable N. Set it to the
1996 difference between the vector's upper and lower bounds. */
1997 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
1998 gcc_assert (info
->subscript
[dim
]
1999 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2001 gfc_init_se (&se
, NULL
);
2002 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2003 zero
= gfc_rank_cst
[0];
2004 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2005 gfc_conv_descriptor_ubound_get (desc
, zero
),
2006 gfc_conv_descriptor_lbound_get (desc
, zero
));
2007 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
2014 /* Add the pre and post chains for all the scalar expressions in a SS chain
2015 to loop. This is called after the loop parameters have been calculated,
2016 but before the actual scalarizing loops. */
2019 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2025 /* TODO: This can generate bad code if there are ordering dependencies,
2026 e.g., a callee allocated function and an unknown size constructor. */
2027 gcc_assert (ss
!= NULL
);
2029 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2036 /* Scalar expression. Evaluate this now. This includes elemental
2037 dimension indices, but not array section bounds. */
2038 gfc_init_se (&se
, NULL
);
2039 gfc_conv_expr (&se
, ss
->expr
);
2040 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2042 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
2044 /* Move the evaluation of scalar expressions outside the
2045 scalarization loop, except for WHERE assignments. */
2047 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2049 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2050 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
2053 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2055 ss
->data
.scalar
.expr
= se
.expr
;
2056 ss
->string_length
= se
.string_length
;
2059 case GFC_SS_REFERENCE
:
2060 /* Scalar argument to elemental procedure. Evaluate this
2062 gfc_init_se (&se
, NULL
);
2063 gfc_conv_expr (&se
, ss
->expr
);
2064 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2065 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2067 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2068 ss
->string_length
= se
.string_length
;
2071 case GFC_SS_SECTION
:
2072 /* Add the expressions for scalar and vector subscripts. */
2073 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2074 if (ss
->data
.info
.subscript
[n
])
2075 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true,
2078 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
2082 /* Get the vector's descriptor and store it in SS. */
2083 gfc_init_se (&se
, NULL
);
2084 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
2085 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2086 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2087 ss
->data
.info
.descriptor
= se
.expr
;
2090 case GFC_SS_INTRINSIC
:
2091 gfc_add_intrinsic_ss_code (loop
, ss
);
2094 case GFC_SS_FUNCTION
:
2095 /* Array function return value. We call the function and save its
2096 result in a temporary for use inside the loop. */
2097 gfc_init_se (&se
, NULL
);
2100 gfc_conv_expr (&se
, ss
->expr
);
2101 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2102 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2103 ss
->string_length
= se
.string_length
;
2106 case GFC_SS_CONSTRUCTOR
:
2107 if (ss
->expr
->ts
.type
== BT_CHARACTER
2108 && ss
->string_length
== NULL
2109 && ss
->expr
->ts
.u
.cl
2110 && ss
->expr
->ts
.u
.cl
->length
)
2112 gfc_init_se (&se
, NULL
);
2113 gfc_conv_expr_type (&se
, ss
->expr
->ts
.u
.cl
->length
,
2114 gfc_charlen_type_node
);
2115 ss
->string_length
= se
.expr
;
2116 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2117 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2119 gfc_trans_array_constructor (loop
, ss
, where
);
2123 case GFC_SS_COMPONENT
:
2124 /* Do nothing. These are handled elsewhere. */
2134 /* Translate expressions for the descriptor and data pointer of a SS. */
2138 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2143 /* Get the descriptor for the array to be scalarized. */
2144 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
2145 gfc_init_se (&se
, NULL
);
2146 se
.descriptor_only
= 1;
2147 gfc_conv_expr_lhs (&se
, ss
->expr
);
2148 gfc_add_block_to_block (block
, &se
.pre
);
2149 ss
->data
.info
.descriptor
= se
.expr
;
2150 ss
->string_length
= se
.string_length
;
2154 /* Also the data pointer. */
2155 tmp
= gfc_conv_array_data (se
.expr
);
2156 /* If this is a variable or address of a variable we use it directly.
2157 Otherwise we must evaluate it now to avoid breaking dependency
2158 analysis by pulling the expressions for elemental array indices
2161 || (TREE_CODE (tmp
) == ADDR_EXPR
2162 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2163 tmp
= gfc_evaluate_now (tmp
, block
);
2164 ss
->data
.info
.data
= tmp
;
2166 tmp
= gfc_conv_array_offset (se
.expr
);
2167 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
2172 /* Initialize a gfc_loopinfo structure. */
2175 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2179 memset (loop
, 0, sizeof (gfc_loopinfo
));
2180 gfc_init_block (&loop
->pre
);
2181 gfc_init_block (&loop
->post
);
2183 /* Initially scalarize in order. */
2184 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2187 loop
->ss
= gfc_ss_terminator
;
2191 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2195 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2201 /* Return an expression for the data pointer of an array. */
2204 gfc_conv_array_data (tree descriptor
)
2208 type
= TREE_TYPE (descriptor
);
2209 if (GFC_ARRAY_TYPE_P (type
))
2211 if (TREE_CODE (type
) == POINTER_TYPE
)
2215 /* Descriptorless arrays. */
2216 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2220 return gfc_conv_descriptor_data_get (descriptor
);
2224 /* Return an expression for the base offset of an array. */
2227 gfc_conv_array_offset (tree descriptor
)
2231 type
= TREE_TYPE (descriptor
);
2232 if (GFC_ARRAY_TYPE_P (type
))
2233 return GFC_TYPE_ARRAY_OFFSET (type
);
2235 return gfc_conv_descriptor_offset_get (descriptor
);
2239 /* Get an expression for the array stride. */
2242 gfc_conv_array_stride (tree descriptor
, int dim
)
2247 type
= TREE_TYPE (descriptor
);
2249 /* For descriptorless arrays use the array size. */
2250 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2251 if (tmp
!= NULL_TREE
)
2254 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2259 /* Like gfc_conv_array_stride, but for the lower bound. */
2262 gfc_conv_array_lbound (tree descriptor
, int dim
)
2267 type
= TREE_TYPE (descriptor
);
2269 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2270 if (tmp
!= NULL_TREE
)
2273 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2278 /* Like gfc_conv_array_stride, but for the upper bound. */
2281 gfc_conv_array_ubound (tree descriptor
, int dim
)
2286 type
= TREE_TYPE (descriptor
);
2288 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2289 if (tmp
!= NULL_TREE
)
2292 /* This should only ever happen when passing an assumed shape array
2293 as an actual parameter. The value will never be used. */
2294 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2295 return gfc_index_zero_node
;
2297 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2302 /* Generate code to perform an array index bound check. */
2305 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2306 locus
* where
, bool check_upper
)
2309 tree tmp_lo
, tmp_up
;
2311 const char * name
= NULL
;
2313 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2316 index
= gfc_evaluate_now (index
, &se
->pre
);
2318 /* We find a name for the error message. */
2320 name
= se
->ss
->expr
->symtree
->name
;
2322 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2323 && se
->loop
->ss
->expr
->symtree
)
2324 name
= se
->loop
->ss
->expr
->symtree
->name
;
2326 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2327 && se
->loop
->ss
->loop_chain
->expr
2328 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2329 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2331 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2333 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2334 && se
->loop
->ss
->expr
->value
.function
.name
)
2335 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2337 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2338 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2339 name
= "unnamed constant";
2342 if (TREE_CODE (descriptor
) == VAR_DECL
)
2343 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2345 /* If upper bound is present, include both bounds in the error message. */
2348 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2349 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2352 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2353 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2355 asprintf (&msg
, "Index '%%ld' of dimension %d "
2356 "outside of expected range (%%ld:%%ld)", n
+1);
2358 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp_lo
);
2359 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2360 fold_convert (long_integer_type_node
, index
),
2361 fold_convert (long_integer_type_node
, tmp_lo
),
2362 fold_convert (long_integer_type_node
, tmp_up
));
2363 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp_up
);
2364 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2365 fold_convert (long_integer_type_node
, index
),
2366 fold_convert (long_integer_type_node
, tmp_lo
),
2367 fold_convert (long_integer_type_node
, tmp_up
));
2372 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2375 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2376 "below lower bound of %%ld", n
+1, name
);
2378 asprintf (&msg
, "Index '%%ld' of dimension %d "
2379 "below lower bound of %%ld", n
+1);
2381 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp_lo
);
2382 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2383 fold_convert (long_integer_type_node
, index
),
2384 fold_convert (long_integer_type_node
, tmp_lo
));
2392 /* Return the offset for an index. Performs bound checking for elemental
2393 dimensions. Single element references are processed separately.
2394 DIM is the array dimension, I is the loop dimension. */
2397 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2398 gfc_array_ref
* ar
, tree stride
)
2404 /* Get the index into the array for this dimension. */
2407 gcc_assert (ar
->type
!= AR_ELEMENT
);
2408 switch (ar
->dimen_type
[dim
])
2411 /* Elemental dimension. */
2412 gcc_assert (info
->subscript
[dim
]
2413 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2414 /* We've already translated this value outside the loop. */
2415 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2417 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2418 index
, dim
, &ar
->where
,
2419 ar
->as
->type
!= AS_ASSUMED_SIZE
2420 || dim
< ar
->dimen
- 1);
2424 gcc_assert (info
&& se
->loop
);
2425 gcc_assert (info
->subscript
[dim
]
2426 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2427 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2429 /* Get a zero-based index into the vector. */
2430 index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2431 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2433 /* Multiply the index by the stride. */
2434 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2435 index
, gfc_conv_array_stride (desc
, 0));
2437 /* Read the vector to get an index into info->descriptor. */
2438 data
= build_fold_indirect_ref_loc (input_location
,
2439 gfc_conv_array_data (desc
));
2440 index
= gfc_build_array_ref (data
, index
, NULL
);
2441 index
= gfc_evaluate_now (index
, &se
->pre
);
2442 index
= fold_convert (gfc_array_index_type
, index
);
2444 /* Do any bounds checking on the final info->descriptor index. */
2445 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2446 index
, dim
, &ar
->where
,
2447 ar
->as
->type
!= AS_ASSUMED_SIZE
2448 || dim
< ar
->dimen
- 1);
2452 /* Scalarized dimension. */
2453 gcc_assert (info
&& se
->loop
);
2455 /* Multiply the loop variable by the stride and delta. */
2456 index
= se
->loop
->loopvar
[i
];
2457 if (!integer_onep (info
->stride
[dim
]))
2458 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
2460 if (!integer_zerop (info
->delta
[dim
]))
2461 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
2471 /* Temporary array or derived type component. */
2472 gcc_assert (se
->loop
);
2473 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2474 if (!integer_zerop (info
->delta
[dim
]))
2475 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2476 index
, info
->delta
[dim
]);
2479 /* Multiply by the stride. */
2480 if (!integer_onep (stride
))
2481 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
2487 /* Build a scalarized reference to an array. */
2490 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2493 tree decl
= NULL_TREE
;
2498 info
= &se
->ss
->data
.info
;
2500 n
= se
->loop
->order
[0];
2504 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2506 /* Add the offset for this dimension to the stored offset for all other
2508 if (!integer_zerop (info
->offset
))
2509 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
2511 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2512 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2514 tmp
= build_fold_indirect_ref_loc (input_location
,
2516 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2520 /* Translate access of temporary array. */
2523 gfc_conv_tmp_array_ref (gfc_se
* se
)
2525 se
->string_length
= se
->ss
->string_length
;
2526 gfc_conv_scalarized_array_ref (se
, NULL
);
2530 /* Build an array reference. se->expr already holds the array descriptor.
2531 This should be either a variable, indirect variable reference or component
2532 reference. For arrays which do not have a descriptor, se->expr will be
2534 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2537 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2550 /* Handle scalarized references separately. */
2551 if (ar
->type
!= AR_ELEMENT
)
2553 gfc_conv_scalarized_array_ref (se
, ar
);
2554 gfc_advance_se_ss_chain (se
);
2558 index
= gfc_index_zero_node
;
2560 /* Calculate the offsets from all the dimensions. */
2561 for (n
= 0; n
< ar
->dimen
; n
++)
2563 /* Calculate the index for this dimension. */
2564 gfc_init_se (&indexse
, se
);
2565 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2566 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2568 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2570 /* Check array bounds. */
2574 /* Evaluate the indexse.expr only once. */
2575 indexse
.expr
= save_expr (indexse
.expr
);
2578 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2579 if (sym
->attr
.temporary
)
2581 gfc_init_se (&tmpse
, se
);
2582 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
2583 gfc_array_index_type
);
2584 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2588 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
2590 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2591 "below lower bound of %%ld", n
+1, sym
->name
);
2592 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2593 fold_convert (long_integer_type_node
,
2595 fold_convert (long_integer_type_node
, tmp
));
2598 /* Upper bound, but not for the last dimension of assumed-size
2600 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
2602 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2603 if (sym
->attr
.temporary
)
2605 gfc_init_se (&tmpse
, se
);
2606 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
2607 gfc_array_index_type
);
2608 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2612 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2614 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2615 "above upper bound of %%ld", n
+1, sym
->name
);
2616 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2617 fold_convert (long_integer_type_node
,
2619 fold_convert (long_integer_type_node
, tmp
));
2624 /* Multiply the index by the stride. */
2625 stride
= gfc_conv_array_stride (se
->expr
, n
);
2626 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
2629 /* And add it to the total. */
2630 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2633 tmp
= gfc_conv_array_offset (se
->expr
);
2634 if (!integer_zerop (tmp
))
2635 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
2637 /* Access the calculated element. */
2638 tmp
= gfc_conv_array_data (se
->expr
);
2639 tmp
= build_fold_indirect_ref (tmp
);
2640 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2644 /* Generate the code to be executed immediately before entering a
2645 scalarization loop. */
2648 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2649 stmtblock_t
* pblock
)
2658 /* This code will be executed before entering the scalarization loop
2659 for this dimension. */
2660 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2662 if ((ss
->useflags
& flag
) == 0)
2665 if (ss
->type
!= GFC_SS_SECTION
2666 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2667 && ss
->type
!= GFC_SS_COMPONENT
)
2670 info
= &ss
->data
.info
;
2672 if (dim
>= info
->dimen
)
2675 if (dim
== info
->dimen
- 1)
2677 /* For the outermost loop calculate the offset due to any
2678 elemental dimensions. It will have been initialized with the
2679 base offset of the array. */
2682 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2684 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2687 gfc_init_se (&se
, NULL
);
2689 se
.expr
= info
->descriptor
;
2690 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2691 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2694 gfc_add_block_to_block (pblock
, &se
.pre
);
2696 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2697 info
->offset
, index
);
2698 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2702 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2705 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
2707 /* Calculate the stride of the innermost loop. Hopefully this will
2708 allow the backend optimizers to do their stuff more effectively.
2710 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2714 /* Add the offset for the previous loop dimension. */
2719 ar
= &info
->ref
->u
.ar
;
2720 i
= loop
->order
[dim
+ 1];
2728 gfc_init_se (&se
, NULL
);
2730 se
.expr
= info
->descriptor
;
2731 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2732 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2734 gfc_add_block_to_block (pblock
, &se
.pre
);
2735 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2736 info
->offset
, index
);
2737 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2740 /* Remember this offset for the second loop. */
2741 if (dim
== loop
->temp_dim
- 1)
2742 info
->saved_offset
= info
->offset
;
2747 /* Start a scalarized expression. Creates a scope and declares loop
2751 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2757 gcc_assert (!loop
->array_parameter
);
2759 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2761 n
= loop
->order
[dim
];
2763 gfc_start_block (&loop
->code
[n
]);
2765 /* Create the loop variable. */
2766 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2768 if (dim
< loop
->temp_dim
)
2772 /* Calculate values that will be constant within this loop. */
2773 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2775 gfc_start_block (pbody
);
2779 /* Generates the actual loop code for a scalarization loop. */
2782 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2783 stmtblock_t
* pbody
)
2794 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
2795 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
2796 && n
== loop
->dimen
- 1)
2798 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2799 init
= make_tree_vec (1);
2800 cond
= make_tree_vec (1);
2801 incr
= make_tree_vec (1);
2803 /* Cycle statement is implemented with a goto. Exit statement must not
2804 be present for this loop. */
2805 exit_label
= gfc_build_label_decl (NULL_TREE
);
2806 TREE_USED (exit_label
) = 1;
2808 /* Label for cycle statements (if needed). */
2809 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2810 gfc_add_expr_to_block (pbody
, tmp
);
2812 stmt
= make_node (OMP_FOR
);
2814 TREE_TYPE (stmt
) = void_type_node
;
2815 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
2817 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
2818 OMP_CLAUSE_SCHEDULE
);
2819 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
2820 = OMP_CLAUSE_SCHEDULE_STATIC
;
2821 if (ompws_flags
& OMPWS_NOWAIT
)
2822 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
2823 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
2825 /* Initialize the loopvar. */
2826 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
2828 OMP_FOR_INIT (stmt
) = init
;
2829 /* The exit condition. */
2830 TREE_VEC_ELT (cond
, 0) = build2 (LE_EXPR
, boolean_type_node
,
2831 loop
->loopvar
[n
], loop
->to
[n
]);
2832 OMP_FOR_COND (stmt
) = cond
;
2833 /* Increment the loopvar. */
2834 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2835 loop
->loopvar
[n
], gfc_index_one_node
);
2836 TREE_VEC_ELT (incr
, 0) = fold_build2 (MODIFY_EXPR
,
2837 void_type_node
, loop
->loopvar
[n
], tmp
);
2838 OMP_FOR_INCR (stmt
) = incr
;
2840 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
2841 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
2845 loopbody
= gfc_finish_block (pbody
);
2847 /* Initialize the loopvar. */
2848 if (loop
->loopvar
[n
] != loop
->from
[n
])
2849 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2851 exit_label
= gfc_build_label_decl (NULL_TREE
);
2853 /* Generate the loop body. */
2854 gfc_init_block (&block
);
2856 /* The exit condition. */
2857 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
2858 loop
->loopvar
[n
], loop
->to
[n
]);
2859 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2860 TREE_USED (exit_label
) = 1;
2861 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2862 gfc_add_expr_to_block (&block
, tmp
);
2864 /* The main body. */
2865 gfc_add_expr_to_block (&block
, loopbody
);
2867 /* Increment the loopvar. */
2868 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2869 loop
->loopvar
[n
], gfc_index_one_node
);
2870 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
2872 /* Build the loop. */
2873 tmp
= gfc_finish_block (&block
);
2874 tmp
= build1_v (LOOP_EXPR
, tmp
);
2875 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2877 /* Add the exit label. */
2878 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2879 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2885 /* Finishes and generates the loops for a scalarized expression. */
2888 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2893 stmtblock_t
*pblock
;
2897 /* Generate the loops. */
2898 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2900 n
= loop
->order
[dim
];
2901 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2902 loop
->loopvar
[n
] = NULL_TREE
;
2903 pblock
= &loop
->code
[n
];
2906 tmp
= gfc_finish_block (pblock
);
2907 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2909 /* Clear all the used flags. */
2910 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2915 /* Finish the main body of a scalarized expression, and start the secondary
2919 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2923 stmtblock_t
*pblock
;
2927 /* We finish as many loops as are used by the temporary. */
2928 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2930 n
= loop
->order
[dim
];
2931 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2932 loop
->loopvar
[n
] = NULL_TREE
;
2933 pblock
= &loop
->code
[n
];
2936 /* We don't want to finish the outermost loop entirely. */
2937 n
= loop
->order
[loop
->temp_dim
- 1];
2938 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2940 /* Restore the initial offsets. */
2941 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2943 if ((ss
->useflags
& 2) == 0)
2946 if (ss
->type
!= GFC_SS_SECTION
2947 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2948 && ss
->type
!= GFC_SS_COMPONENT
)
2951 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
2954 /* Restart all the inner loops we just finished. */
2955 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
2957 n
= loop
->order
[dim
];
2959 gfc_start_block (&loop
->code
[n
]);
2961 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
2963 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
2966 /* Start a block for the secondary copying code. */
2967 gfc_start_block (body
);
2971 /* Calculate the lower bound of an array section. */
2974 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
2983 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2985 info
= &ss
->data
.info
;
2987 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2989 /* We use a zero-based index to access the vector. */
2990 info
->start
[dim
] = gfc_index_zero_node
;
2991 info
->stride
[dim
] = gfc_index_one_node
;
2992 info
->end
[dim
] = NULL
;
2996 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2997 desc
= info
->descriptor
;
2998 start
= info
->ref
->u
.ar
.start
[dim
];
2999 end
= info
->ref
->u
.ar
.end
[dim
];
3000 stride
= info
->ref
->u
.ar
.stride
[dim
];
3002 /* Calculate the start of the range. For vector subscripts this will
3003 be the range of the vector. */
3006 /* Specified section start. */
3007 gfc_init_se (&se
, NULL
);
3008 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
3009 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3010 info
->start
[dim
] = se
.expr
;
3014 /* No lower bound specified so use the bound of the array. */
3015 info
->start
[dim
] = gfc_conv_array_lbound (desc
, dim
);
3017 info
->start
[dim
] = gfc_evaluate_now (info
->start
[dim
], &loop
->pre
);
3019 /* Similarly calculate the end. Although this is not used in the
3020 scalarizer, it is needed when checking bounds and where the end
3021 is an expression with side-effects. */
3024 /* Specified section start. */
3025 gfc_init_se (&se
, NULL
);
3026 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
3027 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3028 info
->end
[dim
] = se
.expr
;
3032 /* No upper bound specified so use the bound of the array. */
3033 info
->end
[dim
] = gfc_conv_array_ubound (desc
, dim
);
3035 info
->end
[dim
] = gfc_evaluate_now (info
->end
[dim
], &loop
->pre
);
3037 /* Calculate the stride. */
3039 info
->stride
[dim
] = gfc_index_one_node
;
3042 gfc_init_se (&se
, NULL
);
3043 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3044 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3045 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3050 /* Calculates the range start and stride for a SS chain. Also gets the
3051 descriptor and data pointer. The range of vector subscripts is the size
3052 of the vector. Array bounds are also checked. */
3055 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3063 /* Determine the rank of the loop. */
3065 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
3069 case GFC_SS_SECTION
:
3070 case GFC_SS_CONSTRUCTOR
:
3071 case GFC_SS_FUNCTION
:
3072 case GFC_SS_COMPONENT
:
3073 loop
->dimen
= ss
->data
.info
.dimen
;
3076 /* As usual, lbound and ubound are exceptions!. */
3077 case GFC_SS_INTRINSIC
:
3078 switch (ss
->expr
->value
.function
.isym
->id
)
3080 case GFC_ISYM_LBOUND
:
3081 case GFC_ISYM_UBOUND
:
3082 loop
->dimen
= ss
->data
.info
.dimen
;
3093 /* We should have determined the rank of the expression by now. If
3094 not, that's bad news. */
3095 gcc_assert (loop
->dimen
!= 0);
3097 /* Loop over all the SS in the chain. */
3098 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3100 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
3101 ss
->shape
= ss
->expr
->shape
;
3105 case GFC_SS_SECTION
:
3106 /* Get the descriptor for the array. */
3107 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3109 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3110 gfc_conv_section_startstride (loop
, ss
, ss
->data
.info
.dim
[n
]);
3113 case GFC_SS_INTRINSIC
:
3114 switch (ss
->expr
->value
.function
.isym
->id
)
3116 /* Fall through to supply start and stride. */
3117 case GFC_ISYM_LBOUND
:
3118 case GFC_ISYM_UBOUND
:
3124 case GFC_SS_CONSTRUCTOR
:
3125 case GFC_SS_FUNCTION
:
3126 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3128 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
3129 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
3130 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3139 /* The rest is just runtime bound checking. */
3140 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3143 tree lbound
, ubound
;
3145 tree size
[GFC_MAX_DIMENSIONS
];
3146 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3151 gfc_start_block (&block
);
3153 for (n
= 0; n
< loop
->dimen
; n
++)
3154 size
[n
] = NULL_TREE
;
3156 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3160 if (ss
->type
!= GFC_SS_SECTION
)
3163 gfc_start_block (&inner
);
3165 /* TODO: range checking for mapped dimensions. */
3166 info
= &ss
->data
.info
;
3168 /* This code only checks ranges. Elemental and vector
3169 dimensions are checked later. */
3170 for (n
= 0; n
< loop
->dimen
; n
++)
3175 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3178 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3179 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3180 check_upper
= false;
3184 /* Zero stride is not allowed. */
3185 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, info
->stride
[dim
],
3186 gfc_index_zero_node
);
3187 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3188 "of array '%s'", dim
+ 1, ss
->expr
->symtree
->name
);
3189 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3190 &ss
->expr
->where
, msg
);
3193 desc
= ss
->data
.info
.descriptor
;
3195 /* This is the run-time equivalent of resolve.c's
3196 check_dimension(). The logical is more readable there
3197 than it is here, with all the trees. */
3198 lbound
= gfc_conv_array_lbound (desc
, dim
);
3199 end
= info
->end
[dim
];
3201 ubound
= gfc_conv_array_ubound (desc
, dim
);
3205 /* non_zerosized is true when the selected range is not
3207 stride_pos
= fold_build2 (GT_EXPR
, boolean_type_node
,
3208 info
->stride
[dim
], gfc_index_zero_node
);
3209 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, info
->start
[dim
],
3211 stride_pos
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3214 stride_neg
= fold_build2 (LT_EXPR
, boolean_type_node
,
3215 info
->stride
[dim
], gfc_index_zero_node
);
3216 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
, info
->start
[dim
],
3218 stride_neg
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3220 non_zerosized
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
3221 stride_pos
, stride_neg
);
3223 /* Check the start of the range against the lower and upper
3224 bounds of the array, if the range is not empty.
3225 If upper bound is present, include both bounds in the
3229 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
3230 info
->start
[dim
], lbound
);
3231 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3232 non_zerosized
, tmp
);
3233 tmp2
= fold_build2 (GT_EXPR
, boolean_type_node
,
3234 info
->start
[dim
], ubound
);
3235 tmp2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3236 non_zerosized
, tmp2
);
3237 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3238 "outside of expected range (%%ld:%%ld)",
3239 dim
+ 1, ss
->expr
->symtree
->name
);
3240 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3241 &ss
->expr
->where
, msg
,
3242 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3243 fold_convert (long_integer_type_node
, lbound
),
3244 fold_convert (long_integer_type_node
, ubound
));
3245 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3246 &ss
->expr
->where
, msg
,
3247 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3248 fold_convert (long_integer_type_node
, lbound
),
3249 fold_convert (long_integer_type_node
, ubound
));
3254 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
3255 info
->start
[dim
], lbound
);
3256 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3257 non_zerosized
, tmp
);
3258 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3259 "below lower bound of %%ld",
3260 dim
+ 1, ss
->expr
->symtree
->name
);
3261 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3262 &ss
->expr
->where
, msg
,
3263 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3264 fold_convert (long_integer_type_node
, lbound
));
3268 /* Compute the last element of the range, which is not
3269 necessarily "end" (think 0:5:3, which doesn't contain 5)
3270 and check it against both lower and upper bounds. */
3272 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3274 tmp
= fold_build2 (TRUNC_MOD_EXPR
, gfc_array_index_type
, tmp
,
3276 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3278 tmp2
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, lbound
);
3279 tmp2
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3280 non_zerosized
, tmp2
);
3283 tmp3
= fold_build2 (GT_EXPR
, boolean_type_node
, tmp
, ubound
);
3284 tmp3
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
3285 non_zerosized
, tmp3
);
3286 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3287 "outside of expected range (%%ld:%%ld)",
3288 dim
+ 1, ss
->expr
->symtree
->name
);
3289 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3290 &ss
->expr
->where
, msg
,
3291 fold_convert (long_integer_type_node
, tmp
),
3292 fold_convert (long_integer_type_node
, ubound
),
3293 fold_convert (long_integer_type_node
, lbound
));
3294 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3295 &ss
->expr
->where
, msg
,
3296 fold_convert (long_integer_type_node
, tmp
),
3297 fold_convert (long_integer_type_node
, ubound
),
3298 fold_convert (long_integer_type_node
, lbound
));
3303 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3304 "below lower bound of %%ld",
3305 dim
+ 1, ss
->expr
->symtree
->name
);
3306 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3307 &ss
->expr
->where
, msg
,
3308 fold_convert (long_integer_type_node
, tmp
),
3309 fold_convert (long_integer_type_node
, lbound
));
3313 /* Check the section sizes match. */
3314 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
3316 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
3318 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3319 gfc_index_one_node
, tmp
);
3320 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3321 build_int_cst (gfc_array_index_type
, 0));
3322 /* We remember the size of the first section, and check all the
3323 others against this. */
3326 tmp3
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
3327 asprintf (&msg
, "Array bound mismatch for dimension %d "
3328 "of array '%s' (%%ld/%%ld)",
3329 dim
+ 1, ss
->expr
->symtree
->name
);
3331 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3332 &ss
->expr
->where
, msg
,
3333 fold_convert (long_integer_type_node
, tmp
),
3334 fold_convert (long_integer_type_node
, size
[n
]));
3339 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
3342 tmp
= gfc_finish_block (&inner
);
3344 /* For optional arguments, only check bounds if the argument is
3346 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3347 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3348 tmp
= build3_v (COND_EXPR
,
3349 gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
),
3350 tmp
, build_empty_stmt (input_location
));
3352 gfc_add_expr_to_block (&block
, tmp
);
3356 tmp
= gfc_finish_block (&block
);
3357 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3362 /* Return true if the two SS could be aliased, i.e. both point to the same data
3364 /* TODO: resolve aliases based on frontend expressions. */
3367 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3374 lsym
= lss
->expr
->symtree
->n
.sym
;
3375 rsym
= rss
->expr
->symtree
->n
.sym
;
3376 if (gfc_symbols_could_alias (lsym
, rsym
))
3379 if (rsym
->ts
.type
!= BT_DERIVED
3380 && lsym
->ts
.type
!= BT_DERIVED
)
3383 /* For derived types we must check all the component types. We can ignore
3384 array references as these will have the same base type as the previous
3386 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3388 if (lref
->type
!= REF_COMPONENT
)
3391 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3394 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3397 if (rref
->type
!= REF_COMPONENT
)
3400 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3405 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3407 if (rref
->type
!= REF_COMPONENT
)
3410 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3418 /* Resolve array data dependencies. Creates a temporary if required. */
3419 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3423 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3431 loop
->temp_ss
= NULL
;
3433 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3435 if (ss
->type
!= GFC_SS_SECTION
)
3438 if (dest
->expr
->symtree
->n
.sym
!= ss
->expr
->symtree
->n
.sym
)
3440 if (gfc_could_be_alias (dest
, ss
)
3441 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3449 lref
= dest
->expr
->ref
;
3450 rref
= ss
->expr
->ref
;
3452 nDepend
= gfc_dep_resolver (lref
, rref
);
3456 /* TODO : loop shifting. */
3459 /* Mark the dimensions for LOOP SHIFTING */
3460 for (n
= 0; n
< loop
->dimen
; n
++)
3462 int dim
= dest
->data
.info
.dim
[n
];
3464 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3466 else if (! gfc_is_same_range (&lref
->u
.ar
,
3467 &rref
->u
.ar
, dim
, 0))
3471 /* Put all the dimensions with dependencies in the
3474 for (n
= 0; n
< loop
->dimen
; n
++)
3476 gcc_assert (loop
->order
[n
] == n
);
3478 loop
->order
[dim
++] = n
;
3480 for (n
= 0; n
< loop
->dimen
; n
++)
3483 loop
->order
[dim
++] = n
;
3486 gcc_assert (dim
== loop
->dimen
);
3495 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3496 if (GFC_ARRAY_TYPE_P (base_type
)
3497 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3498 base_type
= gfc_get_element_type (base_type
);
3499 loop
->temp_ss
= gfc_get_ss ();
3500 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3501 loop
->temp_ss
->data
.temp
.type
= base_type
;
3502 loop
->temp_ss
->string_length
= dest
->string_length
;
3503 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3504 loop
->temp_ss
->next
= gfc_ss_terminator
;
3505 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3508 loop
->temp_ss
= NULL
;
3512 /* Initialize the scalarization loop. Creates the loop variables. Determines
3513 the range of the loop variables. Creates a temporary if required.
3514 Calculates how to transform from loop variables to array indices for each
3515 expression. Also generates code for scalar expressions which have been
3516 moved outside the loop. */
3519 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
3521 int n
, dim
, spec_dim
;
3523 gfc_ss_info
*specinfo
;
3526 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3527 bool dynamic
[GFC_MAX_DIMENSIONS
];
3532 for (n
= 0; n
< loop
->dimen
; n
++)
3536 /* We use one SS term, and use that to determine the bounds of the
3537 loop for this dimension. We try to pick the simplest term. */
3538 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3540 if (ss
->type
== GFC_SS_SCALAR
|| ss
->type
== GFC_SS_REFERENCE
)
3543 info
= &ss
->data
.info
;
3546 if (loopspec
[n
] != NULL
)
3548 specinfo
= &loopspec
[n
]->data
.info
;
3549 spec_dim
= specinfo
->dim
[n
];
3553 /* Silence unitialized warnings. */
3560 gcc_assert (ss
->shape
[dim
]);
3561 /* The frontend has worked out the size for us. */
3563 || !loopspec
[n
]->shape
3564 || !integer_zerop (specinfo
->start
[spec_dim
]))
3565 /* Prefer zero-based descriptors if possible. */
3570 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3572 gfc_constructor_base base
;
3573 /* An unknown size constructor will always be rank one.
3574 Higher rank constructors will either have known shape,
3575 or still be wrapped in a call to reshape. */
3576 gcc_assert (loop
->dimen
== 1);
3578 /* Always prefer to use the constructor bounds if the size
3579 can be determined at compile time. Prefer not to otherwise,
3580 since the general case involves realloc, and it's better to
3581 avoid that overhead if possible. */
3582 base
= ss
->expr
->value
.constructor
;
3583 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
3584 if (!dynamic
[n
] || !loopspec
[n
])
3589 /* TODO: Pick the best bound if we have a choice between a
3590 function and something else. */
3591 if (ss
->type
== GFC_SS_FUNCTION
)
3597 if (ss
->type
!= GFC_SS_SECTION
)
3602 /* Criteria for choosing a loop specifier (most important first):
3603 doesn't need realloc
3609 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3611 else if (integer_onep (info
->stride
[dim
])
3612 && !integer_onep (specinfo
->stride
[spec_dim
]))
3614 else if (INTEGER_CST_P (info
->stride
[dim
])
3615 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
3617 else if (INTEGER_CST_P (info
->start
[dim
])
3618 && !INTEGER_CST_P (specinfo
->start
[spec_dim
]))
3620 /* We don't work out the upper bound.
3621 else if (INTEGER_CST_P (info->finish[n])
3622 && ! INTEGER_CST_P (specinfo->finish[n]))
3623 loopspec[n] = ss; */
3626 /* We should have found the scalarization loop specifier. If not,
3628 gcc_assert (loopspec
[n
]);
3630 info
= &loopspec
[n
]->data
.info
;
3633 /* Set the extents of this range. */
3634 cshape
= loopspec
[n
]->shape
;
3635 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
3636 && INTEGER_CST_P (info
->stride
[dim
]))
3638 loop
->from
[n
] = info
->start
[dim
];
3639 mpz_set (i
, cshape
[n
]);
3640 mpz_sub_ui (i
, i
, 1);
3641 /* To = from + (size - 1) * stride. */
3642 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3643 if (!integer_onep (info
->stride
[dim
]))
3644 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3645 tmp
, info
->stride
[dim
]);
3646 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3647 loop
->from
[n
], tmp
);
3651 loop
->from
[n
] = info
->start
[dim
];
3652 switch (loopspec
[n
]->type
)
3654 case GFC_SS_CONSTRUCTOR
:
3655 /* The upper bound is calculated when we expand the
3657 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3660 case GFC_SS_SECTION
:
3661 /* Use the end expression if it exists and is not constant,
3662 so that it is only evaluated once. */
3663 loop
->to
[n
] = info
->end
[dim
];
3666 case GFC_SS_FUNCTION
:
3667 /* The loop bound will be set when we generate the call. */
3668 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3676 /* Transform everything so we have a simple incrementing variable. */
3677 if (integer_onep (info
->stride
[dim
]))
3678 info
->delta
[dim
] = gfc_index_zero_node
;
3681 /* Set the delta for this section. */
3682 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3683 /* Number of iterations is (end - start + step) / step.
3684 with start = 0, this simplifies to
3686 for (i = 0; i<=last; i++){...}; */
3687 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3688 loop
->to
[n
], loop
->from
[n
]);
3689 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
,
3690 tmp
, info
->stride
[dim
]);
3691 tmp
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, tmp
,
3692 build_int_cst (gfc_array_index_type
, -1));
3693 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3694 /* Make the loop variable start at 0. */
3695 loop
->from
[n
] = gfc_index_zero_node
;
3699 /* Add all the scalar code that can be taken out of the loops.
3700 This may include calculating the loop bounds, so do it before
3701 allocating the temporary. */
3702 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
3704 /* If we want a temporary then create it. */
3705 if (loop
->temp_ss
!= NULL
)
3707 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3709 /* Make absolutely sure that this is a complete type. */
3710 if (loop
->temp_ss
->string_length
)
3711 loop
->temp_ss
->data
.temp
.type
3712 = gfc_get_character_type_len_for_eltype
3713 (TREE_TYPE (loop
->temp_ss
->data
.temp
.type
),
3714 loop
->temp_ss
->string_length
);
3716 tmp
= loop
->temp_ss
->data
.temp
.type
;
3717 n
= loop
->temp_ss
->data
.temp
.dimen
;
3718 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3719 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3720 loop
->temp_ss
->data
.info
.dimen
= n
;
3721 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3722 &loop
->temp_ss
->data
.info
, tmp
, NULL_TREE
,
3723 false, true, false, where
);
3726 for (n
= 0; n
< loop
->temp_dim
; n
++)
3727 loopspec
[loop
->order
[n
]] = NULL
;
3731 /* For array parameters we don't have loop variables, so don't calculate the
3733 if (loop
->array_parameter
)
3736 /* Calculate the translation from loop variables to array indices. */
3737 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3739 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
3740 && ss
->type
!= GFC_SS_CONSTRUCTOR
)
3744 info
= &ss
->data
.info
;
3746 for (n
= 0; n
< info
->dimen
; n
++)
3748 /* If we are specifying the range the delta is already set. */
3749 if (loopspec
[n
] != ss
)
3751 dim
= ss
->data
.info
.dim
[n
];
3753 /* Calculate the offset relative to the loop variable.
3754 First multiply by the stride. */
3755 tmp
= loop
->from
[n
];
3756 if (!integer_onep (info
->stride
[dim
]))
3757 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3758 tmp
, info
->stride
[dim
]);
3760 /* Then subtract this from our starting value. */
3761 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3762 info
->start
[dim
], tmp
);
3764 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3771 /* Fills in an array descriptor, and returns the size of the array. The size
3772 will be a simple_val, ie a variable or a constant. Also calculates the
3773 offset of the base. Returns the size of the array.
3777 for (n = 0; n < rank; n++)
3779 a.lbound[n] = specified_lower_bound;
3780 offset = offset + a.lbond[n] * stride;
3782 a.ubound[n] = specified_upper_bound;
3783 a.stride[n] = stride;
3784 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3785 stride = stride * size;
3792 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
3793 gfc_expr
** lower
, gfc_expr
** upper
,
3794 stmtblock_t
* pblock
)
3806 stmtblock_t thenblock
;
3807 stmtblock_t elseblock
;
3812 type
= TREE_TYPE (descriptor
);
3814 stride
= gfc_index_one_node
;
3815 offset
= gfc_index_zero_node
;
3817 /* Set the dtype. */
3818 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3819 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3821 or_expr
= NULL_TREE
;
3823 for (n
= 0; n
< rank
; n
++)
3825 /* We have 3 possibilities for determining the size of the array:
3826 lower == NULL => lbound = 1, ubound = upper[n]
3827 upper[n] = NULL => lbound = 1, ubound = lower[n]
3828 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3831 /* Set lower bound. */
3832 gfc_init_se (&se
, NULL
);
3834 se
.expr
= gfc_index_one_node
;
3837 gcc_assert (lower
[n
]);
3840 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3841 gfc_add_block_to_block (pblock
, &se
.pre
);
3845 se
.expr
= gfc_index_one_node
;
3849 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
3852 /* Work out the offset for this component. */
3853 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
3854 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3856 /* Start the calculation for the size of this dimension. */
3857 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3858 gfc_index_one_node
, se
.expr
);
3860 /* Set upper bound. */
3861 gfc_init_se (&se
, NULL
);
3862 gcc_assert (ubound
);
3863 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3864 gfc_add_block_to_block (pblock
, &se
.pre
);
3866 gfc_conv_descriptor_ubound_set (pblock
, descriptor
, gfc_rank_cst
[n
], se
.expr
);
3868 /* Store the stride. */
3869 gfc_conv_descriptor_stride_set (pblock
, descriptor
, gfc_rank_cst
[n
], stride
);
3871 /* Calculate the size of this dimension. */
3872 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
3874 /* Check whether the size for this dimension is negative. */
3875 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, size
,
3876 gfc_index_zero_node
);
3880 or_expr
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, or_expr
, cond
);
3882 size
= fold_build3 (COND_EXPR
, gfc_array_index_type
, cond
,
3883 gfc_index_zero_node
, size
);
3885 /* Multiply the stride by the number of elements in this dimension. */
3886 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
3887 stride
= gfc_evaluate_now (stride
, pblock
);
3890 for (n
= rank
; n
< rank
+ corank
; n
++)
3894 /* Set lower bound. */
3895 gfc_init_se (&se
, NULL
);
3896 if (lower
== NULL
|| lower
[n
] == NULL
)
3898 gcc_assert (n
== rank
+ corank
- 1);
3899 se
.expr
= gfc_index_one_node
;
3903 if (ubound
|| n
== rank
+ corank
- 1)
3905 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3906 gfc_add_block_to_block (pblock
, &se
.pre
);
3910 se
.expr
= gfc_index_one_node
;
3914 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
3917 if (n
< rank
+ corank
- 1)
3919 gfc_init_se (&se
, NULL
);
3920 gcc_assert (ubound
);
3921 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
3922 gfc_add_block_to_block (pblock
, &se
.pre
);
3923 gfc_conv_descriptor_ubound_set (pblock
, descriptor
, gfc_rank_cst
[n
], se
.expr
);
3927 /* The stride is the number of elements in the array, so multiply by the
3928 size of an element to get the total size. */
3929 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3930 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
,
3931 fold_convert (gfc_array_index_type
, tmp
));
3933 if (poffset
!= NULL
)
3935 offset
= gfc_evaluate_now (offset
, pblock
);
3939 if (integer_zerop (or_expr
))
3941 if (integer_onep (or_expr
))
3942 return gfc_index_zero_node
;
3944 var
= gfc_create_var (TREE_TYPE (size
), "size");
3945 gfc_start_block (&thenblock
);
3946 gfc_add_modify (&thenblock
, var
, gfc_index_zero_node
);
3947 thencase
= gfc_finish_block (&thenblock
);
3949 gfc_start_block (&elseblock
);
3950 gfc_add_modify (&elseblock
, var
, size
);
3951 elsecase
= gfc_finish_block (&elseblock
);
3953 tmp
= gfc_evaluate_now (or_expr
, pblock
);
3954 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
3955 gfc_add_expr_to_block (pblock
, tmp
);
3961 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3962 the work for an ALLOCATE statement. */
3966 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
3974 gfc_ref
*ref
, *prev_ref
= NULL
;
3975 bool allocatable_array
, coarray
;
3979 /* Find the last reference in the chain. */
3980 while (ref
&& ref
->next
!= NULL
)
3982 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
3983 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
3988 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
3993 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
3994 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
3998 allocatable_array
= prev_ref
->u
.c
.component
->attr
.allocatable
;
3999 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
4002 /* Return if this is a scalar coarray. */
4003 if ((!prev_ref
&& !expr
->symtree
->n
.sym
->attr
.dimension
)
4004 || (prev_ref
&& !prev_ref
->u
.c
.component
->attr
.dimension
))
4006 gcc_assert (coarray
);
4010 /* Figure out the size of the array. */
4011 switch (ref
->u
.ar
.type
)
4017 upper
= ref
->u
.ar
.start
;
4023 lower
= ref
->u
.ar
.start
;
4024 upper
= ref
->u
.ar
.end
;
4028 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
4030 lower
= ref
->u
.ar
.as
->lower
;
4031 upper
= ref
->u
.ar
.as
->upper
;
4039 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
4040 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
4043 /* Allocate memory to store the data. */
4044 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
4045 STRIP_NOPS (pointer
);
4047 /* The allocate_array variants take the old pointer as first argument. */
4048 if (allocatable_array
)
4049 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
, expr
);
4051 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
4052 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, pointer
, tmp
);
4053 gfc_add_expr_to_block (&se
->pre
, tmp
);
4055 gfc_conv_descriptor_offset_set (&se
->pre
, se
->expr
, offset
);
4057 if (expr
->ts
.type
== BT_DERIVED
4058 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
4060 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
4061 ref
->u
.ar
.as
->rank
);
4062 gfc_add_expr_to_block (&se
->pre
, tmp
);
4069 /* Deallocate an array variable. Also used when an allocated variable goes
4074 gfc_array_deallocate (tree descriptor
, tree pstat
, gfc_expr
* expr
)
4080 gfc_start_block (&block
);
4081 /* Get a pointer to the data. */
4082 var
= gfc_conv_descriptor_data_get (descriptor
);
4085 /* Parameter is the address of the data component. */
4086 tmp
= gfc_deallocate_with_status (var
, pstat
, false, expr
);
4087 gfc_add_expr_to_block (&block
, tmp
);
4089 /* Zero the data pointer. */
4090 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
4091 var
, build_int_cst (TREE_TYPE (var
), 0));
4092 gfc_add_expr_to_block (&block
, tmp
);
4094 return gfc_finish_block (&block
);
4098 /* Create an array constructor from an initialization expression.
4099 We assume the frontend already did any expansions and conversions. */
4102 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
4108 unsigned HOST_WIDE_INT lo
;
4110 VEC(constructor_elt
,gc
) *v
= NULL
;
4112 switch (expr
->expr_type
)
4115 case EXPR_STRUCTURE
:
4116 /* A single scalar or derived type value. Create an array with all
4117 elements equal to that value. */
4118 gfc_init_se (&se
, NULL
);
4120 if (expr
->expr_type
== EXPR_CONSTANT
)
4121 gfc_conv_constant (&se
, expr
);
4123 gfc_conv_structure (&se
, expr
, 1);
4125 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
4126 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
4127 hi
= TREE_INT_CST_HIGH (tmp
);
4128 lo
= TREE_INT_CST_LOW (tmp
);
4132 /* This will probably eat buckets of memory for large arrays. */
4133 while (hi
!= 0 || lo
!= 0)
4135 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
4143 /* Create a vector of all the elements. */
4144 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4145 c
; c
= gfc_constructor_next (c
))
4149 /* Problems occur when we get something like
4150 integer :: a(lots) = (/(i, i=1, lots)/) */
4151 gfc_fatal_error ("The number of elements in the array constructor "
4152 "at %L requires an increase of the allowed %d "
4153 "upper limit. See -fmax-array-constructor "
4154 "option", &expr
->where
,
4155 gfc_option
.flag_max_array_constructor
);
4158 if (mpz_cmp_si (c
->offset
, 0) != 0)
4159 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
4163 gfc_init_se (&se
, NULL
);
4164 switch (c
->expr
->expr_type
)
4167 gfc_conv_constant (&se
, c
->expr
);
4168 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4171 case EXPR_STRUCTURE
:
4172 gfc_conv_structure (&se
, c
->expr
, 1);
4173 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4178 /* Catch those occasional beasts that do not simplify
4179 for one reason or another, assuming that if they are
4180 standard defying the frontend will catch them. */
4181 gfc_conv_expr (&se
, c
->expr
);
4182 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4189 return gfc_build_null_descriptor (type
);
4195 /* Create a constructor from the list of elements. */
4196 tmp
= build_constructor (type
, v
);
4197 TREE_CONSTANT (tmp
) = 1;
4202 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4203 returns the size (in elements) of the array. */
4206 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
4207 stmtblock_t
* pblock
)
4222 size
= gfc_index_one_node
;
4223 offset
= gfc_index_zero_node
;
4224 for (dim
= 0; dim
< as
->rank
; dim
++)
4226 /* Evaluate non-constant array bound expressions. */
4227 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
4228 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
4230 gfc_init_se (&se
, NULL
);
4231 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
4232 gfc_add_block_to_block (pblock
, &se
.pre
);
4233 gfc_add_modify (pblock
, lbound
, se
.expr
);
4235 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
4236 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
4238 gfc_init_se (&se
, NULL
);
4239 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
4240 gfc_add_block_to_block (pblock
, &se
.pre
);
4241 gfc_add_modify (pblock
, ubound
, se
.expr
);
4243 /* The offset of this dimension. offset = offset - lbound * stride. */
4244 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
4245 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4247 /* The size of this dimension, and the stride of the next. */
4248 if (dim
+ 1 < as
->rank
)
4249 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
4251 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4253 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
4255 /* Calculate stride = size * (ubound + 1 - lbound). */
4256 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4257 gfc_index_one_node
, lbound
);
4258 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
4259 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
4261 gfc_add_modify (pblock
, stride
, tmp
);
4263 stride
= gfc_evaluate_now (tmp
, pblock
);
4265 /* Make sure that negative size arrays are translated
4266 to being zero size. */
4267 tmp
= fold_build2 (GE_EXPR
, boolean_type_node
,
4268 stride
, gfc_index_zero_node
);
4269 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4270 stride
, gfc_index_zero_node
);
4271 gfc_add_modify (pblock
, stride
, tmp
);
4277 gfc_trans_vla_type_sizes (sym
, pblock
);
4284 /* Generate code to initialize/allocate an array variable. */
4287 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
4288 gfc_wrapped_block
* block
)
4297 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
4299 /* Do nothing for USEd variables. */
4300 if (sym
->attr
.use_assoc
)
4303 type
= TREE_TYPE (decl
);
4304 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4305 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
4307 gfc_start_block (&init
);
4309 /* Evaluate character string length. */
4310 if (sym
->ts
.type
== BT_CHARACTER
4311 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4313 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4315 gfc_trans_vla_type_sizes (sym
, &init
);
4317 /* Emit a DECL_EXPR for this variable, which will cause the
4318 gimplifier to allocate storage, and all that good stuff. */
4319 tmp
= fold_build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
4320 gfc_add_expr_to_block (&init
, tmp
);
4325 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4329 type
= TREE_TYPE (type
);
4331 gcc_assert (!sym
->attr
.use_assoc
);
4332 gcc_assert (!TREE_STATIC (decl
));
4333 gcc_assert (!sym
->module
);
4335 if (sym
->ts
.type
== BT_CHARACTER
4336 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4337 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4339 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
4341 /* Don't actually allocate space for Cray Pointees. */
4342 if (sym
->attr
.cray_pointee
)
4344 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4345 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4347 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4351 /* The size is the number of elements in the array, so multiply by the
4352 size of an element to get the total size. */
4353 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4354 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
4355 fold_convert (gfc_array_index_type
, tmp
));
4357 /* Allocate memory to hold the data. */
4358 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
4359 gfc_add_modify (&init
, decl
, tmp
);
4361 /* Set offset of the array. */
4362 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4363 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4365 /* Automatic arrays should not have initializers. */
4366 gcc_assert (!sym
->value
);
4368 /* Free the temporary. */
4369 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
4371 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4375 /* Generate entry and exit code for g77 calling convention arrays. */
4378 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
4388 gfc_get_backend_locus (&loc
);
4389 gfc_set_backend_locus (&sym
->declared_at
);
4391 /* Descriptor type. */
4392 parm
= sym
->backend_decl
;
4393 type
= TREE_TYPE (parm
);
4394 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4396 gfc_start_block (&init
);
4398 if (sym
->ts
.type
== BT_CHARACTER
4399 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4400 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4402 /* Evaluate the bounds of the array. */
4403 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
4405 /* Set the offset. */
4406 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4407 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4409 /* Set the pointer itself if we aren't using the parameter directly. */
4410 if (TREE_CODE (parm
) != PARM_DECL
)
4412 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4413 gfc_add_modify (&init
, parm
, tmp
);
4415 stmt
= gfc_finish_block (&init
);
4417 gfc_set_backend_locus (&loc
);
4419 /* Add the initialization code to the start of the function. */
4421 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4423 tmp
= gfc_conv_expr_present (sym
);
4424 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4427 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
4431 /* Modify the descriptor of an array parameter so that it has the
4432 correct lower bound. Also move the upper bound accordingly.
4433 If the array is not packed, it will be copied into a temporary.
4434 For each dimension we set the new lower and upper bounds. Then we copy the
4435 stride and calculate the offset for this dimension. We also work out
4436 what the stride of a packed array would be, and see it the two match.
4437 If the array need repacking, we set the stride to the values we just
4438 calculated, recalculate the offset and copy the array data.
4439 Code is also added to copy the data back at the end of the function.
4443 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
4444 gfc_wrapped_block
* block
)
4451 tree stmtInit
, stmtCleanup
;
4458 tree stride
, stride2
;
4468 /* Do nothing for pointer and allocatable arrays. */
4469 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4472 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4474 gfc_trans_g77_array (sym
, block
);
4478 gfc_get_backend_locus (&loc
);
4479 gfc_set_backend_locus (&sym
->declared_at
);
4481 /* Descriptor type. */
4482 type
= TREE_TYPE (tmpdesc
);
4483 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4484 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4485 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
4486 gfc_start_block (&init
);
4488 if (sym
->ts
.type
== BT_CHARACTER
4489 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4490 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4492 checkparm
= (sym
->as
->type
== AS_EXPLICIT
4493 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
4495 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4496 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4498 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4500 /* For non-constant shape arrays we only check if the first dimension
4501 is contiguous. Repacking higher dimensions wouldn't gain us
4502 anything as we still don't know the array stride. */
4503 partial
= gfc_create_var (boolean_type_node
, "partial");
4504 TREE_USED (partial
) = 1;
4505 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4506 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, gfc_index_one_node
);
4507 gfc_add_modify (&init
, partial
, tmp
);
4510 partial
= NULL_TREE
;
4512 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4513 here, however I think it does the right thing. */
4516 /* Set the first stride. */
4517 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4518 stride
= gfc_evaluate_now (stride
, &init
);
4520 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4521 stride
, gfc_index_zero_node
);
4522 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
4523 gfc_index_one_node
, stride
);
4524 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4525 gfc_add_modify (&init
, stride
, tmp
);
4527 /* Allow the user to disable array repacking. */
4528 stmt_unpacked
= NULL_TREE
;
4532 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4533 /* A library call to repack the array if necessary. */
4534 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4535 stmt_unpacked
= build_call_expr_loc (input_location
,
4536 gfor_fndecl_in_pack
, 1, tmp
);
4538 stride
= gfc_index_one_node
;
4540 if (gfc_option
.warn_array_temp
)
4541 gfc_warning ("Creating array temporary at %L", &loc
);
4544 /* This is for the case where the array data is used directly without
4545 calling the repack function. */
4546 if (no_repack
|| partial
!= NULL_TREE
)
4547 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4549 stmt_packed
= NULL_TREE
;
4551 /* Assign the data pointer. */
4552 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4554 /* Don't repack unknown shape arrays when the first stride is 1. */
4555 tmp
= fold_build3 (COND_EXPR
, TREE_TYPE (stmt_packed
),
4556 partial
, stmt_packed
, stmt_unpacked
);
4559 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4560 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
4562 offset
= gfc_index_zero_node
;
4563 size
= gfc_index_one_node
;
4565 /* Evaluate the bounds of the array. */
4566 for (n
= 0; n
< sym
->as
->rank
; n
++)
4568 if (checkparm
|| !sym
->as
->upper
[n
])
4570 /* Get the bounds of the actual parameter. */
4571 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
4572 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
4576 dubound
= NULL_TREE
;
4577 dlbound
= NULL_TREE
;
4580 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4581 if (!INTEGER_CST_P (lbound
))
4583 gfc_init_se (&se
, NULL
);
4584 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4585 gfc_array_index_type
);
4586 gfc_add_block_to_block (&init
, &se
.pre
);
4587 gfc_add_modify (&init
, lbound
, se
.expr
);
4590 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4591 /* Set the desired upper bound. */
4592 if (sym
->as
->upper
[n
])
4594 /* We know what we want the upper bound to be. */
4595 if (!INTEGER_CST_P (ubound
))
4597 gfc_init_se (&se
, NULL
);
4598 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4599 gfc_array_index_type
);
4600 gfc_add_block_to_block (&init
, &se
.pre
);
4601 gfc_add_modify (&init
, ubound
, se
.expr
);
4604 /* Check the sizes match. */
4607 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4611 temp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4613 temp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4614 gfc_index_one_node
, temp
);
4616 stride2
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4618 stride2
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4619 gfc_index_one_node
, stride2
);
4621 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, temp
, stride2
);
4622 asprintf (&msg
, "Dimension %d of array '%s' has extent "
4623 "%%ld instead of %%ld", n
+1, sym
->name
);
4625 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
4626 fold_convert (long_integer_type_node
, temp
),
4627 fold_convert (long_integer_type_node
, stride2
));
4634 /* For assumed shape arrays move the upper bound by the same amount
4635 as the lower bound. */
4636 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4638 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
4639 gfc_add_modify (&init
, ubound
, tmp
);
4641 /* The offset of this dimension. offset = offset - lbound * stride. */
4642 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
4643 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
4645 /* The size of this dimension, and the stride of the next. */
4646 if (n
+ 1 < sym
->as
->rank
)
4648 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4650 if (no_repack
|| partial
!= NULL_TREE
)
4652 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
4654 /* Figure out the stride if not a known constant. */
4655 if (!INTEGER_CST_P (stride
))
4658 stmt_packed
= NULL_TREE
;
4661 /* Calculate stride = size * (ubound + 1 - lbound). */
4662 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4663 gfc_index_one_node
, lbound
);
4664 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4666 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4671 /* Assign the stride. */
4672 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4673 tmp
= fold_build3 (COND_EXPR
, gfc_array_index_type
, partial
,
4674 stmt_unpacked
, stmt_packed
);
4676 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4677 gfc_add_modify (&init
, stride
, tmp
);
4682 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4684 if (stride
&& !INTEGER_CST_P (stride
))
4686 /* Calculate size = stride * (ubound + 1 - lbound). */
4687 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
4688 gfc_index_one_node
, lbound
);
4689 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4691 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4692 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4693 gfc_add_modify (&init
, stride
, tmp
);
4698 /* Set the offset. */
4699 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4700 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4702 gfc_trans_vla_type_sizes (sym
, &init
);
4704 stmtInit
= gfc_finish_block (&init
);
4706 /* Only do the entry/initialization code if the arg is present. */
4707 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4708 optional_arg
= (sym
->attr
.optional
4709 || (sym
->ns
->proc_name
->attr
.entry_master
4710 && sym
->attr
.dummy
));
4713 tmp
= gfc_conv_expr_present (sym
);
4714 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
4715 build_empty_stmt (input_location
));
4720 stmtCleanup
= NULL_TREE
;
4723 stmtblock_t cleanup
;
4724 gfc_start_block (&cleanup
);
4726 if (sym
->attr
.intent
!= INTENT_IN
)
4728 /* Copy the data back. */
4729 tmp
= build_call_expr_loc (input_location
,
4730 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4731 gfc_add_expr_to_block (&cleanup
, tmp
);
4734 /* Free the temporary. */
4735 tmp
= gfc_call_free (tmpdesc
);
4736 gfc_add_expr_to_block (&cleanup
, tmp
);
4738 stmtCleanup
= gfc_finish_block (&cleanup
);
4740 /* Only do the cleanup if the array was repacked. */
4741 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
4742 tmp
= gfc_conv_descriptor_data_get (tmp
);
4743 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
4744 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
4745 build_empty_stmt (input_location
));
4749 tmp
= gfc_conv_expr_present (sym
);
4750 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
4751 build_empty_stmt (input_location
));
4755 /* We don't need to free any memory allocated by internal_pack as it will
4756 be freed at the end of the function by pop_context. */
4757 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
4761 /* Calculate the overall offset, including subreferences. */
4763 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4764 bool subref
, gfc_expr
*expr
)
4774 /* If offset is NULL and this is not a subreferenced array, there is
4776 if (offset
== NULL_TREE
)
4779 offset
= gfc_index_zero_node
;
4784 tmp
= gfc_conv_array_data (desc
);
4785 tmp
= build_fold_indirect_ref_loc (input_location
,
4787 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4789 /* Offset the data pointer for pointer assignments from arrays with
4790 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4793 /* Go past the array reference. */
4794 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4795 if (ref
->type
== REF_ARRAY
&&
4796 ref
->u
.ar
.type
!= AR_ELEMENT
)
4802 /* Calculate the offset for each subsequent subreference. */
4803 for (; ref
; ref
= ref
->next
)
4808 field
= ref
->u
.c
.component
->backend_decl
;
4809 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
4810 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4811 tmp
, field
, NULL_TREE
);
4815 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
4816 gfc_init_se (&start
, NULL
);
4817 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
4818 gfc_add_block_to_block (block
, &start
.pre
);
4819 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
4823 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
4824 && ref
->u
.ar
.type
== AR_ELEMENT
);
4826 /* TODO - Add bounds checking. */
4827 stride
= gfc_index_one_node
;
4828 index
= gfc_index_zero_node
;
4829 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4834 /* Update the index. */
4835 gfc_init_se (&start
, NULL
);
4836 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
4837 itmp
= gfc_evaluate_now (start
.expr
, block
);
4838 gfc_init_se (&start
, NULL
);
4839 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
4840 jtmp
= gfc_evaluate_now (start
.expr
, block
);
4841 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, itmp
, jtmp
);
4842 itmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, itmp
, stride
);
4843 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, itmp
, index
);
4844 index
= gfc_evaluate_now (index
, block
);
4846 /* Update the stride. */
4847 gfc_init_se (&start
, NULL
);
4848 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
4849 itmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, start
.expr
, jtmp
);
4850 itmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4851 gfc_index_one_node
, itmp
);
4852 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, itmp
);
4853 stride
= gfc_evaluate_now (stride
, block
);
4856 /* Apply the index to obtain the array element. */
4857 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
4867 /* Set the target data pointer. */
4868 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
4869 gfc_conv_descriptor_data_set (block
, parm
, offset
);
4873 /* gfc_conv_expr_descriptor needs the string length an expression
4874 so that the size of the temporary can be obtained. This is done
4875 by adding up the string lengths of all the elements in the
4876 expression. Function with non-constant expressions have their
4877 string lengths mapped onto the actual arguments using the
4878 interface mapping machinery in trans-expr.c. */
4880 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
4882 gfc_interface_mapping mapping
;
4883 gfc_formal_arglist
*formal
;
4884 gfc_actual_arglist
*arg
;
4887 if (expr
->ts
.u
.cl
->length
4888 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
4890 if (!expr
->ts
.u
.cl
->backend_decl
)
4891 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
4895 switch (expr
->expr_type
)
4898 get_array_charlen (expr
->value
.op
.op1
, se
);
4900 /* For parentheses the expression ts.u.cl is identical. */
4901 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
4904 expr
->ts
.u
.cl
->backend_decl
=
4905 gfc_create_var (gfc_charlen_type_node
, "sln");
4907 if (expr
->value
.op
.op2
)
4909 get_array_charlen (expr
->value
.op
.op2
, se
);
4911 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
4913 /* Add the string lengths and assign them to the expression
4914 string length backend declaration. */
4915 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
4916 fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
,
4917 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
4918 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
4921 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
4922 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
4926 if (expr
->value
.function
.esym
== NULL
4927 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4929 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
4933 /* Map expressions involving the dummy arguments onto the actual
4934 argument expressions. */
4935 gfc_init_interface_mapping (&mapping
);
4936 formal
= expr
->symtree
->n
.sym
->formal
;
4937 arg
= expr
->value
.function
.actual
;
4939 /* Set se = NULL in the calls to the interface mapping, to suppress any
4941 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4946 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
4949 gfc_init_se (&tse
, NULL
);
4951 /* Build the expression for the character length and convert it. */
4952 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
4954 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
4955 gfc_add_block_to_block (&se
->post
, &tse
.post
);
4956 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
4957 tse
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tse
.expr
,
4958 build_int_cst (gfc_charlen_type_node
, 0));
4959 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4960 gfc_free_interface_mapping (&mapping
);
4964 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
4971 /* Convert an array for passing as an actual argument. Expressions and
4972 vector subscripts are evaluated and stored in a temporary, which is then
4973 passed. For whole arrays the descriptor is passed. For array sections
4974 a modified copy of the descriptor is passed, but using the original data.
4976 This function is also used for array pointer assignments, and there
4979 - se->want_pointer && !se->direct_byref
4980 EXPR is an actual argument. On exit, se->expr contains a
4981 pointer to the array descriptor.
4983 - !se->want_pointer && !se->direct_byref
4984 EXPR is an actual argument to an intrinsic function or the
4985 left-hand side of a pointer assignment. On exit, se->expr
4986 contains the descriptor for EXPR.
4988 - !se->want_pointer && se->direct_byref
4989 EXPR is the right-hand side of a pointer assignment and
4990 se->expr is the descriptor for the previously-evaluated
4991 left-hand side. The function creates an assignment from
4992 EXPR to se->expr. */
4995 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
5008 bool subref_array_target
= false;
5010 gcc_assert (ss
!= gfc_ss_terminator
);
5012 /* Special case things we know we can pass easily. */
5013 switch (expr
->expr_type
)
5016 /* If we have a linear array section, we can pass it directly.
5017 Otherwise we need to copy it into a temporary. */
5019 /* Find the SS for the array section. */
5021 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
5022 secss
= secss
->next
;
5024 gcc_assert (secss
!= gfc_ss_terminator
);
5025 info
= &secss
->data
.info
;
5027 /* Get the descriptor for the array. */
5028 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
5029 desc
= info
->descriptor
;
5031 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
5032 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
5033 && !subref_array_target
;
5037 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5039 /* Create a new descriptor if the array doesn't have one. */
5042 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
5044 else if (se
->direct_byref
)
5047 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
5051 if (se
->direct_byref
)
5053 /* Copy the descriptor for pointer assignments. */
5054 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
5056 /* Add any offsets from subreferences. */
5057 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
5058 subref_array_target
, expr
);
5060 else if (se
->want_pointer
)
5062 /* We pass full arrays directly. This means that pointers and
5063 allocatable arrays should also work. */
5064 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5071 if (expr
->ts
.type
== BT_CHARACTER
)
5072 se
->string_length
= gfc_get_expr_charlen (expr
);
5079 /* A transformational function return value will be a temporary
5080 array descriptor. We still need to go through the scalarizer
5081 to create the descriptor. Elemental functions ar handled as
5082 arbitrary expressions, i.e. copy to a temporary. */
5084 /* Look for the SS for this function. */
5085 while (secss
!= gfc_ss_terminator
5086 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
5087 secss
= secss
->next
;
5089 if (se
->direct_byref
)
5091 gcc_assert (secss
!= gfc_ss_terminator
);
5093 /* For pointer assignments pass the descriptor directly. */
5095 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5096 gfc_conv_expr (se
, expr
);
5100 if (secss
== gfc_ss_terminator
)
5102 /* Elemental function. */
5104 if (expr
->ts
.type
== BT_CHARACTER
5105 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5106 get_array_charlen (expr
, se
);
5112 /* Transformational function. */
5113 info
= &secss
->data
.info
;
5119 /* Constant array constructors don't need a temporary. */
5120 if (ss
->type
== GFC_SS_CONSTRUCTOR
5121 && expr
->ts
.type
!= BT_CHARACTER
5122 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
5125 info
= &ss
->data
.info
;
5137 /* Something complicated. Copy it into a temporary. */
5144 gfc_init_loopinfo (&loop
);
5146 /* Associate the SS with the loop. */
5147 gfc_add_ss_to_loop (&loop
, ss
);
5149 /* Tell the scalarizer not to bother creating loop variables, etc. */
5151 loop
.array_parameter
= 1;
5153 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5154 gcc_assert (!se
->direct_byref
);
5156 /* Setup the scalarizing loops and bounds. */
5157 gfc_conv_ss_startstride (&loop
);
5161 /* Tell the scalarizer to make a temporary. */
5162 loop
.temp_ss
= gfc_get_ss ();
5163 loop
.temp_ss
->type
= GFC_SS_TEMP
;
5164 loop
.temp_ss
->next
= gfc_ss_terminator
;
5166 if (expr
->ts
.type
== BT_CHARACTER
5167 && !expr
->ts
.u
.cl
->backend_decl
)
5168 get_array_charlen (expr
, se
);
5170 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
5172 if (expr
->ts
.type
== BT_CHARACTER
)
5173 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5175 loop
.temp_ss
->string_length
= NULL
;
5177 se
->string_length
= loop
.temp_ss
->string_length
;
5178 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
5179 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
5182 gfc_conv_loop_setup (&loop
, & expr
->where
);
5186 /* Copy into a temporary and pass that. We don't need to copy the data
5187 back because expressions and vector subscripts must be INTENT_IN. */
5188 /* TODO: Optimize passing function return values. */
5192 /* Start the copying loops. */
5193 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
5194 gfc_mark_ss_chain_used (ss
, 1);
5195 gfc_start_scalarized_body (&loop
, &block
);
5197 /* Copy each data element. */
5198 gfc_init_se (&lse
, NULL
);
5199 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5200 gfc_init_se (&rse
, NULL
);
5201 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5203 lse
.ss
= loop
.temp_ss
;
5206 gfc_conv_scalarized_array_ref (&lse
, NULL
);
5207 if (expr
->ts
.type
== BT_CHARACTER
)
5209 gfc_conv_expr (&rse
, expr
);
5210 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
5211 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
5215 gfc_conv_expr_val (&rse
, expr
);
5217 gfc_add_block_to_block (&block
, &rse
.pre
);
5218 gfc_add_block_to_block (&block
, &lse
.pre
);
5220 lse
.string_length
= rse
.string_length
;
5221 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
5222 expr
->expr_type
== EXPR_VARIABLE
, true);
5223 gfc_add_expr_to_block (&block
, tmp
);
5225 /* Finish the copying loops. */
5226 gfc_trans_scalarizing_loops (&loop
, &block
);
5228 desc
= loop
.temp_ss
->data
.info
.descriptor
;
5230 else if (expr
->expr_type
== EXPR_FUNCTION
)
5232 desc
= info
->descriptor
;
5233 se
->string_length
= ss
->string_length
;
5237 /* We pass sections without copying to a temporary. Make a new
5238 descriptor and point it at the section we want. The loop variable
5239 limits will be the limits of the section.
5240 A function may decide to repack the array to speed up access, but
5241 we're not bothered about that here. */
5250 /* Set the string_length for a character array. */
5251 if (expr
->ts
.type
== BT_CHARACTER
)
5252 se
->string_length
= gfc_get_expr_charlen (expr
);
5254 desc
= info
->descriptor
;
5255 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
5256 if (se
->direct_byref
)
5258 /* For pointer assignments we fill in the destination. */
5260 parmtype
= TREE_TYPE (parm
);
5264 /* Otherwise make a new one. */
5265 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
5266 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
5267 loop
.from
, loop
.to
, 0,
5268 GFC_ARRAY_UNKNOWN
, false);
5269 parm
= gfc_create_var (parmtype
, "parm");
5272 offset
= gfc_index_zero_node
;
5275 /* The following can be somewhat confusing. We have two
5276 descriptors, a new one and the original array.
5277 {parm, parmtype, dim} refer to the new one.
5278 {desc, type, n, secss, loop} refer to the original, which maybe
5279 a descriptorless array.
5280 The bounds of the scalarization are the bounds of the section.
5281 We don't have to worry about numeric overflows when calculating
5282 the offsets because all elements are within the array data. */
5284 /* Set the dtype. */
5285 tmp
= gfc_conv_descriptor_dtype (parm
);
5286 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
5288 /* Set offset for assignments to pointer only to zero if it is not
5290 if (se
->direct_byref
5291 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
5292 base
= gfc_index_zero_node
;
5293 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5294 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
5298 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
5299 for (n
= 0; n
< ndim
; n
++)
5301 stride
= gfc_conv_array_stride (desc
, n
);
5303 /* Work out the offset. */
5305 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5307 gcc_assert (info
->subscript
[n
]
5308 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
5309 start
= info
->subscript
[n
]->data
.scalar
.expr
;
5313 /* Check we haven't somehow got out of sync. */
5314 gcc_assert (info
->dim
[dim
] == n
);
5316 /* Evaluate and remember the start of the section. */
5317 start
= info
->start
[n
];
5318 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
5321 tmp
= gfc_conv_array_lbound (desc
, n
);
5322 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
5324 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
5325 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
5328 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5330 /* For elemental dimensions, we only need the offset. */
5334 /* Vector subscripts need copying and are handled elsewhere. */
5336 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
5338 /* Set the new lower bound. */
5339 from
= loop
.from
[dim
];
5342 /* If we have an array section or are assigning make sure that
5343 the lower bound is 1. References to the full
5344 array should otherwise keep the original bounds. */
5346 || info
->ref
->u
.ar
.type
!= AR_FULL
)
5347 && !integer_onep (from
))
5349 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5350 gfc_index_one_node
, from
);
5351 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
5352 from
= gfc_index_one_node
;
5354 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
5355 gfc_rank_cst
[dim
], from
);
5357 /* Set the new upper bound. */
5358 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
5359 gfc_rank_cst
[dim
], to
);
5361 /* Multiply the stride by the section stride to get the
5363 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
5364 stride
, info
->stride
[n
]);
5366 if (se
->direct_byref
5368 && info
->ref
->u
.ar
.type
!= AR_FULL
)
5370 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5373 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5375 tmp
= gfc_conv_array_lbound (desc
, n
);
5376 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
5377 tmp
, loop
.from
[dim
]);
5378 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (base
),
5379 tmp
, gfc_conv_array_stride (desc
, n
));
5380 base
= fold_build2 (PLUS_EXPR
, TREE_TYPE (base
),
5384 /* Store the new stride. */
5385 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
5386 gfc_rank_cst
[dim
], stride
);
5391 if (se
->data_not_needed
)
5392 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
5393 gfc_index_zero_node
);
5395 /* Point the data pointer at the 1st element in the section. */
5396 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
5397 subref_array_target
, expr
);
5399 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5400 && !se
->data_not_needed
)
5402 /* Set the offset. */
5403 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
5407 /* Only the callee knows what the correct offset it, so just set
5409 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
5414 if (!se
->direct_byref
)
5416 /* Get a pointer to the new descriptor. */
5417 if (se
->want_pointer
)
5418 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5423 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5424 gfc_add_block_to_block (&se
->post
, &loop
.post
);
5426 /* Cleanup the scalarizer. */
5427 gfc_cleanup_loop (&loop
);
5430 /* Helper function for gfc_conv_array_parameter if array size needs to be
5434 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
5437 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5438 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
5439 else if (expr
->rank
> 1)
5440 *size
= build_call_expr_loc (input_location
,
5441 gfor_fndecl_size0
, 1,
5442 gfc_build_addr_expr (NULL
, desc
));
5445 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
5446 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
5448 *size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, ubound
, lbound
);
5449 *size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, *size
,
5450 gfc_index_one_node
);
5451 *size
= fold_build2 (MAX_EXPR
, gfc_array_index_type
, *size
,
5452 gfc_index_zero_node
);
5454 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
5455 *size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, *size
,
5456 fold_convert (gfc_array_index_type
, elem
));
5459 /* Convert an array for passing as an actual parameter. */
5460 /* TODO: Optimize passing g77 arrays. */
5463 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, bool g77
,
5464 const gfc_symbol
*fsym
, const char *proc_name
,
5469 tree tmp
= NULL_TREE
;
5471 tree parent
= DECL_CONTEXT (current_function_decl
);
5472 bool full_array_var
;
5473 bool this_array_result
;
5476 bool array_constructor
;
5477 bool good_allocatable
;
5478 bool ultimate_ptr_comp
;
5479 bool ultimate_alloc_comp
;
5484 ultimate_ptr_comp
= false;
5485 ultimate_alloc_comp
= false;
5487 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5489 if (ref
->next
== NULL
)
5492 if (ref
->type
== REF_COMPONENT
)
5494 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
5495 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
5499 full_array_var
= false;
5502 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
5503 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
5505 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
5507 /* The symbol should have an array specification. */
5508 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
5510 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
5512 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
5513 expr
->ts
.u
.cl
->backend_decl
= tmp
;
5514 se
->string_length
= tmp
;
5517 /* Is this the result of the enclosing procedure? */
5518 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
5519 if (this_array_result
5520 && (sym
->backend_decl
!= current_function_decl
)
5521 && (sym
->backend_decl
!= parent
))
5522 this_array_result
= false;
5524 /* Passing address of the array if it is not pointer or assumed-shape. */
5525 if (full_array_var
&& g77
&& !this_array_result
)
5527 tmp
= gfc_get_symbol_decl (sym
);
5529 if (sym
->ts
.type
== BT_CHARACTER
)
5530 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5532 if (sym
->ts
.type
== BT_DERIVED
)
5534 gfc_conv_expr_descriptor (se
, expr
, ss
);
5535 se
->expr
= gfc_conv_array_data (se
->expr
);
5539 if (!sym
->attr
.pointer
5541 && sym
->as
->type
!= AS_ASSUMED_SHAPE
5542 && !sym
->attr
.allocatable
)
5544 /* Some variables are declared directly, others are declared as
5545 pointers and allocated on the heap. */
5546 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
5549 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5551 array_parameter_size (tmp
, expr
, size
);
5555 if (sym
->attr
.allocatable
)
5557 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5559 gfc_conv_expr_descriptor (se
, expr
, ss
);
5563 array_parameter_size (tmp
, expr
, size
);
5564 se
->expr
= gfc_conv_array_data (tmp
);
5569 /* A convenient reduction in scope. */
5570 contiguous
= g77
&& !this_array_result
&& contiguous
;
5572 /* There is no need to pack and unpack the array, if it is contiguous
5573 and not a deferred- or assumed-shape array, or if it is simply
5575 no_pack
= ((sym
&& sym
->as
5576 && !sym
->attr
.pointer
5577 && sym
->as
->type
!= AS_DEFERRED
5578 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
5580 (ref
&& ref
->u
.ar
.as
5581 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
5582 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
5584 gfc_is_simply_contiguous (expr
, false));
5586 no_pack
= contiguous
&& no_pack
;
5588 /* Array constructors are always contiguous and do not need packing. */
5589 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
5591 /* Same is true of contiguous sections from allocatable variables. */
5592 good_allocatable
= contiguous
5594 && expr
->symtree
->n
.sym
->attr
.allocatable
;
5596 /* Or ultimate allocatable components. */
5597 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
5599 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
5601 gfc_conv_expr_descriptor (se
, expr
, ss
);
5602 if (expr
->ts
.type
== BT_CHARACTER
)
5603 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5605 array_parameter_size (se
->expr
, expr
, size
);
5606 se
->expr
= gfc_conv_array_data (se
->expr
);
5610 if (this_array_result
)
5612 /* Result of the enclosing function. */
5613 gfc_conv_expr_descriptor (se
, expr
, ss
);
5615 array_parameter_size (se
->expr
, expr
, size
);
5616 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5618 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
5619 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
5620 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
5627 /* Every other type of array. */
5628 se
->want_pointer
= 1;
5629 gfc_conv_expr_descriptor (se
, expr
, ss
);
5631 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
5636 /* Deallocate the allocatable components of structures that are
5638 if (expr
->ts
.type
== BT_DERIVED
5639 && expr
->ts
.u
.derived
->attr
.alloc_comp
5640 && expr
->expr_type
!= EXPR_VARIABLE
)
5642 tmp
= build_fold_indirect_ref_loc (input_location
,
5644 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
5645 gfc_add_expr_to_block (&se
->post
, tmp
);
5648 if (g77
|| (fsym
&& fsym
->attr
.contiguous
5649 && !gfc_is_simply_contiguous (expr
, false)))
5651 tree origptr
= NULL_TREE
;
5655 /* For contiguous arrays, save the original value of the descriptor. */
5658 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
5659 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5660 tmp
= gfc_conv_array_data (tmp
);
5661 tmp
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (origptr
), origptr
,
5662 fold_convert (TREE_TYPE (origptr
), tmp
));
5663 gfc_add_expr_to_block (&se
->pre
, tmp
);
5666 /* Repack the array. */
5667 if (gfc_option
.warn_array_temp
)
5670 gfc_warning ("Creating array temporary at %L for argument '%s'",
5671 &expr
->where
, fsym
->name
);
5673 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5676 ptr
= build_call_expr_loc (input_location
,
5677 gfor_fndecl_in_pack
, 1, desc
);
5679 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5681 tmp
= gfc_conv_expr_present (sym
);
5682 ptr
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), tmp
,
5683 fold_convert (TREE_TYPE (se
->expr
), ptr
),
5684 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
5687 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5689 /* Use the packed data for the actual argument, except for contiguous arrays,
5690 where the descriptor's data component is set. */
5695 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5696 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
5699 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
5703 if (fsym
&& proc_name
)
5704 asprintf (&msg
, "An array temporary was created for argument "
5705 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
5707 asprintf (&msg
, "An array temporary was created");
5709 tmp
= build_fold_indirect_ref_loc (input_location
,
5711 tmp
= gfc_conv_array_data (tmp
);
5712 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
5713 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5715 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5716 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
5717 gfc_conv_expr_present (sym
), tmp
);
5719 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
5724 gfc_start_block (&block
);
5726 /* Copy the data back. */
5727 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
5729 tmp
= build_call_expr_loc (input_location
,
5730 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5731 gfc_add_expr_to_block (&block
, tmp
);
5734 /* Free the temporary. */
5735 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5736 gfc_add_expr_to_block (&block
, tmp
);
5738 stmt
= gfc_finish_block (&block
);
5740 gfc_init_block (&block
);
5741 /* Only if it was repacked. This code needs to be executed before the
5742 loop cleanup code. */
5743 tmp
= build_fold_indirect_ref_loc (input_location
,
5745 tmp
= gfc_conv_array_data (tmp
);
5746 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
5747 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5749 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5750 tmp
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
5751 gfc_conv_expr_present (sym
), tmp
);
5753 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5755 gfc_add_expr_to_block (&block
, tmp
);
5756 gfc_add_block_to_block (&block
, &se
->post
);
5758 gfc_init_block (&se
->post
);
5760 /* Reset the descriptor pointer. */
5763 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5764 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
5767 gfc_add_block_to_block (&se
->post
, &block
);
5772 /* Generate code to deallocate an array, if it is allocated. */
5775 gfc_trans_dealloc_allocated (tree descriptor
)
5781 gfc_start_block (&block
);
5783 var
= gfc_conv_descriptor_data_get (descriptor
);
5786 /* Call array_deallocate with an int * present in the second argument.
5787 Although it is ignored here, it's presence ensures that arrays that
5788 are already deallocated are ignored. */
5789 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true, NULL
);
5790 gfc_add_expr_to_block (&block
, tmp
);
5792 /* Zero the data pointer. */
5793 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5794 var
, build_int_cst (TREE_TYPE (var
), 0));
5795 gfc_add_expr_to_block (&block
, tmp
);
5797 return gfc_finish_block (&block
);
5801 /* This helper function calculates the size in words of a full array. */
5804 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
5809 idx
= gfc_rank_cst
[rank
- 1];
5810 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
5811 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
5812 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5813 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
5814 tmp
, gfc_index_one_node
);
5815 tmp
= gfc_evaluate_now (tmp
, block
);
5817 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
5818 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5819 return gfc_evaluate_now (tmp
, block
);
5823 /* Allocate dest to the same size as src, and copy src -> dest.
5824 If no_malloc is set, only the copy is done. */
5827 duplicate_allocatable(tree dest
, tree src
, tree type
, int rank
,
5837 /* If the source is null, set the destination to null. Then,
5838 allocate memory to the destination. */
5839 gfc_init_block (&block
);
5843 tmp
= null_pointer_node
;
5844 tmp
= fold_build2 (MODIFY_EXPR
, type
, dest
, tmp
);
5845 gfc_add_expr_to_block (&block
, tmp
);
5846 null_data
= gfc_finish_block (&block
);
5848 gfc_init_block (&block
);
5849 size
= TYPE_SIZE_UNIT (type
);
5852 tmp
= gfc_call_malloc (&block
, type
, size
);
5853 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, dest
,
5854 fold_convert (type
, tmp
));
5855 gfc_add_expr_to_block (&block
, tmp
);
5858 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5859 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
5864 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5865 null_data
= gfc_finish_block (&block
);
5867 gfc_init_block (&block
);
5868 nelems
= get_full_array_size (&block
, src
, rank
);
5869 tmp
= fold_convert (gfc_array_index_type
,
5870 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
5871 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, nelems
, tmp
);
5874 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
5875 tmp
= gfc_call_malloc (&block
, tmp
, size
);
5876 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
5879 /* We know the temporary and the value will be the same length,
5880 so can use memcpy. */
5881 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
5882 tmp
= build_call_expr_loc (input_location
,
5883 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
5884 gfc_conv_descriptor_data_get (src
), size
);
5887 gfc_add_expr_to_block (&block
, tmp
);
5888 tmp
= gfc_finish_block (&block
);
5890 /* Null the destination if the source is null; otherwise do
5891 the allocate and copy. */
5895 null_cond
= gfc_conv_descriptor_data_get (src
);
5897 null_cond
= convert (pvoid_type_node
, null_cond
);
5898 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
,
5899 null_cond
, null_pointer_node
);
5900 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
5904 /* Allocate dest to the same size as src, and copy data src -> dest. */
5907 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
5909 return duplicate_allocatable(dest
, src
, type
, rank
, false);
5913 /* Copy data src -> dest. */
5916 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
5918 return duplicate_allocatable(dest
, src
, type
, rank
, true);
5922 /* Recursively traverse an object of derived type, generating code to
5923 deallocate, nullify or copy allocatable components. This is the work horse
5924 function for the functions named in this enum. */
5926 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
5927 COPY_ONLY_ALLOC_COMP
};
5930 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
5931 tree dest
, int rank
, int purpose
)
5935 stmtblock_t fnblock
;
5936 stmtblock_t loopbody
;
5947 tree null_cond
= NULL_TREE
;
5949 gfc_init_block (&fnblock
);
5951 decl_type
= TREE_TYPE (decl
);
5953 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
5954 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
5956 decl
= build_fold_indirect_ref_loc (input_location
,
5959 /* Just in case in gets dereferenced. */
5960 decl_type
= TREE_TYPE (decl
);
5962 /* If this an array of derived types with allocatable components
5963 build a loop and recursively call this function. */
5964 if (TREE_CODE (decl_type
) == ARRAY_TYPE
5965 || GFC_DESCRIPTOR_TYPE_P (decl_type
))
5967 tmp
= gfc_conv_array_data (decl
);
5968 var
= build_fold_indirect_ref_loc (input_location
,
5971 /* Get the number of elements - 1 and set the counter. */
5972 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
5974 /* Use the descriptor for an allocatable array. Since this
5975 is a full array reference, we only need the descriptor
5976 information from dimension = rank. */
5977 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
5978 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
5979 tmp
, gfc_index_one_node
);
5981 null_cond
= gfc_conv_descriptor_data_get (decl
);
5982 null_cond
= fold_build2 (NE_EXPR
, boolean_type_node
, null_cond
,
5983 build_int_cst (TREE_TYPE (null_cond
), 0));
5987 /* Otherwise use the TYPE_DOMAIN information. */
5988 tmp
= array_type_nelts (decl_type
);
5989 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5992 /* Remember that this is, in fact, the no. of elements - 1. */
5993 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
5994 index
= gfc_create_var (gfc_array_index_type
, "S");
5996 /* Build the body of the loop. */
5997 gfc_init_block (&loopbody
);
5999 vref
= gfc_build_array_ref (var
, index
, NULL
);
6001 if (purpose
== COPY_ALLOC_COMP
)
6003 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
6005 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
6006 gfc_add_expr_to_block (&fnblock
, tmp
);
6008 tmp
= build_fold_indirect_ref_loc (input_location
,
6009 gfc_conv_array_data (dest
));
6010 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
6011 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
6013 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
6015 tmp
= build_fold_indirect_ref_loc (input_location
,
6016 gfc_conv_array_data (dest
));
6017 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
6018 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
6022 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
6024 gfc_add_expr_to_block (&loopbody
, tmp
);
6026 /* Build the loop and return. */
6027 gfc_init_loopinfo (&loop
);
6029 loop
.from
[0] = gfc_index_zero_node
;
6030 loop
.loopvar
[0] = index
;
6031 loop
.to
[0] = nelems
;
6032 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
6033 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
6035 tmp
= gfc_finish_block (&fnblock
);
6036 if (null_cond
!= NULL_TREE
)
6037 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
6038 build_empty_stmt (input_location
));
6043 /* Otherwise, act on the components or recursively call self to
6044 act on a chain of components. */
6045 for (c
= der_type
->components
; c
; c
= c
->next
)
6047 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
6048 && c
->ts
.u
.derived
->attr
.alloc_comp
;
6049 cdecl = c
->backend_decl
;
6050 ctype
= TREE_TYPE (cdecl);
6054 case DEALLOCATE_ALLOC_COMP
:
6055 /* Do not deallocate the components of ultimate pointer
6057 if (cmp_has_alloc_comps
&& !c
->attr
.pointer
)
6059 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6060 decl
, cdecl, NULL_TREE
);
6061 rank
= c
->as
? c
->as
->rank
: 0;
6062 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6064 gfc_add_expr_to_block (&fnblock
, tmp
);
6067 if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6069 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6070 decl
, cdecl, NULL_TREE
);
6071 tmp
= gfc_trans_dealloc_allocated (comp
);
6072 gfc_add_expr_to_block (&fnblock
, tmp
);
6074 else if (c
->attr
.allocatable
)
6076 /* Allocatable scalar components. */
6077 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6079 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, true, NULL
);
6080 gfc_add_expr_to_block (&fnblock
, tmp
);
6082 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6083 build_int_cst (TREE_TYPE (comp
), 0));
6084 gfc_add_expr_to_block (&fnblock
, tmp
);
6086 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
6088 /* Allocatable scalar CLASS components. */
6089 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6091 /* Add reference to '$data' component. */
6092 tmp
= CLASS_DATA (c
)->backend_decl
;
6093 comp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
6094 comp
, tmp
, NULL_TREE
);
6096 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, true, NULL
);
6097 gfc_add_expr_to_block (&fnblock
, tmp
);
6099 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6100 build_int_cst (TREE_TYPE (comp
), 0));
6101 gfc_add_expr_to_block (&fnblock
, tmp
);
6105 case NULLIFY_ALLOC_COMP
:
6106 if (c
->attr
.pointer
)
6108 else if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6110 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6111 decl
, cdecl, NULL_TREE
);
6112 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
6114 else if (c
->attr
.allocatable
)
6116 /* Allocatable scalar components. */
6117 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6118 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6119 build_int_cst (TREE_TYPE (comp
), 0));
6120 gfc_add_expr_to_block (&fnblock
, tmp
);
6122 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
6124 /* Allocatable scalar CLASS components. */
6125 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6126 /* Add reference to '$data' component. */
6127 tmp
= CLASS_DATA (c
)->backend_decl
;
6128 comp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
6129 comp
, tmp
, NULL_TREE
);
6130 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, comp
,
6131 build_int_cst (TREE_TYPE (comp
), 0));
6132 gfc_add_expr_to_block (&fnblock
, tmp
);
6134 else if (cmp_has_alloc_comps
)
6136 comp
= fold_build3 (COMPONENT_REF
, ctype
,
6137 decl
, cdecl, NULL_TREE
);
6138 rank
= c
->as
? c
->as
->rank
: 0;
6139 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6141 gfc_add_expr_to_block (&fnblock
, tmp
);
6145 case COPY_ALLOC_COMP
:
6146 if (c
->attr
.pointer
)
6149 /* We need source and destination components. */
6150 comp
= fold_build3 (COMPONENT_REF
, ctype
, decl
, cdecl, NULL_TREE
);
6151 dcmp
= fold_build3 (COMPONENT_REF
, ctype
, dest
, cdecl, NULL_TREE
);
6152 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
6154 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
6156 rank
= c
->as
? c
->as
->rank
: 0;
6157 tmp
= gfc_duplicate_allocatable(dcmp
, comp
, ctype
, rank
);
6158 gfc_add_expr_to_block (&fnblock
, tmp
);
6161 if (cmp_has_alloc_comps
)
6163 rank
= c
->as
? c
->as
->rank
: 0;
6164 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
6165 gfc_add_modify (&fnblock
, dcmp
, tmp
);
6166 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
6168 gfc_add_expr_to_block (&fnblock
, tmp
);
6178 return gfc_finish_block (&fnblock
);
6181 /* Recursively traverse an object of derived type, generating code to
6182 nullify allocatable components. */
6185 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6187 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6188 NULLIFY_ALLOC_COMP
);
6192 /* Recursively traverse an object of derived type, generating code to
6193 deallocate allocatable components. */
6196 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6198 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6199 DEALLOCATE_ALLOC_COMP
);
6203 /* Recursively traverse an object of derived type, generating code to
6204 copy it and its allocatable components. */
6207 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6209 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
6213 /* Recursively traverse an object of derived type, generating code to
6214 copy only its allocatable components. */
6217 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6219 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
6223 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6224 Do likewise, recursively if necessary, with the allocatable components of
6228 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6234 stmtblock_t cleanup
;
6237 bool sym_has_alloc_comp
;
6239 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
6240 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
6242 /* Make sure the frontend gets these right. */
6243 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
6244 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6245 "allocatable attribute or derived type without allocatable "
6248 gfc_init_block (&init
);
6250 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
6251 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
6253 if (sym
->ts
.type
== BT_CHARACTER
6254 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6256 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6257 gfc_trans_vla_type_sizes (sym
, &init
);
6260 /* Dummy, use associated and result variables don't need anything special. */
6261 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
6263 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6267 gfc_get_backend_locus (&loc
);
6268 gfc_set_backend_locus (&sym
->declared_at
);
6269 descriptor
= sym
->backend_decl
;
6271 /* Although static, derived types with default initializers and
6272 allocatable components must not be nulled wholesale; instead they
6273 are treated component by component. */
6274 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
6276 /* SAVEd variables are not freed on exit. */
6277 gfc_trans_static_array_pointer (sym
);
6279 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6283 /* Get the descriptor type. */
6284 type
= TREE_TYPE (sym
->backend_decl
);
6286 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6289 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
6291 if (sym
->value
== NULL
6292 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
6294 rank
= sym
->as
? sym
->as
->rank
: 0;
6295 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
6297 gfc_add_expr_to_block (&init
, tmp
);
6300 gfc_init_default_dt (sym
, &init
, false);
6303 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
6305 /* If the backend_decl is not a descriptor, we must have a pointer
6307 descriptor
= build_fold_indirect_ref_loc (input_location
,
6309 type
= TREE_TYPE (descriptor
);
6312 /* NULLIFY the data pointer. */
6313 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
6314 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
6316 gfc_init_block (&cleanup
);
6317 gfc_set_backend_locus (&loc
);
6319 /* Allocatable arrays need to be freed when they go out of scope.
6320 The allocatable components of pointers must not be touched. */
6321 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
6322 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
6325 rank
= sym
->as
? sym
->as
->rank
: 0;
6326 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
6327 gfc_add_expr_to_block (&cleanup
, tmp
);
6330 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
6331 && !sym
->attr
.save
&& !sym
->attr
.result
)
6333 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
6334 gfc_add_expr_to_block (&cleanup
, tmp
);
6337 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
6338 gfc_finish_block (&cleanup
));
6341 /************ Expression Walking Functions ******************/
6343 /* Walk a variable reference.
6345 Possible extension - multiple component subscripts.
6346 x(:,:) = foo%a(:)%b(:)
6348 forall (i=..., j=...)
6349 x(i,j) = foo%a(j)%b(i)
6351 This adds a fair amount of complexity because you need to deal with more
6352 than one ref. Maybe handle in a similar manner to vector subscripts.
6353 Maybe not worth the effort. */
6357 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6364 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6365 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
6368 for (; ref
; ref
= ref
->next
)
6370 if (ref
->type
== REF_SUBSTRING
)
6372 newss
= gfc_get_ss ();
6373 newss
->type
= GFC_SS_SCALAR
;
6374 newss
->expr
= ref
->u
.ss
.start
;
6378 newss
= gfc_get_ss ();
6379 newss
->type
= GFC_SS_SCALAR
;
6380 newss
->expr
= ref
->u
.ss
.end
;
6385 /* We're only interested in array sections from now on. */
6386 if (ref
->type
!= REF_ARRAY
)
6391 if (ar
->as
->rank
== 0)
6393 /* Scalar coarray. */
6400 for (n
= 0; n
< ar
->dimen
; n
++)
6402 newss
= gfc_get_ss ();
6403 newss
->type
= GFC_SS_SCALAR
;
6404 newss
->expr
= ar
->start
[n
];
6411 newss
= gfc_get_ss ();
6412 newss
->type
= GFC_SS_SECTION
;
6415 newss
->data
.info
.dimen
= ar
->as
->rank
;
6416 newss
->data
.info
.ref
= ref
;
6418 /* Make sure array is the same as array(:,:), this way
6419 we don't need to special case all the time. */
6420 ar
->dimen
= ar
->as
->rank
;
6421 for (n
= 0; n
< ar
->dimen
; n
++)
6423 newss
->data
.info
.dim
[n
] = n
;
6424 ar
->dimen_type
[n
] = DIMEN_RANGE
;
6426 gcc_assert (ar
->start
[n
] == NULL
);
6427 gcc_assert (ar
->end
[n
] == NULL
);
6428 gcc_assert (ar
->stride
[n
] == NULL
);
6434 newss
= gfc_get_ss ();
6435 newss
->type
= GFC_SS_SECTION
;
6438 newss
->data
.info
.dimen
= 0;
6439 newss
->data
.info
.ref
= ref
;
6441 /* We add SS chains for all the subscripts in the section. */
6442 for (n
= 0; n
< ar
->dimen
; n
++)
6446 switch (ar
->dimen_type
[n
])
6449 /* Add SS for elemental (scalar) subscripts. */
6450 gcc_assert (ar
->start
[n
]);
6451 indexss
= gfc_get_ss ();
6452 indexss
->type
= GFC_SS_SCALAR
;
6453 indexss
->expr
= ar
->start
[n
];
6454 indexss
->next
= gfc_ss_terminator
;
6455 indexss
->loop_chain
= gfc_ss_terminator
;
6456 newss
->data
.info
.subscript
[n
] = indexss
;
6460 /* We don't add anything for sections, just remember this
6461 dimension for later. */
6462 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
6463 newss
->data
.info
.dimen
++;
6467 /* Create a GFC_SS_VECTOR index in which we can store
6468 the vector's descriptor. */
6469 indexss
= gfc_get_ss ();
6470 indexss
->type
= GFC_SS_VECTOR
;
6471 indexss
->expr
= ar
->start
[n
];
6472 indexss
->next
= gfc_ss_terminator
;
6473 indexss
->loop_chain
= gfc_ss_terminator
;
6474 newss
->data
.info
.subscript
[n
] = indexss
;
6475 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
6476 newss
->data
.info
.dimen
++;
6480 /* We should know what sort of section it is by now. */
6484 /* We should have at least one non-elemental dimension. */
6485 gcc_assert (newss
->data
.info
.dimen
> 0);
6490 /* We should know what sort of section it is by now. */
6499 /* Walk an expression operator. If only one operand of a binary expression is
6500 scalar, we must also add the scalar term to the SS chain. */
6503 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6509 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
6510 if (expr
->value
.op
.op2
== NULL
)
6513 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
6515 /* All operands are scalar. Pass back and let the caller deal with it. */
6519 /* All operands require scalarization. */
6520 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
6523 /* One of the operands needs scalarization, the other is scalar.
6524 Create a gfc_ss for the scalar expression. */
6525 newss
= gfc_get_ss ();
6526 newss
->type
= GFC_SS_SCALAR
;
6529 /* First operand is scalar. We build the chain in reverse order, so
6530 add the scalar SS after the second operand. */
6532 while (head
&& head
->next
!= ss
)
6534 /* Check we haven't somehow broken the chain. */
6538 newss
->expr
= expr
->value
.op
.op1
;
6540 else /* head2 == head */
6542 gcc_assert (head2
== head
);
6543 /* Second operand is scalar. */
6544 newss
->next
= head2
;
6546 newss
->expr
= expr
->value
.op
.op2
;
6553 /* Reverse a SS chain. */
6556 gfc_reverse_ss (gfc_ss
* ss
)
6561 gcc_assert (ss
!= NULL
);
6563 head
= gfc_ss_terminator
;
6564 while (ss
!= gfc_ss_terminator
)
6567 /* Check we didn't somehow break the chain. */
6568 gcc_assert (next
!= NULL
);
6578 /* Walk the arguments of an elemental function. */
6581 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
6589 head
= gfc_ss_terminator
;
6592 for (; arg
; arg
= arg
->next
)
6597 newss
= gfc_walk_subexpr (head
, arg
->expr
);
6600 /* Scalar argument. */
6601 newss
= gfc_get_ss ();
6603 newss
->expr
= arg
->expr
;
6613 while (tail
->next
!= gfc_ss_terminator
)
6620 /* If all the arguments are scalar we don't need the argument SS. */
6621 gfc_free_ss_chain (head
);
6626 /* Add it onto the existing chain. */
6632 /* Walk a function call. Scalar functions are passed back, and taken out of
6633 scalarization loops. For elemental functions we walk their arguments.
6634 The result of functions returning arrays is stored in a temporary outside
6635 the loop, so that the function is only called once. Hence we do not need
6636 to walk their arguments. */
6639 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6642 gfc_intrinsic_sym
*isym
;
6644 gfc_component
*comp
= NULL
;
6646 isym
= expr
->value
.function
.isym
;
6648 /* Handle intrinsic functions separately. */
6650 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
6652 sym
= expr
->value
.function
.esym
;
6654 sym
= expr
->symtree
->n
.sym
;
6656 /* A function that returns arrays. */
6657 gfc_is_proc_ptr_comp (expr
, &comp
);
6658 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
6659 || (comp
&& comp
->attr
.dimension
))
6661 newss
= gfc_get_ss ();
6662 newss
->type
= GFC_SS_FUNCTION
;
6665 newss
->data
.info
.dimen
= expr
->rank
;
6669 /* Walk the parameters of an elemental function. For now we always pass
6671 if (sym
->attr
.elemental
)
6672 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
6675 /* Scalar functions are OK as these are evaluated outside the scalarization
6676 loop. Pass back and let the caller deal with it. */
6681 /* An array temporary is constructed for array constructors. */
6684 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
6689 newss
= gfc_get_ss ();
6690 newss
->type
= GFC_SS_CONSTRUCTOR
;
6693 newss
->data
.info
.dimen
= expr
->rank
;
6694 for (n
= 0; n
< expr
->rank
; n
++)
6695 newss
->data
.info
.dim
[n
] = n
;
6701 /* Walk an expression. Add walked expressions to the head of the SS chain.
6702 A wholly scalar expression will not be added. */
6705 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
6709 switch (expr
->expr_type
)
6712 head
= gfc_walk_variable_expr (ss
, expr
);
6716 head
= gfc_walk_op_expr (ss
, expr
);
6720 head
= gfc_walk_function_expr (ss
, expr
);
6725 case EXPR_STRUCTURE
:
6726 /* Pass back and let the caller deal with it. */
6730 head
= gfc_walk_array_constructor (ss
, expr
);
6733 case EXPR_SUBSTRING
:
6734 /* Pass back and let the caller deal with it. */
6738 internal_error ("bad expression type during walk (%d)",
6745 /* Entry point for expression walking.
6746 A return value equal to the passed chain means this is
6747 a scalar expression. It is up to the caller to take whatever action is
6748 necessary to translate these. */
6751 gfc_walk_expr (gfc_expr
* expr
)
6755 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
6756 return gfc_reverse_ss (res
);