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 bool gfc_get_array_constructor_size (mpz_t
*, gfc_constructor_base
);
96 /* The contents of this structure aren't actually used, just the address. */
97 static gfc_ss gfc_ss_terminator_var
;
98 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
102 gfc_array_dataptr_type (tree desc
)
104 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
108 /* Build expressions to access the members of an array descriptor.
109 It's surprisingly easy to mess up here, so never access
110 an array descriptor by "brute force", always use these
111 functions. This also avoids problems if we change the format
112 of an array descriptor.
114 To understand these magic numbers, look at the comments
115 before gfc_build_array_type() in trans-types.c.
117 The code within these defines should be the only code which knows the format
118 of an array descriptor.
120 Any code just needing to read obtain the bounds of an array should use
121 gfc_conv_array_* rather than the following functions as these will return
122 know constant values, and work with arrays which do not have descriptors.
124 Don't forget to #undef these! */
127 #define OFFSET_FIELD 1
128 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 3
131 #define STRIDE_SUBFIELD 0
132 #define LBOUND_SUBFIELD 1
133 #define UBOUND_SUBFIELD 2
135 /* This provides READ-ONLY access to the data field. The field itself
136 doesn't have the proper type. */
139 gfc_conv_descriptor_data_get (tree desc
)
143 type
= TREE_TYPE (desc
);
144 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
146 field
= TYPE_FIELDS (type
);
147 gcc_assert (DATA_FIELD
== 0);
149 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
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_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
177 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (field
), value
));
181 /* This provides address access to the data field. This should only be
182 used by array allocation, passing this on to the runtime. */
185 gfc_conv_descriptor_data_addr (tree desc
)
189 type
= TREE_TYPE (desc
);
190 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
192 field
= TYPE_FIELDS (type
);
193 gcc_assert (DATA_FIELD
== 0);
195 t
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
), desc
,
197 return gfc_build_addr_expr (NULL_TREE
, t
);
201 gfc_conv_descriptor_offset (tree desc
)
206 type
= TREE_TYPE (desc
);
207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
209 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
210 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
212 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
213 desc
, field
, NULL_TREE
);
217 gfc_conv_descriptor_offset_get (tree desc
)
219 return gfc_conv_descriptor_offset (desc
);
223 gfc_conv_descriptor_offset_set (stmtblock_t
*block
, tree desc
,
226 tree t
= gfc_conv_descriptor_offset (desc
);
227 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
232 gfc_conv_descriptor_dtype (tree desc
)
237 type
= TREE_TYPE (desc
);
238 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
240 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
241 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
243 return fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
244 desc
, field
, NULL_TREE
);
248 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
254 type
= TREE_TYPE (desc
);
255 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
257 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
258 gcc_assert (field
!= NULL_TREE
259 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
260 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
262 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
263 desc
, field
, NULL_TREE
);
264 tmp
= gfc_build_array_ref (tmp
, dim
, NULL
);
269 gfc_conv_descriptor_stride (tree desc
, tree dim
)
274 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
275 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
276 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
277 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
279 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
280 tmp
, field
, NULL_TREE
);
285 gfc_conv_descriptor_stride_get (tree desc
, tree dim
)
287 tree type
= TREE_TYPE (desc
);
288 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
289 if (integer_zerop (dim
)
290 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
291 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
292 ||GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
293 return gfc_index_one_node
;
295 return gfc_conv_descriptor_stride (desc
, dim
);
299 gfc_conv_descriptor_stride_set (stmtblock_t
*block
, tree desc
,
300 tree dim
, tree value
)
302 tree t
= gfc_conv_descriptor_stride (desc
, dim
);
303 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
307 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
312 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
313 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
314 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
315 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
317 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
318 tmp
, field
, NULL_TREE
);
323 gfc_conv_descriptor_lbound_get (tree desc
, tree dim
)
325 return gfc_conv_descriptor_lbound (desc
, dim
);
329 gfc_conv_descriptor_lbound_set (stmtblock_t
*block
, tree desc
,
330 tree dim
, tree value
)
332 tree t
= gfc_conv_descriptor_lbound (desc
, dim
);
333 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
337 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
342 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
343 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
344 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
345 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
347 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
348 tmp
, field
, NULL_TREE
);
353 gfc_conv_descriptor_ubound_get (tree desc
, tree dim
)
355 return gfc_conv_descriptor_ubound (desc
, dim
);
359 gfc_conv_descriptor_ubound_set (stmtblock_t
*block
, tree desc
,
360 tree dim
, tree value
)
362 tree t
= gfc_conv_descriptor_ubound (desc
, dim
);
363 gfc_add_modify (block
, t
, fold_convert (TREE_TYPE (t
), value
));
366 /* Build a null array descriptor constructor. */
369 gfc_build_null_descriptor (tree type
)
374 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
375 gcc_assert (DATA_FIELD
== 0);
376 field
= TYPE_FIELDS (type
);
378 /* Set a NULL data pointer. */
379 tmp
= build_constructor_single (type
, field
, null_pointer_node
);
380 TREE_CONSTANT (tmp
) = 1;
381 /* All other fields are ignored. */
387 /* Modify a descriptor such that the lbound of a given dimension is the value
388 specified. This also updates ubound and offset accordingly. */
391 gfc_conv_shift_descriptor_lbound (stmtblock_t
* block
, tree desc
,
392 int dim
, tree new_lbound
)
394 tree offs
, ubound
, lbound
, stride
;
395 tree diff
, offs_diff
;
397 new_lbound
= fold_convert (gfc_array_index_type
, new_lbound
);
399 offs
= gfc_conv_descriptor_offset_get (desc
);
400 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
401 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
402 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[dim
]);
404 /* Get difference (new - old) by which to shift stuff. */
405 diff
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
408 /* Shift ubound and offset accordingly. This has to be done before
409 updating the lbound, as they depend on the lbound expression! */
410 ubound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
412 gfc_conv_descriptor_ubound_set (block
, desc
, gfc_rank_cst
[dim
], ubound
);
413 offs_diff
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
415 offs
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
417 gfc_conv_descriptor_offset_set (block
, desc
, offs
);
419 /* Finally set lbound to value we want. */
420 gfc_conv_descriptor_lbound_set (block
, desc
, gfc_rank_cst
[dim
], new_lbound
);
424 /* Cleanup those #defines. */
429 #undef DIMENSION_FIELD
430 #undef STRIDE_SUBFIELD
431 #undef LBOUND_SUBFIELD
432 #undef UBOUND_SUBFIELD
435 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
436 flags & 1 = Main loop body.
437 flags & 2 = temp copy loop. */
440 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
442 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
443 ss
->useflags
= flags
;
446 static void gfc_free_ss (gfc_ss
*);
449 /* Free a gfc_ss chain. */
452 gfc_free_ss_chain (gfc_ss
* ss
)
456 while (ss
!= gfc_ss_terminator
)
458 gcc_assert (ss
!= NULL
);
469 gfc_free_ss (gfc_ss
* ss
)
476 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
478 if (ss
->data
.info
.subscript
[ss
->data
.info
.dim
[n
]])
479 gfc_free_ss_chain (ss
->data
.info
.subscript
[ss
->data
.info
.dim
[n
]]);
491 /* Free all the SS associated with a loop. */
494 gfc_cleanup_loop (gfc_loopinfo
* loop
)
500 while (ss
!= gfc_ss_terminator
)
502 gcc_assert (ss
!= NULL
);
503 next
= ss
->loop_chain
;
510 /* Associate a SS chain with a loop. */
513 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
517 if (head
== gfc_ss_terminator
)
521 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
523 if (ss
->next
== gfc_ss_terminator
)
524 ss
->loop_chain
= loop
->ss
;
526 ss
->loop_chain
= ss
->next
;
528 gcc_assert (ss
== gfc_ss_terminator
);
533 /* Generate an initializer for a static pointer or allocatable array. */
536 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
540 gcc_assert (TREE_STATIC (sym
->backend_decl
));
541 /* Just zero the data member. */
542 type
= TREE_TYPE (sym
->backend_decl
);
543 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
547 /* If the bounds of SE's loop have not yet been set, see if they can be
548 determined from array spec AS, which is the array spec of a called
549 function. MAPPING maps the callee's dummy arguments to the values
550 that the caller is passing. Add any initialization and finalization
554 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping
* mapping
,
555 gfc_se
* se
, gfc_array_spec
* as
)
563 if (as
&& as
->type
== AS_EXPLICIT
)
564 for (n
= 0; n
< se
->loop
->dimen
; n
++)
566 dim
= se
->ss
->data
.info
.dim
[n
];
567 gcc_assert (dim
< as
->rank
);
568 gcc_assert (se
->loop
->dimen
== as
->rank
);
569 if (se
->loop
->to
[n
] == NULL_TREE
)
571 /* Evaluate the lower bound. */
572 gfc_init_se (&tmpse
, NULL
);
573 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->lower
[dim
]);
574 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
575 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
576 lower
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
578 /* ...and the upper bound. */
579 gfc_init_se (&tmpse
, NULL
);
580 gfc_apply_interface_mapping (mapping
, &tmpse
, as
->upper
[dim
]);
581 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
582 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
583 upper
= fold_convert (gfc_array_index_type
, tmpse
.expr
);
585 /* Set the upper bound of the loop to UPPER - LOWER. */
586 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
587 gfc_array_index_type
, upper
, lower
);
588 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
589 se
->loop
->to
[n
] = tmp
;
595 /* Generate code to allocate an array temporary, or create a variable to
596 hold the data. If size is NULL, zero the descriptor so that the
597 callee will allocate the array. If DEALLOC is true, also generate code to
598 free the array afterwards.
600 If INITIAL is not NULL, it is packed using internal_pack and the result used
601 as data instead of allocating a fresh, unitialized area of memory.
603 Initialization code is added to PRE and finalization code to POST.
604 DYNAMIC is true if the caller may want to extend the array later
605 using realloc. This prevents us from putting the array on the stack. */
608 gfc_trans_allocate_array_storage (stmtblock_t
* pre
, stmtblock_t
* post
,
609 gfc_ss_info
* info
, tree size
, tree nelem
,
610 tree initial
, bool dynamic
, bool dealloc
)
616 desc
= info
->descriptor
;
617 info
->offset
= gfc_index_zero_node
;
618 if (size
== NULL_TREE
|| integer_zerop (size
))
620 /* A callee allocated array. */
621 gfc_conv_descriptor_data_set (pre
, desc
, null_pointer_node
);
626 /* Allocate the temporary. */
627 onstack
= !dynamic
&& initial
== NULL_TREE
628 && gfc_can_put_var_on_stack (size
);
632 /* Make a temporary variable to hold the data. */
633 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (nelem
),
634 nelem
, gfc_index_one_node
);
635 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
637 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
639 tmp
= gfc_create_var (tmp
, "A");
640 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
641 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
645 /* Allocate memory to hold the data or call internal_pack. */
646 if (initial
== NULL_TREE
)
648 tmp
= gfc_call_malloc (pre
, NULL
, size
);
649 tmp
= gfc_evaluate_now (tmp
, pre
);
656 stmtblock_t do_copying
;
658 tmp
= TREE_TYPE (initial
); /* Pointer to descriptor. */
659 gcc_assert (TREE_CODE (tmp
) == POINTER_TYPE
);
660 tmp
= TREE_TYPE (tmp
); /* The descriptor itself. */
661 tmp
= gfc_get_element_type (tmp
);
662 gcc_assert (tmp
== gfc_get_element_type (TREE_TYPE (desc
)));
663 packed
= gfc_create_var (build_pointer_type (tmp
), "data");
665 tmp
= build_call_expr_loc (input_location
,
666 gfor_fndecl_in_pack
, 1, initial
);
667 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
668 gfc_add_modify (pre
, packed
, tmp
);
670 tmp
= build_fold_indirect_ref_loc (input_location
,
672 source_data
= gfc_conv_descriptor_data_get (tmp
);
674 /* internal_pack may return source->data without any allocation
675 or copying if it is already packed. If that's the case, we
676 need to allocate and copy manually. */
678 gfc_start_block (&do_copying
);
679 tmp
= gfc_call_malloc (&do_copying
, NULL
, size
);
680 tmp
= fold_convert (TREE_TYPE (packed
), tmp
);
681 gfc_add_modify (&do_copying
, packed
, tmp
);
682 tmp
= gfc_build_memcpy_call (packed
, source_data
, size
);
683 gfc_add_expr_to_block (&do_copying
, tmp
);
685 was_packed
= fold_build2_loc (input_location
, EQ_EXPR
,
686 boolean_type_node
, packed
,
688 tmp
= gfc_finish_block (&do_copying
);
689 tmp
= build3_v (COND_EXPR
, was_packed
, tmp
,
690 build_empty_stmt (input_location
));
691 gfc_add_expr_to_block (pre
, tmp
);
693 tmp
= fold_convert (pvoid_type_node
, packed
);
696 gfc_conv_descriptor_data_set (pre
, desc
, tmp
);
699 info
->data
= gfc_conv_descriptor_data_get (desc
);
701 /* The offset is zero because we create temporaries with a zero
703 gfc_conv_descriptor_offset_set (pre
, desc
, gfc_index_zero_node
);
705 if (dealloc
&& !onstack
)
707 /* Free the temporary. */
708 tmp
= gfc_conv_descriptor_data_get (desc
);
709 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
710 gfc_add_expr_to_block (post
, tmp
);
715 /* Get the array reference dimension corresponding to the given loop dimension.
716 It is different from the true array dimension given by the dim array in
717 the case of a partial array reference
718 It is different from the loop dimension in the case of a transposed array.
722 get_array_ref_dim (gfc_ss_info
*info
, int loop_dim
)
724 int n
, array_dim
, array_ref_dim
;
727 array_dim
= info
->dim
[loop_dim
];
729 for (n
= 0; n
< info
->dimen
; n
++)
730 if (n
!= loop_dim
&& info
->dim
[n
] < array_dim
)
733 return array_ref_dim
;
737 /* Generate code to create and initialize the descriptor for a temporary
738 array. This is used for both temporaries needed by the scalarizer, and
739 functions returning arrays. Adjusts the loop variables to be
740 zero-based, and calculates the loop bounds for callee allocated arrays.
741 Allocate the array unless it's callee allocated (we have a callee
742 allocated array if 'callee_alloc' is true, or if loop->to[n] is
743 NULL_TREE for any n). Also fills in the descriptor, data and offset
744 fields of info if known. Returns the size of the array, or NULL for a
745 callee allocated array.
747 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
748 gfc_trans_allocate_array_storage.
752 gfc_trans_create_temp_array (stmtblock_t
* pre
, stmtblock_t
* post
,
753 gfc_loopinfo
* loop
, gfc_ss_info
* info
,
754 tree eltype
, tree initial
, bool dynamic
,
755 bool dealloc
, bool callee_alloc
, locus
* where
)
757 tree from
[GFC_MAX_DIMENSIONS
], to
[GFC_MAX_DIMENSIONS
];
767 memset (from
, 0, sizeof (from
));
768 memset (to
, 0, sizeof (to
));
770 gcc_assert (info
->dimen
> 0);
771 gcc_assert (loop
->dimen
== info
->dimen
);
773 if (gfc_option
.warn_array_temp
&& where
)
774 gfc_warning ("Creating array temporary at %L", where
);
776 /* Set the lower bound to zero. */
777 for (n
= 0; n
< loop
->dimen
; n
++)
781 /* Callee allocated arrays may not have a known bound yet. */
783 loop
->to
[n
] = gfc_evaluate_now (
784 fold_build2_loc (input_location
, MINUS_EXPR
,
785 gfc_array_index_type
,
786 loop
->to
[n
], loop
->from
[n
]),
788 loop
->from
[n
] = gfc_index_zero_node
;
790 /* We are constructing the temporary's descriptor based on the loop
791 dimensions. As the dimensions may be accessed in arbitrary order
792 (think of transpose) the size taken from the n'th loop may not map
793 to the n'th dimension of the array. We need to reconstruct loop infos
794 in the right order before using it to set the descriptor
796 tmp_dim
= get_array_ref_dim (info
, n
);
797 from
[tmp_dim
] = loop
->from
[n
];
798 to
[tmp_dim
] = loop
->to
[n
];
800 info
->delta
[dim
] = gfc_index_zero_node
;
801 info
->start
[dim
] = gfc_index_zero_node
;
802 info
->end
[dim
] = gfc_index_zero_node
;
803 info
->stride
[dim
] = gfc_index_one_node
;
806 /* Initialize the descriptor. */
808 gfc_get_array_type_bounds (eltype
, info
->dimen
, 0, from
, to
, 1,
809 GFC_ARRAY_UNKNOWN
, true);
810 desc
= gfc_create_var (type
, "atmp");
811 GFC_DECL_PACKED_ARRAY (desc
) = 1;
813 info
->descriptor
= desc
;
814 size
= gfc_index_one_node
;
816 /* Fill in the array dtype. */
817 tmp
= gfc_conv_descriptor_dtype (desc
);
818 gfc_add_modify (pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
821 Fill in the bounds and stride. This is a packed array, so:
824 for (n = 0; n < rank; n++)
827 delta = ubound[n] + 1 - lbound[n];
830 size = size * sizeof(element);
835 /* If there is at least one null loop->to[n], it is a callee allocated
837 for (n
= 0; n
< loop
->dimen
; n
++)
838 if (loop
->to
[n
] == NULL_TREE
)
844 for (n
= 0; n
< loop
->dimen
; n
++)
848 if (size
== NULL_TREE
)
850 /* For a callee allocated array express the loop bounds in terms
851 of the descriptor fields. */
852 tmp
= fold_build2_loc (input_location
,
853 MINUS_EXPR
, gfc_array_index_type
,
854 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]),
855 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]));
860 /* Store the stride and bound components in the descriptor. */
861 gfc_conv_descriptor_stride_set (pre
, desc
, gfc_rank_cst
[n
], size
);
863 gfc_conv_descriptor_lbound_set (pre
, desc
, gfc_rank_cst
[n
],
864 gfc_index_zero_node
);
866 gfc_conv_descriptor_ubound_set (pre
, desc
, gfc_rank_cst
[n
],
869 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
870 to
[n
], gfc_index_one_node
);
872 /* Check whether the size for this dimension is negative. */
873 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, tmp
,
874 gfc_index_zero_node
);
875 cond
= gfc_evaluate_now (cond
, pre
);
880 or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
881 boolean_type_node
, or_expr
, cond
);
883 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
885 size
= gfc_evaluate_now (size
, pre
);
888 /* Get the size of the array. */
890 if (size
&& !callee_alloc
)
892 /* If or_expr is true, then the extent in at least one
893 dimension is zero and the size is set to zero. */
894 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
895 or_expr
, gfc_index_zero_node
, size
);
898 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
900 fold_convert (gfc_array_index_type
,
901 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
909 gfc_trans_allocate_array_storage (pre
, post
, info
, size
, nelem
, initial
,
912 if (info
->dimen
> loop
->temp_dim
)
913 loop
->temp_dim
= info
->dimen
;
919 /* Return the number of iterations in a loop that starts at START,
920 ends at END, and has step STEP. */
923 gfc_get_iteration_count (tree start
, tree end
, tree step
)
928 type
= TREE_TYPE (step
);
929 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, end
, start
);
930 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, type
, tmp
, step
);
931 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
,
932 build_int_cst (type
, 1));
933 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, type
, tmp
,
934 build_int_cst (type
, 0));
935 return fold_convert (gfc_array_index_type
, tmp
);
939 /* Extend the data in array DESC by EXTRA elements. */
942 gfc_grow_array (stmtblock_t
* pblock
, tree desc
, tree extra
)
949 if (integer_zerop (extra
))
952 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
954 /* Add EXTRA to the upper bound. */
955 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
957 gfc_conv_descriptor_ubound_set (pblock
, desc
, gfc_rank_cst
[0], tmp
);
959 /* Get the value of the current data pointer. */
960 arg0
= gfc_conv_descriptor_data_get (desc
);
962 /* Calculate the new array size. */
963 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
964 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
965 ubound
, gfc_index_one_node
);
966 arg1
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
967 fold_convert (size_type_node
, tmp
),
968 fold_convert (size_type_node
, size
));
970 /* Call the realloc() function. */
971 tmp
= gfc_call_realloc (pblock
, arg0
, arg1
);
972 gfc_conv_descriptor_data_set (pblock
, desc
, tmp
);
976 /* Return true if the bounds of iterator I can only be determined
980 gfc_iterator_has_dynamic_bounds (gfc_iterator
* i
)
982 return (i
->start
->expr_type
!= EXPR_CONSTANT
983 || i
->end
->expr_type
!= EXPR_CONSTANT
984 || i
->step
->expr_type
!= EXPR_CONSTANT
);
988 /* Split the size of constructor element EXPR into the sum of two terms,
989 one of which can be determined at compile time and one of which must
990 be calculated at run time. Set *SIZE to the former and return true
991 if the latter might be nonzero. */
994 gfc_get_array_constructor_element_size (mpz_t
* size
, gfc_expr
* expr
)
996 if (expr
->expr_type
== EXPR_ARRAY
)
997 return gfc_get_array_constructor_size (size
, expr
->value
.constructor
);
998 else if (expr
->rank
> 0)
1000 /* Calculate everything at run time. */
1001 mpz_set_ui (*size
, 0);
1006 /* A single element. */
1007 mpz_set_ui (*size
, 1);
1013 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1014 of array constructor C. */
1017 gfc_get_array_constructor_size (mpz_t
* size
, gfc_constructor_base base
)
1025 mpz_set_ui (*size
, 0);
1030 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1033 if (i
&& gfc_iterator_has_dynamic_bounds (i
))
1037 dynamic
|= gfc_get_array_constructor_element_size (&len
, c
->expr
);
1040 /* Multiply the static part of the element size by the
1041 number of iterations. */
1042 mpz_sub (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1043 mpz_fdiv_q (val
, val
, i
->step
->value
.integer
);
1044 mpz_add_ui (val
, val
, 1);
1045 if (mpz_sgn (val
) > 0)
1046 mpz_mul (len
, len
, val
);
1048 mpz_set_ui (len
, 0);
1050 mpz_add (*size
, *size
, len
);
1059 /* Make sure offset is a variable. */
1062 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
1065 /* We should have already created the offset variable. We cannot
1066 create it here because we may be in an inner scope. */
1067 gcc_assert (*offsetvar
!= NULL_TREE
);
1068 gfc_add_modify (pblock
, *offsetvar
, *poffset
);
1069 *poffset
= *offsetvar
;
1070 TREE_USED (*offsetvar
) = 1;
1074 /* Variables needed for bounds-checking. */
1075 static bool first_len
;
1076 static tree first_len_val
;
1077 static bool typespec_chararray_ctor
;
1080 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree desc
,
1081 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
1085 gfc_conv_expr (se
, expr
);
1087 /* Store the value. */
1088 tmp
= build_fold_indirect_ref_loc (input_location
,
1089 gfc_conv_descriptor_data_get (desc
));
1090 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
1092 if (expr
->ts
.type
== BT_CHARACTER
)
1094 int i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
1097 esize
= size_in_bytes (gfc_get_element_type (TREE_TYPE (desc
)));
1098 esize
= fold_convert (gfc_charlen_type_node
, esize
);
1099 esize
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1100 gfc_charlen_type_node
, esize
,
1101 build_int_cst (gfc_charlen_type_node
,
1102 gfc_character_kinds
[i
].bit_size
/ 8));
1104 gfc_conv_string_parameter (se
);
1105 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
1107 /* The temporary is an array of pointers. */
1108 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1109 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1113 /* The temporary is an array of string values. */
1114 tmp
= gfc_build_addr_expr (gfc_get_pchar_type (expr
->ts
.kind
), tmp
);
1115 /* We know the temporary and the value will be the same length,
1116 so can use memcpy. */
1117 gfc_trans_string_copy (&se
->pre
, esize
, tmp
, expr
->ts
.kind
,
1118 se
->string_length
, se
->expr
, expr
->ts
.kind
);
1120 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !typespec_chararray_ctor
)
1124 gfc_add_modify (&se
->pre
, first_len_val
,
1130 /* Verify that all constructor elements are of the same
1132 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1133 boolean_type_node
, first_len_val
,
1135 gfc_trans_runtime_check
1136 (true, false, cond
, &se
->pre
, &expr
->where
,
1137 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1138 fold_convert (long_integer_type_node
, first_len_val
),
1139 fold_convert (long_integer_type_node
, se
->string_length
));
1145 /* TODO: Should the frontend already have done this conversion? */
1146 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
1147 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
1150 gfc_add_block_to_block (pblock
, &se
->pre
);
1151 gfc_add_block_to_block (pblock
, &se
->post
);
1155 /* Add the contents of an array to the constructor. DYNAMIC is as for
1156 gfc_trans_array_constructor_value. */
1159 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
1160 tree type ATTRIBUTE_UNUSED
,
1161 tree desc
, gfc_expr
* expr
,
1162 tree
* poffset
, tree
* offsetvar
,
1173 /* We need this to be a variable so we can increment it. */
1174 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
1176 gfc_init_se (&se
, NULL
);
1178 /* Walk the array expression. */
1179 ss
= gfc_walk_expr (expr
);
1180 gcc_assert (ss
!= gfc_ss_terminator
);
1182 /* Initialize the scalarizer. */
1183 gfc_init_loopinfo (&loop
);
1184 gfc_add_ss_to_loop (&loop
, ss
);
1186 /* Initialize the loop. */
1187 gfc_conv_ss_startstride (&loop
);
1188 gfc_conv_loop_setup (&loop
, &expr
->where
);
1190 /* Make sure the constructed array has room for the new data. */
1193 /* Set SIZE to the total number of elements in the subarray. */
1194 size
= gfc_index_one_node
;
1195 for (n
= 0; n
< loop
.dimen
; n
++)
1197 tmp
= gfc_get_iteration_count (loop
.from
[n
], loop
.to
[n
],
1198 gfc_index_one_node
);
1199 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1200 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_loc (input_location
, 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_loc (input_location
, PLUS_EXPR
,
1308 gfc_array_index_type
,
1309 *poffset
, gfc_index_one_node
);
1313 /* Collect multiple scalar constants into a constructor. */
1314 VEC(constructor_elt
,gc
) *v
= NULL
;
1318 HOST_WIDE_INT idx
= 0;
1321 /* Count the number of consecutive scalar constants. */
1322 while (p
&& !(p
->iterator
1323 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
1325 gfc_init_se (&se
, NULL
);
1326 gfc_conv_constant (&se
, p
->expr
);
1328 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1329 se
.expr
= fold_convert (type
, se
.expr
);
1330 /* For constant character array constructors we build
1331 an array of pointers. */
1332 else if (POINTER_TYPE_P (type
))
1333 se
.expr
= gfc_build_addr_expr
1334 (gfc_get_pchar_type (p
->expr
->ts
.kind
),
1337 CONSTRUCTOR_APPEND_ELT (v
,
1338 build_int_cst (gfc_array_index_type
,
1342 p
= gfc_constructor_next (p
);
1345 bound
= build_int_cst (NULL_TREE
, n
- 1);
1346 /* Create an array type to hold them. */
1347 tmptype
= build_range_type (gfc_array_index_type
,
1348 gfc_index_zero_node
, bound
);
1349 tmptype
= build_array_type (type
, tmptype
);
1351 init
= build_constructor (tmptype
, v
);
1352 TREE_CONSTANT (init
) = 1;
1353 TREE_STATIC (init
) = 1;
1354 /* Create a static variable to hold the data. */
1355 tmp
= gfc_create_var (tmptype
, "data");
1356 TREE_STATIC (tmp
) = 1;
1357 TREE_CONSTANT (tmp
) = 1;
1358 TREE_READONLY (tmp
) = 1;
1359 DECL_INITIAL (tmp
) = init
;
1362 /* Use BUILTIN_MEMCPY to assign the values. */
1363 tmp
= gfc_conv_descriptor_data_get (desc
);
1364 tmp
= build_fold_indirect_ref_loc (input_location
,
1366 tmp
= gfc_build_array_ref (tmp
, *poffset
, NULL
);
1367 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1368 init
= gfc_build_addr_expr (NULL_TREE
, init
);
1370 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
1371 bound
= build_int_cst (NULL_TREE
, n
* size
);
1372 tmp
= build_call_expr_loc (input_location
,
1373 built_in_decls
[BUILT_IN_MEMCPY
], 3,
1375 gfc_add_expr_to_block (&body
, tmp
);
1377 *poffset
= fold_build2_loc (input_location
, PLUS_EXPR
,
1378 gfc_array_index_type
, *poffset
,
1379 build_int_cst (gfc_array_index_type
, n
));
1381 if (!INTEGER_CST_P (*poffset
))
1383 gfc_add_modify (&body
, *offsetvar
, *poffset
);
1384 *poffset
= *offsetvar
;
1388 /* The frontend should already have done any expansions
1392 /* Pass the code as is. */
1393 tmp
= gfc_finish_block (&body
);
1394 gfc_add_expr_to_block (pblock
, tmp
);
1398 /* Build the implied do-loop. */
1399 stmtblock_t implied_do_block
;
1407 loopbody
= gfc_finish_block (&body
);
1409 /* Create a new block that holds the implied-do loop. A temporary
1410 loop-variable is used. */
1411 gfc_start_block(&implied_do_block
);
1413 /* Initialize the loop. */
1414 gfc_init_se (&se
, NULL
);
1415 gfc_conv_expr_val (&se
, c
->iterator
->start
);
1416 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1417 gfc_add_modify (&implied_do_block
, shadow_loopvar
, se
.expr
);
1419 gfc_init_se (&se
, NULL
);
1420 gfc_conv_expr_val (&se
, c
->iterator
->end
);
1421 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1422 end
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1424 gfc_init_se (&se
, NULL
);
1425 gfc_conv_expr_val (&se
, c
->iterator
->step
);
1426 gfc_add_block_to_block (&implied_do_block
, &se
.pre
);
1427 step
= gfc_evaluate_now (se
.expr
, &implied_do_block
);
1429 /* If this array expands dynamically, and the number of iterations
1430 is not constant, we won't have allocated space for the static
1431 part of C->EXPR's size. Do that now. */
1432 if (dynamic
&& gfc_iterator_has_dynamic_bounds (c
->iterator
))
1434 /* Get the number of iterations. */
1435 tmp
= gfc_get_iteration_count (shadow_loopvar
, end
, step
);
1437 /* Get the static part of C->EXPR's size. */
1438 gfc_get_array_constructor_element_size (&size
, c
->expr
);
1439 tmp2
= gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1441 /* Grow the array by TMP * TMP2 elements. */
1442 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1443 gfc_array_index_type
, tmp
, tmp2
);
1444 gfc_grow_array (&implied_do_block
, desc
, tmp
);
1447 /* Generate the loop body. */
1448 exit_label
= gfc_build_label_decl (NULL_TREE
);
1449 gfc_start_block (&body
);
1451 /* Generate the exit condition. Depending on the sign of
1452 the step variable we have to generate the correct
1454 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1455 step
, build_int_cst (TREE_TYPE (step
), 0));
1456 cond
= fold_build3_loc (input_location
, COND_EXPR
,
1457 boolean_type_node
, tmp
,
1458 fold_build2_loc (input_location
, GT_EXPR
,
1459 boolean_type_node
, shadow_loopvar
, end
),
1460 fold_build2_loc (input_location
, LT_EXPR
,
1461 boolean_type_node
, shadow_loopvar
, end
));
1462 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1463 TREE_USED (exit_label
) = 1;
1464 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1465 build_empty_stmt (input_location
));
1466 gfc_add_expr_to_block (&body
, tmp
);
1468 /* The main loop body. */
1469 gfc_add_expr_to_block (&body
, loopbody
);
1471 /* Increase loop variable by step. */
1472 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1473 TREE_TYPE (shadow_loopvar
), shadow_loopvar
,
1475 gfc_add_modify (&body
, shadow_loopvar
, tmp
);
1477 /* Finish the loop. */
1478 tmp
= gfc_finish_block (&body
);
1479 tmp
= build1_v (LOOP_EXPR
, tmp
);
1480 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1482 /* Add the exit label. */
1483 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1484 gfc_add_expr_to_block (&implied_do_block
, tmp
);
1486 /* Finishe the implied-do loop. */
1487 tmp
= gfc_finish_block(&implied_do_block
);
1488 gfc_add_expr_to_block(pblock
, tmp
);
1490 gfc_restore_sym (c
->iterator
->var
->symtree
->n
.sym
, &saved_loopvar
);
1497 /* Figure out the string length of a variable reference expression.
1498 Used by get_array_ctor_strlen. */
1501 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1507 /* Don't bother if we already know the length is a constant. */
1508 if (*len
&& INTEGER_CST_P (*len
))
1511 ts
= &expr
->symtree
->n
.sym
->ts
;
1512 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1517 /* Array references don't change the string length. */
1521 /* Use the length of the component. */
1522 ts
= &ref
->u
.c
.component
->ts
;
1526 if (ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1527 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1529 mpz_init_set_ui (char_len
, 1);
1530 mpz_add (char_len
, char_len
, ref
->u
.ss
.end
->value
.integer
);
1531 mpz_sub (char_len
, char_len
, ref
->u
.ss
.start
->value
.integer
);
1532 *len
= gfc_conv_mpz_to_tree (char_len
, gfc_default_integer_kind
);
1533 *len
= convert (gfc_charlen_type_node
, *len
);
1534 mpz_clear (char_len
);
1538 /* TODO: Substrings are tricky because we can't evaluate the
1539 expression more than once. For now we just give up, and hope
1540 we can figure it out elsewhere. */
1545 *len
= ts
->u
.cl
->backend_decl
;
1549 /* A catch-all to obtain the string length for anything that is not a
1550 constant, array or variable. */
1552 get_array_ctor_all_strlen (stmtblock_t
*block
, gfc_expr
*e
, tree
*len
)
1557 /* Don't bother if we already know the length is a constant. */
1558 if (*len
&& INTEGER_CST_P (*len
))
1561 if (!e
->ref
&& e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1562 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1565 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1566 *len
= e
->ts
.u
.cl
->backend_decl
;
1570 /* Otherwise, be brutal even if inefficient. */
1571 ss
= gfc_walk_expr (e
);
1572 gfc_init_se (&se
, NULL
);
1574 /* No function call, in case of side effects. */
1575 se
.no_function_call
= 1;
1576 if (ss
== gfc_ss_terminator
)
1577 gfc_conv_expr (&se
, e
);
1579 gfc_conv_expr_descriptor (&se
, e
, ss
);
1581 /* Fix the value. */
1582 *len
= gfc_evaluate_now (se
.string_length
, &se
.pre
);
1584 gfc_add_block_to_block (block
, &se
.pre
);
1585 gfc_add_block_to_block (block
, &se
.post
);
1587 e
->ts
.u
.cl
->backend_decl
= *len
;
1592 /* Figure out the string length of a character array constructor.
1593 If len is NULL, don't calculate the length; this happens for recursive calls
1594 when a sub-array-constructor is an element but not at the first position,
1595 so when we're not interested in the length.
1596 Returns TRUE if all elements are character constants. */
1599 get_array_ctor_strlen (stmtblock_t
*block
, gfc_constructor_base base
, tree
* len
)
1606 if (gfc_constructor_first (base
) == NULL
)
1609 *len
= build_int_cstu (gfc_charlen_type_node
, 0);
1613 /* Loop over all constructor elements to find out is_const, but in len we
1614 want to store the length of the first, not the last, element. We can
1615 of course exit the loop as soon as is_const is found to be false. */
1616 for (c
= gfc_constructor_first (base
);
1617 c
&& is_const
; c
= gfc_constructor_next (c
))
1619 switch (c
->expr
->expr_type
)
1622 if (len
&& !(*len
&& INTEGER_CST_P (*len
)))
1623 *len
= build_int_cstu (gfc_charlen_type_node
,
1624 c
->expr
->value
.character
.length
);
1628 if (!get_array_ctor_strlen (block
, c
->expr
->value
.constructor
, len
))
1635 get_array_ctor_var_strlen (c
->expr
, len
);
1641 get_array_ctor_all_strlen (block
, c
->expr
, len
);
1645 /* After the first iteration, we don't want the length modified. */
1652 /* Check whether the array constructor C consists entirely of constant
1653 elements, and if so returns the number of those elements, otherwise
1654 return zero. Note, an empty or NULL array constructor returns zero. */
1656 unsigned HOST_WIDE_INT
1657 gfc_constant_array_constructor_p (gfc_constructor_base base
)
1659 unsigned HOST_WIDE_INT nelem
= 0;
1661 gfc_constructor
*c
= gfc_constructor_first (base
);
1665 || c
->expr
->rank
> 0
1666 || c
->expr
->expr_type
!= EXPR_CONSTANT
)
1668 c
= gfc_constructor_next (c
);
1675 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1676 and the tree type of it's elements, TYPE, return a static constant
1677 variable that is compile-time initialized. */
1680 gfc_build_constant_array_constructor (gfc_expr
* expr
, tree type
)
1682 tree tmptype
, init
, tmp
;
1683 HOST_WIDE_INT nelem
;
1688 VEC(constructor_elt
,gc
) *v
= NULL
;
1690 /* First traverse the constructor list, converting the constants
1691 to tree to build an initializer. */
1693 c
= gfc_constructor_first (expr
->value
.constructor
);
1696 gfc_init_se (&se
, NULL
);
1697 gfc_conv_constant (&se
, c
->expr
);
1698 if (c
->expr
->ts
.type
!= BT_CHARACTER
)
1699 se
.expr
= fold_convert (type
, se
.expr
);
1700 else if (POINTER_TYPE_P (type
))
1701 se
.expr
= gfc_build_addr_expr (gfc_get_pchar_type (c
->expr
->ts
.kind
),
1703 CONSTRUCTOR_APPEND_ELT (v
, build_int_cst (gfc_array_index_type
, nelem
),
1705 c
= gfc_constructor_next (c
);
1709 /* Next determine the tree type for the array. We use the gfortran
1710 front-end's gfc_get_nodesc_array_type in order to create a suitable
1711 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1713 memset (&as
, 0, sizeof (gfc_array_spec
));
1715 as
.rank
= expr
->rank
;
1716 as
.type
= AS_EXPLICIT
;
1719 as
.lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1720 as
.upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
1724 for (i
= 0; i
< expr
->rank
; i
++)
1726 int tmp
= (int) mpz_get_si (expr
->shape
[i
]);
1727 as
.lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
1728 as
.upper
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
1732 tmptype
= gfc_get_nodesc_array_type (type
, &as
, PACKED_STATIC
, true);
1734 /* as is not needed anymore. */
1735 for (i
= 0; i
< as
.rank
+ as
.corank
; i
++)
1737 gfc_free_expr (as
.lower
[i
]);
1738 gfc_free_expr (as
.upper
[i
]);
1741 init
= build_constructor (tmptype
, v
);
1743 TREE_CONSTANT (init
) = 1;
1744 TREE_STATIC (init
) = 1;
1746 tmp
= gfc_create_var (tmptype
, "A");
1747 TREE_STATIC (tmp
) = 1;
1748 TREE_CONSTANT (tmp
) = 1;
1749 TREE_READONLY (tmp
) = 1;
1750 DECL_INITIAL (tmp
) = init
;
1756 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1757 This mostly initializes the scalarizer state info structure with the
1758 appropriate values to directly use the array created by the function
1759 gfc_build_constant_array_constructor. */
1762 gfc_trans_constant_array_constructor (gfc_loopinfo
* loop
,
1763 gfc_ss
* ss
, tree type
)
1769 tmp
= gfc_build_constant_array_constructor (ss
->expr
, type
);
1771 info
= &ss
->data
.info
;
1773 info
->descriptor
= tmp
;
1774 info
->data
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1775 info
->offset
= gfc_index_zero_node
;
1777 for (i
= 0; i
< info
->dimen
; i
++)
1779 info
->delta
[i
] = gfc_index_zero_node
;
1780 info
->start
[i
] = gfc_index_zero_node
;
1781 info
->end
[i
] = gfc_index_zero_node
;
1782 info
->stride
[i
] = gfc_index_one_node
;
1786 if (info
->dimen
> loop
->temp_dim
)
1787 loop
->temp_dim
= info
->dimen
;
1790 /* Helper routine of gfc_trans_array_constructor to determine if the
1791 bounds of the loop specified by LOOP are constant and simple enough
1792 to use with gfc_trans_constant_array_constructor. Returns the
1793 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1796 constant_array_constructor_loop_size (gfc_loopinfo
* loop
)
1798 tree size
= gfc_index_one_node
;
1802 for (i
= 0; i
< loop
->dimen
; i
++)
1804 /* If the bounds aren't constant, return NULL_TREE. */
1805 if (!INTEGER_CST_P (loop
->from
[i
]) || !INTEGER_CST_P (loop
->to
[i
]))
1807 if (!integer_zerop (loop
->from
[i
]))
1809 /* Only allow nonzero "from" in one-dimensional arrays. */
1810 if (loop
->dimen
!= 1)
1812 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1813 gfc_array_index_type
,
1814 loop
->to
[i
], loop
->from
[i
]);
1818 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1819 tmp
, gfc_index_one_node
);
1820 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1828 /* Array constructors are handled by constructing a temporary, then using that
1829 within the scalarization loop. This is not optimal, but seems by far the
1833 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
, locus
* where
)
1835 gfc_constructor_base c
;
1841 bool old_first_len
, old_typespec_chararray_ctor
;
1842 tree old_first_len_val
;
1844 /* Save the old values for nested checking. */
1845 old_first_len
= first_len
;
1846 old_first_len_val
= first_len_val
;
1847 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
1849 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1850 typespec was given for the array constructor. */
1851 typespec_chararray_ctor
= (ss
->expr
->ts
.u
.cl
1852 && ss
->expr
->ts
.u
.cl
->length_from_typespec
);
1854 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1855 && ss
->expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
1857 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
1861 ss
->data
.info
.dimen
= loop
->dimen
;
1863 c
= ss
->expr
->value
.constructor
;
1864 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1868 /* get_array_ctor_strlen walks the elements of the constructor, if a
1869 typespec was given, we already know the string length and want the one
1871 if (typespec_chararray_ctor
&& ss
->expr
->ts
.u
.cl
->length
1872 && ss
->expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1876 const_string
= false;
1877 gfc_init_se (&length_se
, NULL
);
1878 gfc_conv_expr_type (&length_se
, ss
->expr
->ts
.u
.cl
->length
,
1879 gfc_charlen_type_node
);
1880 ss
->string_length
= length_se
.expr
;
1881 gfc_add_block_to_block (&loop
->pre
, &length_se
.pre
);
1882 gfc_add_block_to_block (&loop
->post
, &length_se
.post
);
1885 const_string
= get_array_ctor_strlen (&loop
->pre
, c
,
1886 &ss
->string_length
);
1888 /* Complex character array constructors should have been taken care of
1889 and not end up here. */
1890 gcc_assert (ss
->string_length
);
1892 ss
->expr
->ts
.u
.cl
->backend_decl
= ss
->string_length
;
1894 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1896 type
= build_pointer_type (type
);
1899 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1901 /* See if the constructor determines the loop bounds. */
1904 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1906 /* We have a multidimensional parameter. */
1908 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1910 loop
->from
[n
] = gfc_index_zero_node
;
1911 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1912 gfc_index_integer_kind
);
1913 loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
1914 gfc_array_index_type
,
1915 loop
->to
[n
], gfc_index_one_node
);
1919 if (loop
->to
[0] == NULL_TREE
)
1923 /* We should have a 1-dimensional, zero-based loop. */
1924 gcc_assert (loop
->dimen
== 1);
1925 gcc_assert (integer_zerop (loop
->from
[0]));
1927 /* Split the constructor size into a static part and a dynamic part.
1928 Allocate the static size up-front and record whether the dynamic
1929 size might be nonzero. */
1931 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1932 mpz_sub_ui (size
, size
, 1);
1933 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1937 /* Special case constant array constructors. */
1940 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1943 tree size
= constant_array_constructor_loop_size (loop
);
1944 if (size
&& compare_tree_int (size
, nelem
) == 0)
1946 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1952 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1953 type
, NULL_TREE
, dynamic
, true, false, where
);
1955 desc
= ss
->data
.info
.descriptor
;
1956 offset
= gfc_index_zero_node
;
1957 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1958 TREE_NO_WARNING (offsetvar
) = 1;
1959 TREE_USED (offsetvar
) = 0;
1960 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1961 &offset
, &offsetvar
, dynamic
);
1963 /* If the array grows dynamically, the upper bound of the loop variable
1964 is determined by the array's final upper bound. */
1966 loop
->to
[0] = gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[0]);
1968 if (TREE_USED (offsetvar
))
1969 pushdecl (offsetvar
);
1971 gcc_assert (INTEGER_CST_P (offset
));
1973 /* Disable bound checking for now because it's probably broken. */
1974 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1981 /* Restore old values of globals. */
1982 first_len
= old_first_len
;
1983 first_len_val
= old_first_len_val
;
1984 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
1988 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1989 called after evaluating all of INFO's vector dimensions. Go through
1990 each such vector dimension and see if we can now fill in any missing
1994 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
2003 for (n
= 0; n
< loop
->dimen
; n
++)
2006 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
2007 && loop
->to
[n
] == NULL
)
2009 /* Loop variable N indexes vector dimension DIM, and we don't
2010 yet know the upper bound of loop variable N. Set it to the
2011 difference between the vector's upper and lower bounds. */
2012 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2013 gcc_assert (info
->subscript
[dim
]
2014 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2016 gfc_init_se (&se
, NULL
);
2017 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2018 zero
= gfc_rank_cst
[0];
2019 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2020 gfc_array_index_type
,
2021 gfc_conv_descriptor_ubound_get (desc
, zero
),
2022 gfc_conv_descriptor_lbound_get (desc
, zero
));
2023 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
2030 /* Add the pre and post chains for all the scalar expressions in a SS chain
2031 to loop. This is called after the loop parameters have been calculated,
2032 but before the actual scalarizing loops. */
2035 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2041 /* TODO: This can generate bad code if there are ordering dependencies,
2042 e.g., a callee allocated function and an unknown size constructor. */
2043 gcc_assert (ss
!= NULL
);
2045 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2052 /* Scalar expression. Evaluate this now. This includes elemental
2053 dimension indices, but not array section bounds. */
2054 gfc_init_se (&se
, NULL
);
2055 gfc_conv_expr (&se
, ss
->expr
);
2056 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2058 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
2060 /* Move the evaluation of scalar expressions outside the
2061 scalarization loop, except for WHERE assignments. */
2063 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2065 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2066 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
2069 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2071 ss
->data
.scalar
.expr
= se
.expr
;
2072 ss
->string_length
= se
.string_length
;
2075 case GFC_SS_REFERENCE
:
2076 /* Scalar argument to elemental procedure. Evaluate this
2078 gfc_init_se (&se
, NULL
);
2079 gfc_conv_expr (&se
, ss
->expr
);
2080 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2081 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2083 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2084 ss
->string_length
= se
.string_length
;
2087 case GFC_SS_SECTION
:
2088 /* Add the expressions for scalar and vector subscripts. */
2089 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2090 if (ss
->data
.info
.subscript
[n
])
2091 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true,
2094 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
2098 /* Get the vector's descriptor and store it in SS. */
2099 gfc_init_se (&se
, NULL
);
2100 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
2101 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2102 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2103 ss
->data
.info
.descriptor
= se
.expr
;
2106 case GFC_SS_INTRINSIC
:
2107 gfc_add_intrinsic_ss_code (loop
, ss
);
2110 case GFC_SS_FUNCTION
:
2111 /* Array function return value. We call the function and save its
2112 result in a temporary for use inside the loop. */
2113 gfc_init_se (&se
, NULL
);
2116 gfc_conv_expr (&se
, ss
->expr
);
2117 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2118 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2119 ss
->string_length
= se
.string_length
;
2122 case GFC_SS_CONSTRUCTOR
:
2123 if (ss
->expr
->ts
.type
== BT_CHARACTER
2124 && ss
->string_length
== NULL
2125 && ss
->expr
->ts
.u
.cl
2126 && ss
->expr
->ts
.u
.cl
->length
)
2128 gfc_init_se (&se
, NULL
);
2129 gfc_conv_expr_type (&se
, ss
->expr
->ts
.u
.cl
->length
,
2130 gfc_charlen_type_node
);
2131 ss
->string_length
= se
.expr
;
2132 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2133 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2135 gfc_trans_array_constructor (loop
, ss
, where
);
2139 case GFC_SS_COMPONENT
:
2140 /* Do nothing. These are handled elsewhere. */
2150 /* Translate expressions for the descriptor and data pointer of a SS. */
2154 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2159 /* Get the descriptor for the array to be scalarized. */
2160 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
2161 gfc_init_se (&se
, NULL
);
2162 se
.descriptor_only
= 1;
2163 gfc_conv_expr_lhs (&se
, ss
->expr
);
2164 gfc_add_block_to_block (block
, &se
.pre
);
2165 ss
->data
.info
.descriptor
= se
.expr
;
2166 ss
->string_length
= se
.string_length
;
2170 /* Also the data pointer. */
2171 tmp
= gfc_conv_array_data (se
.expr
);
2172 /* If this is a variable or address of a variable we use it directly.
2173 Otherwise we must evaluate it now to avoid breaking dependency
2174 analysis by pulling the expressions for elemental array indices
2177 || (TREE_CODE (tmp
) == ADDR_EXPR
2178 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2179 tmp
= gfc_evaluate_now (tmp
, block
);
2180 ss
->data
.info
.data
= tmp
;
2182 tmp
= gfc_conv_array_offset (se
.expr
);
2183 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
2188 /* Initialize a gfc_loopinfo structure. */
2191 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2195 memset (loop
, 0, sizeof (gfc_loopinfo
));
2196 gfc_init_block (&loop
->pre
);
2197 gfc_init_block (&loop
->post
);
2199 /* Initially scalarize in order and default to no loop reversal. */
2200 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2203 loop
->reverse
[n
] = GFC_CANNOT_REVERSE
;
2206 loop
->ss
= gfc_ss_terminator
;
2210 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2214 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2220 /* Return an expression for the data pointer of an array. */
2223 gfc_conv_array_data (tree descriptor
)
2227 type
= TREE_TYPE (descriptor
);
2228 if (GFC_ARRAY_TYPE_P (type
))
2230 if (TREE_CODE (type
) == POINTER_TYPE
)
2234 /* Descriptorless arrays. */
2235 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2239 return gfc_conv_descriptor_data_get (descriptor
);
2243 /* Return an expression for the base offset of an array. */
2246 gfc_conv_array_offset (tree descriptor
)
2250 type
= TREE_TYPE (descriptor
);
2251 if (GFC_ARRAY_TYPE_P (type
))
2252 return GFC_TYPE_ARRAY_OFFSET (type
);
2254 return gfc_conv_descriptor_offset_get (descriptor
);
2258 /* Get an expression for the array stride. */
2261 gfc_conv_array_stride (tree descriptor
, int dim
)
2266 type
= TREE_TYPE (descriptor
);
2268 /* For descriptorless arrays use the array size. */
2269 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2270 if (tmp
!= NULL_TREE
)
2273 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2278 /* Like gfc_conv_array_stride, but for the lower bound. */
2281 gfc_conv_array_lbound (tree descriptor
, int dim
)
2286 type
= TREE_TYPE (descriptor
);
2288 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2289 if (tmp
!= NULL_TREE
)
2292 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2297 /* Like gfc_conv_array_stride, but for the upper bound. */
2300 gfc_conv_array_ubound (tree descriptor
, int dim
)
2305 type
= TREE_TYPE (descriptor
);
2307 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2308 if (tmp
!= NULL_TREE
)
2311 /* This should only ever happen when passing an assumed shape array
2312 as an actual parameter. The value will never be used. */
2313 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2314 return gfc_index_zero_node
;
2316 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2321 /* Generate code to perform an array index bound check. */
2324 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2325 locus
* where
, bool check_upper
)
2328 tree tmp_lo
, tmp_up
;
2330 const char * name
= NULL
;
2332 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2335 index
= gfc_evaluate_now (index
, &se
->pre
);
2337 /* We find a name for the error message. */
2339 name
= se
->ss
->expr
->symtree
->name
;
2341 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2342 && se
->loop
->ss
->expr
->symtree
)
2343 name
= se
->loop
->ss
->expr
->symtree
->name
;
2345 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2346 && se
->loop
->ss
->loop_chain
->expr
2347 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2348 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2350 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2352 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2353 && se
->loop
->ss
->expr
->value
.function
.name
)
2354 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2356 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2357 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2358 name
= "unnamed constant";
2361 if (TREE_CODE (descriptor
) == VAR_DECL
)
2362 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2364 /* If upper bound is present, include both bounds in the error message. */
2367 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2368 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2371 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2372 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2374 asprintf (&msg
, "Index '%%ld' of dimension %d "
2375 "outside of expected range (%%ld:%%ld)", n
+1);
2377 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2379 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2380 fold_convert (long_integer_type_node
, index
),
2381 fold_convert (long_integer_type_node
, tmp_lo
),
2382 fold_convert (long_integer_type_node
, tmp_up
));
2383 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2385 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2386 fold_convert (long_integer_type_node
, index
),
2387 fold_convert (long_integer_type_node
, tmp_lo
),
2388 fold_convert (long_integer_type_node
, tmp_up
));
2393 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2396 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2397 "below lower bound of %%ld", n
+1, name
);
2399 asprintf (&msg
, "Index '%%ld' of dimension %d "
2400 "below lower bound of %%ld", n
+1);
2402 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2404 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2405 fold_convert (long_integer_type_node
, index
),
2406 fold_convert (long_integer_type_node
, tmp_lo
));
2414 /* Return the offset for an index. Performs bound checking for elemental
2415 dimensions. Single element references are processed separately.
2416 DIM is the array dimension, I is the loop dimension. */
2419 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2420 gfc_array_ref
* ar
, tree stride
)
2426 /* Get the index into the array for this dimension. */
2429 gcc_assert (ar
->type
!= AR_ELEMENT
);
2430 switch (ar
->dimen_type
[dim
])
2433 /* Elemental dimension. */
2434 gcc_assert (info
->subscript
[dim
]
2435 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2436 /* We've already translated this value outside the loop. */
2437 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2439 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2440 index
, dim
, &ar
->where
,
2441 ar
->as
->type
!= AS_ASSUMED_SIZE
2442 || dim
< ar
->dimen
- 1);
2446 gcc_assert (info
&& se
->loop
);
2447 gcc_assert (info
->subscript
[dim
]
2448 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2449 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2451 /* Get a zero-based index into the vector. */
2452 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2453 gfc_array_index_type
,
2454 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2456 /* Multiply the index by the stride. */
2457 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2458 gfc_array_index_type
,
2459 index
, gfc_conv_array_stride (desc
, 0));
2461 /* Read the vector to get an index into info->descriptor. */
2462 data
= build_fold_indirect_ref_loc (input_location
,
2463 gfc_conv_array_data (desc
));
2464 index
= gfc_build_array_ref (data
, index
, NULL
);
2465 index
= gfc_evaluate_now (index
, &se
->pre
);
2466 index
= fold_convert (gfc_array_index_type
, index
);
2468 /* Do any bounds checking on the final info->descriptor index. */
2469 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2470 index
, dim
, &ar
->where
,
2471 ar
->as
->type
!= AS_ASSUMED_SIZE
2472 || dim
< ar
->dimen
- 1);
2476 /* Scalarized dimension. */
2477 gcc_assert (info
&& se
->loop
);
2479 /* Multiply the loop variable by the stride and delta. */
2480 index
= se
->loop
->loopvar
[i
];
2481 if (!integer_onep (info
->stride
[dim
]))
2482 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2483 gfc_array_index_type
, index
,
2485 if (!integer_zerop (info
->delta
[dim
]))
2486 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2487 gfc_array_index_type
, index
,
2497 /* Temporary array or derived type component. */
2498 gcc_assert (se
->loop
);
2499 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2500 if (!integer_zerop (info
->delta
[dim
]))
2501 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2502 gfc_array_index_type
, index
, info
->delta
[dim
]);
2505 /* Multiply by the stride. */
2506 if (!integer_onep (stride
))
2507 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2514 /* Build a scalarized reference to an array. */
2517 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2520 tree decl
= NULL_TREE
;
2525 info
= &se
->ss
->data
.info
;
2527 n
= se
->loop
->order
[0];
2531 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2533 /* Add the offset for this dimension to the stored offset for all other
2535 if (!integer_zerop (info
->offset
))
2536 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2537 index
, info
->offset
);
2539 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2540 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2542 tmp
= build_fold_indirect_ref_loc (input_location
,
2544 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2548 /* Translate access of temporary array. */
2551 gfc_conv_tmp_array_ref (gfc_se
* se
)
2553 se
->string_length
= se
->ss
->string_length
;
2554 gfc_conv_scalarized_array_ref (se
, NULL
);
2555 gfc_advance_se_ss_chain (se
);
2559 /* Build an array reference. se->expr already holds the array descriptor.
2560 This should be either a variable, indirect variable reference or component
2561 reference. For arrays which do not have a descriptor, se->expr will be
2563 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2566 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2579 /* Handle scalarized references separately. */
2580 if (ar
->type
!= AR_ELEMENT
)
2582 gfc_conv_scalarized_array_ref (se
, ar
);
2583 gfc_advance_se_ss_chain (se
);
2587 index
= gfc_index_zero_node
;
2589 /* Calculate the offsets from all the dimensions. */
2590 for (n
= 0; n
< ar
->dimen
; n
++)
2592 /* Calculate the index for this dimension. */
2593 gfc_init_se (&indexse
, se
);
2594 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2595 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2597 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2599 /* Check array bounds. */
2603 /* Evaluate the indexse.expr only once. */
2604 indexse
.expr
= save_expr (indexse
.expr
);
2607 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2608 if (sym
->attr
.temporary
)
2610 gfc_init_se (&tmpse
, se
);
2611 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
2612 gfc_array_index_type
);
2613 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2617 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2619 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2620 "below lower bound of %%ld", n
+1, sym
->name
);
2621 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2622 fold_convert (long_integer_type_node
,
2624 fold_convert (long_integer_type_node
, tmp
));
2627 /* Upper bound, but not for the last dimension of assumed-size
2629 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
2631 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2632 if (sym
->attr
.temporary
)
2634 gfc_init_se (&tmpse
, se
);
2635 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
2636 gfc_array_index_type
);
2637 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2641 cond
= fold_build2_loc (input_location
, GT_EXPR
,
2642 boolean_type_node
, indexse
.expr
, tmp
);
2643 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2644 "above upper bound of %%ld", n
+1, sym
->name
);
2645 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2646 fold_convert (long_integer_type_node
,
2648 fold_convert (long_integer_type_node
, tmp
));
2653 /* Multiply the index by the stride. */
2654 stride
= gfc_conv_array_stride (se
->expr
, n
);
2655 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2656 indexse
.expr
, stride
);
2658 /* And add it to the total. */
2659 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2660 gfc_array_index_type
, index
, tmp
);
2663 tmp
= gfc_conv_array_offset (se
->expr
);
2664 if (!integer_zerop (tmp
))
2665 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2666 gfc_array_index_type
, index
, tmp
);
2668 /* Access the calculated element. */
2669 tmp
= gfc_conv_array_data (se
->expr
);
2670 tmp
= build_fold_indirect_ref (tmp
);
2671 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2675 /* Generate the code to be executed immediately before entering a
2676 scalarization loop. */
2679 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2680 stmtblock_t
* pblock
)
2689 /* This code will be executed before entering the scalarization loop
2690 for this dimension. */
2691 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2693 if ((ss
->useflags
& flag
) == 0)
2696 if (ss
->type
!= GFC_SS_SECTION
2697 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2698 && ss
->type
!= GFC_SS_COMPONENT
)
2701 info
= &ss
->data
.info
;
2703 if (dim
>= info
->dimen
)
2706 if (dim
== info
->dimen
- 1)
2708 /* For the outermost loop calculate the offset due to any
2709 elemental dimensions. It will have been initialized with the
2710 base offset of the array. */
2713 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2715 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2718 gfc_init_se (&se
, NULL
);
2720 se
.expr
= info
->descriptor
;
2721 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2722 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2725 gfc_add_block_to_block (pblock
, &se
.pre
);
2727 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2728 gfc_array_index_type
,
2729 info
->offset
, index
);
2730 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2735 /* For the time being, the innermost loop is unconditionally on
2736 the first dimension of the scalarization loop. */
2737 gcc_assert (i
== 0);
2738 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2740 /* Calculate the stride of the innermost loop. Hopefully this will
2741 allow the backend optimizers to do their stuff more effectively.
2743 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2747 /* Add the offset for the previous loop dimension. */
2752 ar
= &info
->ref
->u
.ar
;
2753 i
= loop
->order
[dim
+ 1];
2761 gfc_init_se (&se
, NULL
);
2763 se
.expr
= info
->descriptor
;
2764 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2765 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2767 gfc_add_block_to_block (pblock
, &se
.pre
);
2768 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2769 gfc_array_index_type
, info
->offset
,
2771 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2774 /* Remember this offset for the second loop. */
2775 if (dim
== loop
->temp_dim
- 1)
2776 info
->saved_offset
= info
->offset
;
2781 /* Start a scalarized expression. Creates a scope and declares loop
2785 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2791 gcc_assert (!loop
->array_parameter
);
2793 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2795 n
= loop
->order
[dim
];
2797 gfc_start_block (&loop
->code
[n
]);
2799 /* Create the loop variable. */
2800 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2802 if (dim
< loop
->temp_dim
)
2806 /* Calculate values that will be constant within this loop. */
2807 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2809 gfc_start_block (pbody
);
2813 /* Generates the actual loop code for a scalarization loop. */
2816 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2817 stmtblock_t
* pbody
)
2828 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
2829 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
2830 && n
== loop
->dimen
- 1)
2832 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2833 init
= make_tree_vec (1);
2834 cond
= make_tree_vec (1);
2835 incr
= make_tree_vec (1);
2837 /* Cycle statement is implemented with a goto. Exit statement must not
2838 be present for this loop. */
2839 exit_label
= gfc_build_label_decl (NULL_TREE
);
2840 TREE_USED (exit_label
) = 1;
2842 /* Label for cycle statements (if needed). */
2843 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2844 gfc_add_expr_to_block (pbody
, tmp
);
2846 stmt
= make_node (OMP_FOR
);
2848 TREE_TYPE (stmt
) = void_type_node
;
2849 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
2851 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
2852 OMP_CLAUSE_SCHEDULE
);
2853 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
2854 = OMP_CLAUSE_SCHEDULE_STATIC
;
2855 if (ompws_flags
& OMPWS_NOWAIT
)
2856 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
2857 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
2859 /* Initialize the loopvar. */
2860 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
2862 OMP_FOR_INIT (stmt
) = init
;
2863 /* The exit condition. */
2864 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
2866 loop
->loopvar
[n
], loop
->to
[n
]);
2867 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
2868 OMP_FOR_COND (stmt
) = cond
;
2869 /* Increment the loopvar. */
2870 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2871 loop
->loopvar
[n
], gfc_index_one_node
);
2872 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
2873 void_type_node
, loop
->loopvar
[n
], tmp
);
2874 OMP_FOR_INCR (stmt
) = incr
;
2876 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
2877 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
2881 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
2882 && (loop
->temp_ss
== NULL
);
2884 loopbody
= gfc_finish_block (pbody
);
2888 tmp
= loop
->from
[n
];
2889 loop
->from
[n
] = loop
->to
[n
];
2893 /* Initialize the loopvar. */
2894 if (loop
->loopvar
[n
] != loop
->from
[n
])
2895 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2897 exit_label
= gfc_build_label_decl (NULL_TREE
);
2899 /* Generate the loop body. */
2900 gfc_init_block (&block
);
2902 /* The exit condition. */
2903 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
2904 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2905 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2906 TREE_USED (exit_label
) = 1;
2907 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2908 gfc_add_expr_to_block (&block
, tmp
);
2910 /* The main body. */
2911 gfc_add_expr_to_block (&block
, loopbody
);
2913 /* Increment the loopvar. */
2914 tmp
= fold_build2_loc (input_location
,
2915 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
2916 gfc_array_index_type
, loop
->loopvar
[n
],
2917 gfc_index_one_node
);
2919 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
2921 /* Build the loop. */
2922 tmp
= gfc_finish_block (&block
);
2923 tmp
= build1_v (LOOP_EXPR
, tmp
);
2924 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2926 /* Add the exit label. */
2927 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2928 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2934 /* Finishes and generates the loops for a scalarized expression. */
2937 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2942 stmtblock_t
*pblock
;
2946 /* Generate the loops. */
2947 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2949 n
= loop
->order
[dim
];
2950 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2951 loop
->loopvar
[n
] = NULL_TREE
;
2952 pblock
= &loop
->code
[n
];
2955 tmp
= gfc_finish_block (pblock
);
2956 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2958 /* Clear all the used flags. */
2959 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2964 /* Finish the main body of a scalarized expression, and start the secondary
2968 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2972 stmtblock_t
*pblock
;
2976 /* We finish as many loops as are used by the temporary. */
2977 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2979 n
= loop
->order
[dim
];
2980 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2981 loop
->loopvar
[n
] = NULL_TREE
;
2982 pblock
= &loop
->code
[n
];
2985 /* We don't want to finish the outermost loop entirely. */
2986 n
= loop
->order
[loop
->temp_dim
- 1];
2987 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2989 /* Restore the initial offsets. */
2990 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2992 if ((ss
->useflags
& 2) == 0)
2995 if (ss
->type
!= GFC_SS_SECTION
2996 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2997 && ss
->type
!= GFC_SS_COMPONENT
)
3000 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
3003 /* Restart all the inner loops we just finished. */
3004 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3006 n
= loop
->order
[dim
];
3008 gfc_start_block (&loop
->code
[n
]);
3010 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3012 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3015 /* Start a block for the secondary copying code. */
3016 gfc_start_block (body
);
3020 /* Calculate the lower bound of an array section. */
3023 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
3032 gcc_assert (ss
->type
== GFC_SS_SECTION
);
3034 info
= &ss
->data
.info
;
3036 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3038 /* We use a zero-based index to access the vector. */
3039 info
->start
[dim
] = gfc_index_zero_node
;
3040 info
->stride
[dim
] = gfc_index_one_node
;
3041 info
->end
[dim
] = NULL
;
3045 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
3046 desc
= info
->descriptor
;
3047 start
= info
->ref
->u
.ar
.start
[dim
];
3048 end
= info
->ref
->u
.ar
.end
[dim
];
3049 stride
= info
->ref
->u
.ar
.stride
[dim
];
3051 /* Calculate the start of the range. For vector subscripts this will
3052 be the range of the vector. */
3055 /* Specified section start. */
3056 gfc_init_se (&se
, NULL
);
3057 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
3058 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3059 info
->start
[dim
] = se
.expr
;
3063 /* No lower bound specified so use the bound of the array. */
3064 info
->start
[dim
] = gfc_conv_array_lbound (desc
, dim
);
3066 info
->start
[dim
] = gfc_evaluate_now (info
->start
[dim
], &loop
->pre
);
3068 /* Similarly calculate the end. Although this is not used in the
3069 scalarizer, it is needed when checking bounds and where the end
3070 is an expression with side-effects. */
3073 /* Specified section start. */
3074 gfc_init_se (&se
, NULL
);
3075 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
3076 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3077 info
->end
[dim
] = se
.expr
;
3081 /* No upper bound specified so use the bound of the array. */
3082 info
->end
[dim
] = gfc_conv_array_ubound (desc
, dim
);
3084 info
->end
[dim
] = gfc_evaluate_now (info
->end
[dim
], &loop
->pre
);
3086 /* Calculate the stride. */
3088 info
->stride
[dim
] = gfc_index_one_node
;
3091 gfc_init_se (&se
, NULL
);
3092 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3093 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3094 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3099 /* Calculates the range start and stride for a SS chain. Also gets the
3100 descriptor and data pointer. The range of vector subscripts is the size
3101 of the vector. Array bounds are also checked. */
3104 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3112 /* Determine the rank of the loop. */
3114 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
3118 case GFC_SS_SECTION
:
3119 case GFC_SS_CONSTRUCTOR
:
3120 case GFC_SS_FUNCTION
:
3121 case GFC_SS_COMPONENT
:
3122 loop
->dimen
= ss
->data
.info
.dimen
;
3125 /* As usual, lbound and ubound are exceptions!. */
3126 case GFC_SS_INTRINSIC
:
3127 switch (ss
->expr
->value
.function
.isym
->id
)
3129 case GFC_ISYM_LBOUND
:
3130 case GFC_ISYM_UBOUND
:
3131 loop
->dimen
= ss
->data
.info
.dimen
;
3142 /* We should have determined the rank of the expression by now. If
3143 not, that's bad news. */
3144 gcc_assert (loop
->dimen
!= 0);
3146 /* Loop over all the SS in the chain. */
3147 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3149 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
3150 ss
->shape
= ss
->expr
->shape
;
3154 case GFC_SS_SECTION
:
3155 /* Get the descriptor for the array. */
3156 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3158 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3159 gfc_conv_section_startstride (loop
, ss
, ss
->data
.info
.dim
[n
]);
3162 case GFC_SS_INTRINSIC
:
3163 switch (ss
->expr
->value
.function
.isym
->id
)
3165 /* Fall through to supply start and stride. */
3166 case GFC_ISYM_LBOUND
:
3167 case GFC_ISYM_UBOUND
:
3173 case GFC_SS_CONSTRUCTOR
:
3174 case GFC_SS_FUNCTION
:
3175 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3177 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
3178 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
3179 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3188 /* The rest is just runtime bound checking. */
3189 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3192 tree lbound
, ubound
;
3194 tree size
[GFC_MAX_DIMENSIONS
];
3195 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3200 gfc_start_block (&block
);
3202 for (n
= 0; n
< loop
->dimen
; n
++)
3203 size
[n
] = NULL_TREE
;
3205 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3209 if (ss
->type
!= GFC_SS_SECTION
)
3212 gfc_start_block (&inner
);
3214 /* TODO: range checking for mapped dimensions. */
3215 info
= &ss
->data
.info
;
3217 /* This code only checks ranges. Elemental and vector
3218 dimensions are checked later. */
3219 for (n
= 0; n
< loop
->dimen
; n
++)
3224 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3227 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3228 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3229 check_upper
= false;
3233 /* Zero stride is not allowed. */
3234 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3235 info
->stride
[dim
], gfc_index_zero_node
);
3236 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3237 "of array '%s'", dim
+ 1, ss
->expr
->symtree
->name
);
3238 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3239 &ss
->expr
->where
, msg
);
3242 desc
= ss
->data
.info
.descriptor
;
3244 /* This is the run-time equivalent of resolve.c's
3245 check_dimension(). The logical is more readable there
3246 than it is here, with all the trees. */
3247 lbound
= gfc_conv_array_lbound (desc
, dim
);
3248 end
= info
->end
[dim
];
3250 ubound
= gfc_conv_array_ubound (desc
, dim
);
3254 /* non_zerosized is true when the selected range is not
3256 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
3257 boolean_type_node
, info
->stride
[dim
],
3258 gfc_index_zero_node
);
3259 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3260 info
->start
[dim
], end
);
3261 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3262 boolean_type_node
, stride_pos
, tmp
);
3264 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
3266 info
->stride
[dim
], gfc_index_zero_node
);
3267 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3268 info
->start
[dim
], end
);
3269 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3272 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3274 stride_pos
, stride_neg
);
3276 /* Check the start of the range against the lower and upper
3277 bounds of the array, if the range is not empty.
3278 If upper bound is present, include both bounds in the
3282 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3284 info
->start
[dim
], lbound
);
3285 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3287 non_zerosized
, tmp
);
3288 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
3290 info
->start
[dim
], ubound
);
3291 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3293 non_zerosized
, tmp2
);
3294 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3295 "outside of expected range (%%ld:%%ld)",
3296 dim
+ 1, ss
->expr
->symtree
->name
);
3297 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3298 &ss
->expr
->where
, msg
,
3299 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3300 fold_convert (long_integer_type_node
, lbound
),
3301 fold_convert (long_integer_type_node
, ubound
));
3302 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3303 &ss
->expr
->where
, msg
,
3304 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3305 fold_convert (long_integer_type_node
, lbound
),
3306 fold_convert (long_integer_type_node
, ubound
));
3311 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3313 info
->start
[dim
], lbound
);
3314 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3315 boolean_type_node
, non_zerosized
, tmp
);
3316 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3317 "below lower bound of %%ld",
3318 dim
+ 1, ss
->expr
->symtree
->name
);
3319 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3320 &ss
->expr
->where
, msg
,
3321 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3322 fold_convert (long_integer_type_node
, lbound
));
3326 /* Compute the last element of the range, which is not
3327 necessarily "end" (think 0:5:3, which doesn't contain 5)
3328 and check it against both lower and upper bounds. */
3330 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3331 gfc_array_index_type
, end
,
3333 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
3334 gfc_array_index_type
, tmp
,
3336 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3337 gfc_array_index_type
, end
, tmp
);
3338 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
3339 boolean_type_node
, tmp
, lbound
);
3340 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3341 boolean_type_node
, non_zerosized
, tmp2
);
3344 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
3345 boolean_type_node
, tmp
, ubound
);
3346 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3347 boolean_type_node
, non_zerosized
, tmp3
);
3348 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3349 "outside of expected range (%%ld:%%ld)",
3350 dim
+ 1, ss
->expr
->symtree
->name
);
3351 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3352 &ss
->expr
->where
, msg
,
3353 fold_convert (long_integer_type_node
, tmp
),
3354 fold_convert (long_integer_type_node
, ubound
),
3355 fold_convert (long_integer_type_node
, lbound
));
3356 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3357 &ss
->expr
->where
, msg
,
3358 fold_convert (long_integer_type_node
, tmp
),
3359 fold_convert (long_integer_type_node
, ubound
),
3360 fold_convert (long_integer_type_node
, lbound
));
3365 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3366 "below lower bound of %%ld",
3367 dim
+ 1, ss
->expr
->symtree
->name
);
3368 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3369 &ss
->expr
->where
, msg
,
3370 fold_convert (long_integer_type_node
, tmp
),
3371 fold_convert (long_integer_type_node
, lbound
));
3375 /* Check the section sizes match. */
3376 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3377 gfc_array_index_type
, end
,
3379 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
3380 gfc_array_index_type
, tmp
,
3382 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3383 gfc_array_index_type
,
3384 gfc_index_one_node
, tmp
);
3385 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
3386 gfc_array_index_type
, tmp
,
3387 build_int_cst (gfc_array_index_type
, 0));
3388 /* We remember the size of the first section, and check all the
3389 others against this. */
3392 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
3393 boolean_type_node
, tmp
, size
[n
]);
3394 asprintf (&msg
, "Array bound mismatch for dimension %d "
3395 "of array '%s' (%%ld/%%ld)",
3396 dim
+ 1, ss
->expr
->symtree
->name
);
3398 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3399 &ss
->expr
->where
, msg
,
3400 fold_convert (long_integer_type_node
, tmp
),
3401 fold_convert (long_integer_type_node
, size
[n
]));
3406 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
3409 tmp
= gfc_finish_block (&inner
);
3411 /* For optional arguments, only check bounds if the argument is
3413 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3414 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3415 tmp
= build3_v (COND_EXPR
,
3416 gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
),
3417 tmp
, build_empty_stmt (input_location
));
3419 gfc_add_expr_to_block (&block
, tmp
);
3423 tmp
= gfc_finish_block (&block
);
3424 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3429 /* Return true if the two SS could be aliased, i.e. both point to the same data
3431 /* TODO: resolve aliases based on frontend expressions. */
3434 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3441 lsym
= lss
->expr
->symtree
->n
.sym
;
3442 rsym
= rss
->expr
->symtree
->n
.sym
;
3443 if (gfc_symbols_could_alias (lsym
, rsym
))
3446 if (rsym
->ts
.type
!= BT_DERIVED
3447 && lsym
->ts
.type
!= BT_DERIVED
)
3450 /* For derived types we must check all the component types. We can ignore
3451 array references as these will have the same base type as the previous
3453 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3455 if (lref
->type
!= REF_COMPONENT
)
3458 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3461 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3464 if (rref
->type
!= REF_COMPONENT
)
3467 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3472 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3474 if (rref
->type
!= REF_COMPONENT
)
3477 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3485 /* Resolve array data dependencies. Creates a temporary if required. */
3486 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3490 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3499 loop
->temp_ss
= NULL
;
3501 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3503 if (ss
->type
!= GFC_SS_SECTION
)
3506 if (dest
->expr
->symtree
->n
.sym
!= ss
->expr
->symtree
->n
.sym
)
3508 if (gfc_could_be_alias (dest
, ss
)
3509 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3517 lref
= dest
->expr
->ref
;
3518 rref
= ss
->expr
->ref
;
3520 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
3525 for (i
= 0; i
< dest
->data
.info
.dimen
; i
++)
3526 for (j
= 0; j
< ss
->data
.info
.dimen
; j
++)
3528 && dest
->data
.info
.dim
[i
] == ss
->data
.info
.dim
[j
])
3530 /* If we don't access array elements in the same order,
3531 there is a dependency. */
3536 /* TODO : loop shifting. */
3539 /* Mark the dimensions for LOOP SHIFTING */
3540 for (n
= 0; n
< loop
->dimen
; n
++)
3542 int dim
= dest
->data
.info
.dim
[n
];
3544 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3546 else if (! gfc_is_same_range (&lref
->u
.ar
,
3547 &rref
->u
.ar
, dim
, 0))
3551 /* Put all the dimensions with dependencies in the
3554 for (n
= 0; n
< loop
->dimen
; n
++)
3556 gcc_assert (loop
->order
[n
] == n
);
3558 loop
->order
[dim
++] = n
;
3560 for (n
= 0; n
< loop
->dimen
; n
++)
3563 loop
->order
[dim
++] = n
;
3566 gcc_assert (dim
== loop
->dimen
);
3577 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3578 if (GFC_ARRAY_TYPE_P (base_type
)
3579 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3580 base_type
= gfc_get_element_type (base_type
);
3581 loop
->temp_ss
= gfc_get_ss ();
3582 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3583 loop
->temp_ss
->data
.temp
.type
= base_type
;
3584 loop
->temp_ss
->string_length
= dest
->string_length
;
3585 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3586 loop
->temp_ss
->next
= gfc_ss_terminator
;
3587 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3590 loop
->temp_ss
= NULL
;
3594 /* Initialize the scalarization loop. Creates the loop variables. Determines
3595 the range of the loop variables. Creates a temporary if required.
3596 Calculates how to transform from loop variables to array indices for each
3597 expression. Also generates code for scalar expressions which have been
3598 moved outside the loop. */
3601 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
3603 int n
, dim
, spec_dim
;
3605 gfc_ss_info
*specinfo
;
3608 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3609 bool dynamic
[GFC_MAX_DIMENSIONS
];
3614 for (n
= 0; n
< loop
->dimen
; n
++)
3618 /* We use one SS term, and use that to determine the bounds of the
3619 loop for this dimension. We try to pick the simplest term. */
3620 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3622 if (ss
->type
== GFC_SS_SCALAR
|| ss
->type
== GFC_SS_REFERENCE
)
3625 info
= &ss
->data
.info
;
3628 if (loopspec
[n
] != NULL
)
3630 specinfo
= &loopspec
[n
]->data
.info
;
3631 spec_dim
= specinfo
->dim
[n
];
3635 /* Silence unitialized warnings. */
3642 gcc_assert (ss
->shape
[dim
]);
3643 /* The frontend has worked out the size for us. */
3645 || !loopspec
[n
]->shape
3646 || !integer_zerop (specinfo
->start
[spec_dim
]))
3647 /* Prefer zero-based descriptors if possible. */
3652 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3654 gfc_constructor_base base
;
3655 /* An unknown size constructor will always be rank one.
3656 Higher rank constructors will either have known shape,
3657 or still be wrapped in a call to reshape. */
3658 gcc_assert (loop
->dimen
== 1);
3660 /* Always prefer to use the constructor bounds if the size
3661 can be determined at compile time. Prefer not to otherwise,
3662 since the general case involves realloc, and it's better to
3663 avoid that overhead if possible. */
3664 base
= ss
->expr
->value
.constructor
;
3665 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
3666 if (!dynamic
[n
] || !loopspec
[n
])
3671 /* TODO: Pick the best bound if we have a choice between a
3672 function and something else. */
3673 if (ss
->type
== GFC_SS_FUNCTION
)
3679 if (ss
->type
!= GFC_SS_SECTION
)
3684 /* Criteria for choosing a loop specifier (most important first):
3685 doesn't need realloc
3691 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3693 else if (integer_onep (info
->stride
[dim
])
3694 && !integer_onep (specinfo
->stride
[spec_dim
]))
3696 else if (INTEGER_CST_P (info
->stride
[dim
])
3697 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
3699 else if (INTEGER_CST_P (info
->start
[dim
])
3700 && !INTEGER_CST_P (specinfo
->start
[spec_dim
]))
3702 /* We don't work out the upper bound.
3703 else if (INTEGER_CST_P (info->finish[n])
3704 && ! INTEGER_CST_P (specinfo->finish[n]))
3705 loopspec[n] = ss; */
3708 /* We should have found the scalarization loop specifier. If not,
3710 gcc_assert (loopspec
[n
]);
3712 info
= &loopspec
[n
]->data
.info
;
3715 /* Set the extents of this range. */
3716 cshape
= loopspec
[n
]->shape
;
3717 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
3718 && INTEGER_CST_P (info
->stride
[dim
]))
3720 loop
->from
[n
] = info
->start
[dim
];
3721 mpz_set (i
, cshape
[get_array_ref_dim (info
, n
)]);
3722 mpz_sub_ui (i
, i
, 1);
3723 /* To = from + (size - 1) * stride. */
3724 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3725 if (!integer_onep (info
->stride
[dim
]))
3726 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
3727 gfc_array_index_type
, tmp
,
3729 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
3730 gfc_array_index_type
,
3731 loop
->from
[n
], tmp
);
3735 loop
->from
[n
] = info
->start
[dim
];
3736 switch (loopspec
[n
]->type
)
3738 case GFC_SS_CONSTRUCTOR
:
3739 /* The upper bound is calculated when we expand the
3741 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3744 case GFC_SS_SECTION
:
3745 /* Use the end expression if it exists and is not constant,
3746 so that it is only evaluated once. */
3747 loop
->to
[n
] = info
->end
[dim
];
3750 case GFC_SS_FUNCTION
:
3751 /* The loop bound will be set when we generate the call. */
3752 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3760 /* Transform everything so we have a simple incrementing variable. */
3761 if (integer_onep (info
->stride
[dim
]))
3762 info
->delta
[dim
] = gfc_index_zero_node
;
3765 /* Set the delta for this section. */
3766 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3767 /* Number of iterations is (end - start + step) / step.
3768 with start = 0, this simplifies to
3770 for (i = 0; i<=last; i++){...}; */
3771 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3772 gfc_array_index_type
, loop
->to
[n
],
3774 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
3775 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
3776 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
3777 tmp
, build_int_cst (gfc_array_index_type
, -1));
3778 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3779 /* Make the loop variable start at 0. */
3780 loop
->from
[n
] = gfc_index_zero_node
;
3784 /* Add all the scalar code that can be taken out of the loops.
3785 This may include calculating the loop bounds, so do it before
3786 allocating the temporary. */
3787 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
3789 /* If we want a temporary then create it. */
3790 if (loop
->temp_ss
!= NULL
)
3792 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3794 /* Make absolutely sure that this is a complete type. */
3795 if (loop
->temp_ss
->string_length
)
3796 loop
->temp_ss
->data
.temp
.type
3797 = gfc_get_character_type_len_for_eltype
3798 (TREE_TYPE (loop
->temp_ss
->data
.temp
.type
),
3799 loop
->temp_ss
->string_length
);
3801 tmp
= loop
->temp_ss
->data
.temp
.type
;
3802 n
= loop
->temp_ss
->data
.temp
.dimen
;
3803 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3804 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3805 loop
->temp_ss
->data
.info
.dimen
= n
;
3807 gcc_assert (loop
->temp_ss
->data
.info
.dimen
!= 0);
3808 for (n
= 0; n
< loop
->temp_ss
->data
.info
.dimen
; n
++)
3809 loop
->temp_ss
->data
.info
.dim
[n
] = n
;
3811 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3812 &loop
->temp_ss
->data
.info
, tmp
, NULL_TREE
,
3813 false, true, false, where
);
3816 for (n
= 0; n
< loop
->temp_dim
; n
++)
3817 loopspec
[loop
->order
[n
]] = NULL
;
3821 /* For array parameters we don't have loop variables, so don't calculate the
3823 if (loop
->array_parameter
)
3826 /* Calculate the translation from loop variables to array indices. */
3827 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3829 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
3830 && ss
->type
!= GFC_SS_CONSTRUCTOR
)
3834 info
= &ss
->data
.info
;
3836 for (n
= 0; n
< info
->dimen
; n
++)
3838 /* If we are specifying the range the delta is already set. */
3839 if (loopspec
[n
] != ss
)
3841 dim
= ss
->data
.info
.dim
[n
];
3843 /* Calculate the offset relative to the loop variable.
3844 First multiply by the stride. */
3845 tmp
= loop
->from
[n
];
3846 if (!integer_onep (info
->stride
[dim
]))
3847 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
3848 gfc_array_index_type
,
3849 tmp
, info
->stride
[dim
]);
3851 /* Then subtract this from our starting value. */
3852 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3853 gfc_array_index_type
,
3854 info
->start
[dim
], tmp
);
3856 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3863 /* Calculate the size of a given array dimension from the bounds. This
3864 is simply (ubound - lbound + 1) if this expression is positive
3865 or 0 if it is negative (pick either one if it is zero). Optionally
3866 (if or_expr is present) OR the (expression != 0) condition to it. */
3869 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
3874 /* Calculate (ubound - lbound + 1). */
3875 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3877 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
3878 gfc_index_one_node
);
3880 /* Check whether the size for this dimension is negative. */
3881 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
3882 gfc_index_zero_node
);
3883 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
3884 gfc_index_zero_node
, res
);
3886 /* Build OR expression. */
3888 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3889 boolean_type_node
, *or_expr
, cond
);
3895 /* For an array descriptor, get the total number of elements. This is just
3896 the product of the extents along all dimensions. */
3899 gfc_conv_descriptor_size (tree desc
, int rank
)
3904 res
= gfc_index_one_node
;
3906 for (dim
= 0; dim
< rank
; ++dim
)
3912 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
3913 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
3915 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
3916 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3924 /* Fills in an array descriptor, and returns the size of the array. The size
3925 will be a simple_val, ie a variable or a constant. Also calculates the
3926 offset of the base. Returns the size of the array.
3930 for (n = 0; n < rank; n++)
3932 a.lbound[n] = specified_lower_bound;
3933 offset = offset + a.lbond[n] * stride;
3935 a.ubound[n] = specified_upper_bound;
3936 a.stride[n] = stride;
3937 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3938 stride = stride * size;
3945 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
3946 gfc_expr
** lower
, gfc_expr
** upper
,
3947 stmtblock_t
* pblock
)
3958 stmtblock_t thenblock
;
3959 stmtblock_t elseblock
;
3964 type
= TREE_TYPE (descriptor
);
3966 stride
= gfc_index_one_node
;
3967 offset
= gfc_index_zero_node
;
3969 /* Set the dtype. */
3970 tmp
= gfc_conv_descriptor_dtype (descriptor
);
3971 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
3973 or_expr
= boolean_false_node
;
3975 for (n
= 0; n
< rank
; n
++)
3980 /* We have 3 possibilities for determining the size of the array:
3981 lower == NULL => lbound = 1, ubound = upper[n]
3982 upper[n] = NULL => lbound = 1, ubound = lower[n]
3983 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3986 /* Set lower bound. */
3987 gfc_init_se (&se
, NULL
);
3989 se
.expr
= gfc_index_one_node
;
3992 gcc_assert (lower
[n
]);
3995 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
3996 gfc_add_block_to_block (pblock
, &se
.pre
);
4000 se
.expr
= gfc_index_one_node
;
4004 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
4006 conv_lbound
= se
.expr
;
4008 /* Work out the offset for this component. */
4009 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4011 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4012 gfc_array_index_type
, offset
, tmp
);
4014 /* Set upper bound. */
4015 gfc_init_se (&se
, NULL
);
4016 gcc_assert (ubound
);
4017 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4018 gfc_add_block_to_block (pblock
, &se
.pre
);
4020 gfc_conv_descriptor_ubound_set (pblock
, descriptor
,
4021 gfc_rank_cst
[n
], se
.expr
);
4022 conv_ubound
= se
.expr
;
4024 /* Store the stride. */
4025 gfc_conv_descriptor_stride_set (pblock
, descriptor
,
4026 gfc_rank_cst
[n
], stride
);
4028 /* Calculate size and check whether extent is negative. */
4029 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4031 /* Multiply the stride by the number of elements in this dimension. */
4032 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
4033 gfc_array_index_type
, stride
, size
);
4034 stride
= gfc_evaluate_now (stride
, pblock
);
4037 for (n
= rank
; n
< rank
+ corank
; n
++)
4041 /* Set lower bound. */
4042 gfc_init_se (&se
, NULL
);
4043 if (lower
== NULL
|| lower
[n
] == NULL
)
4045 gcc_assert (n
== rank
+ corank
- 1);
4046 se
.expr
= gfc_index_one_node
;
4050 if (ubound
|| n
== rank
+ corank
- 1)
4052 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4053 gfc_add_block_to_block (pblock
, &se
.pre
);
4057 se
.expr
= gfc_index_one_node
;
4061 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
4064 if (n
< rank
+ corank
- 1)
4066 gfc_init_se (&se
, NULL
);
4067 gcc_assert (ubound
);
4068 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4069 gfc_add_block_to_block (pblock
, &se
.pre
);
4070 gfc_conv_descriptor_ubound_set (pblock
, descriptor
,
4071 gfc_rank_cst
[n
], se
.expr
);
4075 /* The stride is the number of elements in the array, so multiply by the
4076 size of an element to get the total size. */
4077 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4078 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4079 stride
, fold_convert (gfc_array_index_type
, tmp
));
4081 if (poffset
!= NULL
)
4083 offset
= gfc_evaluate_now (offset
, pblock
);
4087 if (integer_zerop (or_expr
))
4089 if (integer_onep (or_expr
))
4090 return gfc_index_zero_node
;
4092 var
= gfc_create_var (TREE_TYPE (size
), "size");
4093 gfc_start_block (&thenblock
);
4094 gfc_add_modify (&thenblock
, var
, gfc_index_zero_node
);
4095 thencase
= gfc_finish_block (&thenblock
);
4097 gfc_start_block (&elseblock
);
4098 gfc_add_modify (&elseblock
, var
, size
);
4099 elsecase
= gfc_finish_block (&elseblock
);
4101 tmp
= gfc_evaluate_now (or_expr
, pblock
);
4102 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
4103 gfc_add_expr_to_block (pblock
, tmp
);
4109 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4110 the work for an ALLOCATE statement. */
4114 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
4122 gfc_ref
*ref
, *prev_ref
= NULL
;
4123 bool allocatable_array
, coarray
;
4127 /* Find the last reference in the chain. */
4128 while (ref
&& ref
->next
!= NULL
)
4130 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
4131 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
4136 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
4141 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
4142 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
4146 allocatable_array
= prev_ref
->u
.c
.component
->attr
.allocatable
;
4147 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
4150 /* Return if this is a scalar coarray. */
4151 if ((!prev_ref
&& !expr
->symtree
->n
.sym
->attr
.dimension
)
4152 || (prev_ref
&& !prev_ref
->u
.c
.component
->attr
.dimension
))
4154 gcc_assert (coarray
);
4158 /* Figure out the size of the array. */
4159 switch (ref
->u
.ar
.type
)
4165 upper
= ref
->u
.ar
.start
;
4171 lower
= ref
->u
.ar
.start
;
4172 upper
= ref
->u
.ar
.end
;
4176 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
4178 lower
= ref
->u
.ar
.as
->lower
;
4179 upper
= ref
->u
.ar
.as
->upper
;
4187 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
4188 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
4191 /* Allocate memory to store the data. */
4192 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
4193 STRIP_NOPS (pointer
);
4195 /* The allocate_array variants take the old pointer as first argument. */
4196 if (allocatable_array
)
4197 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
, expr
);
4199 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
4200 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, pointer
,
4202 gfc_add_expr_to_block (&se
->pre
, tmp
);
4204 gfc_conv_descriptor_offset_set (&se
->pre
, se
->expr
, offset
);
4206 if (expr
->ts
.type
== BT_DERIVED
4207 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
4209 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
4210 ref
->u
.ar
.as
->rank
);
4211 gfc_add_expr_to_block (&se
->pre
, tmp
);
4218 /* Deallocate an array variable. Also used when an allocated variable goes
4223 gfc_array_deallocate (tree descriptor
, tree pstat
, gfc_expr
* expr
)
4229 gfc_start_block (&block
);
4230 /* Get a pointer to the data. */
4231 var
= gfc_conv_descriptor_data_get (descriptor
);
4234 /* Parameter is the address of the data component. */
4235 tmp
= gfc_deallocate_with_status (var
, pstat
, false, expr
);
4236 gfc_add_expr_to_block (&block
, tmp
);
4238 /* Zero the data pointer. */
4239 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
4240 var
, build_int_cst (TREE_TYPE (var
), 0));
4241 gfc_add_expr_to_block (&block
, tmp
);
4243 return gfc_finish_block (&block
);
4247 /* Create an array constructor from an initialization expression.
4248 We assume the frontend already did any expansions and conversions. */
4251 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
4257 unsigned HOST_WIDE_INT lo
;
4259 VEC(constructor_elt
,gc
) *v
= NULL
;
4261 switch (expr
->expr_type
)
4264 case EXPR_STRUCTURE
:
4265 /* A single scalar or derived type value. Create an array with all
4266 elements equal to that value. */
4267 gfc_init_se (&se
, NULL
);
4269 if (expr
->expr_type
== EXPR_CONSTANT
)
4270 gfc_conv_constant (&se
, expr
);
4272 gfc_conv_structure (&se
, expr
, 1);
4274 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
4275 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
4276 hi
= TREE_INT_CST_HIGH (tmp
);
4277 lo
= TREE_INT_CST_LOW (tmp
);
4281 /* This will probably eat buckets of memory for large arrays. */
4282 while (hi
!= 0 || lo
!= 0)
4284 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
4292 /* Create a vector of all the elements. */
4293 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4294 c
; c
= gfc_constructor_next (c
))
4298 /* Problems occur when we get something like
4299 integer :: a(lots) = (/(i, i=1, lots)/) */
4300 gfc_fatal_error ("The number of elements in the array constructor "
4301 "at %L requires an increase of the allowed %d "
4302 "upper limit. See -fmax-array-constructor "
4303 "option", &expr
->where
,
4304 gfc_option
.flag_max_array_constructor
);
4307 if (mpz_cmp_si (c
->offset
, 0) != 0)
4308 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
4312 gfc_init_se (&se
, NULL
);
4313 switch (c
->expr
->expr_type
)
4316 gfc_conv_constant (&se
, c
->expr
);
4317 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4320 case EXPR_STRUCTURE
:
4321 gfc_conv_structure (&se
, c
->expr
, 1);
4322 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4327 /* Catch those occasional beasts that do not simplify
4328 for one reason or another, assuming that if they are
4329 standard defying the frontend will catch them. */
4330 gfc_conv_expr (&se
, c
->expr
);
4331 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4338 return gfc_build_null_descriptor (type
);
4344 /* Create a constructor from the list of elements. */
4345 tmp
= build_constructor (type
, v
);
4346 TREE_CONSTANT (tmp
) = 1;
4351 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4352 returns the size (in elements) of the array. */
4355 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
4356 stmtblock_t
* pblock
)
4371 size
= gfc_index_one_node
;
4372 offset
= gfc_index_zero_node
;
4373 for (dim
= 0; dim
< as
->rank
; dim
++)
4375 /* Evaluate non-constant array bound expressions. */
4376 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
4377 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
4379 gfc_init_se (&se
, NULL
);
4380 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
4381 gfc_add_block_to_block (pblock
, &se
.pre
);
4382 gfc_add_modify (pblock
, lbound
, se
.expr
);
4384 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
4385 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
4387 gfc_init_se (&se
, NULL
);
4388 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
4389 gfc_add_block_to_block (pblock
, &se
.pre
);
4390 gfc_add_modify (pblock
, ubound
, se
.expr
);
4392 /* The offset of this dimension. offset = offset - lbound * stride. */
4393 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4395 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4398 /* The size of this dimension, and the stride of the next. */
4399 if (dim
+ 1 < as
->rank
)
4400 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
4402 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4404 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
4406 /* Calculate stride = size * (ubound + 1 - lbound). */
4407 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4408 gfc_array_index_type
,
4409 gfc_index_one_node
, lbound
);
4410 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4411 gfc_array_index_type
, ubound
, tmp
);
4412 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4413 gfc_array_index_type
, size
, tmp
);
4415 gfc_add_modify (pblock
, stride
, tmp
);
4417 stride
= gfc_evaluate_now (tmp
, pblock
);
4419 /* Make sure that negative size arrays are translated
4420 to being zero size. */
4421 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4422 stride
, gfc_index_zero_node
);
4423 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4424 gfc_array_index_type
, tmp
,
4425 stride
, gfc_index_zero_node
);
4426 gfc_add_modify (pblock
, stride
, tmp
);
4432 gfc_trans_vla_type_sizes (sym
, pblock
);
4439 /* Generate code to initialize/allocate an array variable. */
4442 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
4443 gfc_wrapped_block
* block
)
4452 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
4454 /* Do nothing for USEd variables. */
4455 if (sym
->attr
.use_assoc
)
4458 type
= TREE_TYPE (decl
);
4459 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4460 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
4462 gfc_start_block (&init
);
4464 /* Evaluate character string length. */
4465 if (sym
->ts
.type
== BT_CHARACTER
4466 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4468 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4470 gfc_trans_vla_type_sizes (sym
, &init
);
4472 /* Emit a DECL_EXPR for this variable, which will cause the
4473 gimplifier to allocate storage, and all that good stuff. */
4474 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
4475 gfc_add_expr_to_block (&init
, tmp
);
4480 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4484 type
= TREE_TYPE (type
);
4486 gcc_assert (!sym
->attr
.use_assoc
);
4487 gcc_assert (!TREE_STATIC (decl
));
4488 gcc_assert (!sym
->module
);
4490 if (sym
->ts
.type
== BT_CHARACTER
4491 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4492 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4494 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
4496 /* Don't actually allocate space for Cray Pointees. */
4497 if (sym
->attr
.cray_pointee
)
4499 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4500 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4502 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4506 /* The size is the number of elements in the array, so multiply by the
4507 size of an element to get the total size. */
4508 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4509 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4510 size
, fold_convert (gfc_array_index_type
, tmp
));
4512 /* Allocate memory to hold the data. */
4513 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
4514 gfc_add_modify (&init
, decl
, tmp
);
4516 /* Set offset of the array. */
4517 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4518 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4520 /* Automatic arrays should not have initializers. */
4521 gcc_assert (!sym
->value
);
4523 /* Free the temporary. */
4524 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
4526 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4530 /* Generate entry and exit code for g77 calling convention arrays. */
4533 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
4543 gfc_save_backend_locus (&loc
);
4544 gfc_set_backend_locus (&sym
->declared_at
);
4546 /* Descriptor type. */
4547 parm
= sym
->backend_decl
;
4548 type
= TREE_TYPE (parm
);
4549 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4551 gfc_start_block (&init
);
4553 if (sym
->ts
.type
== BT_CHARACTER
4554 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4555 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4557 /* Evaluate the bounds of the array. */
4558 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
4560 /* Set the offset. */
4561 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4562 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4564 /* Set the pointer itself if we aren't using the parameter directly. */
4565 if (TREE_CODE (parm
) != PARM_DECL
)
4567 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4568 gfc_add_modify (&init
, parm
, tmp
);
4570 stmt
= gfc_finish_block (&init
);
4572 gfc_restore_backend_locus (&loc
);
4574 /* Add the initialization code to the start of the function. */
4576 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4578 tmp
= gfc_conv_expr_present (sym
);
4579 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4582 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
4586 /* Modify the descriptor of an array parameter so that it has the
4587 correct lower bound. Also move the upper bound accordingly.
4588 If the array is not packed, it will be copied into a temporary.
4589 For each dimension we set the new lower and upper bounds. Then we copy the
4590 stride and calculate the offset for this dimension. We also work out
4591 what the stride of a packed array would be, and see it the two match.
4592 If the array need repacking, we set the stride to the values we just
4593 calculated, recalculate the offset and copy the array data.
4594 Code is also added to copy the data back at the end of the function.
4598 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
4599 gfc_wrapped_block
* block
)
4606 tree stmtInit
, stmtCleanup
;
4613 tree stride
, stride2
;
4623 /* Do nothing for pointer and allocatable arrays. */
4624 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4627 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4629 gfc_trans_g77_array (sym
, block
);
4633 gfc_save_backend_locus (&loc
);
4634 gfc_set_backend_locus (&sym
->declared_at
);
4636 /* Descriptor type. */
4637 type
= TREE_TYPE (tmpdesc
);
4638 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4639 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4640 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
4641 gfc_start_block (&init
);
4643 if (sym
->ts
.type
== BT_CHARACTER
4644 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4645 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4647 checkparm
= (sym
->as
->type
== AS_EXPLICIT
4648 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
4650 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4651 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4653 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4655 /* For non-constant shape arrays we only check if the first dimension
4656 is contiguous. Repacking higher dimensions wouldn't gain us
4657 anything as we still don't know the array stride. */
4658 partial
= gfc_create_var (boolean_type_node
, "partial");
4659 TREE_USED (partial
) = 1;
4660 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4661 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
4662 gfc_index_one_node
);
4663 gfc_add_modify (&init
, partial
, tmp
);
4666 partial
= NULL_TREE
;
4668 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4669 here, however I think it does the right thing. */
4672 /* Set the first stride. */
4673 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4674 stride
= gfc_evaluate_now (stride
, &init
);
4676 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4677 stride
, gfc_index_zero_node
);
4678 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
4679 tmp
, gfc_index_one_node
, stride
);
4680 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4681 gfc_add_modify (&init
, stride
, tmp
);
4683 /* Allow the user to disable array repacking. */
4684 stmt_unpacked
= NULL_TREE
;
4688 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4689 /* A library call to repack the array if necessary. */
4690 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4691 stmt_unpacked
= build_call_expr_loc (input_location
,
4692 gfor_fndecl_in_pack
, 1, tmp
);
4694 stride
= gfc_index_one_node
;
4696 if (gfc_option
.warn_array_temp
)
4697 gfc_warning ("Creating array temporary at %L", &loc
);
4700 /* This is for the case where the array data is used directly without
4701 calling the repack function. */
4702 if (no_repack
|| partial
!= NULL_TREE
)
4703 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4705 stmt_packed
= NULL_TREE
;
4707 /* Assign the data pointer. */
4708 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4710 /* Don't repack unknown shape arrays when the first stride is 1. */
4711 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
4712 partial
, stmt_packed
, stmt_unpacked
);
4715 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4716 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
4718 offset
= gfc_index_zero_node
;
4719 size
= gfc_index_one_node
;
4721 /* Evaluate the bounds of the array. */
4722 for (n
= 0; n
< sym
->as
->rank
; n
++)
4724 if (checkparm
|| !sym
->as
->upper
[n
])
4726 /* Get the bounds of the actual parameter. */
4727 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
4728 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
4732 dubound
= NULL_TREE
;
4733 dlbound
= NULL_TREE
;
4736 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4737 if (!INTEGER_CST_P (lbound
))
4739 gfc_init_se (&se
, NULL
);
4740 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4741 gfc_array_index_type
);
4742 gfc_add_block_to_block (&init
, &se
.pre
);
4743 gfc_add_modify (&init
, lbound
, se
.expr
);
4746 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4747 /* Set the desired upper bound. */
4748 if (sym
->as
->upper
[n
])
4750 /* We know what we want the upper bound to be. */
4751 if (!INTEGER_CST_P (ubound
))
4753 gfc_init_se (&se
, NULL
);
4754 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4755 gfc_array_index_type
);
4756 gfc_add_block_to_block (&init
, &se
.pre
);
4757 gfc_add_modify (&init
, ubound
, se
.expr
);
4760 /* Check the sizes match. */
4763 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4767 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4768 gfc_array_index_type
, ubound
, lbound
);
4769 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4770 gfc_array_index_type
,
4771 gfc_index_one_node
, temp
);
4772 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
4773 gfc_array_index_type
, dubound
,
4775 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
4776 gfc_array_index_type
,
4777 gfc_index_one_node
, stride2
);
4778 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
4779 gfc_array_index_type
, temp
, stride2
);
4780 asprintf (&msg
, "Dimension %d of array '%s' has extent "
4781 "%%ld instead of %%ld", n
+1, sym
->name
);
4783 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
4784 fold_convert (long_integer_type_node
, temp
),
4785 fold_convert (long_integer_type_node
, stride2
));
4792 /* For assumed shape arrays move the upper bound by the same amount
4793 as the lower bound. */
4794 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4795 gfc_array_index_type
, dubound
, dlbound
);
4796 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4797 gfc_array_index_type
, tmp
, lbound
);
4798 gfc_add_modify (&init
, ubound
, tmp
);
4800 /* The offset of this dimension. offset = offset - lbound * stride. */
4801 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4803 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4804 gfc_array_index_type
, offset
, tmp
);
4806 /* The size of this dimension, and the stride of the next. */
4807 if (n
+ 1 < sym
->as
->rank
)
4809 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4811 if (no_repack
|| partial
!= NULL_TREE
)
4813 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
4815 /* Figure out the stride if not a known constant. */
4816 if (!INTEGER_CST_P (stride
))
4819 stmt_packed
= NULL_TREE
;
4822 /* Calculate stride = size * (ubound + 1 - lbound). */
4823 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4824 gfc_array_index_type
,
4825 gfc_index_one_node
, lbound
);
4826 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4827 gfc_array_index_type
, ubound
, tmp
);
4828 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4829 gfc_array_index_type
, size
, tmp
);
4833 /* Assign the stride. */
4834 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4835 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4836 gfc_array_index_type
, partial
,
4837 stmt_unpacked
, stmt_packed
);
4839 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4840 gfc_add_modify (&init
, stride
, tmp
);
4845 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4847 if (stride
&& !INTEGER_CST_P (stride
))
4849 /* Calculate size = stride * (ubound + 1 - lbound). */
4850 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4851 gfc_array_index_type
,
4852 gfc_index_one_node
, lbound
);
4853 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4854 gfc_array_index_type
,
4856 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4857 gfc_array_index_type
,
4858 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4859 gfc_add_modify (&init
, stride
, tmp
);
4864 /* Set the offset. */
4865 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4866 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4868 gfc_trans_vla_type_sizes (sym
, &init
);
4870 stmtInit
= gfc_finish_block (&init
);
4872 /* Only do the entry/initialization code if the arg is present. */
4873 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4874 optional_arg
= (sym
->attr
.optional
4875 || (sym
->ns
->proc_name
->attr
.entry_master
4876 && sym
->attr
.dummy
));
4879 tmp
= gfc_conv_expr_present (sym
);
4880 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
4881 build_empty_stmt (input_location
));
4886 stmtCleanup
= NULL_TREE
;
4889 stmtblock_t cleanup
;
4890 gfc_start_block (&cleanup
);
4892 if (sym
->attr
.intent
!= INTENT_IN
)
4894 /* Copy the data back. */
4895 tmp
= build_call_expr_loc (input_location
,
4896 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4897 gfc_add_expr_to_block (&cleanup
, tmp
);
4900 /* Free the temporary. */
4901 tmp
= gfc_call_free (tmpdesc
);
4902 gfc_add_expr_to_block (&cleanup
, tmp
);
4904 stmtCleanup
= gfc_finish_block (&cleanup
);
4906 /* Only do the cleanup if the array was repacked. */
4907 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
4908 tmp
= gfc_conv_descriptor_data_get (tmp
);
4909 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4911 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
4912 build_empty_stmt (input_location
));
4916 tmp
= gfc_conv_expr_present (sym
);
4917 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
4918 build_empty_stmt (input_location
));
4922 /* We don't need to free any memory allocated by internal_pack as it will
4923 be freed at the end of the function by pop_context. */
4924 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
4926 gfc_restore_backend_locus (&loc
);
4930 /* Calculate the overall offset, including subreferences. */
4932 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4933 bool subref
, gfc_expr
*expr
)
4943 /* If offset is NULL and this is not a subreferenced array, there is
4945 if (offset
== NULL_TREE
)
4948 offset
= gfc_index_zero_node
;
4953 tmp
= gfc_conv_array_data (desc
);
4954 tmp
= build_fold_indirect_ref_loc (input_location
,
4956 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4958 /* Offset the data pointer for pointer assignments from arrays with
4959 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4962 /* Go past the array reference. */
4963 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4964 if (ref
->type
== REF_ARRAY
&&
4965 ref
->u
.ar
.type
!= AR_ELEMENT
)
4971 /* Calculate the offset for each subsequent subreference. */
4972 for (; ref
; ref
= ref
->next
)
4977 field
= ref
->u
.c
.component
->backend_decl
;
4978 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
4979 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
4981 tmp
, field
, NULL_TREE
);
4985 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
4986 gfc_init_se (&start
, NULL
);
4987 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
4988 gfc_add_block_to_block (block
, &start
.pre
);
4989 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
4993 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
4994 && ref
->u
.ar
.type
== AR_ELEMENT
);
4996 /* TODO - Add bounds checking. */
4997 stride
= gfc_index_one_node
;
4998 index
= gfc_index_zero_node
;
4999 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5004 /* Update the index. */
5005 gfc_init_se (&start
, NULL
);
5006 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
5007 itmp
= gfc_evaluate_now (start
.expr
, block
);
5008 gfc_init_se (&start
, NULL
);
5009 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
5010 jtmp
= gfc_evaluate_now (start
.expr
, block
);
5011 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5012 gfc_array_index_type
, itmp
, jtmp
);
5013 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5014 gfc_array_index_type
, itmp
, stride
);
5015 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
5016 gfc_array_index_type
, itmp
, index
);
5017 index
= gfc_evaluate_now (index
, block
);
5019 /* Update the stride. */
5020 gfc_init_se (&start
, NULL
);
5021 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
5022 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5023 gfc_array_index_type
, start
.expr
,
5025 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5026 gfc_array_index_type
,
5027 gfc_index_one_node
, itmp
);
5028 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5029 gfc_array_index_type
, stride
, itmp
);
5030 stride
= gfc_evaluate_now (stride
, block
);
5033 /* Apply the index to obtain the array element. */
5034 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
5044 /* Set the target data pointer. */
5045 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
5046 gfc_conv_descriptor_data_set (block
, parm
, offset
);
5050 /* gfc_conv_expr_descriptor needs the string length an expression
5051 so that the size of the temporary can be obtained. This is done
5052 by adding up the string lengths of all the elements in the
5053 expression. Function with non-constant expressions have their
5054 string lengths mapped onto the actual arguments using the
5055 interface mapping machinery in trans-expr.c. */
5057 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
5059 gfc_interface_mapping mapping
;
5060 gfc_formal_arglist
*formal
;
5061 gfc_actual_arglist
*arg
;
5064 if (expr
->ts
.u
.cl
->length
5065 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
5067 if (!expr
->ts
.u
.cl
->backend_decl
)
5068 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5072 switch (expr
->expr_type
)
5075 get_array_charlen (expr
->value
.op
.op1
, se
);
5077 /* For parentheses the expression ts.u.cl is identical. */
5078 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
5081 expr
->ts
.u
.cl
->backend_decl
=
5082 gfc_create_var (gfc_charlen_type_node
, "sln");
5084 if (expr
->value
.op
.op2
)
5086 get_array_charlen (expr
->value
.op
.op2
, se
);
5088 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
5090 /* Add the string lengths and assign them to the expression
5091 string length backend declaration. */
5092 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5093 fold_build2_loc (input_location
, PLUS_EXPR
,
5094 gfc_charlen_type_node
,
5095 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
5096 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
5099 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5100 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
5104 if (expr
->value
.function
.esym
== NULL
5105 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5107 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5111 /* Map expressions involving the dummy arguments onto the actual
5112 argument expressions. */
5113 gfc_init_interface_mapping (&mapping
);
5114 formal
= expr
->symtree
->n
.sym
->formal
;
5115 arg
= expr
->value
.function
.actual
;
5117 /* Set se = NULL in the calls to the interface mapping, to suppress any
5119 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
5124 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
5127 gfc_init_se (&tse
, NULL
);
5129 /* Build the expression for the character length and convert it. */
5130 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
5132 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
5133 gfc_add_block_to_block (&se
->post
, &tse
.post
);
5134 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
5135 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5136 gfc_charlen_type_node
, tse
.expr
,
5137 build_int_cst (gfc_charlen_type_node
, 0));
5138 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
5139 gfc_free_interface_mapping (&mapping
);
5143 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5149 /* Convert an array for passing as an actual argument. Expressions and
5150 vector subscripts are evaluated and stored in a temporary, which is then
5151 passed. For whole arrays the descriptor is passed. For array sections
5152 a modified copy of the descriptor is passed, but using the original data.
5154 This function is also used for array pointer assignments, and there
5157 - se->want_pointer && !se->direct_byref
5158 EXPR is an actual argument. On exit, se->expr contains a
5159 pointer to the array descriptor.
5161 - !se->want_pointer && !se->direct_byref
5162 EXPR is an actual argument to an intrinsic function or the
5163 left-hand side of a pointer assignment. On exit, se->expr
5164 contains the descriptor for EXPR.
5166 - !se->want_pointer && se->direct_byref
5167 EXPR is the right-hand side of a pointer assignment and
5168 se->expr is the descriptor for the previously-evaluated
5169 left-hand side. The function creates an assignment from
5173 The se->force_tmp flag disables the non-copying descriptor optimization
5174 that is used for transpose. It may be used in cases where there is an
5175 alias between the transpose argument and another argument in the same
5179 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
5191 bool subref_array_target
= false;
5194 gcc_assert (ss
!= NULL
);
5195 gcc_assert (ss
!= gfc_ss_terminator
);
5197 /* Special case things we know we can pass easily. */
5198 switch (expr
->expr_type
)
5201 /* If we have a linear array section, we can pass it directly.
5202 Otherwise we need to copy it into a temporary. */
5204 gcc_assert (ss
->type
== GFC_SS_SECTION
);
5205 gcc_assert (ss
->expr
== expr
);
5206 info
= &ss
->data
.info
;
5208 /* Get the descriptor for the array. */
5209 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
5210 desc
= info
->descriptor
;
5212 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
5213 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
5214 && !subref_array_target
;
5221 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5223 /* Create a new descriptor if the array doesn't have one. */
5226 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
5228 else if (se
->direct_byref
)
5231 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
5234 for (n
= 0; n
< info
->dimen
; n
++)
5235 if (info
->dim
[n
] != n
)
5243 if (se
->direct_byref
&& !se
->byref_noassign
)
5245 /* Copy the descriptor for pointer assignments. */
5246 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
5248 /* Add any offsets from subreferences. */
5249 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
5250 subref_array_target
, expr
);
5252 else if (se
->want_pointer
)
5254 /* We pass full arrays directly. This means that pointers and
5255 allocatable arrays should also work. */
5256 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5263 if (expr
->ts
.type
== BT_CHARACTER
)
5264 se
->string_length
= gfc_get_expr_charlen (expr
);
5272 /* We don't need to copy data in some cases. */
5273 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
5276 /* This is a call to transpose... */
5277 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
5278 /* ... which has already been handled by the scalarizer, so
5279 that we just need to get its argument's descriptor. */
5280 gfc_conv_expr_descriptor (se
, expr
->value
.function
.actual
->expr
, ss
);
5284 /* A transformational function return value will be a temporary
5285 array descriptor. We still need to go through the scalarizer
5286 to create the descriptor. Elemental functions ar handled as
5287 arbitrary expressions, i.e. copy to a temporary. */
5289 if (se
->direct_byref
)
5291 gcc_assert (ss
->type
== GFC_SS_FUNCTION
&& ss
->expr
== expr
);
5293 /* For pointer assignments pass the descriptor directly. */
5297 gcc_assert (se
->ss
== ss
);
5298 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5299 gfc_conv_expr (se
, expr
);
5303 if (ss
->expr
!= expr
|| ss
->type
!= GFC_SS_FUNCTION
)
5305 if (ss
->expr
!= expr
)
5306 /* Elemental function. */
5307 gcc_assert ((expr
->value
.function
.esym
!= NULL
5308 && expr
->value
.function
.esym
->attr
.elemental
)
5309 || (expr
->value
.function
.isym
!= NULL
5310 && expr
->value
.function
.isym
->elemental
));
5312 gcc_assert (ss
->type
== GFC_SS_INTRINSIC
);
5315 if (expr
->ts
.type
== BT_CHARACTER
5316 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5317 get_array_charlen (expr
, se
);
5323 /* Transformational function. */
5324 info
= &ss
->data
.info
;
5330 /* Constant array constructors don't need a temporary. */
5331 if (ss
->type
== GFC_SS_CONSTRUCTOR
5332 && expr
->ts
.type
!= BT_CHARACTER
5333 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
5336 info
= &ss
->data
.info
;
5346 /* Something complicated. Copy it into a temporary. */
5352 /* If we are creating a temporary, we don't need to bother about aliases
5357 gfc_init_loopinfo (&loop
);
5359 /* Associate the SS with the loop. */
5360 gfc_add_ss_to_loop (&loop
, ss
);
5362 /* Tell the scalarizer not to bother creating loop variables, etc. */
5364 loop
.array_parameter
= 1;
5366 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5367 gcc_assert (!se
->direct_byref
);
5369 /* Setup the scalarizing loops and bounds. */
5370 gfc_conv_ss_startstride (&loop
);
5374 /* Tell the scalarizer to make a temporary. */
5375 loop
.temp_ss
= gfc_get_ss ();
5376 loop
.temp_ss
->type
= GFC_SS_TEMP
;
5377 loop
.temp_ss
->next
= gfc_ss_terminator
;
5379 if (expr
->ts
.type
== BT_CHARACTER
5380 && !expr
->ts
.u
.cl
->backend_decl
)
5381 get_array_charlen (expr
, se
);
5383 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
5385 if (expr
->ts
.type
== BT_CHARACTER
)
5386 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5388 loop
.temp_ss
->string_length
= NULL
;
5390 se
->string_length
= loop
.temp_ss
->string_length
;
5391 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
5392 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
5395 gfc_conv_loop_setup (&loop
, & expr
->where
);
5399 /* Copy into a temporary and pass that. We don't need to copy the data
5400 back because expressions and vector subscripts must be INTENT_IN. */
5401 /* TODO: Optimize passing function return values. */
5405 /* Start the copying loops. */
5406 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
5407 gfc_mark_ss_chain_used (ss
, 1);
5408 gfc_start_scalarized_body (&loop
, &block
);
5410 /* Copy each data element. */
5411 gfc_init_se (&lse
, NULL
);
5412 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5413 gfc_init_se (&rse
, NULL
);
5414 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5416 lse
.ss
= loop
.temp_ss
;
5419 gfc_conv_scalarized_array_ref (&lse
, NULL
);
5420 if (expr
->ts
.type
== BT_CHARACTER
)
5422 gfc_conv_expr (&rse
, expr
);
5423 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
5424 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
5428 gfc_conv_expr_val (&rse
, expr
);
5430 gfc_add_block_to_block (&block
, &rse
.pre
);
5431 gfc_add_block_to_block (&block
, &lse
.pre
);
5433 lse
.string_length
= rse
.string_length
;
5434 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
5435 expr
->expr_type
== EXPR_VARIABLE
, true);
5436 gfc_add_expr_to_block (&block
, tmp
);
5438 /* Finish the copying loops. */
5439 gfc_trans_scalarizing_loops (&loop
, &block
);
5441 desc
= loop
.temp_ss
->data
.info
.descriptor
;
5443 else if (expr
->expr_type
== EXPR_FUNCTION
)
5445 desc
= info
->descriptor
;
5446 se
->string_length
= ss
->string_length
;
5450 /* We pass sections without copying to a temporary. Make a new
5451 descriptor and point it at the section we want. The loop variable
5452 limits will be the limits of the section.
5453 A function may decide to repack the array to speed up access, but
5454 we're not bothered about that here. */
5463 /* Set the string_length for a character array. */
5464 if (expr
->ts
.type
== BT_CHARACTER
)
5465 se
->string_length
= gfc_get_expr_charlen (expr
);
5467 desc
= info
->descriptor
;
5468 if (se
->direct_byref
&& !se
->byref_noassign
)
5470 /* For pointer assignments we fill in the destination. */
5472 parmtype
= TREE_TYPE (parm
);
5476 /* Otherwise make a new one. */
5477 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
5478 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
5479 loop
.from
, loop
.to
, 0,
5480 GFC_ARRAY_UNKNOWN
, false);
5481 parm
= gfc_create_var (parmtype
, "parm");
5484 offset
= gfc_index_zero_node
;
5486 /* The following can be somewhat confusing. We have two
5487 descriptors, a new one and the original array.
5488 {parm, parmtype, dim} refer to the new one.
5489 {desc, type, n, loop} refer to the original, which maybe
5490 a descriptorless array.
5491 The bounds of the scalarization are the bounds of the section.
5492 We don't have to worry about numeric overflows when calculating
5493 the offsets because all elements are within the array data. */
5495 /* Set the dtype. */
5496 tmp
= gfc_conv_descriptor_dtype (parm
);
5497 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
5499 /* Set offset for assignments to pointer only to zero if it is not
5501 if (se
->direct_byref
5502 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
5503 base
= gfc_index_zero_node
;
5504 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5505 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
5509 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
5510 for (n
= 0; n
< ndim
; n
++)
5512 stride
= gfc_conv_array_stride (desc
, n
);
5514 /* Work out the offset. */
5516 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5518 gcc_assert (info
->subscript
[n
]
5519 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
5520 start
= info
->subscript
[n
]->data
.scalar
.expr
;
5524 /* Evaluate and remember the start of the section. */
5525 start
= info
->start
[n
];
5526 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
5529 tmp
= gfc_conv_array_lbound (desc
, n
);
5530 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5532 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
5534 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
5538 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5540 /* For elemental dimensions, we only need the offset. */
5544 /* Vector subscripts need copying and are handled elsewhere. */
5546 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
5548 /* look for the corresponding scalarizer dimension: dim. */
5549 for (dim
= 0; dim
< ndim
; dim
++)
5550 if (info
->dim
[dim
] == n
)
5553 /* loop exited early: the DIM being looked for has been found. */
5554 gcc_assert (dim
< ndim
);
5556 /* Set the new lower bound. */
5557 from
= loop
.from
[dim
];
5560 /* If we have an array section or are assigning make sure that
5561 the lower bound is 1. References to the full
5562 array should otherwise keep the original bounds. */
5564 || info
->ref
->u
.ar
.type
!= AR_FULL
)
5565 && !integer_onep (from
))
5567 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5568 gfc_array_index_type
, gfc_index_one_node
,
5570 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
5571 gfc_array_index_type
, to
, tmp
);
5572 from
= gfc_index_one_node
;
5574 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
5575 gfc_rank_cst
[dim
], from
);
5577 /* Set the new upper bound. */
5578 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
5579 gfc_rank_cst
[dim
], to
);
5581 /* Multiply the stride by the section stride to get the
5583 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5584 gfc_array_index_type
,
5585 stride
, info
->stride
[n
]);
5587 if (se
->direct_byref
5589 && info
->ref
->u
.ar
.type
!= AR_FULL
)
5591 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
5592 TREE_TYPE (base
), base
, stride
);
5594 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5596 tmp
= gfc_conv_array_lbound (desc
, n
);
5597 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5598 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
5599 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5600 TREE_TYPE (base
), tmp
,
5601 gfc_conv_array_stride (desc
, n
));
5602 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
5603 TREE_TYPE (base
), tmp
, base
);
5606 /* Store the new stride. */
5607 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
5608 gfc_rank_cst
[dim
], stride
);
5611 if (se
->data_not_needed
)
5612 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
5613 gfc_index_zero_node
);
5615 /* Point the data pointer at the 1st element in the section. */
5616 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
5617 subref_array_target
, expr
);
5619 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5620 && !se
->data_not_needed
)
5622 /* Set the offset. */
5623 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
5627 /* Only the callee knows what the correct offset it, so just set
5629 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
5634 if (!se
->direct_byref
|| se
->byref_noassign
)
5636 /* Get a pointer to the new descriptor. */
5637 if (se
->want_pointer
)
5638 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5643 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5644 gfc_add_block_to_block (&se
->post
, &loop
.post
);
5646 /* Cleanup the scalarizer. */
5647 gfc_cleanup_loop (&loop
);
5650 /* Helper function for gfc_conv_array_parameter if array size needs to be
5654 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
5657 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5658 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
5659 else if (expr
->rank
> 1)
5660 *size
= build_call_expr_loc (input_location
,
5661 gfor_fndecl_size0
, 1,
5662 gfc_build_addr_expr (NULL
, desc
));
5665 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
5666 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
5668 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
5669 gfc_array_index_type
, ubound
, lbound
);
5670 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5671 *size
, gfc_index_one_node
);
5672 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5673 *size
, gfc_index_zero_node
);
5675 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
5676 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5677 *size
, fold_convert (gfc_array_index_type
, elem
));
5680 /* Convert an array for passing as an actual parameter. */
5681 /* TODO: Optimize passing g77 arrays. */
5684 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, bool g77
,
5685 const gfc_symbol
*fsym
, const char *proc_name
,
5690 tree tmp
= NULL_TREE
;
5692 tree parent
= DECL_CONTEXT (current_function_decl
);
5693 bool full_array_var
;
5694 bool this_array_result
;
5697 bool array_constructor
;
5698 bool good_allocatable
;
5699 bool ultimate_ptr_comp
;
5700 bool ultimate_alloc_comp
;
5705 ultimate_ptr_comp
= false;
5706 ultimate_alloc_comp
= false;
5708 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5710 if (ref
->next
== NULL
)
5713 if (ref
->type
== REF_COMPONENT
)
5715 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
5716 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
5720 full_array_var
= false;
5723 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
5724 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
5726 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
5728 /* The symbol should have an array specification. */
5729 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
5731 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
5733 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
5734 expr
->ts
.u
.cl
->backend_decl
= tmp
;
5735 se
->string_length
= tmp
;
5738 /* Is this the result of the enclosing procedure? */
5739 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
5740 if (this_array_result
5741 && (sym
->backend_decl
!= current_function_decl
)
5742 && (sym
->backend_decl
!= parent
))
5743 this_array_result
= false;
5745 /* Passing address of the array if it is not pointer or assumed-shape. */
5746 if (full_array_var
&& g77
&& !this_array_result
)
5748 tmp
= gfc_get_symbol_decl (sym
);
5750 if (sym
->ts
.type
== BT_CHARACTER
)
5751 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5753 if (sym
->ts
.type
== BT_DERIVED
)
5755 gfc_conv_expr_descriptor (se
, expr
, ss
);
5756 se
->expr
= gfc_conv_array_data (se
->expr
);
5760 if (!sym
->attr
.pointer
5762 && sym
->as
->type
!= AS_ASSUMED_SHAPE
5763 && !sym
->attr
.allocatable
)
5765 /* Some variables are declared directly, others are declared as
5766 pointers and allocated on the heap. */
5767 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
5770 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5772 array_parameter_size (tmp
, expr
, size
);
5776 if (sym
->attr
.allocatable
)
5778 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5780 gfc_conv_expr_descriptor (se
, expr
, ss
);
5784 array_parameter_size (tmp
, expr
, size
);
5785 se
->expr
= gfc_conv_array_data (tmp
);
5790 /* A convenient reduction in scope. */
5791 contiguous
= g77
&& !this_array_result
&& contiguous
;
5793 /* There is no need to pack and unpack the array, if it is contiguous
5794 and not a deferred- or assumed-shape array, or if it is simply
5796 no_pack
= ((sym
&& sym
->as
5797 && !sym
->attr
.pointer
5798 && sym
->as
->type
!= AS_DEFERRED
5799 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
5801 (ref
&& ref
->u
.ar
.as
5802 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
5803 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
5805 gfc_is_simply_contiguous (expr
, false));
5807 no_pack
= contiguous
&& no_pack
;
5809 /* Array constructors are always contiguous and do not need packing. */
5810 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
5812 /* Same is true of contiguous sections from allocatable variables. */
5813 good_allocatable
= contiguous
5815 && expr
->symtree
->n
.sym
->attr
.allocatable
;
5817 /* Or ultimate allocatable components. */
5818 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
5820 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
5822 gfc_conv_expr_descriptor (se
, expr
, ss
);
5823 if (expr
->ts
.type
== BT_CHARACTER
)
5824 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5826 array_parameter_size (se
->expr
, expr
, size
);
5827 se
->expr
= gfc_conv_array_data (se
->expr
);
5831 if (this_array_result
)
5833 /* Result of the enclosing function. */
5834 gfc_conv_expr_descriptor (se
, expr
, ss
);
5836 array_parameter_size (se
->expr
, expr
, size
);
5837 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5839 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
5840 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
5841 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
5848 /* Every other type of array. */
5849 se
->want_pointer
= 1;
5850 gfc_conv_expr_descriptor (se
, expr
, ss
);
5852 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
5857 /* Deallocate the allocatable components of structures that are
5859 if (expr
->ts
.type
== BT_DERIVED
5860 && expr
->ts
.u
.derived
->attr
.alloc_comp
5861 && expr
->expr_type
!= EXPR_VARIABLE
)
5863 tmp
= build_fold_indirect_ref_loc (input_location
,
5865 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
5866 gfc_add_expr_to_block (&se
->post
, tmp
);
5869 if (g77
|| (fsym
&& fsym
->attr
.contiguous
5870 && !gfc_is_simply_contiguous (expr
, false)))
5872 tree origptr
= NULL_TREE
;
5876 /* For contiguous arrays, save the original value of the descriptor. */
5879 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
5880 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5881 tmp
= gfc_conv_array_data (tmp
);
5882 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5883 TREE_TYPE (origptr
), origptr
,
5884 fold_convert (TREE_TYPE (origptr
), tmp
));
5885 gfc_add_expr_to_block (&se
->pre
, tmp
);
5888 /* Repack the array. */
5889 if (gfc_option
.warn_array_temp
)
5892 gfc_warning ("Creating array temporary at %L for argument '%s'",
5893 &expr
->where
, fsym
->name
);
5895 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5898 ptr
= build_call_expr_loc (input_location
,
5899 gfor_fndecl_in_pack
, 1, desc
);
5901 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5903 tmp
= gfc_conv_expr_present (sym
);
5904 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
5905 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
5906 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
5909 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5911 /* Use the packed data for the actual argument, except for contiguous arrays,
5912 where the descriptor's data component is set. */
5917 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5918 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
5921 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
5925 if (fsym
&& proc_name
)
5926 asprintf (&msg
, "An array temporary was created for argument "
5927 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
5929 asprintf (&msg
, "An array temporary was created");
5931 tmp
= build_fold_indirect_ref_loc (input_location
,
5933 tmp
= gfc_conv_array_data (tmp
);
5934 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5935 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5937 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5938 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5940 gfc_conv_expr_present (sym
), tmp
);
5942 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
5947 gfc_start_block (&block
);
5949 /* Copy the data back. */
5950 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
5952 tmp
= build_call_expr_loc (input_location
,
5953 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5954 gfc_add_expr_to_block (&block
, tmp
);
5957 /* Free the temporary. */
5958 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5959 gfc_add_expr_to_block (&block
, tmp
);
5961 stmt
= gfc_finish_block (&block
);
5963 gfc_init_block (&block
);
5964 /* Only if it was repacked. This code needs to be executed before the
5965 loop cleanup code. */
5966 tmp
= build_fold_indirect_ref_loc (input_location
,
5968 tmp
= gfc_conv_array_data (tmp
);
5969 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5970 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5972 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5973 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5975 gfc_conv_expr_present (sym
), tmp
);
5977 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
5979 gfc_add_expr_to_block (&block
, tmp
);
5980 gfc_add_block_to_block (&block
, &se
->post
);
5982 gfc_init_block (&se
->post
);
5984 /* Reset the descriptor pointer. */
5987 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5988 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
5991 gfc_add_block_to_block (&se
->post
, &block
);
5996 /* Generate code to deallocate an array, if it is allocated. */
5999 gfc_trans_dealloc_allocated (tree descriptor
)
6005 gfc_start_block (&block
);
6007 var
= gfc_conv_descriptor_data_get (descriptor
);
6010 /* Call array_deallocate with an int * present in the second argument.
6011 Although it is ignored here, it's presence ensures that arrays that
6012 are already deallocated are ignored. */
6013 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true, NULL
);
6014 gfc_add_expr_to_block (&block
, tmp
);
6016 /* Zero the data pointer. */
6017 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6018 var
, build_int_cst (TREE_TYPE (var
), 0));
6019 gfc_add_expr_to_block (&block
, tmp
);
6021 return gfc_finish_block (&block
);
6025 /* This helper function calculates the size in words of a full array. */
6028 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
6033 idx
= gfc_rank_cst
[rank
- 1];
6034 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
6035 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
6036 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6038 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6039 tmp
, gfc_index_one_node
);
6040 tmp
= gfc_evaluate_now (tmp
, block
);
6042 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
6043 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6045 return gfc_evaluate_now (tmp
, block
);
6049 /* Allocate dest to the same size as src, and copy src -> dest.
6050 If no_malloc is set, only the copy is done. */
6053 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
6063 /* If the source is null, set the destination to null. Then,
6064 allocate memory to the destination. */
6065 gfc_init_block (&block
);
6069 tmp
= null_pointer_node
;
6070 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
6071 gfc_add_expr_to_block (&block
, tmp
);
6072 null_data
= gfc_finish_block (&block
);
6074 gfc_init_block (&block
);
6075 size
= TYPE_SIZE_UNIT (type
);
6078 tmp
= gfc_call_malloc (&block
, type
, size
);
6079 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6080 dest
, fold_convert (type
, tmp
));
6081 gfc_add_expr_to_block (&block
, tmp
);
6084 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
6085 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
6090 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6091 null_data
= gfc_finish_block (&block
);
6093 gfc_init_block (&block
);
6094 nelems
= get_full_array_size (&block
, src
, rank
);
6095 tmp
= fold_convert (gfc_array_index_type
,
6096 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
6097 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6101 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
6102 tmp
= gfc_call_malloc (&block
, tmp
, size
);
6103 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
6106 /* We know the temporary and the value will be the same length,
6107 so can use memcpy. */
6108 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
6109 tmp
= build_call_expr_loc (input_location
,
6110 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
6111 gfc_conv_descriptor_data_get (src
), size
);
6114 gfc_add_expr_to_block (&block
, tmp
);
6115 tmp
= gfc_finish_block (&block
);
6117 /* Null the destination if the source is null; otherwise do
6118 the allocate and copy. */
6122 null_cond
= gfc_conv_descriptor_data_get (src
);
6124 null_cond
= convert (pvoid_type_node
, null_cond
);
6125 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6126 null_cond
, null_pointer_node
);
6127 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
6131 /* Allocate dest to the same size as src, and copy data src -> dest. */
6134 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
6136 return duplicate_allocatable (dest
, src
, type
, rank
, false);
6140 /* Copy data src -> dest. */
6143 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
6145 return duplicate_allocatable (dest
, src
, type
, rank
, true);
6149 /* Recursively traverse an object of derived type, generating code to
6150 deallocate, nullify or copy allocatable components. This is the work horse
6151 function for the functions named in this enum. */
6153 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
6154 COPY_ONLY_ALLOC_COMP
};
6157 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
6158 tree dest
, int rank
, int purpose
)
6162 stmtblock_t fnblock
;
6163 stmtblock_t loopbody
;
6174 tree null_cond
= NULL_TREE
;
6176 gfc_init_block (&fnblock
);
6178 decl_type
= TREE_TYPE (decl
);
6180 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
6181 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
6183 decl
= build_fold_indirect_ref_loc (input_location
,
6186 /* Just in case in gets dereferenced. */
6187 decl_type
= TREE_TYPE (decl
);
6189 /* If this an array of derived types with allocatable components
6190 build a loop and recursively call this function. */
6191 if (TREE_CODE (decl_type
) == ARRAY_TYPE
6192 || GFC_DESCRIPTOR_TYPE_P (decl_type
))
6194 tmp
= gfc_conv_array_data (decl
);
6195 var
= build_fold_indirect_ref_loc (input_location
,
6198 /* Get the number of elements - 1 and set the counter. */
6199 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
6201 /* Use the descriptor for an allocatable array. Since this
6202 is a full array reference, we only need the descriptor
6203 information from dimension = rank. */
6204 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
6205 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6206 gfc_array_index_type
, tmp
,
6207 gfc_index_one_node
);
6209 null_cond
= gfc_conv_descriptor_data_get (decl
);
6210 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
6211 boolean_type_node
, null_cond
,
6212 build_int_cst (TREE_TYPE (null_cond
), 0));
6216 /* Otherwise use the TYPE_DOMAIN information. */
6217 tmp
= array_type_nelts (decl_type
);
6218 tmp
= fold_convert (gfc_array_index_type
, tmp
);
6221 /* Remember that this is, in fact, the no. of elements - 1. */
6222 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
6223 index
= gfc_create_var (gfc_array_index_type
, "S");
6225 /* Build the body of the loop. */
6226 gfc_init_block (&loopbody
);
6228 vref
= gfc_build_array_ref (var
, index
, NULL
);
6230 if (purpose
== COPY_ALLOC_COMP
)
6232 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
6234 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
6235 gfc_add_expr_to_block (&fnblock
, tmp
);
6237 tmp
= build_fold_indirect_ref_loc (input_location
,
6238 gfc_conv_array_data (dest
));
6239 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
6240 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
6242 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
6244 tmp
= build_fold_indirect_ref_loc (input_location
,
6245 gfc_conv_array_data (dest
));
6246 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
6247 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
6251 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
6253 gfc_add_expr_to_block (&loopbody
, tmp
);
6255 /* Build the loop and return. */
6256 gfc_init_loopinfo (&loop
);
6258 loop
.from
[0] = gfc_index_zero_node
;
6259 loop
.loopvar
[0] = index
;
6260 loop
.to
[0] = nelems
;
6261 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
6262 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
6264 tmp
= gfc_finish_block (&fnblock
);
6265 if (null_cond
!= NULL_TREE
)
6266 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
6267 build_empty_stmt (input_location
));
6272 /* Otherwise, act on the components or recursively call self to
6273 act on a chain of components. */
6274 for (c
= der_type
->components
; c
; c
= c
->next
)
6276 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
6277 && c
->ts
.u
.derived
->attr
.alloc_comp
;
6278 cdecl = c
->backend_decl
;
6279 ctype
= TREE_TYPE (cdecl);
6283 case DEALLOCATE_ALLOC_COMP
:
6284 /* Do not deallocate the components of ultimate pointer
6286 if (cmp_has_alloc_comps
&& !c
->attr
.pointer
)
6288 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6289 decl
, cdecl, NULL_TREE
);
6290 rank
= c
->as
? c
->as
->rank
: 0;
6291 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6293 gfc_add_expr_to_block (&fnblock
, tmp
);
6296 if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6298 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6299 decl
, cdecl, NULL_TREE
);
6300 tmp
= gfc_trans_dealloc_allocated (comp
);
6301 gfc_add_expr_to_block (&fnblock
, tmp
);
6303 else if (c
->attr
.allocatable
)
6305 /* Allocatable scalar components. */
6306 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6307 decl
, cdecl, NULL_TREE
);
6309 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, true, NULL
);
6310 gfc_add_expr_to_block (&fnblock
, tmp
);
6312 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6313 void_type_node
, comp
,
6314 build_int_cst (TREE_TYPE (comp
), 0));
6315 gfc_add_expr_to_block (&fnblock
, tmp
);
6317 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
6319 /* Allocatable scalar CLASS components. */
6320 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6321 decl
, cdecl, NULL_TREE
);
6323 /* Add reference to '$data' component. */
6324 tmp
= CLASS_DATA (c
)->backend_decl
;
6325 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6326 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
6328 tmp
= gfc_deallocate_with_status (comp
, NULL_TREE
, true, NULL
);
6329 gfc_add_expr_to_block (&fnblock
, tmp
);
6331 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6332 void_type_node
, comp
,
6333 build_int_cst (TREE_TYPE (comp
), 0));
6334 gfc_add_expr_to_block (&fnblock
, tmp
);
6338 case NULLIFY_ALLOC_COMP
:
6339 if (c
->attr
.pointer
)
6341 else if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6343 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6344 decl
, cdecl, NULL_TREE
);
6345 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
6347 else if (c
->attr
.allocatable
)
6349 /* Allocatable scalar components. */
6350 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6351 decl
, cdecl, NULL_TREE
);
6352 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6353 void_type_node
, comp
,
6354 build_int_cst (TREE_TYPE (comp
), 0));
6355 gfc_add_expr_to_block (&fnblock
, tmp
);
6357 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
6359 /* Allocatable scalar CLASS components. */
6360 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6361 decl
, cdecl, NULL_TREE
);
6362 /* Add reference to '$data' component. */
6363 tmp
= CLASS_DATA (c
)->backend_decl
;
6364 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6365 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
6366 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6367 void_type_node
, comp
,
6368 build_int_cst (TREE_TYPE (comp
), 0));
6369 gfc_add_expr_to_block (&fnblock
, tmp
);
6371 else if (cmp_has_alloc_comps
)
6373 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6374 decl
, cdecl, NULL_TREE
);
6375 rank
= c
->as
? c
->as
->rank
: 0;
6376 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6378 gfc_add_expr_to_block (&fnblock
, tmp
);
6382 case COPY_ALLOC_COMP
:
6383 if (c
->attr
.pointer
)
6386 /* We need source and destination components. */
6387 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
6389 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
6391 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
6393 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
6395 rank
= c
->as
? c
->as
->rank
: 0;
6396 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
6397 gfc_add_expr_to_block (&fnblock
, tmp
);
6400 if (cmp_has_alloc_comps
)
6402 rank
= c
->as
? c
->as
->rank
: 0;
6403 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
6404 gfc_add_modify (&fnblock
, dcmp
, tmp
);
6405 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
6407 gfc_add_expr_to_block (&fnblock
, tmp
);
6417 return gfc_finish_block (&fnblock
);
6420 /* Recursively traverse an object of derived type, generating code to
6421 nullify allocatable components. */
6424 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6426 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6427 NULLIFY_ALLOC_COMP
);
6431 /* Recursively traverse an object of derived type, generating code to
6432 deallocate allocatable components. */
6435 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6437 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6438 DEALLOCATE_ALLOC_COMP
);
6442 /* Recursively traverse an object of derived type, generating code to
6443 copy it and its allocatable components. */
6446 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6448 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
6452 /* Recursively traverse an object of derived type, generating code to
6453 copy only its allocatable components. */
6456 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6458 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
6462 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6463 Do likewise, recursively if necessary, with the allocatable components of
6467 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6473 stmtblock_t cleanup
;
6476 bool sym_has_alloc_comp
;
6478 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
6479 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
6481 /* Make sure the frontend gets these right. */
6482 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
6483 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6484 "allocatable attribute or derived type without allocatable "
6487 gfc_init_block (&init
);
6489 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
6490 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
6492 if (sym
->ts
.type
== BT_CHARACTER
6493 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6495 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6496 gfc_trans_vla_type_sizes (sym
, &init
);
6499 /* Dummy, use associated and result variables don't need anything special. */
6500 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
6502 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6506 gfc_save_backend_locus (&loc
);
6507 gfc_set_backend_locus (&sym
->declared_at
);
6508 descriptor
= sym
->backend_decl
;
6510 /* Although static, derived types with default initializers and
6511 allocatable components must not be nulled wholesale; instead they
6512 are treated component by component. */
6513 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
6515 /* SAVEd variables are not freed on exit. */
6516 gfc_trans_static_array_pointer (sym
);
6518 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6519 gfc_restore_backend_locus (&loc
);
6523 /* Get the descriptor type. */
6524 type
= TREE_TYPE (sym
->backend_decl
);
6526 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6529 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
6531 if (sym
->value
== NULL
6532 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
6534 rank
= sym
->as
? sym
->as
->rank
: 0;
6535 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
6537 gfc_add_expr_to_block (&init
, tmp
);
6540 gfc_init_default_dt (sym
, &init
, false);
6543 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
6545 /* If the backend_decl is not a descriptor, we must have a pointer
6547 descriptor
= build_fold_indirect_ref_loc (input_location
,
6549 type
= TREE_TYPE (descriptor
);
6552 /* NULLIFY the data pointer. */
6553 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
6554 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
6556 gfc_init_block (&cleanup
);
6557 gfc_restore_backend_locus (&loc
);
6559 /* Allocatable arrays need to be freed when they go out of scope.
6560 The allocatable components of pointers must not be touched. */
6561 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
6562 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
6565 rank
= sym
->as
? sym
->as
->rank
: 0;
6566 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
6567 gfc_add_expr_to_block (&cleanup
, tmp
);
6570 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
6571 && !sym
->attr
.save
&& !sym
->attr
.result
)
6573 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
6574 gfc_add_expr_to_block (&cleanup
, tmp
);
6577 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
6578 gfc_finish_block (&cleanup
));
6581 /************ Expression Walking Functions ******************/
6583 /* Walk a variable reference.
6585 Possible extension - multiple component subscripts.
6586 x(:,:) = foo%a(:)%b(:)
6588 forall (i=..., j=...)
6589 x(i,j) = foo%a(j)%b(i)
6591 This adds a fair amount of complexity because you need to deal with more
6592 than one ref. Maybe handle in a similar manner to vector subscripts.
6593 Maybe not worth the effort. */
6597 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6604 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6605 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
6608 for (; ref
; ref
= ref
->next
)
6610 if (ref
->type
== REF_SUBSTRING
)
6612 newss
= gfc_get_ss ();
6613 newss
->type
= GFC_SS_SCALAR
;
6614 newss
->expr
= ref
->u
.ss
.start
;
6618 newss
= gfc_get_ss ();
6619 newss
->type
= GFC_SS_SCALAR
;
6620 newss
->expr
= ref
->u
.ss
.end
;
6625 /* We're only interested in array sections from now on. */
6626 if (ref
->type
!= REF_ARRAY
)
6631 if (ar
->as
->rank
== 0)
6633 /* Scalar coarray. */
6640 for (n
= 0; n
< ar
->dimen
; n
++)
6642 newss
= gfc_get_ss ();
6643 newss
->type
= GFC_SS_SCALAR
;
6644 newss
->expr
= ar
->start
[n
];
6651 newss
= gfc_get_ss ();
6652 newss
->type
= GFC_SS_SECTION
;
6655 newss
->data
.info
.dimen
= ar
->as
->rank
;
6656 newss
->data
.info
.ref
= ref
;
6658 /* Make sure array is the same as array(:,:), this way
6659 we don't need to special case all the time. */
6660 ar
->dimen
= ar
->as
->rank
;
6661 for (n
= 0; n
< ar
->dimen
; n
++)
6663 newss
->data
.info
.dim
[n
] = n
;
6664 ar
->dimen_type
[n
] = DIMEN_RANGE
;
6666 gcc_assert (ar
->start
[n
] == NULL
);
6667 gcc_assert (ar
->end
[n
] == NULL
);
6668 gcc_assert (ar
->stride
[n
] == NULL
);
6674 newss
= gfc_get_ss ();
6675 newss
->type
= GFC_SS_SECTION
;
6678 newss
->data
.info
.dimen
= 0;
6679 newss
->data
.info
.ref
= ref
;
6681 /* We add SS chains for all the subscripts in the section. */
6682 for (n
= 0; n
< ar
->dimen
; n
++)
6686 switch (ar
->dimen_type
[n
])
6689 /* Add SS for elemental (scalar) subscripts. */
6690 gcc_assert (ar
->start
[n
]);
6691 indexss
= gfc_get_ss ();
6692 indexss
->type
= GFC_SS_SCALAR
;
6693 indexss
->expr
= ar
->start
[n
];
6694 indexss
->next
= gfc_ss_terminator
;
6695 indexss
->loop_chain
= gfc_ss_terminator
;
6696 newss
->data
.info
.subscript
[n
] = indexss
;
6700 /* We don't add anything for sections, just remember this
6701 dimension for later. */
6702 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
6703 newss
->data
.info
.dimen
++;
6707 /* Create a GFC_SS_VECTOR index in which we can store
6708 the vector's descriptor. */
6709 indexss
= gfc_get_ss ();
6710 indexss
->type
= GFC_SS_VECTOR
;
6711 indexss
->expr
= ar
->start
[n
];
6712 indexss
->next
= gfc_ss_terminator
;
6713 indexss
->loop_chain
= gfc_ss_terminator
;
6714 newss
->data
.info
.subscript
[n
] = indexss
;
6715 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
6716 newss
->data
.info
.dimen
++;
6720 /* We should know what sort of section it is by now. */
6724 /* We should have at least one non-elemental dimension. */
6725 gcc_assert (newss
->data
.info
.dimen
> 0);
6730 /* We should know what sort of section it is by now. */
6739 /* Walk an expression operator. If only one operand of a binary expression is
6740 scalar, we must also add the scalar term to the SS chain. */
6743 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6749 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
6750 if (expr
->value
.op
.op2
== NULL
)
6753 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
6755 /* All operands are scalar. Pass back and let the caller deal with it. */
6759 /* All operands require scalarization. */
6760 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
6763 /* One of the operands needs scalarization, the other is scalar.
6764 Create a gfc_ss for the scalar expression. */
6765 newss
= gfc_get_ss ();
6766 newss
->type
= GFC_SS_SCALAR
;
6769 /* First operand is scalar. We build the chain in reverse order, so
6770 add the scalar SS after the second operand. */
6772 while (head
&& head
->next
!= ss
)
6774 /* Check we haven't somehow broken the chain. */
6778 newss
->expr
= expr
->value
.op
.op1
;
6780 else /* head2 == head */
6782 gcc_assert (head2
== head
);
6783 /* Second operand is scalar. */
6784 newss
->next
= head2
;
6786 newss
->expr
= expr
->value
.op
.op2
;
6793 /* Reverse a SS chain. */
6796 gfc_reverse_ss (gfc_ss
* ss
)
6801 gcc_assert (ss
!= NULL
);
6803 head
= gfc_ss_terminator
;
6804 while (ss
!= gfc_ss_terminator
)
6807 /* Check we didn't somehow break the chain. */
6808 gcc_assert (next
!= NULL
);
6818 /* Walk the arguments of an elemental function. */
6821 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
6829 head
= gfc_ss_terminator
;
6832 for (; arg
; arg
= arg
->next
)
6837 newss
= gfc_walk_subexpr (head
, arg
->expr
);
6840 /* Scalar argument. */
6841 newss
= gfc_get_ss ();
6843 newss
->expr
= arg
->expr
;
6853 while (tail
->next
!= gfc_ss_terminator
)
6860 /* If all the arguments are scalar we don't need the argument SS. */
6861 gfc_free_ss_chain (head
);
6866 /* Add it onto the existing chain. */
6872 /* Walk a function call. Scalar functions are passed back, and taken out of
6873 scalarization loops. For elemental functions we walk their arguments.
6874 The result of functions returning arrays is stored in a temporary outside
6875 the loop, so that the function is only called once. Hence we do not need
6876 to walk their arguments. */
6879 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
6882 gfc_intrinsic_sym
*isym
;
6884 gfc_component
*comp
= NULL
;
6887 isym
= expr
->value
.function
.isym
;
6889 /* Handle intrinsic functions separately. */
6891 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
6893 sym
= expr
->value
.function
.esym
;
6895 sym
= expr
->symtree
->n
.sym
;
6897 /* A function that returns arrays. */
6898 gfc_is_proc_ptr_comp (expr
, &comp
);
6899 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
6900 || (comp
&& comp
->attr
.dimension
))
6902 newss
= gfc_get_ss ();
6903 newss
->type
= GFC_SS_FUNCTION
;
6906 newss
->data
.info
.dimen
= expr
->rank
;
6907 for (n
= 0; n
< newss
->data
.info
.dimen
; n
++)
6908 newss
->data
.info
.dim
[n
] = n
;
6912 /* Walk the parameters of an elemental function. For now we always pass
6914 if (sym
->attr
.elemental
)
6915 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
6918 /* Scalar functions are OK as these are evaluated outside the scalarization
6919 loop. Pass back and let the caller deal with it. */
6924 /* An array temporary is constructed for array constructors. */
6927 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
6932 newss
= gfc_get_ss ();
6933 newss
->type
= GFC_SS_CONSTRUCTOR
;
6936 newss
->data
.info
.dimen
= expr
->rank
;
6937 for (n
= 0; n
< expr
->rank
; n
++)
6938 newss
->data
.info
.dim
[n
] = n
;
6944 /* Walk an expression. Add walked expressions to the head of the SS chain.
6945 A wholly scalar expression will not be added. */
6948 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
6952 switch (expr
->expr_type
)
6955 head
= gfc_walk_variable_expr (ss
, expr
);
6959 head
= gfc_walk_op_expr (ss
, expr
);
6963 head
= gfc_walk_function_expr (ss
, expr
);
6968 case EXPR_STRUCTURE
:
6969 /* Pass back and let the caller deal with it. */
6973 head
= gfc_walk_array_constructor (ss
, expr
);
6976 case EXPR_SUBSTRING
:
6977 /* Pass back and let the caller deal with it. */
6981 internal_error ("bad expression type during walk (%d)",
6988 /* Entry point for expression walking.
6989 A return value equal to the passed chain means this is
6990 a scalar expression. It is up to the caller to take whatever action is
6991 necessary to translate these. */
6994 gfc_walk_expr (gfc_expr
* expr
)
6998 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
6999 return gfc_reverse_ss (res
);