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
;
1842 bool old_first_len
, old_typespec_chararray_ctor
;
1843 tree old_first_len_val
;
1845 /* Save the old values for nested checking. */
1846 old_first_len
= first_len
;
1847 old_first_len_val
= first_len_val
;
1848 old_typespec_chararray_ctor
= typespec_chararray_ctor
;
1850 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1851 typespec was given for the array constructor. */
1852 typespec_chararray_ctor
= (ss
->expr
->ts
.u
.cl
1853 && ss
->expr
->ts
.u
.cl
->length_from_typespec
);
1855 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1856 && ss
->expr
->ts
.type
== BT_CHARACTER
&& !typespec_chararray_ctor
)
1858 first_len_val
= gfc_create_var (gfc_charlen_type_node
, "len");
1862 ss
->data
.info
.dimen
= loop
->dimen
;
1864 c
= ss
->expr
->value
.constructor
;
1865 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1869 /* get_array_ctor_strlen walks the elements of the constructor, if a
1870 typespec was given, we already know the string length and want the one
1872 if (typespec_chararray_ctor
&& ss
->expr
->ts
.u
.cl
->length
1873 && ss
->expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1877 const_string
= false;
1878 gfc_init_se (&length_se
, NULL
);
1879 gfc_conv_expr_type (&length_se
, ss
->expr
->ts
.u
.cl
->length
,
1880 gfc_charlen_type_node
);
1881 ss
->string_length
= length_se
.expr
;
1882 gfc_add_block_to_block (&loop
->pre
, &length_se
.pre
);
1883 gfc_add_block_to_block (&loop
->post
, &length_se
.post
);
1886 const_string
= get_array_ctor_strlen (&loop
->pre
, c
,
1887 &ss
->string_length
);
1889 /* Complex character array constructors should have been taken care of
1890 and not end up here. */
1891 gcc_assert (ss
->string_length
);
1893 ss
->expr
->ts
.u
.cl
->backend_decl
= ss
->string_length
;
1895 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1897 type
= build_pointer_type (type
);
1900 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1902 /* See if the constructor determines the loop bounds. */
1905 if (ss
->expr
->shape
&& loop
->dimen
> 1 && loop
->to
[0] == NULL_TREE
)
1907 /* We have a multidimensional parameter. */
1909 for (n
= 0; n
< ss
->expr
->rank
; n
++)
1911 loop
->from
[n
] = gfc_index_zero_node
;
1912 loop
->to
[n
] = gfc_conv_mpz_to_tree (ss
->expr
->shape
[n
],
1913 gfc_index_integer_kind
);
1914 loop
->to
[n
] = fold_build2_loc (input_location
, MINUS_EXPR
,
1915 gfc_array_index_type
,
1916 loop
->to
[n
], gfc_index_one_node
);
1920 if (loop
->to
[0] == NULL_TREE
)
1924 /* We should have a 1-dimensional, zero-based loop. */
1925 gcc_assert (loop
->dimen
== 1);
1926 gcc_assert (integer_zerop (loop
->from
[0]));
1928 /* Split the constructor size into a static part and a dynamic part.
1929 Allocate the static size up-front and record whether the dynamic
1930 size might be nonzero. */
1932 dynamic
= gfc_get_array_constructor_size (&size
, c
);
1933 mpz_sub_ui (size
, size
, 1);
1934 loop
->to
[0] = gfc_conv_mpz_to_tree (size
, gfc_index_integer_kind
);
1938 /* Special case constant array constructors. */
1941 unsigned HOST_WIDE_INT nelem
= gfc_constant_array_constructor_p (c
);
1944 tree size
= constant_array_constructor_loop_size (loop
);
1945 if (size
&& compare_tree_int (size
, nelem
) == 0)
1947 gfc_trans_constant_array_constructor (loop
, ss
, type
);
1953 if (TREE_CODE (loop
->to
[0]) == VAR_DECL
)
1956 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
, &ss
->data
.info
,
1957 type
, NULL_TREE
, dynamic
, true, false, where
);
1959 desc
= ss
->data
.info
.descriptor
;
1960 offset
= gfc_index_zero_node
;
1961 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1962 TREE_NO_WARNING (offsetvar
) = 1;
1963 TREE_USED (offsetvar
) = 0;
1964 gfc_trans_array_constructor_value (&loop
->pre
, type
, desc
, c
,
1965 &offset
, &offsetvar
, dynamic
);
1967 /* If the array grows dynamically, the upper bound of the loop variable
1968 is determined by the array's final upper bound. */
1971 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1972 gfc_array_index_type
,
1973 offsetvar
, gfc_index_one_node
);
1974 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
1975 gfc_conv_descriptor_ubound_set (&loop
->pre
, desc
, gfc_rank_cst
[0], tmp
);
1976 if (loop
->to
[0] && TREE_CODE (loop
->to
[0]) == VAR_DECL
)
1977 gfc_add_modify (&loop
->pre
, loop
->to
[0], tmp
);
1982 if (TREE_USED (offsetvar
))
1983 pushdecl (offsetvar
);
1985 gcc_assert (INTEGER_CST_P (offset
));
1988 /* Disable bound checking for now because it's probably broken. */
1989 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1996 /* Restore old values of globals. */
1997 first_len
= old_first_len
;
1998 first_len_val
= old_first_len_val
;
1999 typespec_chararray_ctor
= old_typespec_chararray_ctor
;
2003 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2004 called after evaluating all of INFO's vector dimensions. Go through
2005 each such vector dimension and see if we can now fill in any missing
2009 gfc_set_vector_loop_bounds (gfc_loopinfo
* loop
, gfc_ss_info
* info
)
2018 for (n
= 0; n
< loop
->dimen
; n
++)
2021 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
2022 && loop
->to
[n
] == NULL
)
2024 /* Loop variable N indexes vector dimension DIM, and we don't
2025 yet know the upper bound of loop variable N. Set it to the
2026 difference between the vector's upper and lower bounds. */
2027 gcc_assert (loop
->from
[n
] == gfc_index_zero_node
);
2028 gcc_assert (info
->subscript
[dim
]
2029 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2031 gfc_init_se (&se
, NULL
);
2032 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2033 zero
= gfc_rank_cst
[0];
2034 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2035 gfc_array_index_type
,
2036 gfc_conv_descriptor_ubound_get (desc
, zero
),
2037 gfc_conv_descriptor_lbound_get (desc
, zero
));
2038 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
2045 /* Add the pre and post chains for all the scalar expressions in a SS chain
2046 to loop. This is called after the loop parameters have been calculated,
2047 but before the actual scalarizing loops. */
2050 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
,
2056 /* TODO: This can generate bad code if there are ordering dependencies,
2057 e.g., a callee allocated function and an unknown size constructor. */
2058 gcc_assert (ss
!= NULL
);
2060 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2067 /* Scalar expression. Evaluate this now. This includes elemental
2068 dimension indices, but not array section bounds. */
2069 gfc_init_se (&se
, NULL
);
2070 gfc_conv_expr (&se
, ss
->expr
);
2071 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2073 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
2075 /* Move the evaluation of scalar expressions outside the
2076 scalarization loop, except for WHERE assignments. */
2078 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
2080 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2081 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
2084 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2086 ss
->data
.scalar
.expr
= se
.expr
;
2087 ss
->string_length
= se
.string_length
;
2090 case GFC_SS_REFERENCE
:
2091 /* Scalar argument to elemental procedure. Evaluate this
2093 gfc_init_se (&se
, NULL
);
2094 gfc_conv_expr (&se
, ss
->expr
);
2095 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2096 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2098 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
2099 ss
->string_length
= se
.string_length
;
2102 case GFC_SS_SECTION
:
2103 /* Add the expressions for scalar and vector subscripts. */
2104 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2105 if (ss
->data
.info
.subscript
[n
])
2106 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true,
2109 gfc_set_vector_loop_bounds (loop
, &ss
->data
.info
);
2113 /* Get the vector's descriptor and store it in SS. */
2114 gfc_init_se (&se
, NULL
);
2115 gfc_conv_expr_descriptor (&se
, ss
->expr
, gfc_walk_expr (ss
->expr
));
2116 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2117 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2118 ss
->data
.info
.descriptor
= se
.expr
;
2121 case GFC_SS_INTRINSIC
:
2122 gfc_add_intrinsic_ss_code (loop
, ss
);
2125 case GFC_SS_FUNCTION
:
2126 /* Array function return value. We call the function and save its
2127 result in a temporary for use inside the loop. */
2128 gfc_init_se (&se
, NULL
);
2131 gfc_conv_expr (&se
, ss
->expr
);
2132 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2133 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2134 ss
->string_length
= se
.string_length
;
2137 case GFC_SS_CONSTRUCTOR
:
2138 if (ss
->expr
->ts
.type
== BT_CHARACTER
2139 && ss
->string_length
== NULL
2140 && ss
->expr
->ts
.u
.cl
2141 && ss
->expr
->ts
.u
.cl
->length
)
2143 gfc_init_se (&se
, NULL
);
2144 gfc_conv_expr_type (&se
, ss
->expr
->ts
.u
.cl
->length
,
2145 gfc_charlen_type_node
);
2146 ss
->string_length
= se
.expr
;
2147 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2148 gfc_add_block_to_block (&loop
->post
, &se
.post
);
2150 gfc_trans_array_constructor (loop
, ss
, where
);
2154 case GFC_SS_COMPONENT
:
2155 /* Do nothing. These are handled elsewhere. */
2165 /* Translate expressions for the descriptor and data pointer of a SS. */
2169 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
2174 /* Get the descriptor for the array to be scalarized. */
2175 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
2176 gfc_init_se (&se
, NULL
);
2177 se
.descriptor_only
= 1;
2178 gfc_conv_expr_lhs (&se
, ss
->expr
);
2179 gfc_add_block_to_block (block
, &se
.pre
);
2180 ss
->data
.info
.descriptor
= se
.expr
;
2181 ss
->string_length
= se
.string_length
;
2185 /* Also the data pointer. */
2186 tmp
= gfc_conv_array_data (se
.expr
);
2187 /* If this is a variable or address of a variable we use it directly.
2188 Otherwise we must evaluate it now to avoid breaking dependency
2189 analysis by pulling the expressions for elemental array indices
2192 || (TREE_CODE (tmp
) == ADDR_EXPR
2193 && DECL_P (TREE_OPERAND (tmp
, 0)))))
2194 tmp
= gfc_evaluate_now (tmp
, block
);
2195 ss
->data
.info
.data
= tmp
;
2197 tmp
= gfc_conv_array_offset (se
.expr
);
2198 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
2200 /* Make absolutely sure that the saved_offset is indeed saved
2201 so that the variable is still accessible after the loops
2203 ss
->data
.info
.saved_offset
= ss
->data
.info
.offset
;
2208 /* Initialize a gfc_loopinfo structure. */
2211 gfc_init_loopinfo (gfc_loopinfo
* loop
)
2215 memset (loop
, 0, sizeof (gfc_loopinfo
));
2216 gfc_init_block (&loop
->pre
);
2217 gfc_init_block (&loop
->post
);
2219 /* Initially scalarize in order and default to no loop reversal. */
2220 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
2223 loop
->reverse
[n
] = GFC_CANNOT_REVERSE
;
2226 loop
->ss
= gfc_ss_terminator
;
2230 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2234 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
2240 /* Return an expression for the data pointer of an array. */
2243 gfc_conv_array_data (tree descriptor
)
2247 type
= TREE_TYPE (descriptor
);
2248 if (GFC_ARRAY_TYPE_P (type
))
2250 if (TREE_CODE (type
) == POINTER_TYPE
)
2254 /* Descriptorless arrays. */
2255 return gfc_build_addr_expr (NULL_TREE
, descriptor
);
2259 return gfc_conv_descriptor_data_get (descriptor
);
2263 /* Return an expression for the base offset of an array. */
2266 gfc_conv_array_offset (tree descriptor
)
2270 type
= TREE_TYPE (descriptor
);
2271 if (GFC_ARRAY_TYPE_P (type
))
2272 return GFC_TYPE_ARRAY_OFFSET (type
);
2274 return gfc_conv_descriptor_offset_get (descriptor
);
2278 /* Get an expression for the array stride. */
2281 gfc_conv_array_stride (tree descriptor
, int dim
)
2286 type
= TREE_TYPE (descriptor
);
2288 /* For descriptorless arrays use the array size. */
2289 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
2290 if (tmp
!= NULL_TREE
)
2293 tmp
= gfc_conv_descriptor_stride_get (descriptor
, gfc_rank_cst
[dim
]);
2298 /* Like gfc_conv_array_stride, but for the lower bound. */
2301 gfc_conv_array_lbound (tree descriptor
, int dim
)
2306 type
= TREE_TYPE (descriptor
);
2308 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2309 if (tmp
!= NULL_TREE
)
2312 tmp
= gfc_conv_descriptor_lbound_get (descriptor
, gfc_rank_cst
[dim
]);
2317 /* Like gfc_conv_array_stride, but for the upper bound. */
2320 gfc_conv_array_ubound (tree descriptor
, int dim
)
2325 type
= TREE_TYPE (descriptor
);
2327 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2328 if (tmp
!= NULL_TREE
)
2331 /* This should only ever happen when passing an assumed shape array
2332 as an actual parameter. The value will never be used. */
2333 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
2334 return gfc_index_zero_node
;
2336 tmp
= gfc_conv_descriptor_ubound_get (descriptor
, gfc_rank_cst
[dim
]);
2341 /* Generate code to perform an array index bound check. */
2344 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
,
2345 locus
* where
, bool check_upper
)
2348 tree tmp_lo
, tmp_up
;
2350 const char * name
= NULL
;
2352 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
2355 index
= gfc_evaluate_now (index
, &se
->pre
);
2357 /* We find a name for the error message. */
2359 name
= se
->ss
->expr
->symtree
->name
;
2361 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
2362 && se
->loop
->ss
->expr
->symtree
)
2363 name
= se
->loop
->ss
->expr
->symtree
->name
;
2365 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->loop_chain
2366 && se
->loop
->ss
->loop_chain
->expr
2367 && se
->loop
->ss
->loop_chain
->expr
->symtree
)
2368 name
= se
->loop
->ss
->loop_chain
->expr
->symtree
->name
;
2370 if (!name
&& se
->loop
&& se
->loop
->ss
&& se
->loop
->ss
->expr
)
2372 if (se
->loop
->ss
->expr
->expr_type
== EXPR_FUNCTION
2373 && se
->loop
->ss
->expr
->value
.function
.name
)
2374 name
= se
->loop
->ss
->expr
->value
.function
.name
;
2376 if (se
->loop
->ss
->type
== GFC_SS_CONSTRUCTOR
2377 || se
->loop
->ss
->type
== GFC_SS_SCALAR
)
2378 name
= "unnamed constant";
2381 if (TREE_CODE (descriptor
) == VAR_DECL
)
2382 name
= IDENTIFIER_POINTER (DECL_NAME (descriptor
));
2384 /* If upper bound is present, include both bounds in the error message. */
2387 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2388 tmp_up
= gfc_conv_array_ubound (descriptor
, n
);
2391 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2392 "outside of expected range (%%ld:%%ld)", n
+1, name
);
2394 asprintf (&msg
, "Index '%%ld' of dimension %d "
2395 "outside of expected range (%%ld:%%ld)", n
+1);
2397 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2399 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2400 fold_convert (long_integer_type_node
, index
),
2401 fold_convert (long_integer_type_node
, tmp_lo
),
2402 fold_convert (long_integer_type_node
, tmp_up
));
2403 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2405 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2406 fold_convert (long_integer_type_node
, index
),
2407 fold_convert (long_integer_type_node
, tmp_lo
),
2408 fold_convert (long_integer_type_node
, tmp_up
));
2413 tmp_lo
= gfc_conv_array_lbound (descriptor
, n
);
2416 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2417 "below lower bound of %%ld", n
+1, name
);
2419 asprintf (&msg
, "Index '%%ld' of dimension %d "
2420 "below lower bound of %%ld", n
+1);
2422 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2424 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2425 fold_convert (long_integer_type_node
, index
),
2426 fold_convert (long_integer_type_node
, tmp_lo
));
2434 /* Return the offset for an index. Performs bound checking for elemental
2435 dimensions. Single element references are processed separately.
2436 DIM is the array dimension, I is the loop dimension. */
2439 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
2440 gfc_array_ref
* ar
, tree stride
)
2446 /* Get the index into the array for this dimension. */
2449 gcc_assert (ar
->type
!= AR_ELEMENT
);
2450 switch (ar
->dimen_type
[dim
])
2453 /* Elemental dimension. */
2454 gcc_assert (info
->subscript
[dim
]
2455 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
2456 /* We've already translated this value outside the loop. */
2457 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
2459 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2460 index
, dim
, &ar
->where
,
2461 ar
->as
->type
!= AS_ASSUMED_SIZE
2462 || dim
< ar
->dimen
- 1);
2466 gcc_assert (info
&& se
->loop
);
2467 gcc_assert (info
->subscript
[dim
]
2468 && info
->subscript
[dim
]->type
== GFC_SS_VECTOR
);
2469 desc
= info
->subscript
[dim
]->data
.info
.descriptor
;
2471 /* Get a zero-based index into the vector. */
2472 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2473 gfc_array_index_type
,
2474 se
->loop
->loopvar
[i
], se
->loop
->from
[i
]);
2476 /* Multiply the index by the stride. */
2477 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2478 gfc_array_index_type
,
2479 index
, gfc_conv_array_stride (desc
, 0));
2481 /* Read the vector to get an index into info->descriptor. */
2482 data
= build_fold_indirect_ref_loc (input_location
,
2483 gfc_conv_array_data (desc
));
2484 index
= gfc_build_array_ref (data
, index
, NULL
);
2485 index
= gfc_evaluate_now (index
, &se
->pre
);
2486 index
= fold_convert (gfc_array_index_type
, index
);
2488 /* Do any bounds checking on the final info->descriptor index. */
2489 index
= gfc_trans_array_bound_check (se
, info
->descriptor
,
2490 index
, dim
, &ar
->where
,
2491 ar
->as
->type
!= AS_ASSUMED_SIZE
2492 || dim
< ar
->dimen
- 1);
2496 /* Scalarized dimension. */
2497 gcc_assert (info
&& se
->loop
);
2499 /* Multiply the loop variable by the stride and delta. */
2500 index
= se
->loop
->loopvar
[i
];
2501 if (!integer_onep (info
->stride
[dim
]))
2502 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2503 gfc_array_index_type
, index
,
2505 if (!integer_zerop (info
->delta
[dim
]))
2506 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2507 gfc_array_index_type
, index
,
2517 /* Temporary array or derived type component. */
2518 gcc_assert (se
->loop
);
2519 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
2520 if (!integer_zerop (info
->delta
[dim
]))
2521 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2522 gfc_array_index_type
, index
, info
->delta
[dim
]);
2525 /* Multiply by the stride. */
2526 if (!integer_onep (stride
))
2527 index
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2534 /* Build a scalarized reference to an array. */
2537 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
2540 tree decl
= NULL_TREE
;
2545 info
= &se
->ss
->data
.info
;
2547 n
= se
->loop
->order
[0];
2551 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
2553 /* Add the offset for this dimension to the stored offset for all other
2555 if (!integer_zerop (info
->offset
))
2556 index
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2557 index
, info
->offset
);
2559 if (se
->ss
->expr
&& is_subref_array (se
->ss
->expr
))
2560 decl
= se
->ss
->expr
->symtree
->n
.sym
->backend_decl
;
2562 tmp
= build_fold_indirect_ref_loc (input_location
,
2564 se
->expr
= gfc_build_array_ref (tmp
, index
, decl
);
2568 /* Translate access of temporary array. */
2571 gfc_conv_tmp_array_ref (gfc_se
* se
)
2573 se
->string_length
= se
->ss
->string_length
;
2574 gfc_conv_scalarized_array_ref (se
, NULL
);
2575 gfc_advance_se_ss_chain (se
);
2579 /* Build an array reference. se->expr already holds the array descriptor.
2580 This should be either a variable, indirect variable reference or component
2581 reference. For arrays which do not have a descriptor, se->expr will be
2583 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2586 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
, gfc_symbol
* sym
,
2599 /* Handle scalarized references separately. */
2600 if (ar
->type
!= AR_ELEMENT
)
2602 gfc_conv_scalarized_array_ref (se
, ar
);
2603 gfc_advance_se_ss_chain (se
);
2607 index
= gfc_index_zero_node
;
2609 /* Calculate the offsets from all the dimensions. */
2610 for (n
= 0; n
< ar
->dimen
; n
++)
2612 /* Calculate the index for this dimension. */
2613 gfc_init_se (&indexse
, se
);
2614 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
2615 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
2617 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2619 /* Check array bounds. */
2623 /* Evaluate the indexse.expr only once. */
2624 indexse
.expr
= save_expr (indexse
.expr
);
2627 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
2628 if (sym
->attr
.temporary
)
2630 gfc_init_se (&tmpse
, se
);
2631 gfc_conv_expr_type (&tmpse
, ar
->as
->lower
[n
],
2632 gfc_array_index_type
);
2633 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2637 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2639 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2640 "below lower bound of %%ld", n
+1, sym
->name
);
2641 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2642 fold_convert (long_integer_type_node
,
2644 fold_convert (long_integer_type_node
, tmp
));
2647 /* Upper bound, but not for the last dimension of assumed-size
2649 if (n
< ar
->dimen
- 1 || ar
->as
->type
!= AS_ASSUMED_SIZE
)
2651 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
2652 if (sym
->attr
.temporary
)
2654 gfc_init_se (&tmpse
, se
);
2655 gfc_conv_expr_type (&tmpse
, ar
->as
->upper
[n
],
2656 gfc_array_index_type
);
2657 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
2661 cond
= fold_build2_loc (input_location
, GT_EXPR
,
2662 boolean_type_node
, indexse
.expr
, tmp
);
2663 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
2664 "above upper bound of %%ld", n
+1, sym
->name
);
2665 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, where
, msg
,
2666 fold_convert (long_integer_type_node
,
2668 fold_convert (long_integer_type_node
, tmp
));
2673 /* Multiply the index by the stride. */
2674 stride
= gfc_conv_array_stride (se
->expr
, n
);
2675 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2676 indexse
.expr
, stride
);
2678 /* And add it to the total. */
2679 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2680 gfc_array_index_type
, index
, tmp
);
2683 tmp
= gfc_conv_array_offset (se
->expr
);
2684 if (!integer_zerop (tmp
))
2685 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2686 gfc_array_index_type
, index
, tmp
);
2688 /* Access the calculated element. */
2689 tmp
= gfc_conv_array_data (se
->expr
);
2690 tmp
= build_fold_indirect_ref (tmp
);
2691 se
->expr
= gfc_build_array_ref (tmp
, index
, sym
->backend_decl
);
2695 /* Generate the code to be executed immediately before entering a
2696 scalarization loop. */
2699 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
2700 stmtblock_t
* pblock
)
2709 /* This code will be executed before entering the scalarization loop
2710 for this dimension. */
2711 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2713 if ((ss
->useflags
& flag
) == 0)
2716 if (ss
->type
!= GFC_SS_SECTION
2717 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
2718 && ss
->type
!= GFC_SS_COMPONENT
)
2721 info
= &ss
->data
.info
;
2723 if (dim
>= info
->dimen
)
2726 if (dim
== info
->dimen
- 1)
2728 /* For the outermost loop calculate the offset due to any
2729 elemental dimensions. It will have been initialized with the
2730 base offset of the array. */
2733 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
2735 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2738 gfc_init_se (&se
, NULL
);
2740 se
.expr
= info
->descriptor
;
2741 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
2742 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
2745 gfc_add_block_to_block (pblock
, &se
.pre
);
2747 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2748 gfc_array_index_type
,
2749 info
->offset
, index
);
2750 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2755 /* For the time being, the innermost loop is unconditionally on
2756 the first dimension of the scalarization loop. */
2757 gcc_assert (i
== 0);
2758 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2760 /* Calculate the stride of the innermost loop. Hopefully this will
2761 allow the backend optimizers to do their stuff more effectively.
2763 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
2767 /* Add the offset for the previous loop dimension. */
2772 ar
= &info
->ref
->u
.ar
;
2773 i
= loop
->order
[dim
+ 1];
2781 gfc_init_se (&se
, NULL
);
2783 se
.expr
= info
->descriptor
;
2784 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
2785 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
2787 gfc_add_block_to_block (pblock
, &se
.pre
);
2788 info
->offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
2789 gfc_array_index_type
, info
->offset
,
2791 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
2794 /* Remember this offset for the second loop. */
2795 if (dim
== loop
->temp_dim
- 1)
2796 info
->saved_offset
= info
->offset
;
2801 /* Start a scalarized expression. Creates a scope and declares loop
2805 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
2811 gcc_assert (!loop
->array_parameter
);
2813 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
2815 n
= loop
->order
[dim
];
2817 gfc_start_block (&loop
->code
[n
]);
2819 /* Create the loop variable. */
2820 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
2822 if (dim
< loop
->temp_dim
)
2826 /* Calculate values that will be constant within this loop. */
2827 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
2829 gfc_start_block (pbody
);
2833 /* Generates the actual loop code for a scalarization loop. */
2836 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
2837 stmtblock_t
* pbody
)
2848 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
))
2849 == (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_WS
)
2850 && n
== loop
->dimen
- 1)
2852 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2853 init
= make_tree_vec (1);
2854 cond
= make_tree_vec (1);
2855 incr
= make_tree_vec (1);
2857 /* Cycle statement is implemented with a goto. Exit statement must not
2858 be present for this loop. */
2859 exit_label
= gfc_build_label_decl (NULL_TREE
);
2860 TREE_USED (exit_label
) = 1;
2862 /* Label for cycle statements (if needed). */
2863 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2864 gfc_add_expr_to_block (pbody
, tmp
);
2866 stmt
= make_node (OMP_FOR
);
2868 TREE_TYPE (stmt
) = void_type_node
;
2869 OMP_FOR_BODY (stmt
) = loopbody
= gfc_finish_block (pbody
);
2871 OMP_FOR_CLAUSES (stmt
) = build_omp_clause (input_location
,
2872 OMP_CLAUSE_SCHEDULE
);
2873 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt
))
2874 = OMP_CLAUSE_SCHEDULE_STATIC
;
2875 if (ompws_flags
& OMPWS_NOWAIT
)
2876 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt
))
2877 = build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
);
2879 /* Initialize the loopvar. */
2880 TREE_VEC_ELT (init
, 0) = build2_v (MODIFY_EXPR
, loop
->loopvar
[n
],
2882 OMP_FOR_INIT (stmt
) = init
;
2883 /* The exit condition. */
2884 TREE_VEC_ELT (cond
, 0) = build2_loc (input_location
, LE_EXPR
,
2886 loop
->loopvar
[n
], loop
->to
[n
]);
2887 SET_EXPR_LOCATION (TREE_VEC_ELT (cond
, 0), input_location
);
2888 OMP_FOR_COND (stmt
) = cond
;
2889 /* Increment the loopvar. */
2890 tmp
= build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2891 loop
->loopvar
[n
], gfc_index_one_node
);
2892 TREE_VEC_ELT (incr
, 0) = fold_build2_loc (input_location
, MODIFY_EXPR
,
2893 void_type_node
, loop
->loopvar
[n
], tmp
);
2894 OMP_FOR_INCR (stmt
) = incr
;
2896 ompws_flags
&= ~OMPWS_CURR_SINGLEUNIT
;
2897 gfc_add_expr_to_block (&loop
->code
[n
], stmt
);
2901 bool reverse_loop
= (loop
->reverse
[n
] == GFC_REVERSE_SET
)
2902 && (loop
->temp_ss
== NULL
);
2904 loopbody
= gfc_finish_block (pbody
);
2908 tmp
= loop
->from
[n
];
2909 loop
->from
[n
] = loop
->to
[n
];
2913 /* Initialize the loopvar. */
2914 if (loop
->loopvar
[n
] != loop
->from
[n
])
2915 gfc_add_modify (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
2917 exit_label
= gfc_build_label_decl (NULL_TREE
);
2919 /* Generate the loop body. */
2920 gfc_init_block (&block
);
2922 /* The exit condition. */
2923 cond
= fold_build2_loc (input_location
, reverse_loop
? LT_EXPR
: GT_EXPR
,
2924 boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
2925 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2926 TREE_USED (exit_label
) = 1;
2927 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2928 gfc_add_expr_to_block (&block
, tmp
);
2930 /* The main body. */
2931 gfc_add_expr_to_block (&block
, loopbody
);
2933 /* Increment the loopvar. */
2934 tmp
= fold_build2_loc (input_location
,
2935 reverse_loop
? MINUS_EXPR
: PLUS_EXPR
,
2936 gfc_array_index_type
, loop
->loopvar
[n
],
2937 gfc_index_one_node
);
2939 gfc_add_modify (&block
, loop
->loopvar
[n
], tmp
);
2941 /* Build the loop. */
2942 tmp
= gfc_finish_block (&block
);
2943 tmp
= build1_v (LOOP_EXPR
, tmp
);
2944 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2946 /* Add the exit label. */
2947 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2948 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
2954 /* Finishes and generates the loops for a scalarized expression. */
2957 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2962 stmtblock_t
*pblock
;
2966 /* Generate the loops. */
2967 for (dim
= 0; dim
< loop
->dimen
; dim
++)
2969 n
= loop
->order
[dim
];
2970 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
2971 loop
->loopvar
[n
] = NULL_TREE
;
2972 pblock
= &loop
->code
[n
];
2975 tmp
= gfc_finish_block (pblock
);
2976 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2978 /* Clear all the used flags. */
2979 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
2984 /* Finish the main body of a scalarized expression, and start the secondary
2988 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
2992 stmtblock_t
*pblock
;
2996 /* We finish as many loops as are used by the temporary. */
2997 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
2999 n
= loop
->order
[dim
];
3000 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3001 loop
->loopvar
[n
] = NULL_TREE
;
3002 pblock
= &loop
->code
[n
];
3005 /* We don't want to finish the outermost loop entirely. */
3006 n
= loop
->order
[loop
->temp_dim
- 1];
3007 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
3009 /* Restore the initial offsets. */
3010 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3012 if ((ss
->useflags
& 2) == 0)
3015 if (ss
->type
!= GFC_SS_SECTION
3016 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
3017 && ss
->type
!= GFC_SS_COMPONENT
)
3020 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
3023 /* Restart all the inner loops we just finished. */
3024 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
3026 n
= loop
->order
[dim
];
3028 gfc_start_block (&loop
->code
[n
]);
3030 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
3032 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
3035 /* Start a block for the secondary copying code. */
3036 gfc_start_block (body
);
3040 /* Calculate the lower bound of an array section. */
3043 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int dim
)
3052 gcc_assert (ss
->type
== GFC_SS_SECTION
);
3054 info
= &ss
->data
.info
;
3056 if (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3058 /* We use a zero-based index to access the vector. */
3059 info
->start
[dim
] = gfc_index_zero_node
;
3060 info
->stride
[dim
] = gfc_index_one_node
;
3061 info
->end
[dim
] = NULL
;
3065 gcc_assert (info
->ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
3066 desc
= info
->descriptor
;
3067 start
= info
->ref
->u
.ar
.start
[dim
];
3068 end
= info
->ref
->u
.ar
.end
[dim
];
3069 stride
= info
->ref
->u
.ar
.stride
[dim
];
3071 /* Calculate the start of the range. For vector subscripts this will
3072 be the range of the vector. */
3075 /* Specified section start. */
3076 gfc_init_se (&se
, NULL
);
3077 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
3078 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3079 info
->start
[dim
] = se
.expr
;
3083 /* No lower bound specified so use the bound of the array. */
3084 info
->start
[dim
] = gfc_conv_array_lbound (desc
, dim
);
3086 info
->start
[dim
] = gfc_evaluate_now (info
->start
[dim
], &loop
->pre
);
3088 /* Similarly calculate the end. Although this is not used in the
3089 scalarizer, it is needed when checking bounds and where the end
3090 is an expression with side-effects. */
3093 /* Specified section start. */
3094 gfc_init_se (&se
, NULL
);
3095 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
3096 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3097 info
->end
[dim
] = se
.expr
;
3101 /* No upper bound specified so use the bound of the array. */
3102 info
->end
[dim
] = gfc_conv_array_ubound (desc
, dim
);
3104 info
->end
[dim
] = gfc_evaluate_now (info
->end
[dim
], &loop
->pre
);
3106 /* Calculate the stride. */
3108 info
->stride
[dim
] = gfc_index_one_node
;
3111 gfc_init_se (&se
, NULL
);
3112 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
3113 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
3114 info
->stride
[dim
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
3119 /* Calculates the range start and stride for a SS chain. Also gets the
3120 descriptor and data pointer. The range of vector subscripts is the size
3121 of the vector. Array bounds are also checked. */
3124 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
3132 /* Determine the rank of the loop. */
3134 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
3138 case GFC_SS_SECTION
:
3139 case GFC_SS_CONSTRUCTOR
:
3140 case GFC_SS_FUNCTION
:
3141 case GFC_SS_COMPONENT
:
3142 loop
->dimen
= ss
->data
.info
.dimen
;
3145 /* As usual, lbound and ubound are exceptions!. */
3146 case GFC_SS_INTRINSIC
:
3147 switch (ss
->expr
->value
.function
.isym
->id
)
3149 case GFC_ISYM_LBOUND
:
3150 case GFC_ISYM_UBOUND
:
3151 loop
->dimen
= ss
->data
.info
.dimen
;
3162 /* We should have determined the rank of the expression by now. If
3163 not, that's bad news. */
3164 gcc_assert (loop
->dimen
!= 0);
3166 /* Loop over all the SS in the chain. */
3167 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3169 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
3170 ss
->shape
= ss
->expr
->shape
;
3174 case GFC_SS_SECTION
:
3175 /* Get the descriptor for the array. */
3176 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
3178 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3179 gfc_conv_section_startstride (loop
, ss
, ss
->data
.info
.dim
[n
]);
3182 case GFC_SS_INTRINSIC
:
3183 switch (ss
->expr
->value
.function
.isym
->id
)
3185 /* Fall through to supply start and stride. */
3186 case GFC_ISYM_LBOUND
:
3187 case GFC_ISYM_UBOUND
:
3193 case GFC_SS_CONSTRUCTOR
:
3194 case GFC_SS_FUNCTION
:
3195 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
3197 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
3198 ss
->data
.info
.end
[n
] = gfc_index_zero_node
;
3199 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3208 /* The rest is just runtime bound checking. */
3209 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3212 tree lbound
, ubound
;
3214 tree size
[GFC_MAX_DIMENSIONS
];
3215 tree stride_pos
, stride_neg
, non_zerosized
, tmp2
, tmp3
;
3220 gfc_start_block (&block
);
3222 for (n
= 0; n
< loop
->dimen
; n
++)
3223 size
[n
] = NULL_TREE
;
3225 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3229 if (ss
->type
!= GFC_SS_SECTION
)
3232 /* Catch allocatable lhs in f2003. */
3233 if (gfc_option
.flag_realloc_lhs
&& ss
->is_alloc_lhs
)
3236 gfc_start_block (&inner
);
3238 /* TODO: range checking for mapped dimensions. */
3239 info
= &ss
->data
.info
;
3241 /* This code only checks ranges. Elemental and vector
3242 dimensions are checked later. */
3243 for (n
= 0; n
< loop
->dimen
; n
++)
3248 if (info
->ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3251 if (dim
== info
->ref
->u
.ar
.dimen
- 1
3252 && info
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
3253 check_upper
= false;
3257 /* Zero stride is not allowed. */
3258 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3259 info
->stride
[dim
], gfc_index_zero_node
);
3260 asprintf (&msg
, "Zero stride is not allowed, for dimension %d "
3261 "of array '%s'", dim
+ 1, ss
->expr
->symtree
->name
);
3262 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3263 &ss
->expr
->where
, msg
);
3266 desc
= ss
->data
.info
.descriptor
;
3268 /* This is the run-time equivalent of resolve.c's
3269 check_dimension(). The logical is more readable there
3270 than it is here, with all the trees. */
3271 lbound
= gfc_conv_array_lbound (desc
, dim
);
3272 end
= info
->end
[dim
];
3274 ubound
= gfc_conv_array_ubound (desc
, dim
);
3278 /* non_zerosized is true when the selected range is not
3280 stride_pos
= fold_build2_loc (input_location
, GT_EXPR
,
3281 boolean_type_node
, info
->stride
[dim
],
3282 gfc_index_zero_node
);
3283 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3284 info
->start
[dim
], end
);
3285 stride_pos
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3286 boolean_type_node
, stride_pos
, tmp
);
3288 stride_neg
= fold_build2_loc (input_location
, LT_EXPR
,
3290 info
->stride
[dim
], gfc_index_zero_node
);
3291 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3292 info
->start
[dim
], end
);
3293 stride_neg
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3296 non_zerosized
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3298 stride_pos
, stride_neg
);
3300 /* Check the start of the range against the lower and upper
3301 bounds of the array, if the range is not empty.
3302 If upper bound is present, include both bounds in the
3306 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3308 info
->start
[dim
], lbound
);
3309 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3311 non_zerosized
, tmp
);
3312 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
3314 info
->start
[dim
], ubound
);
3315 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3317 non_zerosized
, tmp2
);
3318 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3319 "outside of expected range (%%ld:%%ld)",
3320 dim
+ 1, ss
->expr
->symtree
->name
);
3321 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3322 &ss
->expr
->where
, msg
,
3323 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3324 fold_convert (long_integer_type_node
, lbound
),
3325 fold_convert (long_integer_type_node
, ubound
));
3326 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3327 &ss
->expr
->where
, msg
,
3328 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3329 fold_convert (long_integer_type_node
, lbound
),
3330 fold_convert (long_integer_type_node
, ubound
));
3335 tmp
= fold_build2_loc (input_location
, LT_EXPR
,
3337 info
->start
[dim
], lbound
);
3338 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3339 boolean_type_node
, non_zerosized
, tmp
);
3340 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3341 "below lower bound of %%ld",
3342 dim
+ 1, ss
->expr
->symtree
->name
);
3343 gfc_trans_runtime_check (true, false, tmp
, &inner
,
3344 &ss
->expr
->where
, msg
,
3345 fold_convert (long_integer_type_node
, info
->start
[dim
]),
3346 fold_convert (long_integer_type_node
, lbound
));
3350 /* Compute the last element of the range, which is not
3351 necessarily "end" (think 0:5:3, which doesn't contain 5)
3352 and check it against both lower and upper bounds. */
3354 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3355 gfc_array_index_type
, end
,
3357 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
3358 gfc_array_index_type
, tmp
,
3360 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3361 gfc_array_index_type
, end
, tmp
);
3362 tmp2
= fold_build2_loc (input_location
, LT_EXPR
,
3363 boolean_type_node
, tmp
, lbound
);
3364 tmp2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3365 boolean_type_node
, non_zerosized
, tmp2
);
3368 tmp3
= fold_build2_loc (input_location
, GT_EXPR
,
3369 boolean_type_node
, tmp
, ubound
);
3370 tmp3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3371 boolean_type_node
, non_zerosized
, tmp3
);
3372 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3373 "outside of expected range (%%ld:%%ld)",
3374 dim
+ 1, ss
->expr
->symtree
->name
);
3375 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3376 &ss
->expr
->where
, msg
,
3377 fold_convert (long_integer_type_node
, tmp
),
3378 fold_convert (long_integer_type_node
, ubound
),
3379 fold_convert (long_integer_type_node
, lbound
));
3380 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3381 &ss
->expr
->where
, msg
,
3382 fold_convert (long_integer_type_node
, tmp
),
3383 fold_convert (long_integer_type_node
, ubound
),
3384 fold_convert (long_integer_type_node
, lbound
));
3389 asprintf (&msg
, "Index '%%ld' of dimension %d of array '%s' "
3390 "below lower bound of %%ld",
3391 dim
+ 1, ss
->expr
->symtree
->name
);
3392 gfc_trans_runtime_check (true, false, tmp2
, &inner
,
3393 &ss
->expr
->where
, msg
,
3394 fold_convert (long_integer_type_node
, tmp
),
3395 fold_convert (long_integer_type_node
, lbound
));
3399 /* Check the section sizes match. */
3400 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3401 gfc_array_index_type
, end
,
3403 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
3404 gfc_array_index_type
, tmp
,
3406 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3407 gfc_array_index_type
,
3408 gfc_index_one_node
, tmp
);
3409 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
3410 gfc_array_index_type
, tmp
,
3411 build_int_cst (gfc_array_index_type
, 0));
3412 /* We remember the size of the first section, and check all the
3413 others against this. */
3416 tmp3
= fold_build2_loc (input_location
, NE_EXPR
,
3417 boolean_type_node
, tmp
, size
[n
]);
3418 asprintf (&msg
, "Array bound mismatch for dimension %d "
3419 "of array '%s' (%%ld/%%ld)",
3420 dim
+ 1, ss
->expr
->symtree
->name
);
3422 gfc_trans_runtime_check (true, false, tmp3
, &inner
,
3423 &ss
->expr
->where
, msg
,
3424 fold_convert (long_integer_type_node
, tmp
),
3425 fold_convert (long_integer_type_node
, size
[n
]));
3430 size
[n
] = gfc_evaluate_now (tmp
, &inner
);
3433 tmp
= gfc_finish_block (&inner
);
3435 /* For optional arguments, only check bounds if the argument is
3437 if (ss
->expr
->symtree
->n
.sym
->attr
.optional
3438 || ss
->expr
->symtree
->n
.sym
->attr
.not_always_present
)
3439 tmp
= build3_v (COND_EXPR
,
3440 gfc_conv_expr_present (ss
->expr
->symtree
->n
.sym
),
3441 tmp
, build_empty_stmt (input_location
));
3443 gfc_add_expr_to_block (&block
, tmp
);
3447 tmp
= gfc_finish_block (&block
);
3448 gfc_add_expr_to_block (&loop
->pre
, tmp
);
3453 /* Return true if the two SS could be aliased, i.e. both point to the same data
3455 /* TODO: resolve aliases based on frontend expressions. */
3458 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
3465 lsym
= lss
->expr
->symtree
->n
.sym
;
3466 rsym
= rss
->expr
->symtree
->n
.sym
;
3467 if (gfc_symbols_could_alias (lsym
, rsym
))
3470 if (rsym
->ts
.type
!= BT_DERIVED
3471 && lsym
->ts
.type
!= BT_DERIVED
)
3474 /* For derived types we must check all the component types. We can ignore
3475 array references as these will have the same base type as the previous
3477 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
3479 if (lref
->type
!= REF_COMPONENT
)
3482 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
3485 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
3488 if (rref
->type
!= REF_COMPONENT
)
3491 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
3496 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
3498 if (rref
->type
!= REF_COMPONENT
)
3501 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
3509 /* Resolve array data dependencies. Creates a temporary if required. */
3510 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3514 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
3523 loop
->temp_ss
= NULL
;
3525 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
3527 if (ss
->type
!= GFC_SS_SECTION
)
3530 if (dest
->expr
->symtree
->n
.sym
!= ss
->expr
->symtree
->n
.sym
)
3532 if (gfc_could_be_alias (dest
, ss
)
3533 || gfc_are_equivalenced_arrays (dest
->expr
, ss
->expr
))
3541 lref
= dest
->expr
->ref
;
3542 rref
= ss
->expr
->ref
;
3544 nDepend
= gfc_dep_resolver (lref
, rref
, &loop
->reverse
[0]);
3549 for (i
= 0; i
< dest
->data
.info
.dimen
; i
++)
3550 for (j
= 0; j
< ss
->data
.info
.dimen
; j
++)
3552 && dest
->data
.info
.dim
[i
] == ss
->data
.info
.dim
[j
])
3554 /* If we don't access array elements in the same order,
3555 there is a dependency. */
3560 /* TODO : loop shifting. */
3563 /* Mark the dimensions for LOOP SHIFTING */
3564 for (n
= 0; n
< loop
->dimen
; n
++)
3566 int dim
= dest
->data
.info
.dim
[n
];
3568 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
3570 else if (! gfc_is_same_range (&lref
->u
.ar
,
3571 &rref
->u
.ar
, dim
, 0))
3575 /* Put all the dimensions with dependencies in the
3578 for (n
= 0; n
< loop
->dimen
; n
++)
3580 gcc_assert (loop
->order
[n
] == n
);
3582 loop
->order
[dim
++] = n
;
3584 for (n
= 0; n
< loop
->dimen
; n
++)
3587 loop
->order
[dim
++] = n
;
3590 gcc_assert (dim
== loop
->dimen
);
3601 tree base_type
= gfc_typenode_for_spec (&dest
->expr
->ts
);
3602 if (GFC_ARRAY_TYPE_P (base_type
)
3603 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3604 base_type
= gfc_get_element_type (base_type
);
3605 loop
->temp_ss
= gfc_get_ss ();
3606 loop
->temp_ss
->type
= GFC_SS_TEMP
;
3607 loop
->temp_ss
->data
.temp
.type
= base_type
;
3608 loop
->temp_ss
->string_length
= dest
->string_length
;
3609 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
3610 loop
->temp_ss
->next
= gfc_ss_terminator
;
3611 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
3614 loop
->temp_ss
= NULL
;
3618 /* Initialize the scalarization loop. Creates the loop variables. Determines
3619 the range of the loop variables. Creates a temporary if required.
3620 Calculates how to transform from loop variables to array indices for each
3621 expression. Also generates code for scalar expressions which have been
3622 moved outside the loop. */
3625 gfc_conv_loop_setup (gfc_loopinfo
* loop
, locus
* where
)
3627 int n
, dim
, spec_dim
;
3629 gfc_ss_info
*specinfo
;
3632 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
3633 bool dynamic
[GFC_MAX_DIMENSIONS
];
3638 for (n
= 0; n
< loop
->dimen
; n
++)
3642 /* We use one SS term, and use that to determine the bounds of the
3643 loop for this dimension. We try to pick the simplest term. */
3644 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3646 if (ss
->type
== GFC_SS_SCALAR
|| ss
->type
== GFC_SS_REFERENCE
)
3649 info
= &ss
->data
.info
;
3652 if (loopspec
[n
] != NULL
)
3654 specinfo
= &loopspec
[n
]->data
.info
;
3655 spec_dim
= specinfo
->dim
[n
];
3659 /* Silence unitialized warnings. */
3666 gcc_assert (ss
->shape
[dim
]);
3667 /* The frontend has worked out the size for us. */
3669 || !loopspec
[n
]->shape
3670 || !integer_zerop (specinfo
->start
[spec_dim
]))
3671 /* Prefer zero-based descriptors if possible. */
3676 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
3678 gfc_constructor_base base
;
3679 /* An unknown size constructor will always be rank one.
3680 Higher rank constructors will either have known shape,
3681 or still be wrapped in a call to reshape. */
3682 gcc_assert (loop
->dimen
== 1);
3684 /* Always prefer to use the constructor bounds if the size
3685 can be determined at compile time. Prefer not to otherwise,
3686 since the general case involves realloc, and it's better to
3687 avoid that overhead if possible. */
3688 base
= ss
->expr
->value
.constructor
;
3689 dynamic
[n
] = gfc_get_array_constructor_size (&i
, base
);
3690 if (!dynamic
[n
] || !loopspec
[n
])
3695 /* TODO: Pick the best bound if we have a choice between a
3696 function and something else. */
3697 if (ss
->type
== GFC_SS_FUNCTION
)
3703 /* Avoid using an allocatable lhs in an assignment, since
3704 there might be a reallocation coming. */
3705 if (loopspec
[n
] && ss
->is_alloc_lhs
)
3708 if (ss
->type
!= GFC_SS_SECTION
)
3713 /* Criteria for choosing a loop specifier (most important first):
3714 doesn't need realloc
3720 else if (loopspec
[n
]->type
== GFC_SS_CONSTRUCTOR
&& dynamic
[n
])
3722 else if (integer_onep (info
->stride
[dim
])
3723 && !integer_onep (specinfo
->stride
[spec_dim
]))
3725 else if (INTEGER_CST_P (info
->stride
[dim
])
3726 && !INTEGER_CST_P (specinfo
->stride
[spec_dim
]))
3728 else if (INTEGER_CST_P (info
->start
[dim
])
3729 && !INTEGER_CST_P (specinfo
->start
[spec_dim
]))
3731 /* We don't work out the upper bound.
3732 else if (INTEGER_CST_P (info->finish[n])
3733 && ! INTEGER_CST_P (specinfo->finish[n]))
3734 loopspec[n] = ss; */
3737 /* We should have found the scalarization loop specifier. If not,
3739 gcc_assert (loopspec
[n
]);
3741 info
= &loopspec
[n
]->data
.info
;
3744 /* Set the extents of this range. */
3745 cshape
= loopspec
[n
]->shape
;
3746 if (cshape
&& INTEGER_CST_P (info
->start
[dim
])
3747 && INTEGER_CST_P (info
->stride
[dim
]))
3749 loop
->from
[n
] = info
->start
[dim
];
3750 mpz_set (i
, cshape
[get_array_ref_dim (info
, n
)]);
3751 mpz_sub_ui (i
, i
, 1);
3752 /* To = from + (size - 1) * stride. */
3753 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
3754 if (!integer_onep (info
->stride
[dim
]))
3755 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
3756 gfc_array_index_type
, tmp
,
3758 loop
->to
[n
] = fold_build2_loc (input_location
, PLUS_EXPR
,
3759 gfc_array_index_type
,
3760 loop
->from
[n
], tmp
);
3764 loop
->from
[n
] = info
->start
[dim
];
3765 switch (loopspec
[n
]->type
)
3767 case GFC_SS_CONSTRUCTOR
:
3768 /* The upper bound is calculated when we expand the
3770 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3773 case GFC_SS_SECTION
:
3774 /* Use the end expression if it exists and is not constant,
3775 so that it is only evaluated once. */
3776 loop
->to
[n
] = info
->end
[dim
];
3779 case GFC_SS_FUNCTION
:
3780 /* The loop bound will be set when we generate the call. */
3781 gcc_assert (loop
->to
[n
] == NULL_TREE
);
3789 /* Transform everything so we have a simple incrementing variable. */
3790 if (integer_onep (info
->stride
[dim
]))
3791 info
->delta
[dim
] = gfc_index_zero_node
;
3794 /* Set the delta for this section. */
3795 info
->delta
[dim
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
3796 /* Number of iterations is (end - start + step) / step.
3797 with start = 0, this simplifies to
3799 for (i = 0; i<=last; i++){...}; */
3800 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3801 gfc_array_index_type
, loop
->to
[n
],
3803 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
,
3804 gfc_array_index_type
, tmp
, info
->stride
[dim
]);
3805 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
3806 tmp
, build_int_cst (gfc_array_index_type
, -1));
3807 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3808 /* Make the loop variable start at 0. */
3809 loop
->from
[n
] = gfc_index_zero_node
;
3813 /* Add all the scalar code that can be taken out of the loops.
3814 This may include calculating the loop bounds, so do it before
3815 allocating the temporary. */
3816 gfc_add_loop_ss_code (loop
, loop
->ss
, false, where
);
3818 /* If we want a temporary then create it. */
3819 if (loop
->temp_ss
!= NULL
)
3821 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
3823 /* Make absolutely sure that this is a complete type. */
3824 if (loop
->temp_ss
->string_length
)
3825 loop
->temp_ss
->data
.temp
.type
3826 = gfc_get_character_type_len_for_eltype
3827 (TREE_TYPE (loop
->temp_ss
->data
.temp
.type
),
3828 loop
->temp_ss
->string_length
);
3830 tmp
= loop
->temp_ss
->data
.temp
.type
;
3831 n
= loop
->temp_ss
->data
.temp
.dimen
;
3832 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
3833 loop
->temp_ss
->type
= GFC_SS_SECTION
;
3834 loop
->temp_ss
->data
.info
.dimen
= n
;
3836 gcc_assert (loop
->temp_ss
->data
.info
.dimen
!= 0);
3837 for (n
= 0; n
< loop
->temp_ss
->data
.info
.dimen
; n
++)
3838 loop
->temp_ss
->data
.info
.dim
[n
] = n
;
3840 gfc_trans_create_temp_array (&loop
->pre
, &loop
->post
, loop
,
3841 &loop
->temp_ss
->data
.info
, tmp
, NULL_TREE
,
3842 false, true, false, where
);
3845 for (n
= 0; n
< loop
->temp_dim
; n
++)
3846 loopspec
[loop
->order
[n
]] = NULL
;
3850 /* For array parameters we don't have loop variables, so don't calculate the
3852 if (loop
->array_parameter
)
3855 /* Calculate the translation from loop variables to array indices. */
3856 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
3858 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
3859 && ss
->type
!= GFC_SS_CONSTRUCTOR
)
3863 info
= &ss
->data
.info
;
3865 for (n
= 0; n
< info
->dimen
; n
++)
3867 /* If we are specifying the range the delta is already set. */
3868 if (loopspec
[n
] != ss
)
3870 dim
= ss
->data
.info
.dim
[n
];
3872 /* Calculate the offset relative to the loop variable.
3873 First multiply by the stride. */
3874 tmp
= loop
->from
[n
];
3875 if (!integer_onep (info
->stride
[dim
]))
3876 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
3877 gfc_array_index_type
,
3878 tmp
, info
->stride
[dim
]);
3880 /* Then subtract this from our starting value. */
3881 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3882 gfc_array_index_type
,
3883 info
->start
[dim
], tmp
);
3885 info
->delta
[dim
] = gfc_evaluate_now (tmp
, &loop
->pre
);
3892 /* Calculate the size of a given array dimension from the bounds. This
3893 is simply (ubound - lbound + 1) if this expression is positive
3894 or 0 if it is negative (pick either one if it is zero). Optionally
3895 (if or_expr is present) OR the (expression != 0) condition to it. */
3898 gfc_conv_array_extent_dim (tree lbound
, tree ubound
, tree
* or_expr
)
3903 /* Calculate (ubound - lbound + 1). */
3904 res
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3906 res
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, res
,
3907 gfc_index_one_node
);
3909 /* Check whether the size for this dimension is negative. */
3910 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, res
,
3911 gfc_index_zero_node
);
3912 res
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
3913 gfc_index_zero_node
, res
);
3915 /* Build OR expression. */
3917 *or_expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3918 boolean_type_node
, *or_expr
, cond
);
3924 /* For an array descriptor, get the total number of elements. This is just
3925 the product of the extents along all dimensions. */
3928 gfc_conv_descriptor_size (tree desc
, int rank
)
3933 res
= gfc_index_one_node
;
3935 for (dim
= 0; dim
< rank
; ++dim
)
3941 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[dim
]);
3942 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[dim
]);
3944 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
3945 res
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3953 /* Fills in an array descriptor, and returns the size of the array. The size
3954 will be a simple_val, ie a variable or a constant. Also calculates the
3955 offset of the base. Returns the size of the array.
3959 for (n = 0; n < rank; n++)
3961 a.lbound[n] = specified_lower_bound;
3962 offset = offset + a.lbond[n] * stride;
3964 a.ubound[n] = specified_upper_bound;
3965 a.stride[n] = stride;
3966 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3967 stride = stride * size;
3974 gfc_array_init_size (tree descriptor
, int rank
, int corank
, tree
* poffset
,
3975 gfc_expr
** lower
, gfc_expr
** upper
,
3976 stmtblock_t
* pblock
)
3987 stmtblock_t thenblock
;
3988 stmtblock_t elseblock
;
3993 type
= TREE_TYPE (descriptor
);
3995 stride
= gfc_index_one_node
;
3996 offset
= gfc_index_zero_node
;
3998 /* Set the dtype. */
3999 tmp
= gfc_conv_descriptor_dtype (descriptor
);
4000 gfc_add_modify (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
4002 or_expr
= boolean_false_node
;
4004 for (n
= 0; n
< rank
; n
++)
4009 /* We have 3 possibilities for determining the size of the array:
4010 lower == NULL => lbound = 1, ubound = upper[n]
4011 upper[n] = NULL => lbound = 1, ubound = lower[n]
4012 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4015 /* Set lower bound. */
4016 gfc_init_se (&se
, NULL
);
4018 se
.expr
= gfc_index_one_node
;
4021 gcc_assert (lower
[n
]);
4024 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4025 gfc_add_block_to_block (pblock
, &se
.pre
);
4029 se
.expr
= gfc_index_one_node
;
4033 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
4035 conv_lbound
= se
.expr
;
4037 /* Work out the offset for this component. */
4038 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4040 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4041 gfc_array_index_type
, offset
, tmp
);
4043 /* Set upper bound. */
4044 gfc_init_se (&se
, NULL
);
4045 gcc_assert (ubound
);
4046 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4047 gfc_add_block_to_block (pblock
, &se
.pre
);
4049 gfc_conv_descriptor_ubound_set (pblock
, descriptor
,
4050 gfc_rank_cst
[n
], se
.expr
);
4051 conv_ubound
= se
.expr
;
4053 /* Store the stride. */
4054 gfc_conv_descriptor_stride_set (pblock
, descriptor
,
4055 gfc_rank_cst
[n
], stride
);
4057 /* Calculate size and check whether extent is negative. */
4058 size
= gfc_conv_array_extent_dim (conv_lbound
, conv_ubound
, &or_expr
);
4060 /* Multiply the stride by the number of elements in this dimension. */
4061 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
4062 gfc_array_index_type
, stride
, size
);
4063 stride
= gfc_evaluate_now (stride
, pblock
);
4066 for (n
= rank
; n
< rank
+ corank
; n
++)
4070 /* Set lower bound. */
4071 gfc_init_se (&se
, NULL
);
4072 if (lower
== NULL
|| lower
[n
] == NULL
)
4074 gcc_assert (n
== rank
+ corank
- 1);
4075 se
.expr
= gfc_index_one_node
;
4079 if (ubound
|| n
== rank
+ corank
- 1)
4081 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
4082 gfc_add_block_to_block (pblock
, &se
.pre
);
4086 se
.expr
= gfc_index_one_node
;
4090 gfc_conv_descriptor_lbound_set (pblock
, descriptor
, gfc_rank_cst
[n
],
4093 if (n
< rank
+ corank
- 1)
4095 gfc_init_se (&se
, NULL
);
4096 gcc_assert (ubound
);
4097 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
4098 gfc_add_block_to_block (pblock
, &se
.pre
);
4099 gfc_conv_descriptor_ubound_set (pblock
, descriptor
,
4100 gfc_rank_cst
[n
], se
.expr
);
4104 /* The stride is the number of elements in the array, so multiply by the
4105 size of an element to get the total size. */
4106 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4107 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4108 stride
, fold_convert (gfc_array_index_type
, tmp
));
4110 if (poffset
!= NULL
)
4112 offset
= gfc_evaluate_now (offset
, pblock
);
4116 if (integer_zerop (or_expr
))
4118 if (integer_onep (or_expr
))
4119 return gfc_index_zero_node
;
4121 var
= gfc_create_var (TREE_TYPE (size
), "size");
4122 gfc_start_block (&thenblock
);
4123 gfc_add_modify (&thenblock
, var
, gfc_index_zero_node
);
4124 thencase
= gfc_finish_block (&thenblock
);
4126 gfc_start_block (&elseblock
);
4127 gfc_add_modify (&elseblock
, var
, size
);
4128 elsecase
= gfc_finish_block (&elseblock
);
4130 tmp
= gfc_evaluate_now (or_expr
, pblock
);
4131 tmp
= build3_v (COND_EXPR
, tmp
, thencase
, elsecase
);
4132 gfc_add_expr_to_block (pblock
, tmp
);
4138 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4139 the work for an ALLOCATE statement. */
4143 gfc_array_allocate (gfc_se
* se
, gfc_expr
* expr
, tree pstat
)
4151 gfc_ref
*ref
, *prev_ref
= NULL
;
4152 bool allocatable_array
, coarray
;
4156 /* Find the last reference in the chain. */
4157 while (ref
&& ref
->next
!= NULL
)
4159 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
4160 || (ref
->u
.ar
.dimen
== 0 && ref
->u
.ar
.codimen
> 0));
4165 if (ref
== NULL
|| ref
->type
!= REF_ARRAY
)
4170 allocatable_array
= expr
->symtree
->n
.sym
->attr
.allocatable
;
4171 coarray
= expr
->symtree
->n
.sym
->attr
.codimension
;
4175 allocatable_array
= prev_ref
->u
.c
.component
->attr
.allocatable
;
4176 coarray
= prev_ref
->u
.c
.component
->attr
.codimension
;
4179 /* Return if this is a scalar coarray. */
4180 if ((!prev_ref
&& !expr
->symtree
->n
.sym
->attr
.dimension
)
4181 || (prev_ref
&& !prev_ref
->u
.c
.component
->attr
.dimension
))
4183 gcc_assert (coarray
);
4187 /* Figure out the size of the array. */
4188 switch (ref
->u
.ar
.type
)
4194 upper
= ref
->u
.ar
.start
;
4200 lower
= ref
->u
.ar
.start
;
4201 upper
= ref
->u
.ar
.end
;
4205 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
4207 lower
= ref
->u
.ar
.as
->lower
;
4208 upper
= ref
->u
.ar
.as
->upper
;
4216 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
,
4217 ref
->u
.ar
.as
->corank
, &offset
, lower
, upper
,
4220 /* Allocate memory to store the data. */
4221 pointer
= gfc_conv_descriptor_data_get (se
->expr
);
4222 STRIP_NOPS (pointer
);
4224 /* The allocate_array variants take the old pointer as first argument. */
4225 if (allocatable_array
)
4226 tmp
= gfc_allocate_array_with_status (&se
->pre
, pointer
, size
, pstat
, expr
);
4228 tmp
= gfc_allocate_with_status (&se
->pre
, size
, pstat
);
4229 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, pointer
,
4231 gfc_add_expr_to_block (&se
->pre
, tmp
);
4233 gfc_conv_descriptor_offset_set (&se
->pre
, se
->expr
, offset
);
4235 if (expr
->ts
.type
== BT_DERIVED
4236 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
4238 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, se
->expr
,
4239 ref
->u
.ar
.as
->rank
);
4240 gfc_add_expr_to_block (&se
->pre
, tmp
);
4247 /* Deallocate an array variable. Also used when an allocated variable goes
4252 gfc_array_deallocate (tree descriptor
, tree pstat
, gfc_expr
* expr
)
4258 gfc_start_block (&block
);
4259 /* Get a pointer to the data. */
4260 var
= gfc_conv_descriptor_data_get (descriptor
);
4263 /* Parameter is the address of the data component. */
4264 tmp
= gfc_deallocate_with_status (var
, pstat
, false, expr
);
4265 gfc_add_expr_to_block (&block
, tmp
);
4267 /* Zero the data pointer. */
4268 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
4269 var
, build_int_cst (TREE_TYPE (var
), 0));
4270 gfc_add_expr_to_block (&block
, tmp
);
4272 return gfc_finish_block (&block
);
4276 /* Create an array constructor from an initialization expression.
4277 We assume the frontend already did any expansions and conversions. */
4280 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
4286 unsigned HOST_WIDE_INT lo
;
4288 VEC(constructor_elt
,gc
) *v
= NULL
;
4290 switch (expr
->expr_type
)
4293 case EXPR_STRUCTURE
:
4294 /* A single scalar or derived type value. Create an array with all
4295 elements equal to that value. */
4296 gfc_init_se (&se
, NULL
);
4298 if (expr
->expr_type
== EXPR_CONSTANT
)
4299 gfc_conv_constant (&se
, expr
);
4301 gfc_conv_structure (&se
, expr
, 1);
4303 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
4304 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
4305 hi
= TREE_INT_CST_HIGH (tmp
);
4306 lo
= TREE_INT_CST_LOW (tmp
);
4310 /* This will probably eat buckets of memory for large arrays. */
4311 while (hi
!= 0 || lo
!= 0)
4313 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
, se
.expr
);
4321 /* Create a vector of all the elements. */
4322 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4323 c
; c
= gfc_constructor_next (c
))
4327 /* Problems occur when we get something like
4328 integer :: a(lots) = (/(i, i=1, lots)/) */
4329 gfc_fatal_error ("The number of elements in the array constructor "
4330 "at %L requires an increase of the allowed %d "
4331 "upper limit. See -fmax-array-constructor "
4332 "option", &expr
->where
,
4333 gfc_option
.flag_max_array_constructor
);
4336 if (mpz_cmp_si (c
->offset
, 0) != 0)
4337 index
= gfc_conv_mpz_to_tree (c
->offset
, gfc_index_integer_kind
);
4341 gfc_init_se (&se
, NULL
);
4342 switch (c
->expr
->expr_type
)
4345 gfc_conv_constant (&se
, c
->expr
);
4346 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4349 case EXPR_STRUCTURE
:
4350 gfc_conv_structure (&se
, c
->expr
, 1);
4351 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4356 /* Catch those occasional beasts that do not simplify
4357 for one reason or another, assuming that if they are
4358 standard defying the frontend will catch them. */
4359 gfc_conv_expr (&se
, c
->expr
);
4360 CONSTRUCTOR_APPEND_ELT (v
, index
, se
.expr
);
4367 return gfc_build_null_descriptor (type
);
4373 /* Create a constructor from the list of elements. */
4374 tmp
= build_constructor (type
, v
);
4375 TREE_CONSTANT (tmp
) = 1;
4380 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4381 returns the size (in elements) of the array. */
4384 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
4385 stmtblock_t
* pblock
)
4400 size
= gfc_index_one_node
;
4401 offset
= gfc_index_zero_node
;
4402 for (dim
= 0; dim
< as
->rank
; dim
++)
4404 /* Evaluate non-constant array bound expressions. */
4405 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
4406 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
4408 gfc_init_se (&se
, NULL
);
4409 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
4410 gfc_add_block_to_block (pblock
, &se
.pre
);
4411 gfc_add_modify (pblock
, lbound
, se
.expr
);
4413 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
4414 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
4416 gfc_init_se (&se
, NULL
);
4417 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
4418 gfc_add_block_to_block (pblock
, &se
.pre
);
4419 gfc_add_modify (pblock
, ubound
, se
.expr
);
4421 /* The offset of this dimension. offset = offset - lbound * stride. */
4422 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4424 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4427 /* The size of this dimension, and the stride of the next. */
4428 if (dim
+ 1 < as
->rank
)
4429 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
4431 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4433 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
4435 /* Calculate stride = size * (ubound + 1 - lbound). */
4436 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4437 gfc_array_index_type
,
4438 gfc_index_one_node
, lbound
);
4439 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4440 gfc_array_index_type
, ubound
, tmp
);
4441 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4442 gfc_array_index_type
, size
, tmp
);
4444 gfc_add_modify (pblock
, stride
, tmp
);
4446 stride
= gfc_evaluate_now (tmp
, pblock
);
4448 /* Make sure that negative size arrays are translated
4449 to being zero size. */
4450 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4451 stride
, gfc_index_zero_node
);
4452 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4453 gfc_array_index_type
, tmp
,
4454 stride
, gfc_index_zero_node
);
4455 gfc_add_modify (pblock
, stride
, tmp
);
4461 gfc_trans_vla_type_sizes (sym
, pblock
);
4468 /* Generate code to initialize/allocate an array variable. */
4471 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
,
4472 gfc_wrapped_block
* block
)
4481 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
4483 /* Do nothing for USEd variables. */
4484 if (sym
->attr
.use_assoc
)
4487 type
= TREE_TYPE (decl
);
4488 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4489 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
4491 gfc_start_block (&init
);
4493 /* Evaluate character string length. */
4494 if (sym
->ts
.type
== BT_CHARACTER
4495 && onstack
&& !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4497 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4499 gfc_trans_vla_type_sizes (sym
, &init
);
4501 /* Emit a DECL_EXPR for this variable, which will cause the
4502 gimplifier to allocate storage, and all that good stuff. */
4503 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
4504 gfc_add_expr_to_block (&init
, tmp
);
4509 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4513 type
= TREE_TYPE (type
);
4515 gcc_assert (!sym
->attr
.use_assoc
);
4516 gcc_assert (!TREE_STATIC (decl
));
4517 gcc_assert (!sym
->module
);
4519 if (sym
->ts
.type
== BT_CHARACTER
4520 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
4521 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4523 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
4525 /* Don't actually allocate space for Cray Pointees. */
4526 if (sym
->attr
.cray_pointee
)
4528 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4529 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4531 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4535 /* The size is the number of elements in the array, so multiply by the
4536 size of an element to get the total size. */
4537 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4538 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4539 size
, fold_convert (gfc_array_index_type
, tmp
));
4541 /* Allocate memory to hold the data. */
4542 tmp
= gfc_call_malloc (&init
, TREE_TYPE (decl
), size
);
4543 gfc_add_modify (&init
, decl
, tmp
);
4545 /* Set offset of the array. */
4546 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4547 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4549 /* Automatic arrays should not have initializers. */
4550 gcc_assert (!sym
->value
);
4552 /* Free the temporary. */
4553 tmp
= gfc_call_free (convert (pvoid_type_node
, decl
));
4555 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4559 /* Generate entry and exit code for g77 calling convention arrays. */
4562 gfc_trans_g77_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
4572 gfc_save_backend_locus (&loc
);
4573 gfc_set_backend_locus (&sym
->declared_at
);
4575 /* Descriptor type. */
4576 parm
= sym
->backend_decl
;
4577 type
= TREE_TYPE (parm
);
4578 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4580 gfc_start_block (&init
);
4582 if (sym
->ts
.type
== BT_CHARACTER
4583 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4584 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4586 /* Evaluate the bounds of the array. */
4587 gfc_trans_array_bounds (type
, sym
, &offset
, &init
);
4589 /* Set the offset. */
4590 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4591 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4593 /* Set the pointer itself if we aren't using the parameter directly. */
4594 if (TREE_CODE (parm
) != PARM_DECL
)
4596 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
4597 gfc_add_modify (&init
, parm
, tmp
);
4599 stmt
= gfc_finish_block (&init
);
4601 gfc_restore_backend_locus (&loc
);
4603 /* Add the initialization code to the start of the function. */
4605 if (sym
->attr
.optional
|| sym
->attr
.not_always_present
)
4607 tmp
= gfc_conv_expr_present (sym
);
4608 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
4611 gfc_add_init_cleanup (block
, stmt
, NULL_TREE
);
4615 /* Modify the descriptor of an array parameter so that it has the
4616 correct lower bound. Also move the upper bound accordingly.
4617 If the array is not packed, it will be copied into a temporary.
4618 For each dimension we set the new lower and upper bounds. Then we copy the
4619 stride and calculate the offset for this dimension. We also work out
4620 what the stride of a packed array would be, and see it the two match.
4621 If the array need repacking, we set the stride to the values we just
4622 calculated, recalculate the offset and copy the array data.
4623 Code is also added to copy the data back at the end of the function.
4627 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
,
4628 gfc_wrapped_block
* block
)
4635 tree stmtInit
, stmtCleanup
;
4642 tree stride
, stride2
;
4652 /* Do nothing for pointer and allocatable arrays. */
4653 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4656 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
4658 gfc_trans_g77_array (sym
, block
);
4662 gfc_save_backend_locus (&loc
);
4663 gfc_set_backend_locus (&sym
->declared_at
);
4665 /* Descriptor type. */
4666 type
= TREE_TYPE (tmpdesc
);
4667 gcc_assert (GFC_ARRAY_TYPE_P (type
));
4668 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4669 dumdesc
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
4670 gfc_start_block (&init
);
4672 if (sym
->ts
.type
== BT_CHARACTER
4673 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4674 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4676 checkparm
= (sym
->as
->type
== AS_EXPLICIT
4677 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
));
4679 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
4680 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
4682 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
4684 /* For non-constant shape arrays we only check if the first dimension
4685 is contiguous. Repacking higher dimensions wouldn't gain us
4686 anything as we still don't know the array stride. */
4687 partial
= gfc_create_var (boolean_type_node
, "partial");
4688 TREE_USED (partial
) = 1;
4689 tmp
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4690 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
4691 gfc_index_one_node
);
4692 gfc_add_modify (&init
, partial
, tmp
);
4695 partial
= NULL_TREE
;
4697 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4698 here, however I think it does the right thing. */
4701 /* Set the first stride. */
4702 stride
= gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[0]);
4703 stride
= gfc_evaluate_now (stride
, &init
);
4705 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4706 stride
, gfc_index_zero_node
);
4707 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
4708 tmp
, gfc_index_one_node
, stride
);
4709 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
4710 gfc_add_modify (&init
, stride
, tmp
);
4712 /* Allow the user to disable array repacking. */
4713 stmt_unpacked
= NULL_TREE
;
4717 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
4718 /* A library call to repack the array if necessary. */
4719 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4720 stmt_unpacked
= build_call_expr_loc (input_location
,
4721 gfor_fndecl_in_pack
, 1, tmp
);
4723 stride
= gfc_index_one_node
;
4725 if (gfc_option
.warn_array_temp
)
4726 gfc_warning ("Creating array temporary at %L", &loc
);
4729 /* This is for the case where the array data is used directly without
4730 calling the repack function. */
4731 if (no_repack
|| partial
!= NULL_TREE
)
4732 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
4734 stmt_packed
= NULL_TREE
;
4736 /* Assign the data pointer. */
4737 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4739 /* Don't repack unknown shape arrays when the first stride is 1. */
4740 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (stmt_packed
),
4741 partial
, stmt_packed
, stmt_unpacked
);
4744 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
4745 gfc_add_modify (&init
, tmpdesc
, fold_convert (type
, tmp
));
4747 offset
= gfc_index_zero_node
;
4748 size
= gfc_index_one_node
;
4750 /* Evaluate the bounds of the array. */
4751 for (n
= 0; n
< sym
->as
->rank
; n
++)
4753 if (checkparm
|| !sym
->as
->upper
[n
])
4755 /* Get the bounds of the actual parameter. */
4756 dubound
= gfc_conv_descriptor_ubound_get (dumdesc
, gfc_rank_cst
[n
]);
4757 dlbound
= gfc_conv_descriptor_lbound_get (dumdesc
, gfc_rank_cst
[n
]);
4761 dubound
= NULL_TREE
;
4762 dlbound
= NULL_TREE
;
4765 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
4766 if (!INTEGER_CST_P (lbound
))
4768 gfc_init_se (&se
, NULL
);
4769 gfc_conv_expr_type (&se
, sym
->as
->lower
[n
],
4770 gfc_array_index_type
);
4771 gfc_add_block_to_block (&init
, &se
.pre
);
4772 gfc_add_modify (&init
, lbound
, se
.expr
);
4775 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
4776 /* Set the desired upper bound. */
4777 if (sym
->as
->upper
[n
])
4779 /* We know what we want the upper bound to be. */
4780 if (!INTEGER_CST_P (ubound
))
4782 gfc_init_se (&se
, NULL
);
4783 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
4784 gfc_array_index_type
);
4785 gfc_add_block_to_block (&init
, &se
.pre
);
4786 gfc_add_modify (&init
, ubound
, se
.expr
);
4789 /* Check the sizes match. */
4792 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4796 temp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4797 gfc_array_index_type
, ubound
, lbound
);
4798 temp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4799 gfc_array_index_type
,
4800 gfc_index_one_node
, temp
);
4801 stride2
= fold_build2_loc (input_location
, MINUS_EXPR
,
4802 gfc_array_index_type
, dubound
,
4804 stride2
= fold_build2_loc (input_location
, PLUS_EXPR
,
4805 gfc_array_index_type
,
4806 gfc_index_one_node
, stride2
);
4807 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
4808 gfc_array_index_type
, temp
, stride2
);
4809 asprintf (&msg
, "Dimension %d of array '%s' has extent "
4810 "%%ld instead of %%ld", n
+1, sym
->name
);
4812 gfc_trans_runtime_check (true, false, tmp
, &init
, &loc
, msg
,
4813 fold_convert (long_integer_type_node
, temp
),
4814 fold_convert (long_integer_type_node
, stride2
));
4821 /* For assumed shape arrays move the upper bound by the same amount
4822 as the lower bound. */
4823 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4824 gfc_array_index_type
, dubound
, dlbound
);
4825 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4826 gfc_array_index_type
, tmp
, lbound
);
4827 gfc_add_modify (&init
, ubound
, tmp
);
4829 /* The offset of this dimension. offset = offset - lbound * stride. */
4830 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4832 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4833 gfc_array_index_type
, offset
, tmp
);
4835 /* The size of this dimension, and the stride of the next. */
4836 if (n
+ 1 < sym
->as
->rank
)
4838 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
4840 if (no_repack
|| partial
!= NULL_TREE
)
4842 gfc_conv_descriptor_stride_get (dumdesc
, gfc_rank_cst
[n
+1]);
4844 /* Figure out the stride if not a known constant. */
4845 if (!INTEGER_CST_P (stride
))
4848 stmt_packed
= NULL_TREE
;
4851 /* Calculate stride = size * (ubound + 1 - lbound). */
4852 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4853 gfc_array_index_type
,
4854 gfc_index_one_node
, lbound
);
4855 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4856 gfc_array_index_type
, ubound
, tmp
);
4857 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4858 gfc_array_index_type
, size
, tmp
);
4862 /* Assign the stride. */
4863 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
4864 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4865 gfc_array_index_type
, partial
,
4866 stmt_unpacked
, stmt_packed
);
4868 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
4869 gfc_add_modify (&init
, stride
, tmp
);
4874 stride
= GFC_TYPE_ARRAY_SIZE (type
);
4876 if (stride
&& !INTEGER_CST_P (stride
))
4878 /* Calculate size = stride * (ubound + 1 - lbound). */
4879 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4880 gfc_array_index_type
,
4881 gfc_index_one_node
, lbound
);
4882 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4883 gfc_array_index_type
,
4885 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4886 gfc_array_index_type
,
4887 GFC_TYPE_ARRAY_STRIDE (type
, n
), tmp
);
4888 gfc_add_modify (&init
, stride
, tmp
);
4893 /* Set the offset. */
4894 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
4895 gfc_add_modify (&init
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
4897 gfc_trans_vla_type_sizes (sym
, &init
);
4899 stmtInit
= gfc_finish_block (&init
);
4901 /* Only do the entry/initialization code if the arg is present. */
4902 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
4903 optional_arg
= (sym
->attr
.optional
4904 || (sym
->ns
->proc_name
->attr
.entry_master
4905 && sym
->attr
.dummy
));
4908 tmp
= gfc_conv_expr_present (sym
);
4909 stmtInit
= build3_v (COND_EXPR
, tmp
, stmtInit
,
4910 build_empty_stmt (input_location
));
4915 stmtCleanup
= NULL_TREE
;
4918 stmtblock_t cleanup
;
4919 gfc_start_block (&cleanup
);
4921 if (sym
->attr
.intent
!= INTENT_IN
)
4923 /* Copy the data back. */
4924 tmp
= build_call_expr_loc (input_location
,
4925 gfor_fndecl_in_unpack
, 2, dumdesc
, tmpdesc
);
4926 gfc_add_expr_to_block (&cleanup
, tmp
);
4929 /* Free the temporary. */
4930 tmp
= gfc_call_free (tmpdesc
);
4931 gfc_add_expr_to_block (&cleanup
, tmp
);
4933 stmtCleanup
= gfc_finish_block (&cleanup
);
4935 /* Only do the cleanup if the array was repacked. */
4936 tmp
= build_fold_indirect_ref_loc (input_location
, dumdesc
);
4937 tmp
= gfc_conv_descriptor_data_get (tmp
);
4938 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4940 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
4941 build_empty_stmt (input_location
));
4945 tmp
= gfc_conv_expr_present (sym
);
4946 stmtCleanup
= build3_v (COND_EXPR
, tmp
, stmtCleanup
,
4947 build_empty_stmt (input_location
));
4951 /* We don't need to free any memory allocated by internal_pack as it will
4952 be freed at the end of the function by pop_context. */
4953 gfc_add_init_cleanup (block
, stmtInit
, stmtCleanup
);
4955 gfc_restore_backend_locus (&loc
);
4959 /* Calculate the overall offset, including subreferences. */
4961 gfc_get_dataptr_offset (stmtblock_t
*block
, tree parm
, tree desc
, tree offset
,
4962 bool subref
, gfc_expr
*expr
)
4972 /* If offset is NULL and this is not a subreferenced array, there is
4974 if (offset
== NULL_TREE
)
4977 offset
= gfc_index_zero_node
;
4982 tmp
= gfc_conv_array_data (desc
);
4983 tmp
= build_fold_indirect_ref_loc (input_location
,
4985 tmp
= gfc_build_array_ref (tmp
, offset
, NULL
);
4987 /* Offset the data pointer for pointer assignments from arrays with
4988 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4991 /* Go past the array reference. */
4992 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4993 if (ref
->type
== REF_ARRAY
&&
4994 ref
->u
.ar
.type
!= AR_ELEMENT
)
5000 /* Calculate the offset for each subsequent subreference. */
5001 for (; ref
; ref
= ref
->next
)
5006 field
= ref
->u
.c
.component
->backend_decl
;
5007 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
5008 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
5010 tmp
, field
, NULL_TREE
);
5014 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
5015 gfc_init_se (&start
, NULL
);
5016 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
5017 gfc_add_block_to_block (block
, &start
.pre
);
5018 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
5022 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
5023 && ref
->u
.ar
.type
== AR_ELEMENT
);
5025 /* TODO - Add bounds checking. */
5026 stride
= gfc_index_one_node
;
5027 index
= gfc_index_zero_node
;
5028 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5033 /* Update the index. */
5034 gfc_init_se (&start
, NULL
);
5035 gfc_conv_expr_type (&start
, ref
->u
.ar
.start
[n
], gfc_array_index_type
);
5036 itmp
= gfc_evaluate_now (start
.expr
, block
);
5037 gfc_init_se (&start
, NULL
);
5038 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->lower
[n
], gfc_array_index_type
);
5039 jtmp
= gfc_evaluate_now (start
.expr
, block
);
5040 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5041 gfc_array_index_type
, itmp
, jtmp
);
5042 itmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5043 gfc_array_index_type
, itmp
, stride
);
5044 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
5045 gfc_array_index_type
, itmp
, index
);
5046 index
= gfc_evaluate_now (index
, block
);
5048 /* Update the stride. */
5049 gfc_init_se (&start
, NULL
);
5050 gfc_conv_expr_type (&start
, ref
->u
.ar
.as
->upper
[n
], gfc_array_index_type
);
5051 itmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5052 gfc_array_index_type
, start
.expr
,
5054 itmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5055 gfc_array_index_type
,
5056 gfc_index_one_node
, itmp
);
5057 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5058 gfc_array_index_type
, stride
, itmp
);
5059 stride
= gfc_evaluate_now (stride
, block
);
5062 /* Apply the index to obtain the array element. */
5063 tmp
= gfc_build_array_ref (tmp
, index
, NULL
);
5073 /* Set the target data pointer. */
5074 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
5075 gfc_conv_descriptor_data_set (block
, parm
, offset
);
5079 /* gfc_conv_expr_descriptor needs the string length an expression
5080 so that the size of the temporary can be obtained. This is done
5081 by adding up the string lengths of all the elements in the
5082 expression. Function with non-constant expressions have their
5083 string lengths mapped onto the actual arguments using the
5084 interface mapping machinery in trans-expr.c. */
5086 get_array_charlen (gfc_expr
*expr
, gfc_se
*se
)
5088 gfc_interface_mapping mapping
;
5089 gfc_formal_arglist
*formal
;
5090 gfc_actual_arglist
*arg
;
5093 if (expr
->ts
.u
.cl
->length
5094 && gfc_is_constant_expr (expr
->ts
.u
.cl
->length
))
5096 if (!expr
->ts
.u
.cl
->backend_decl
)
5097 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5101 switch (expr
->expr_type
)
5104 get_array_charlen (expr
->value
.op
.op1
, se
);
5106 /* For parentheses the expression ts.u.cl is identical. */
5107 if (expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
5110 expr
->ts
.u
.cl
->backend_decl
=
5111 gfc_create_var (gfc_charlen_type_node
, "sln");
5113 if (expr
->value
.op
.op2
)
5115 get_array_charlen (expr
->value
.op
.op2
, se
);
5117 gcc_assert (expr
->value
.op
.op
== INTRINSIC_CONCAT
);
5119 /* Add the string lengths and assign them to the expression
5120 string length backend declaration. */
5121 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5122 fold_build2_loc (input_location
, PLUS_EXPR
,
5123 gfc_charlen_type_node
,
5124 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
,
5125 expr
->value
.op
.op2
->ts
.u
.cl
->backend_decl
));
5128 gfc_add_modify (&se
->pre
, expr
->ts
.u
.cl
->backend_decl
,
5129 expr
->value
.op
.op1
->ts
.u
.cl
->backend_decl
);
5133 if (expr
->value
.function
.esym
== NULL
5134 || expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5136 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5140 /* Map expressions involving the dummy arguments onto the actual
5141 argument expressions. */
5142 gfc_init_interface_mapping (&mapping
);
5143 formal
= expr
->symtree
->n
.sym
->formal
;
5144 arg
= expr
->value
.function
.actual
;
5146 /* Set se = NULL in the calls to the interface mapping, to suppress any
5148 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
5153 gfc_add_interface_mapping (&mapping
, formal
->sym
, NULL
, arg
->expr
);
5156 gfc_init_se (&tse
, NULL
);
5158 /* Build the expression for the character length and convert it. */
5159 gfc_apply_interface_mapping (&mapping
, &tse
, expr
->ts
.u
.cl
->length
);
5161 gfc_add_block_to_block (&se
->pre
, &tse
.pre
);
5162 gfc_add_block_to_block (&se
->post
, &tse
.post
);
5163 tse
.expr
= fold_convert (gfc_charlen_type_node
, tse
.expr
);
5164 tse
.expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5165 gfc_charlen_type_node
, tse
.expr
,
5166 build_int_cst (gfc_charlen_type_node
, 0));
5167 expr
->ts
.u
.cl
->backend_decl
= tse
.expr
;
5168 gfc_free_interface_mapping (&mapping
);
5172 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &se
->pre
);
5178 /* Convert an array for passing as an actual argument. Expressions and
5179 vector subscripts are evaluated and stored in a temporary, which is then
5180 passed. For whole arrays the descriptor is passed. For array sections
5181 a modified copy of the descriptor is passed, but using the original data.
5183 This function is also used for array pointer assignments, and there
5186 - se->want_pointer && !se->direct_byref
5187 EXPR is an actual argument. On exit, se->expr contains a
5188 pointer to the array descriptor.
5190 - !se->want_pointer && !se->direct_byref
5191 EXPR is an actual argument to an intrinsic function or the
5192 left-hand side of a pointer assignment. On exit, se->expr
5193 contains the descriptor for EXPR.
5195 - !se->want_pointer && se->direct_byref
5196 EXPR is the right-hand side of a pointer assignment and
5197 se->expr is the descriptor for the previously-evaluated
5198 left-hand side. The function creates an assignment from
5202 The se->force_tmp flag disables the non-copying descriptor optimization
5203 that is used for transpose. It may be used in cases where there is an
5204 alias between the transpose argument and another argument in the same
5208 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
5220 bool subref_array_target
= false;
5223 gcc_assert (ss
!= NULL
);
5224 gcc_assert (ss
!= gfc_ss_terminator
);
5226 /* Special case things we know we can pass easily. */
5227 switch (expr
->expr_type
)
5230 /* If we have a linear array section, we can pass it directly.
5231 Otherwise we need to copy it into a temporary. */
5233 gcc_assert (ss
->type
== GFC_SS_SECTION
);
5234 gcc_assert (ss
->expr
== expr
);
5235 info
= &ss
->data
.info
;
5237 /* Get the descriptor for the array. */
5238 gfc_conv_ss_descriptor (&se
->pre
, ss
, 0);
5239 desc
= info
->descriptor
;
5241 subref_array_target
= se
->direct_byref
&& is_subref_array (expr
);
5242 need_tmp
= gfc_ref_needs_temporary_p (expr
->ref
)
5243 && !subref_array_target
;
5250 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5252 /* Create a new descriptor if the array doesn't have one. */
5255 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
5257 else if (se
->direct_byref
)
5260 full
= gfc_full_array_ref_p (info
->ref
, NULL
);
5263 for (n
= 0; n
< info
->dimen
; n
++)
5264 if (info
->dim
[n
] != n
)
5272 if (se
->direct_byref
&& !se
->byref_noassign
)
5274 /* Copy the descriptor for pointer assignments. */
5275 gfc_add_modify (&se
->pre
, se
->expr
, desc
);
5277 /* Add any offsets from subreferences. */
5278 gfc_get_dataptr_offset (&se
->pre
, se
->expr
, desc
, NULL_TREE
,
5279 subref_array_target
, expr
);
5281 else if (se
->want_pointer
)
5283 /* We pass full arrays directly. This means that pointers and
5284 allocatable arrays should also work. */
5285 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5292 if (expr
->ts
.type
== BT_CHARACTER
)
5293 se
->string_length
= gfc_get_expr_charlen (expr
);
5301 /* We don't need to copy data in some cases. */
5302 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
5305 /* This is a call to transpose... */
5306 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
5307 /* ... which has already been handled by the scalarizer, so
5308 that we just need to get its argument's descriptor. */
5309 gfc_conv_expr_descriptor (se
, expr
->value
.function
.actual
->expr
, ss
);
5313 /* A transformational function return value will be a temporary
5314 array descriptor. We still need to go through the scalarizer
5315 to create the descriptor. Elemental functions ar handled as
5316 arbitrary expressions, i.e. copy to a temporary. */
5318 if (se
->direct_byref
)
5320 gcc_assert (ss
->type
== GFC_SS_FUNCTION
&& ss
->expr
== expr
);
5322 /* For pointer assignments pass the descriptor directly. */
5326 gcc_assert (se
->ss
== ss
);
5327 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5328 gfc_conv_expr (se
, expr
);
5332 if (ss
->expr
!= expr
|| ss
->type
!= GFC_SS_FUNCTION
)
5334 if (ss
->expr
!= expr
)
5335 /* Elemental function. */
5336 gcc_assert ((expr
->value
.function
.esym
!= NULL
5337 && expr
->value
.function
.esym
->attr
.elemental
)
5338 || (expr
->value
.function
.isym
!= NULL
5339 && expr
->value
.function
.isym
->elemental
));
5341 gcc_assert (ss
->type
== GFC_SS_INTRINSIC
);
5344 if (expr
->ts
.type
== BT_CHARACTER
5345 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5346 get_array_charlen (expr
, se
);
5352 /* Transformational function. */
5353 info
= &ss
->data
.info
;
5359 /* Constant array constructors don't need a temporary. */
5360 if (ss
->type
== GFC_SS_CONSTRUCTOR
5361 && expr
->ts
.type
!= BT_CHARACTER
5362 && gfc_constant_array_constructor_p (expr
->value
.constructor
))
5365 info
= &ss
->data
.info
;
5375 /* Something complicated. Copy it into a temporary. */
5381 /* If we are creating a temporary, we don't need to bother about aliases
5386 gfc_init_loopinfo (&loop
);
5388 /* Associate the SS with the loop. */
5389 gfc_add_ss_to_loop (&loop
, ss
);
5391 /* Tell the scalarizer not to bother creating loop variables, etc. */
5393 loop
.array_parameter
= 1;
5395 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5396 gcc_assert (!se
->direct_byref
);
5398 /* Setup the scalarizing loops and bounds. */
5399 gfc_conv_ss_startstride (&loop
);
5403 /* Tell the scalarizer to make a temporary. */
5404 loop
.temp_ss
= gfc_get_ss ();
5405 loop
.temp_ss
->type
= GFC_SS_TEMP
;
5406 loop
.temp_ss
->next
= gfc_ss_terminator
;
5408 if (expr
->ts
.type
== BT_CHARACTER
5409 && !expr
->ts
.u
.cl
->backend_decl
)
5410 get_array_charlen (expr
, se
);
5412 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
5414 if (expr
->ts
.type
== BT_CHARACTER
)
5415 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5417 loop
.temp_ss
->string_length
= NULL
;
5419 se
->string_length
= loop
.temp_ss
->string_length
;
5420 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
5421 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
5424 gfc_conv_loop_setup (&loop
, & expr
->where
);
5428 /* Copy into a temporary and pass that. We don't need to copy the data
5429 back because expressions and vector subscripts must be INTENT_IN. */
5430 /* TODO: Optimize passing function return values. */
5434 /* Start the copying loops. */
5435 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
5436 gfc_mark_ss_chain_used (ss
, 1);
5437 gfc_start_scalarized_body (&loop
, &block
);
5439 /* Copy each data element. */
5440 gfc_init_se (&lse
, NULL
);
5441 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5442 gfc_init_se (&rse
, NULL
);
5443 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5445 lse
.ss
= loop
.temp_ss
;
5448 gfc_conv_scalarized_array_ref (&lse
, NULL
);
5449 if (expr
->ts
.type
== BT_CHARACTER
)
5451 gfc_conv_expr (&rse
, expr
);
5452 if (POINTER_TYPE_P (TREE_TYPE (rse
.expr
)))
5453 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
5457 gfc_conv_expr_val (&rse
, expr
);
5459 gfc_add_block_to_block (&block
, &rse
.pre
);
5460 gfc_add_block_to_block (&block
, &lse
.pre
);
5462 lse
.string_length
= rse
.string_length
;
5463 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true,
5464 expr
->expr_type
== EXPR_VARIABLE
, true);
5465 gfc_add_expr_to_block (&block
, tmp
);
5467 /* Finish the copying loops. */
5468 gfc_trans_scalarizing_loops (&loop
, &block
);
5470 desc
= loop
.temp_ss
->data
.info
.descriptor
;
5472 else if (expr
->expr_type
== EXPR_FUNCTION
)
5474 desc
= info
->descriptor
;
5475 se
->string_length
= ss
->string_length
;
5479 /* We pass sections without copying to a temporary. Make a new
5480 descriptor and point it at the section we want. The loop variable
5481 limits will be the limits of the section.
5482 A function may decide to repack the array to speed up access, but
5483 we're not bothered about that here. */
5492 /* Set the string_length for a character array. */
5493 if (expr
->ts
.type
== BT_CHARACTER
)
5494 se
->string_length
= gfc_get_expr_charlen (expr
);
5496 desc
= info
->descriptor
;
5497 if (se
->direct_byref
&& !se
->byref_noassign
)
5499 /* For pointer assignments we fill in the destination. */
5501 parmtype
= TREE_TYPE (parm
);
5505 /* Otherwise make a new one. */
5506 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
5507 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
5508 loop
.from
, loop
.to
, 0,
5509 GFC_ARRAY_UNKNOWN
, false);
5510 parm
= gfc_create_var (parmtype
, "parm");
5513 offset
= gfc_index_zero_node
;
5515 /* The following can be somewhat confusing. We have two
5516 descriptors, a new one and the original array.
5517 {parm, parmtype, dim} refer to the new one.
5518 {desc, type, n, loop} refer to the original, which maybe
5519 a descriptorless array.
5520 The bounds of the scalarization are the bounds of the section.
5521 We don't have to worry about numeric overflows when calculating
5522 the offsets because all elements are within the array data. */
5524 /* Set the dtype. */
5525 tmp
= gfc_conv_descriptor_dtype (parm
);
5526 gfc_add_modify (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
5528 /* Set offset for assignments to pointer only to zero if it is not
5530 if (se
->direct_byref
5531 && info
->ref
&& info
->ref
->u
.ar
.type
!= AR_FULL
)
5532 base
= gfc_index_zero_node
;
5533 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5534 base
= gfc_evaluate_now (gfc_conv_array_offset (desc
), &loop
.pre
);
5538 ndim
= info
->ref
? info
->ref
->u
.ar
.dimen
: info
->dimen
;
5539 for (n
= 0; n
< ndim
; n
++)
5541 stride
= gfc_conv_array_stride (desc
, n
);
5543 /* Work out the offset. */
5545 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5547 gcc_assert (info
->subscript
[n
]
5548 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
5549 start
= info
->subscript
[n
]->data
.scalar
.expr
;
5553 /* Evaluate and remember the start of the section. */
5554 start
= info
->start
[n
];
5555 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
5558 tmp
= gfc_conv_array_lbound (desc
, n
);
5559 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5561 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
5563 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
5567 && info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
5569 /* For elemental dimensions, we only need the offset. */
5573 /* Vector subscripts need copying and are handled elsewhere. */
5575 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
5577 /* look for the corresponding scalarizer dimension: dim. */
5578 for (dim
= 0; dim
< ndim
; dim
++)
5579 if (info
->dim
[dim
] == n
)
5582 /* loop exited early: the DIM being looked for has been found. */
5583 gcc_assert (dim
< ndim
);
5585 /* Set the new lower bound. */
5586 from
= loop
.from
[dim
];
5589 /* If we have an array section or are assigning make sure that
5590 the lower bound is 1. References to the full
5591 array should otherwise keep the original bounds. */
5593 || info
->ref
->u
.ar
.type
!= AR_FULL
)
5594 && !integer_onep (from
))
5596 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5597 gfc_array_index_type
, gfc_index_one_node
,
5599 to
= fold_build2_loc (input_location
, PLUS_EXPR
,
5600 gfc_array_index_type
, to
, tmp
);
5601 from
= gfc_index_one_node
;
5603 gfc_conv_descriptor_lbound_set (&loop
.pre
, parm
,
5604 gfc_rank_cst
[dim
], from
);
5606 /* Set the new upper bound. */
5607 gfc_conv_descriptor_ubound_set (&loop
.pre
, parm
,
5608 gfc_rank_cst
[dim
], to
);
5610 /* Multiply the stride by the section stride to get the
5612 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5613 gfc_array_index_type
,
5614 stride
, info
->stride
[n
]);
5616 if (se
->direct_byref
5618 && info
->ref
->u
.ar
.type
!= AR_FULL
)
5620 base
= fold_build2_loc (input_location
, MINUS_EXPR
,
5621 TREE_TYPE (base
), base
, stride
);
5623 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5625 tmp
= gfc_conv_array_lbound (desc
, n
);
5626 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5627 TREE_TYPE (base
), tmp
, loop
.from
[dim
]);
5628 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5629 TREE_TYPE (base
), tmp
,
5630 gfc_conv_array_stride (desc
, n
));
5631 base
= fold_build2_loc (input_location
, PLUS_EXPR
,
5632 TREE_TYPE (base
), tmp
, base
);
5635 /* Store the new stride. */
5636 gfc_conv_descriptor_stride_set (&loop
.pre
, parm
,
5637 gfc_rank_cst
[dim
], stride
);
5640 if (se
->data_not_needed
)
5641 gfc_conv_descriptor_data_set (&loop
.pre
, parm
,
5642 gfc_index_zero_node
);
5644 /* Point the data pointer at the 1st element in the section. */
5645 gfc_get_dataptr_offset (&loop
.pre
, parm
, desc
, offset
,
5646 subref_array_target
, expr
);
5648 if ((se
->direct_byref
|| GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5649 && !se
->data_not_needed
)
5651 /* Set the offset. */
5652 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, base
);
5656 /* Only the callee knows what the correct offset it, so just set
5658 gfc_conv_descriptor_offset_set (&loop
.pre
, parm
, gfc_index_zero_node
);
5663 if (!se
->direct_byref
|| se
->byref_noassign
)
5665 /* Get a pointer to the new descriptor. */
5666 if (se
->want_pointer
)
5667 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
5672 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5673 gfc_add_block_to_block (&se
->post
, &loop
.post
);
5675 /* Cleanup the scalarizer. */
5676 gfc_cleanup_loop (&loop
);
5679 /* Helper function for gfc_conv_array_parameter if array size needs to be
5683 array_parameter_size (tree desc
, gfc_expr
*expr
, tree
*size
)
5686 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
5687 *size
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc
));
5688 else if (expr
->rank
> 1)
5689 *size
= build_call_expr_loc (input_location
,
5690 gfor_fndecl_size0
, 1,
5691 gfc_build_addr_expr (NULL
, desc
));
5694 tree ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_index_zero_node
);
5695 tree lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_index_zero_node
);
5697 *size
= fold_build2_loc (input_location
, MINUS_EXPR
,
5698 gfc_array_index_type
, ubound
, lbound
);
5699 *size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5700 *size
, gfc_index_one_node
);
5701 *size
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5702 *size
, gfc_index_zero_node
);
5704 elem
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
5705 *size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5706 *size
, fold_convert (gfc_array_index_type
, elem
));
5709 /* Convert an array for passing as an actual parameter. */
5710 /* TODO: Optimize passing g77 arrays. */
5713 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, bool g77
,
5714 const gfc_symbol
*fsym
, const char *proc_name
,
5719 tree tmp
= NULL_TREE
;
5721 tree parent
= DECL_CONTEXT (current_function_decl
);
5722 bool full_array_var
;
5723 bool this_array_result
;
5726 bool array_constructor
;
5727 bool good_allocatable
;
5728 bool ultimate_ptr_comp
;
5729 bool ultimate_alloc_comp
;
5734 ultimate_ptr_comp
= false;
5735 ultimate_alloc_comp
= false;
5737 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5739 if (ref
->next
== NULL
)
5742 if (ref
->type
== REF_COMPONENT
)
5744 ultimate_ptr_comp
= ref
->u
.c
.component
->attr
.pointer
;
5745 ultimate_alloc_comp
= ref
->u
.c
.component
->attr
.allocatable
;
5749 full_array_var
= false;
5752 if (expr
->expr_type
== EXPR_VARIABLE
&& ref
&& !ultimate_ptr_comp
)
5753 full_array_var
= gfc_full_array_ref_p (ref
, &contiguous
);
5755 sym
= full_array_var
? expr
->symtree
->n
.sym
: NULL
;
5757 /* The symbol should have an array specification. */
5758 gcc_assert (!sym
|| sym
->as
|| ref
->u
.ar
.as
);
5760 if (expr
->expr_type
== EXPR_ARRAY
&& expr
->ts
.type
== BT_CHARACTER
)
5762 get_array_ctor_strlen (&se
->pre
, expr
->value
.constructor
, &tmp
);
5763 expr
->ts
.u
.cl
->backend_decl
= tmp
;
5764 se
->string_length
= tmp
;
5767 /* Is this the result of the enclosing procedure? */
5768 this_array_result
= (full_array_var
&& sym
->attr
.flavor
== FL_PROCEDURE
);
5769 if (this_array_result
5770 && (sym
->backend_decl
!= current_function_decl
)
5771 && (sym
->backend_decl
!= parent
))
5772 this_array_result
= false;
5774 /* Passing address of the array if it is not pointer or assumed-shape. */
5775 if (full_array_var
&& g77
&& !this_array_result
)
5777 tmp
= gfc_get_symbol_decl (sym
);
5779 if (sym
->ts
.type
== BT_CHARACTER
)
5780 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5782 if (sym
->ts
.type
== BT_DERIVED
)
5784 gfc_conv_expr_descriptor (se
, expr
, ss
);
5785 se
->expr
= gfc_conv_array_data (se
->expr
);
5789 if (!sym
->attr
.pointer
5791 && sym
->as
->type
!= AS_ASSUMED_SHAPE
5792 && !sym
->attr
.allocatable
)
5794 /* Some variables are declared directly, others are declared as
5795 pointers and allocated on the heap. */
5796 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
5799 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5801 array_parameter_size (tmp
, expr
, size
);
5805 if (sym
->attr
.allocatable
)
5807 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5809 gfc_conv_expr_descriptor (se
, expr
, ss
);
5813 array_parameter_size (tmp
, expr
, size
);
5814 se
->expr
= gfc_conv_array_data (tmp
);
5819 /* A convenient reduction in scope. */
5820 contiguous
= g77
&& !this_array_result
&& contiguous
;
5822 /* There is no need to pack and unpack the array, if it is contiguous
5823 and not a deferred- or assumed-shape array, or if it is simply
5825 no_pack
= ((sym
&& sym
->as
5826 && !sym
->attr
.pointer
5827 && sym
->as
->type
!= AS_DEFERRED
5828 && sym
->as
->type
!= AS_ASSUMED_SHAPE
)
5830 (ref
&& ref
->u
.ar
.as
5831 && ref
->u
.ar
.as
->type
!= AS_DEFERRED
5832 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SHAPE
)
5834 gfc_is_simply_contiguous (expr
, false));
5836 no_pack
= contiguous
&& no_pack
;
5838 /* Array constructors are always contiguous and do not need packing. */
5839 array_constructor
= g77
&& !this_array_result
&& expr
->expr_type
== EXPR_ARRAY
;
5841 /* Same is true of contiguous sections from allocatable variables. */
5842 good_allocatable
= contiguous
5844 && expr
->symtree
->n
.sym
->attr
.allocatable
;
5846 /* Or ultimate allocatable components. */
5847 ultimate_alloc_comp
= contiguous
&& ultimate_alloc_comp
;
5849 if (no_pack
|| array_constructor
|| good_allocatable
|| ultimate_alloc_comp
)
5851 gfc_conv_expr_descriptor (se
, expr
, ss
);
5852 if (expr
->ts
.type
== BT_CHARACTER
)
5853 se
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5855 array_parameter_size (se
->expr
, expr
, size
);
5856 se
->expr
= gfc_conv_array_data (se
->expr
);
5860 if (this_array_result
)
5862 /* Result of the enclosing function. */
5863 gfc_conv_expr_descriptor (se
, expr
, ss
);
5865 array_parameter_size (se
->expr
, expr
, size
);
5866 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5868 if (g77
&& TREE_TYPE (TREE_TYPE (se
->expr
)) != NULL_TREE
5869 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
5870 se
->expr
= gfc_conv_array_data (build_fold_indirect_ref_loc (input_location
,
5877 /* Every other type of array. */
5878 se
->want_pointer
= 1;
5879 gfc_conv_expr_descriptor (se
, expr
, ss
);
5881 array_parameter_size (build_fold_indirect_ref_loc (input_location
,
5886 /* Deallocate the allocatable components of structures that are
5888 if (expr
->ts
.type
== BT_DERIVED
5889 && expr
->ts
.u
.derived
->attr
.alloc_comp
5890 && expr
->expr_type
!= EXPR_VARIABLE
)
5892 tmp
= build_fold_indirect_ref_loc (input_location
,
5894 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
5895 gfc_add_expr_to_block (&se
->post
, tmp
);
5898 if (g77
|| (fsym
&& fsym
->attr
.contiguous
5899 && !gfc_is_simply_contiguous (expr
, false)))
5901 tree origptr
= NULL_TREE
;
5905 /* For contiguous arrays, save the original value of the descriptor. */
5908 origptr
= gfc_create_var (pvoid_type_node
, "origptr");
5909 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5910 tmp
= gfc_conv_array_data (tmp
);
5911 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5912 TREE_TYPE (origptr
), origptr
,
5913 fold_convert (TREE_TYPE (origptr
), tmp
));
5914 gfc_add_expr_to_block (&se
->pre
, tmp
);
5917 /* Repack the array. */
5918 if (gfc_option
.warn_array_temp
)
5921 gfc_warning ("Creating array temporary at %L for argument '%s'",
5922 &expr
->where
, fsym
->name
);
5924 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5927 ptr
= build_call_expr_loc (input_location
,
5928 gfor_fndecl_in_pack
, 1, desc
);
5930 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5932 tmp
= gfc_conv_expr_present (sym
);
5933 ptr
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
5934 tmp
, fold_convert (TREE_TYPE (se
->expr
), ptr
),
5935 fold_convert (TREE_TYPE (se
->expr
), null_pointer_node
));
5938 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
5940 /* Use the packed data for the actual argument, except for contiguous arrays,
5941 where the descriptor's data component is set. */
5946 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
5947 gfc_conv_descriptor_data_set (&se
->pre
, tmp
, ptr
);
5950 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
5954 if (fsym
&& proc_name
)
5955 asprintf (&msg
, "An array temporary was created for argument "
5956 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
5958 asprintf (&msg
, "An array temporary was created");
5960 tmp
= build_fold_indirect_ref_loc (input_location
,
5962 tmp
= gfc_conv_array_data (tmp
);
5963 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5964 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
5966 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
5967 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5969 gfc_conv_expr_present (sym
), tmp
);
5971 gfc_trans_runtime_check (false, true, tmp
, &se
->pre
,
5976 gfc_start_block (&block
);
5978 /* Copy the data back. */
5979 if (fsym
== NULL
|| fsym
->attr
.intent
!= INTENT_IN
)
5981 tmp
= build_call_expr_loc (input_location
,
5982 gfor_fndecl_in_unpack
, 2, desc
, ptr
);
5983 gfc_add_expr_to_block (&block
, tmp
);
5986 /* Free the temporary. */
5987 tmp
= gfc_call_free (convert (pvoid_type_node
, ptr
));
5988 gfc_add_expr_to_block (&block
, tmp
);
5990 stmt
= gfc_finish_block (&block
);
5992 gfc_init_block (&block
);
5993 /* Only if it was repacked. This code needs to be executed before the
5994 loop cleanup code. */
5995 tmp
= build_fold_indirect_ref_loc (input_location
,
5997 tmp
= gfc_conv_array_data (tmp
);
5998 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5999 fold_convert (TREE_TYPE (tmp
), ptr
), tmp
);
6001 if (fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
)
6002 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6004 gfc_conv_expr_present (sym
), tmp
);
6006 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt (input_location
));
6008 gfc_add_expr_to_block (&block
, tmp
);
6009 gfc_add_block_to_block (&block
, &se
->post
);
6011 gfc_init_block (&se
->post
);
6013 /* Reset the descriptor pointer. */
6016 tmp
= build_fold_indirect_ref_loc (input_location
, desc
);
6017 gfc_conv_descriptor_data_set (&se
->post
, tmp
, origptr
);
6020 gfc_add_block_to_block (&se
->post
, &block
);
6025 /* Generate code to deallocate an array, if it is allocated. */
6028 gfc_trans_dealloc_allocated (tree descriptor
)
6034 gfc_start_block (&block
);
6036 var
= gfc_conv_descriptor_data_get (descriptor
);
6039 /* Call array_deallocate with an int * present in the second argument.
6040 Although it is ignored here, it's presence ensures that arrays that
6041 are already deallocated are ignored. */
6042 tmp
= gfc_deallocate_with_status (var
, NULL_TREE
, true, NULL
);
6043 gfc_add_expr_to_block (&block
, tmp
);
6045 /* Zero the data pointer. */
6046 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6047 var
, build_int_cst (TREE_TYPE (var
), 0));
6048 gfc_add_expr_to_block (&block
, tmp
);
6050 return gfc_finish_block (&block
);
6054 /* This helper function calculates the size in words of a full array. */
6057 get_full_array_size (stmtblock_t
*block
, tree decl
, int rank
)
6062 idx
= gfc_rank_cst
[rank
- 1];
6063 nelems
= gfc_conv_descriptor_ubound_get (decl
, idx
);
6064 tmp
= gfc_conv_descriptor_lbound_get (decl
, idx
);
6065 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6067 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6068 tmp
, gfc_index_one_node
);
6069 tmp
= gfc_evaluate_now (tmp
, block
);
6071 nelems
= gfc_conv_descriptor_stride_get (decl
, idx
);
6072 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6074 return gfc_evaluate_now (tmp
, block
);
6078 /* Allocate dest to the same size as src, and copy src -> dest.
6079 If no_malloc is set, only the copy is done. */
6082 duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
,
6092 /* If the source is null, set the destination to null. Then,
6093 allocate memory to the destination. */
6094 gfc_init_block (&block
);
6098 tmp
= null_pointer_node
;
6099 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, dest
, tmp
);
6100 gfc_add_expr_to_block (&block
, tmp
);
6101 null_data
= gfc_finish_block (&block
);
6103 gfc_init_block (&block
);
6104 size
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
6107 tmp
= gfc_call_malloc (&block
, type
, size
);
6108 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6109 dest
, fold_convert (type
, tmp
));
6110 gfc_add_expr_to_block (&block
, tmp
);
6113 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
6114 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
6119 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6120 null_data
= gfc_finish_block (&block
);
6122 gfc_init_block (&block
);
6123 nelems
= get_full_array_size (&block
, src
, rank
);
6124 tmp
= fold_convert (gfc_array_index_type
,
6125 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
6126 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6130 tmp
= TREE_TYPE (gfc_conv_descriptor_data_get (src
));
6131 tmp
= gfc_call_malloc (&block
, tmp
, size
);
6132 gfc_conv_descriptor_data_set (&block
, dest
, tmp
);
6135 /* We know the temporary and the value will be the same length,
6136 so can use memcpy. */
6137 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
6138 tmp
= build_call_expr_loc (input_location
,
6139 tmp
, 3, gfc_conv_descriptor_data_get (dest
),
6140 gfc_conv_descriptor_data_get (src
), size
);
6143 gfc_add_expr_to_block (&block
, tmp
);
6144 tmp
= gfc_finish_block (&block
);
6146 /* Null the destination if the source is null; otherwise do
6147 the allocate and copy. */
6151 null_cond
= gfc_conv_descriptor_data_get (src
);
6153 null_cond
= convert (pvoid_type_node
, null_cond
);
6154 null_cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6155 null_cond
, null_pointer_node
);
6156 return build3_v (COND_EXPR
, null_cond
, tmp
, null_data
);
6160 /* Allocate dest to the same size as src, and copy data src -> dest. */
6163 gfc_duplicate_allocatable (tree dest
, tree src
, tree type
, int rank
)
6165 return duplicate_allocatable (dest
, src
, type
, rank
, false);
6169 /* Copy data src -> dest. */
6172 gfc_copy_allocatable_data (tree dest
, tree src
, tree type
, int rank
)
6174 return duplicate_allocatable (dest
, src
, type
, rank
, true);
6178 /* Recursively traverse an object of derived type, generating code to
6179 deallocate, nullify or copy allocatable components. This is the work horse
6180 function for the functions named in this enum. */
6182 enum {DEALLOCATE_ALLOC_COMP
= 1, NULLIFY_ALLOC_COMP
, COPY_ALLOC_COMP
,
6183 COPY_ONLY_ALLOC_COMP
};
6186 structure_alloc_comps (gfc_symbol
* der_type
, tree decl
,
6187 tree dest
, int rank
, int purpose
)
6191 stmtblock_t fnblock
;
6192 stmtblock_t loopbody
;
6203 tree null_cond
= NULL_TREE
;
6205 gfc_init_block (&fnblock
);
6207 decl_type
= TREE_TYPE (decl
);
6209 if ((POINTER_TYPE_P (decl_type
) && rank
!= 0)
6210 || (TREE_CODE (decl_type
) == REFERENCE_TYPE
&& rank
== 0))
6212 decl
= build_fold_indirect_ref_loc (input_location
,
6215 /* Just in case in gets dereferenced. */
6216 decl_type
= TREE_TYPE (decl
);
6218 /* If this an array of derived types with allocatable components
6219 build a loop and recursively call this function. */
6220 if (TREE_CODE (decl_type
) == ARRAY_TYPE
6221 || GFC_DESCRIPTOR_TYPE_P (decl_type
))
6223 tmp
= gfc_conv_array_data (decl
);
6224 var
= build_fold_indirect_ref_loc (input_location
,
6227 /* Get the number of elements - 1 and set the counter. */
6228 if (GFC_DESCRIPTOR_TYPE_P (decl_type
))
6230 /* Use the descriptor for an allocatable array. Since this
6231 is a full array reference, we only need the descriptor
6232 information from dimension = rank. */
6233 tmp
= get_full_array_size (&fnblock
, decl
, rank
);
6234 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6235 gfc_array_index_type
, tmp
,
6236 gfc_index_one_node
);
6238 null_cond
= gfc_conv_descriptor_data_get (decl
);
6239 null_cond
= fold_build2_loc (input_location
, NE_EXPR
,
6240 boolean_type_node
, null_cond
,
6241 build_int_cst (TREE_TYPE (null_cond
), 0));
6245 /* Otherwise use the TYPE_DOMAIN information. */
6246 tmp
= array_type_nelts (decl_type
);
6247 tmp
= fold_convert (gfc_array_index_type
, tmp
);
6250 /* Remember that this is, in fact, the no. of elements - 1. */
6251 nelems
= gfc_evaluate_now (tmp
, &fnblock
);
6252 index
= gfc_create_var (gfc_array_index_type
, "S");
6254 /* Build the body of the loop. */
6255 gfc_init_block (&loopbody
);
6257 vref
= gfc_build_array_ref (var
, index
, NULL
);
6259 if (purpose
== COPY_ALLOC_COMP
)
6261 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest
)))
6263 tmp
= gfc_duplicate_allocatable (dest
, decl
, decl_type
, rank
);
6264 gfc_add_expr_to_block (&fnblock
, tmp
);
6266 tmp
= build_fold_indirect_ref_loc (input_location
,
6267 gfc_conv_array_data (dest
));
6268 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
6269 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
, purpose
);
6271 else if (purpose
== COPY_ONLY_ALLOC_COMP
)
6273 tmp
= build_fold_indirect_ref_loc (input_location
,
6274 gfc_conv_array_data (dest
));
6275 dref
= gfc_build_array_ref (tmp
, index
, NULL
);
6276 tmp
= structure_alloc_comps (der_type
, vref
, dref
, rank
,
6280 tmp
= structure_alloc_comps (der_type
, vref
, NULL_TREE
, rank
, purpose
);
6282 gfc_add_expr_to_block (&loopbody
, tmp
);
6284 /* Build the loop and return. */
6285 gfc_init_loopinfo (&loop
);
6287 loop
.from
[0] = gfc_index_zero_node
;
6288 loop
.loopvar
[0] = index
;
6289 loop
.to
[0] = nelems
;
6290 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
6291 gfc_add_block_to_block (&fnblock
, &loop
.pre
);
6293 tmp
= gfc_finish_block (&fnblock
);
6294 if (null_cond
!= NULL_TREE
)
6295 tmp
= build3_v (COND_EXPR
, null_cond
, tmp
,
6296 build_empty_stmt (input_location
));
6301 /* Otherwise, act on the components or recursively call self to
6302 act on a chain of components. */
6303 for (c
= der_type
->components
; c
; c
= c
->next
)
6305 bool cmp_has_alloc_comps
= (c
->ts
.type
== BT_DERIVED
)
6306 && c
->ts
.u
.derived
->attr
.alloc_comp
;
6307 cdecl = c
->backend_decl
;
6308 ctype
= TREE_TYPE (cdecl);
6312 case DEALLOCATE_ALLOC_COMP
:
6313 if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6315 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6316 decl
, cdecl, NULL_TREE
);
6317 if (cmp_has_alloc_comps
&& !c
->attr
.pointer
)
6319 /* Do not deallocate the components of ultimate pointer
6321 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6322 c
->as
->rank
, purpose
);
6323 gfc_add_expr_to_block (&fnblock
, tmp
);
6325 tmp
= gfc_trans_dealloc_allocated (comp
);
6326 gfc_add_expr_to_block (&fnblock
, tmp
);
6328 else if (c
->attr
.allocatable
)
6330 /* Allocatable scalar components. */
6331 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6332 decl
, cdecl, NULL_TREE
);
6334 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
6336 gfc_add_expr_to_block (&fnblock
, tmp
);
6338 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6339 void_type_node
, comp
,
6340 build_int_cst (TREE_TYPE (comp
), 0));
6341 gfc_add_expr_to_block (&fnblock
, tmp
);
6343 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
6345 /* Allocatable scalar CLASS components. */
6346 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6347 decl
, cdecl, NULL_TREE
);
6349 /* Add reference to '_data' component. */
6350 tmp
= CLASS_DATA (c
)->backend_decl
;
6351 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6352 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
6354 tmp
= gfc_deallocate_scalar_with_status (comp
, NULL
, true, NULL
,
6355 CLASS_DATA (c
)->ts
);
6356 gfc_add_expr_to_block (&fnblock
, tmp
);
6358 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6359 void_type_node
, comp
,
6360 build_int_cst (TREE_TYPE (comp
), 0));
6361 gfc_add_expr_to_block (&fnblock
, tmp
);
6365 case NULLIFY_ALLOC_COMP
:
6366 if (c
->attr
.pointer
)
6368 else if (c
->attr
.allocatable
&& c
->attr
.dimension
)
6370 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6371 decl
, cdecl, NULL_TREE
);
6372 gfc_conv_descriptor_data_set (&fnblock
, comp
, null_pointer_node
);
6374 else if (c
->attr
.allocatable
)
6376 /* Allocatable scalar components. */
6377 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6378 decl
, cdecl, NULL_TREE
);
6379 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6380 void_type_node
, comp
,
6381 build_int_cst (TREE_TYPE (comp
), 0));
6382 gfc_add_expr_to_block (&fnblock
, tmp
);
6384 else if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.allocatable
)
6386 /* Allocatable scalar CLASS components. */
6387 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6388 decl
, cdecl, NULL_TREE
);
6389 /* Add reference to '_data' component. */
6390 tmp
= CLASS_DATA (c
)->backend_decl
;
6391 comp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6392 TREE_TYPE (tmp
), comp
, tmp
, NULL_TREE
);
6393 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6394 void_type_node
, comp
,
6395 build_int_cst (TREE_TYPE (comp
), 0));
6396 gfc_add_expr_to_block (&fnblock
, tmp
);
6398 else if (cmp_has_alloc_comps
)
6400 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
,
6401 decl
, cdecl, NULL_TREE
);
6402 rank
= c
->as
? c
->as
->rank
: 0;
6403 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, NULL_TREE
,
6405 gfc_add_expr_to_block (&fnblock
, tmp
);
6409 case COPY_ALLOC_COMP
:
6410 if (c
->attr
.pointer
)
6413 /* We need source and destination components. */
6414 comp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, decl
,
6416 dcmp
= fold_build3_loc (input_location
, COMPONENT_REF
, ctype
, dest
,
6418 dcmp
= fold_convert (TREE_TYPE (comp
), dcmp
);
6420 if (c
->attr
.allocatable
&& !cmp_has_alloc_comps
)
6422 rank
= c
->as
? c
->as
->rank
: 0;
6423 tmp
= gfc_duplicate_allocatable (dcmp
, comp
, ctype
, rank
);
6424 gfc_add_expr_to_block (&fnblock
, tmp
);
6427 if (cmp_has_alloc_comps
)
6429 rank
= c
->as
? c
->as
->rank
: 0;
6430 tmp
= fold_convert (TREE_TYPE (dcmp
), comp
);
6431 gfc_add_modify (&fnblock
, dcmp
, tmp
);
6432 tmp
= structure_alloc_comps (c
->ts
.u
.derived
, comp
, dcmp
,
6434 gfc_add_expr_to_block (&fnblock
, tmp
);
6444 return gfc_finish_block (&fnblock
);
6447 /* Recursively traverse an object of derived type, generating code to
6448 nullify allocatable components. */
6451 gfc_nullify_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6453 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6454 NULLIFY_ALLOC_COMP
);
6458 /* Recursively traverse an object of derived type, generating code to
6459 deallocate allocatable components. */
6462 gfc_deallocate_alloc_comp (gfc_symbol
* der_type
, tree decl
, int rank
)
6464 return structure_alloc_comps (der_type
, decl
, NULL_TREE
, rank
,
6465 DEALLOCATE_ALLOC_COMP
);
6469 /* Recursively traverse an object of derived type, generating code to
6470 copy it and its allocatable components. */
6473 gfc_copy_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6475 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ALLOC_COMP
);
6479 /* Recursively traverse an object of derived type, generating code to
6480 copy only its allocatable components. */
6483 gfc_copy_only_alloc_comp (gfc_symbol
* der_type
, tree decl
, tree dest
, int rank
)
6485 return structure_alloc_comps (der_type
, decl
, dest
, rank
, COPY_ONLY_ALLOC_COMP
);
6489 /* Returns the value of LBOUND for an expression. This could be broken out
6490 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
6491 called by gfc_alloc_allocatable_for_assignment. */
6493 get_std_lbound (gfc_expr
*expr
, tree desc
, int dim
, bool assumed_size
)
6498 tree cond
, cond1
, cond3
, cond4
;
6500 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
6502 tmp
= gfc_rank_cst
[dim
];
6503 lbound
= gfc_conv_descriptor_lbound_get (desc
, tmp
);
6504 ubound
= gfc_conv_descriptor_ubound_get (desc
, tmp
);
6505 stride
= gfc_conv_descriptor_stride_get (desc
, tmp
);
6506 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6508 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6509 stride
, gfc_index_zero_node
);
6510 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6511 boolean_type_node
, cond3
, cond1
);
6512 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6513 stride
, gfc_index_zero_node
);
6515 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6516 tmp
, build_int_cst (gfc_array_index_type
,
6519 cond
= boolean_false_node
;
6521 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6522 boolean_type_node
, cond3
, cond4
);
6523 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6524 boolean_type_node
, cond
, cond1
);
6526 return fold_build3_loc (input_location
, COND_EXPR
,
6527 gfc_array_index_type
, cond
,
6528 lbound
, gfc_index_one_node
);
6530 else if (expr
->expr_type
== EXPR_VARIABLE
)
6532 tmp
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
6533 return GFC_TYPE_ARRAY_LBOUND(tmp
, dim
);
6535 else if (expr
->expr_type
== EXPR_FUNCTION
)
6537 /* A conversion function, so use the argument. */
6538 expr
= expr
->value
.function
.actual
->expr
;
6539 if (expr
->expr_type
!= EXPR_VARIABLE
)
6540 return gfc_index_one_node
;
6541 desc
= TREE_TYPE (expr
->symtree
->n
.sym
->backend_decl
);
6542 return get_std_lbound (expr
, desc
, dim
, assumed_size
);
6545 return gfc_index_one_node
;
6549 /* Returns true if an expression represents an lhs that can be reallocated
6553 gfc_is_reallocatable_lhs (gfc_expr
*expr
)
6560 /* An allocatable variable. */
6561 if (expr
->symtree
->n
.sym
->attr
.allocatable
6563 && expr
->ref
->type
== REF_ARRAY
6564 && expr
->ref
->u
.ar
.type
== AR_FULL
)
6567 /* All that can be left are allocatable components. */
6568 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
6569 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
6572 /* Find a component ref followed by an array reference. */
6573 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6575 && ref
->type
== REF_COMPONENT
6576 && ref
->next
->type
== REF_ARRAY
6577 && !ref
->next
->next
)
6583 /* Return true if valid reallocatable lhs. */
6584 if (ref
->u
.c
.component
->attr
.allocatable
6585 && ref
->next
->u
.ar
.type
== AR_FULL
)
6592 /* Allocate the lhs of an assignment to an allocatable array, otherwise
6596 gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop
,
6600 stmtblock_t realloc_block
;
6601 stmtblock_t alloc_block
;
6624 gfc_array_spec
* as
;
6626 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
6627 Find the lhs expression in the loop chain and set expr1 and
6628 expr2 accordingly. */
6629 if (expr1
->expr_type
== EXPR_FUNCTION
&& expr2
== NULL
)
6632 /* Find the ss for the lhs. */
6634 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
6635 if (lss
->expr
&& lss
->expr
->expr_type
== EXPR_VARIABLE
)
6637 if (lss
== gfc_ss_terminator
)
6642 /* Bail out if this is not a valid allocate on assignment. */
6643 if (!gfc_is_reallocatable_lhs (expr1
)
6644 || (expr2
&& !expr2
->rank
))
6647 /* Find the ss for the lhs. */
6649 for (; lss
&& lss
!= gfc_ss_terminator
; lss
= lss
->loop_chain
)
6650 if (lss
->expr
== expr1
)
6653 if (lss
== gfc_ss_terminator
)
6656 /* Find an ss for the rhs. For operator expressions, we see the
6657 ss's for the operands. Any one of these will do. */
6659 for (; rss
&& rss
!= gfc_ss_terminator
; rss
= rss
->loop_chain
)
6660 if (rss
->expr
!= expr1
&& rss
!= loop
->temp_ss
)
6663 if (expr2
&& rss
== gfc_ss_terminator
)
6666 gfc_start_block (&fblock
);
6668 /* Since the lhs is allocatable, this must be a descriptor type.
6669 Get the data and array size. */
6670 desc
= lss
->data
.info
.descriptor
;
6671 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)));
6672 array1
= gfc_conv_descriptor_data_get (desc
);
6673 size1
= gfc_conv_descriptor_size (desc
, expr1
->rank
);
6675 /* Get the rhs size. Fix both sizes. */
6677 desc2
= rss
->data
.info
.descriptor
;
6680 size2
= gfc_index_one_node
;
6681 for (n
= 0; n
< expr2
->rank
; n
++)
6683 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6684 gfc_array_index_type
,
6685 loop
->to
[n
], loop
->from
[n
]);
6686 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6687 gfc_array_index_type
,
6688 tmp
, gfc_index_one_node
);
6689 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
6690 gfc_array_index_type
,
6693 size1
= gfc_evaluate_now (size1
, &fblock
);
6694 size2
= gfc_evaluate_now (size2
, &fblock
);
6695 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6697 neq_size
= gfc_evaluate_now (cond
, &fblock
);
6699 /* If the lhs is allocated and the lhs and rhs are equal length, jump
6700 past the realloc/malloc. This allows F95 compliant expressions
6701 to escape allocation on assignment. */
6702 jump_label1
= gfc_build_label_decl (NULL_TREE
);
6703 jump_label2
= gfc_build_label_decl (NULL_TREE
);
6705 /* Allocate if data is NULL. */
6706 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6707 array1
, build_int_cst (TREE_TYPE (array1
), 0));
6708 tmp
= build3_v (COND_EXPR
, cond
,
6709 build1_v (GOTO_EXPR
, jump_label1
),
6710 build_empty_stmt (input_location
));
6711 gfc_add_expr_to_block (&fblock
, tmp
);
6713 /* Reallocate if sizes are different. */
6714 tmp
= build3_v (COND_EXPR
, neq_size
,
6715 build1_v (GOTO_EXPR
, jump_label1
),
6716 build_empty_stmt (input_location
));
6717 gfc_add_expr_to_block (&fblock
, tmp
);
6719 if (expr2
&& expr2
->expr_type
== EXPR_FUNCTION
6720 && expr2
->value
.function
.isym
6721 && expr2
->value
.function
.isym
->conversion
)
6723 /* For conversion functions, take the arg. */
6724 gfc_expr
*arg
= expr2
->value
.function
.actual
->expr
;
6725 as
= gfc_get_full_arrayspec_from_expr (arg
);
6728 as
= gfc_get_full_arrayspec_from_expr (expr2
);
6732 /* Reset the lhs bounds if any are different from the rhs. */
6733 if (as
&& expr2
->expr_type
== EXPR_VARIABLE
)
6735 for (n
= 0; n
< expr1
->rank
; n
++)
6737 /* First check the lbounds. */
6738 dim
= rss
->data
.info
.dim
[n
];
6739 lbd
= get_std_lbound (expr2
, desc2
, dim
,
6740 as
->type
== AS_ASSUMED_SIZE
);
6741 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
6742 cond
= fold_build2_loc (input_location
, NE_EXPR
,
6743 boolean_type_node
, lbd
, lbound
);
6744 tmp
= build3_v (COND_EXPR
, cond
,
6745 build1_v (GOTO_EXPR
, jump_label1
),
6746 build_empty_stmt (input_location
));
6747 gfc_add_expr_to_block (&fblock
, tmp
);
6749 /* Now check the shape. */
6750 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6751 gfc_array_index_type
,
6752 loop
->to
[n
], loop
->from
[n
]);
6753 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6754 gfc_array_index_type
,
6756 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
6757 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6758 gfc_array_index_type
,
6760 cond
= fold_build2_loc (input_location
, NE_EXPR
,
6762 tmp
, gfc_index_zero_node
);
6763 tmp
= build3_v (COND_EXPR
, cond
,
6764 build1_v (GOTO_EXPR
, jump_label1
),
6765 build_empty_stmt (input_location
));
6766 gfc_add_expr_to_block (&fblock
, tmp
);
6770 /* Otherwise jump past the (re)alloc code. */
6771 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
6772 gfc_add_expr_to_block (&fblock
, tmp
);
6774 /* Add the label to start automatic (re)allocation. */
6775 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
6776 gfc_add_expr_to_block (&fblock
, tmp
);
6778 /* Now modify the lhs descriptor and the associated scalarizer
6780 7.4.1.3: If variable is or becomes an unallocated allocatable
6781 variable, then it is allocated with each deferred type parameter
6782 equal to the corresponding type parameters of expr , with the
6783 shape of expr , and with each lower bound equal to the
6784 corresponding element of LBOUND(expr). */
6785 size1
= gfc_index_one_node
;
6786 offset
= gfc_index_zero_node
;
6788 for (n
= 0; n
< expr2
->rank
; n
++)
6790 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6791 gfc_array_index_type
,
6792 loop
->to
[n
], loop
->from
[n
]);
6793 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6794 gfc_array_index_type
,
6795 tmp
, gfc_index_one_node
);
6797 lbound
= gfc_index_one_node
;
6802 lbd
= get_std_lbound (expr2
, desc2
, n
,
6803 as
->type
== AS_ASSUMED_SIZE
);
6804 ubound
= fold_build2_loc (input_location
,
6806 gfc_array_index_type
,
6808 ubound
= fold_build2_loc (input_location
,
6810 gfc_array_index_type
,
6815 gfc_conv_descriptor_lbound_set (&fblock
, desc
,
6818 gfc_conv_descriptor_ubound_set (&fblock
, desc
,
6821 gfc_conv_descriptor_stride_set (&fblock
, desc
,
6824 lbound
= gfc_conv_descriptor_lbound_get (desc
,
6826 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
6827 gfc_array_index_type
,
6829 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6830 gfc_array_index_type
,
6832 size1
= fold_build2_loc (input_location
, MULT_EXPR
,
6833 gfc_array_index_type
,
6837 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
6838 the array offset is saved and the info.offset is used for a
6839 running offset. Use the saved_offset instead. */
6840 tmp
= gfc_conv_descriptor_offset (desc
);
6841 gfc_add_modify (&fblock
, tmp
, offset
);
6842 if (lss
->data
.info
.saved_offset
6843 && TREE_CODE (lss
->data
.info
.saved_offset
) == VAR_DECL
)
6844 gfc_add_modify (&fblock
, lss
->data
.info
.saved_offset
, tmp
);
6846 /* Now set the deltas for the lhs. */
6847 for (n
= 0; n
< expr1
->rank
; n
++)
6849 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
6850 dim
= lss
->data
.info
.dim
[n
];
6851 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6852 gfc_array_index_type
, tmp
,
6854 if (lss
->data
.info
.delta
[dim
]
6855 && TREE_CODE (lss
->data
.info
.delta
[dim
]) == VAR_DECL
)
6856 gfc_add_modify (&fblock
, lss
->data
.info
.delta
[dim
], tmp
);
6859 /* Get the new lhs size in bytes. */
6860 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6862 tmp
= expr2
->ts
.u
.cl
->backend_decl
;
6863 gcc_assert (expr1
->ts
.u
.cl
->backend_decl
);
6864 tmp
= fold_convert (TREE_TYPE (expr1
->ts
.u
.cl
->backend_decl
), tmp
);
6865 gfc_add_modify (&fblock
, expr1
->ts
.u
.cl
->backend_decl
, tmp
);
6867 else if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->backend_decl
)
6869 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
)));
6870 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6871 gfc_array_index_type
, tmp
,
6872 expr1
->ts
.u
.cl
->backend_decl
);
6875 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
6876 tmp
= fold_convert (gfc_array_index_type
, tmp
);
6877 size2
= fold_build2_loc (input_location
, MULT_EXPR
,
6878 gfc_array_index_type
,
6880 size2
= fold_convert (size_type_node
, size2
);
6881 size2
= gfc_evaluate_now (size2
, &fblock
);
6883 /* Realloc expression. Note that the scalarizer uses desc.data
6884 in the array reference - (*desc.data)[<element>]. */
6885 gfc_init_block (&realloc_block
);
6886 tmp
= build_call_expr_loc (input_location
,
6887 built_in_decls
[BUILT_IN_REALLOC
], 2,
6888 fold_convert (pvoid_type_node
, array1
),
6890 gfc_conv_descriptor_data_set (&realloc_block
,
6892 realloc_expr
= gfc_finish_block (&realloc_block
);
6894 /* Only reallocate if sizes are different. */
6895 tmp
= build3_v (COND_EXPR
, neq_size
, realloc_expr
,
6896 build_empty_stmt (input_location
));
6900 /* Malloc expression. */
6901 gfc_init_block (&alloc_block
);
6902 tmp
= build_call_expr_loc (input_location
,
6903 built_in_decls
[BUILT_IN_MALLOC
], 1,
6905 gfc_conv_descriptor_data_set (&alloc_block
,
6907 tmp
= gfc_conv_descriptor_dtype (desc
);
6908 gfc_add_modify (&alloc_block
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
6909 alloc_expr
= gfc_finish_block (&alloc_block
);
6911 /* Malloc if not allocated; realloc otherwise. */
6912 tmp
= build_int_cst (TREE_TYPE (array1
), 0);
6913 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6916 tmp
= build3_v (COND_EXPR
, cond
, alloc_expr
, realloc_expr
);
6917 gfc_add_expr_to_block (&fblock
, tmp
);
6919 /* Make sure that the scalarizer data pointer is updated. */
6920 if (lss
->data
.info
.data
6921 && TREE_CODE (lss
->data
.info
.data
) == VAR_DECL
)
6923 tmp
= gfc_conv_descriptor_data_get (desc
);
6924 gfc_add_modify (&fblock
, lss
->data
.info
.data
, tmp
);
6927 /* Add the exit label. */
6928 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
6929 gfc_add_expr_to_block (&fblock
, tmp
);
6931 return gfc_finish_block (&fblock
);
6935 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6936 Do likewise, recursively if necessary, with the allocatable components of
6940 gfc_trans_deferred_array (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
6946 stmtblock_t cleanup
;
6949 bool sym_has_alloc_comp
;
6951 sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
6952 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
6954 /* Make sure the frontend gets these right. */
6955 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym_has_alloc_comp
))
6956 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
6957 "allocatable attribute or derived type without allocatable "
6960 gfc_init_block (&init
);
6962 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
6963 || TREE_CODE (sym
->backend_decl
) == PARM_DECL
);
6965 if (sym
->ts
.type
== BT_CHARACTER
6966 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6968 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
6969 gfc_trans_vla_type_sizes (sym
, &init
);
6972 /* Dummy, use associated and result variables don't need anything special. */
6973 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
|| sym
->attr
.result
)
6975 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6979 gfc_save_backend_locus (&loc
);
6980 gfc_set_backend_locus (&sym
->declared_at
);
6981 descriptor
= sym
->backend_decl
;
6983 /* Although static, derived types with default initializers and
6984 allocatable components must not be nulled wholesale; instead they
6985 are treated component by component. */
6986 if (TREE_STATIC (descriptor
) && !sym_has_alloc_comp
)
6988 /* SAVEd variables are not freed on exit. */
6989 gfc_trans_static_array_pointer (sym
);
6991 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
6992 gfc_restore_backend_locus (&loc
);
6996 /* Get the descriptor type. */
6997 type
= TREE_TYPE (sym
->backend_decl
);
6999 if (sym_has_alloc_comp
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7002 && !(TREE_STATIC (sym
->backend_decl
) && sym
->attr
.is_main_program
))
7004 if (sym
->value
== NULL
7005 || !gfc_has_default_initializer (sym
->ts
.u
.derived
))
7007 rank
= sym
->as
? sym
->as
->rank
: 0;
7008 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
,
7010 gfc_add_expr_to_block (&init
, tmp
);
7013 gfc_init_default_dt (sym
, &init
, false);
7016 else if (!GFC_DESCRIPTOR_TYPE_P (type
))
7018 /* If the backend_decl is not a descriptor, we must have a pointer
7020 descriptor
= build_fold_indirect_ref_loc (input_location
,
7022 type
= TREE_TYPE (descriptor
);
7025 /* NULLIFY the data pointer. */
7026 if (GFC_DESCRIPTOR_TYPE_P (type
) && !sym
->attr
.save
)
7027 gfc_conv_descriptor_data_set (&init
, descriptor
, null_pointer_node
);
7029 gfc_init_block (&cleanup
);
7030 gfc_restore_backend_locus (&loc
);
7032 /* Allocatable arrays need to be freed when they go out of scope.
7033 The allocatable components of pointers must not be touched. */
7034 if (sym_has_alloc_comp
&& !(sym
->attr
.function
|| sym
->attr
.result
)
7035 && !sym
->attr
.pointer
&& !sym
->attr
.save
)
7038 rank
= sym
->as
? sym
->as
->rank
: 0;
7039 tmp
= gfc_deallocate_alloc_comp (sym
->ts
.u
.derived
, descriptor
, rank
);
7040 gfc_add_expr_to_block (&cleanup
, tmp
);
7043 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
7044 && !sym
->attr
.save
&& !sym
->attr
.result
)
7046 tmp
= gfc_trans_dealloc_allocated (sym
->backend_decl
);
7047 gfc_add_expr_to_block (&cleanup
, tmp
);
7050 gfc_add_init_cleanup (block
, gfc_finish_block (&init
),
7051 gfc_finish_block (&cleanup
));
7054 /************ Expression Walking Functions ******************/
7056 /* Walk a variable reference.
7058 Possible extension - multiple component subscripts.
7059 x(:,:) = foo%a(:)%b(:)
7061 forall (i=..., j=...)
7062 x(i,j) = foo%a(j)%b(i)
7064 This adds a fair amount of complexity because you need to deal with more
7065 than one ref. Maybe handle in a similar manner to vector subscripts.
7066 Maybe not worth the effort. */
7070 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
7077 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7078 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
7081 for (; ref
; ref
= ref
->next
)
7083 if (ref
->type
== REF_SUBSTRING
)
7085 newss
= gfc_get_ss ();
7086 newss
->type
= GFC_SS_SCALAR
;
7087 newss
->expr
= ref
->u
.ss
.start
;
7091 newss
= gfc_get_ss ();
7092 newss
->type
= GFC_SS_SCALAR
;
7093 newss
->expr
= ref
->u
.ss
.end
;
7098 /* We're only interested in array sections from now on. */
7099 if (ref
->type
!= REF_ARRAY
)
7104 if (ar
->as
->rank
== 0)
7106 /* Scalar coarray. */
7113 for (n
= 0; n
< ar
->dimen
; n
++)
7115 newss
= gfc_get_ss ();
7116 newss
->type
= GFC_SS_SCALAR
;
7117 newss
->expr
= ar
->start
[n
];
7124 newss
= gfc_get_ss ();
7125 newss
->type
= GFC_SS_SECTION
;
7128 newss
->data
.info
.dimen
= ar
->as
->rank
;
7129 newss
->data
.info
.ref
= ref
;
7131 /* Make sure array is the same as array(:,:), this way
7132 we don't need to special case all the time. */
7133 ar
->dimen
= ar
->as
->rank
;
7134 for (n
= 0; n
< ar
->dimen
; n
++)
7136 newss
->data
.info
.dim
[n
] = n
;
7137 ar
->dimen_type
[n
] = DIMEN_RANGE
;
7139 gcc_assert (ar
->start
[n
] == NULL
);
7140 gcc_assert (ar
->end
[n
] == NULL
);
7141 gcc_assert (ar
->stride
[n
] == NULL
);
7147 newss
= gfc_get_ss ();
7148 newss
->type
= GFC_SS_SECTION
;
7151 newss
->data
.info
.dimen
= 0;
7152 newss
->data
.info
.ref
= ref
;
7154 /* We add SS chains for all the subscripts in the section. */
7155 for (n
= 0; n
< ar
->dimen
; n
++)
7159 switch (ar
->dimen_type
[n
])
7162 /* Add SS for elemental (scalar) subscripts. */
7163 gcc_assert (ar
->start
[n
]);
7164 indexss
= gfc_get_ss ();
7165 indexss
->type
= GFC_SS_SCALAR
;
7166 indexss
->expr
= ar
->start
[n
];
7167 indexss
->next
= gfc_ss_terminator
;
7168 indexss
->loop_chain
= gfc_ss_terminator
;
7169 newss
->data
.info
.subscript
[n
] = indexss
;
7173 /* We don't add anything for sections, just remember this
7174 dimension for later. */
7175 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
7176 newss
->data
.info
.dimen
++;
7180 /* Create a GFC_SS_VECTOR index in which we can store
7181 the vector's descriptor. */
7182 indexss
= gfc_get_ss ();
7183 indexss
->type
= GFC_SS_VECTOR
;
7184 indexss
->expr
= ar
->start
[n
];
7185 indexss
->next
= gfc_ss_terminator
;
7186 indexss
->loop_chain
= gfc_ss_terminator
;
7187 newss
->data
.info
.subscript
[n
] = indexss
;
7188 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
7189 newss
->data
.info
.dimen
++;
7193 /* We should know what sort of section it is by now. */
7197 /* We should have at least one non-elemental dimension. */
7198 gcc_assert (newss
->data
.info
.dimen
> 0);
7203 /* We should know what sort of section it is by now. */
7212 /* Walk an expression operator. If only one operand of a binary expression is
7213 scalar, we must also add the scalar term to the SS chain. */
7216 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
7222 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
7223 if (expr
->value
.op
.op2
== NULL
)
7226 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
7228 /* All operands are scalar. Pass back and let the caller deal with it. */
7232 /* All operands require scalarization. */
7233 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
7236 /* One of the operands needs scalarization, the other is scalar.
7237 Create a gfc_ss for the scalar expression. */
7238 newss
= gfc_get_ss ();
7239 newss
->type
= GFC_SS_SCALAR
;
7242 /* First operand is scalar. We build the chain in reverse order, so
7243 add the scalar SS after the second operand. */
7245 while (head
&& head
->next
!= ss
)
7247 /* Check we haven't somehow broken the chain. */
7251 newss
->expr
= expr
->value
.op
.op1
;
7253 else /* head2 == head */
7255 gcc_assert (head2
== head
);
7256 /* Second operand is scalar. */
7257 newss
->next
= head2
;
7259 newss
->expr
= expr
->value
.op
.op2
;
7266 /* Reverse a SS chain. */
7269 gfc_reverse_ss (gfc_ss
* ss
)
7274 gcc_assert (ss
!= NULL
);
7276 head
= gfc_ss_terminator
;
7277 while (ss
!= gfc_ss_terminator
)
7280 /* Check we didn't somehow break the chain. */
7281 gcc_assert (next
!= NULL
);
7291 /* Walk the arguments of an elemental function. */
7294 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_actual_arglist
*arg
,
7302 head
= gfc_ss_terminator
;
7305 for (; arg
; arg
= arg
->next
)
7310 newss
= gfc_walk_subexpr (head
, arg
->expr
);
7313 /* Scalar argument. */
7314 newss
= gfc_get_ss ();
7316 newss
->expr
= arg
->expr
;
7326 while (tail
->next
!= gfc_ss_terminator
)
7333 /* If all the arguments are scalar we don't need the argument SS. */
7334 gfc_free_ss_chain (head
);
7339 /* Add it onto the existing chain. */
7345 /* Walk a function call. Scalar functions are passed back, and taken out of
7346 scalarization loops. For elemental functions we walk their arguments.
7347 The result of functions returning arrays is stored in a temporary outside
7348 the loop, so that the function is only called once. Hence we do not need
7349 to walk their arguments. */
7352 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
7355 gfc_intrinsic_sym
*isym
;
7357 gfc_component
*comp
= NULL
;
7360 isym
= expr
->value
.function
.isym
;
7362 /* Handle intrinsic functions separately. */
7364 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
7366 sym
= expr
->value
.function
.esym
;
7368 sym
= expr
->symtree
->n
.sym
;
7370 /* A function that returns arrays. */
7371 gfc_is_proc_ptr_comp (expr
, &comp
);
7372 if ((!comp
&& gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
7373 || (comp
&& comp
->attr
.dimension
))
7375 newss
= gfc_get_ss ();
7376 newss
->type
= GFC_SS_FUNCTION
;
7379 newss
->data
.info
.dimen
= expr
->rank
;
7380 for (n
= 0; n
< newss
->data
.info
.dimen
; n
++)
7381 newss
->data
.info
.dim
[n
] = n
;
7385 /* Walk the parameters of an elemental function. For now we always pass
7387 if (sym
->attr
.elemental
)
7388 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7391 /* Scalar functions are OK as these are evaluated outside the scalarization
7392 loop. Pass back and let the caller deal with it. */
7397 /* An array temporary is constructed for array constructors. */
7400 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
7405 newss
= gfc_get_ss ();
7406 newss
->type
= GFC_SS_CONSTRUCTOR
;
7409 newss
->data
.info
.dimen
= expr
->rank
;
7410 for (n
= 0; n
< expr
->rank
; n
++)
7411 newss
->data
.info
.dim
[n
] = n
;
7417 /* Walk an expression. Add walked expressions to the head of the SS chain.
7418 A wholly scalar expression will not be added. */
7421 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
7425 switch (expr
->expr_type
)
7428 head
= gfc_walk_variable_expr (ss
, expr
);
7432 head
= gfc_walk_op_expr (ss
, expr
);
7436 head
= gfc_walk_function_expr (ss
, expr
);
7441 case EXPR_STRUCTURE
:
7442 /* Pass back and let the caller deal with it. */
7446 head
= gfc_walk_array_constructor (ss
, expr
);
7449 case EXPR_SUBSTRING
:
7450 /* Pass back and let the caller deal with it. */
7454 internal_error ("bad expression type during walk (%d)",
7461 /* Entry point for expression walking.
7462 A return value equal to the passed chain means this is
7463 a scalar expression. It is up to the caller to take whatever action is
7464 necessary to translate these. */
7467 gfc_walk_expr (gfc_expr
* expr
)
7471 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
7472 return gfc_reverse_ss (res
);