1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
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 subecripts 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 "tree-gimple.h"
92 #include "trans-stmt.h"
93 #include "trans-types.h"
94 #include "trans-array.h"
95 #include "trans-const.h"
96 #include "dependency.h"
98 static gfc_ss
*gfc_walk_subexpr (gfc_ss
*, gfc_expr
*);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var
;
102 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
104 unsigned HOST_WIDE_INT gfc_stack_space_left
;
107 /* Returns true if a variable of specified size should go on the stack. */
110 gfc_can_put_var_on_stack (tree size
)
112 unsigned HOST_WIDE_INT low
;
114 if (!INTEGER_CST_P (size
))
117 if (gfc_option
.flag_max_stack_var_size
< 0)
120 if (TREE_INT_CST_HIGH (size
) != 0)
123 low
= TREE_INT_CST_LOW (size
);
124 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
127 /* TODO: Set a per-function stack size limit. */
129 /* We should be a bit more clever with array temps. */
130 if (gfc_option
.flag_max_function_vars_size
>= 0)
132 if (low
> gfc_stack_space_left
)
135 gfc_stack_space_left
-= low
;
143 gfc_array_dataptr_type (tree desc
)
145 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
149 /* Build expressions to access the members of an array descriptor.
150 It's surprisingly easy to mess up here, so never access
151 an array descriptor by "brute force", always use these
152 functions. This also avoids problems if we change the format
153 of an array descriptor.
155 To understand these magic numbers, look at the comments
156 before gfc_build_array_type() in trans-types.c.
158 The code within these defines should be the only code which knows the format
159 of an array descriptor.
161 Any code just needing to read obtain the bounds of an array should use
162 gfc_conv_array_* rather than the following functions as these will return
163 know constant values, and work with arrays which do not have descriptors.
165 Don't forget to #undef these! */
168 #define OFFSET_FIELD 1
169 #define DTYPE_FIELD 2
170 #define DIMENSION_FIELD 3
172 #define STRIDE_SUBFIELD 0
173 #define LBOUND_SUBFIELD 1
174 #define UBOUND_SUBFIELD 2
177 gfc_conv_descriptor_data (tree desc
)
182 type
= TREE_TYPE (desc
);
183 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
185 field
= TYPE_FIELDS (type
);
186 gcc_assert (DATA_FIELD
== 0);
187 gcc_assert (field
!= NULL_TREE
188 && TREE_CODE (TREE_TYPE (field
)) == POINTER_TYPE
189 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == ARRAY_TYPE
);
191 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
195 gfc_conv_descriptor_offset (tree desc
)
200 type
= TREE_TYPE (desc
);
201 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
203 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
204 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
206 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
210 gfc_conv_descriptor_dtype (tree desc
)
215 type
= TREE_TYPE (desc
);
216 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
218 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
219 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
221 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
225 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
231 type
= TREE_TYPE (desc
);
232 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
234 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
235 gcc_assert (field
!= NULL_TREE
236 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
237 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
239 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
240 tmp
= gfc_build_array_ref (tmp
, dim
);
245 gfc_conv_descriptor_stride (tree desc
, tree dim
)
250 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
251 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
252 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
253 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
255 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
260 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
265 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
266 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
267 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
268 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
270 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
275 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
280 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
281 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
282 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
283 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
285 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
290 /* Build an null array descriptor constructor. */
293 gfc_build_null_descriptor (tree type
)
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
299 gcc_assert (DATA_FIELD
== 0);
300 field
= TYPE_FIELDS (type
);
302 /* Set a NULL data pointer. */
303 tmp
= tree_cons (field
, null_pointer_node
, NULL_TREE
);
304 tmp
= build1 (CONSTRUCTOR
, type
, tmp
);
305 TREE_CONSTANT (tmp
) = 1;
306 TREE_INVARIANT (tmp
) = 1;
307 /* All other fields are ignored. */
313 /* Cleanup those #defines. */
318 #undef DIMENSION_FIELD
319 #undef STRIDE_SUBFIELD
320 #undef LBOUND_SUBFIELD
321 #undef UBOUND_SUBFIELD
324 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
325 flags & 1 = Main loop body.
326 flags & 2 = temp copy loop. */
329 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
331 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
332 ss
->useflags
= flags
;
335 static void gfc_free_ss (gfc_ss
*);
338 /* Free a gfc_ss chain. */
341 gfc_free_ss_chain (gfc_ss
* ss
)
345 while (ss
!= gfc_ss_terminator
)
347 gcc_assert (ss
!= NULL
);
358 gfc_free_ss (gfc_ss
* ss
)
366 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
368 if (ss
->data
.info
.subscript
[n
])
369 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
381 /* Free all the SS associated with a loop. */
384 gfc_cleanup_loop (gfc_loopinfo
* loop
)
390 while (ss
!= gfc_ss_terminator
)
392 gcc_assert (ss
!= NULL
);
393 next
= ss
->loop_chain
;
400 /* Associate a SS chain with a loop. */
403 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
407 if (head
== gfc_ss_terminator
)
411 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
413 if (ss
->next
== gfc_ss_terminator
)
414 ss
->loop_chain
= loop
->ss
;
416 ss
->loop_chain
= ss
->next
;
418 gcc_assert (ss
== gfc_ss_terminator
);
423 /* Generate an initializer for a static pointer or allocatable array. */
426 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
430 gcc_assert (TREE_STATIC (sym
->backend_decl
));
431 /* Just zero the data member. */
432 type
= TREE_TYPE (sym
->backend_decl
);
433 DECL_INITIAL (sym
->backend_decl
) =gfc_build_null_descriptor (type
);
437 /* Generate code to allocate an array temporary, or create a variable to
438 hold the data. If size is NULL zero the descriptor so that so that the
439 callee will allocate the array. Also generates code to free the array
443 gfc_trans_allocate_array_storage (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
444 tree size
, tree nelem
)
452 desc
= info
->descriptor
;
453 data
= gfc_conv_descriptor_data (desc
);
454 if (size
== NULL_TREE
)
456 /* A callee allocated array. */
457 gfc_add_modify_expr (&loop
->pre
, data
, convert (TREE_TYPE (data
),
458 gfc_index_zero_node
));
460 info
->offset
= gfc_index_zero_node
;
465 /* Allocate the temporary. */
466 onstack
= gfc_can_put_var_on_stack (size
);
470 /* Make a temporary variable to hold the data. */
471 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
473 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
475 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
477 tmp
= gfc_create_var (tmp
, "A");
478 tmp
= gfc_build_addr_expr (TREE_TYPE (data
), tmp
);
479 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
481 info
->offset
= gfc_index_zero_node
;
486 /* Allocate memory to hold the data. */
487 args
= gfc_chainon_list (NULL_TREE
, size
);
489 if (gfc_index_integer_kind
== 4)
490 tmp
= gfor_fndecl_internal_malloc
;
491 else if (gfc_index_integer_kind
== 8)
492 tmp
= gfor_fndecl_internal_malloc64
;
495 tmp
= gfc_build_function_call (tmp
, args
);
496 tmp
= convert (TREE_TYPE (data
), tmp
);
497 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
500 info
->offset
= gfc_index_zero_node
;
504 /* The offset is zero because we create temporaries with a zero
506 tmp
= gfc_conv_descriptor_offset (desc
);
507 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
511 /* Free the temporary. */
512 tmp
= convert (pvoid_type_node
, info
->data
);
513 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
514 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
515 gfc_add_expr_to_block (&loop
->post
, tmp
);
520 /* Generate code to allocate and initialize the descriptor for a temporary
521 array. This is used for both temporaries needed by the scaparizer, and
522 functions returning arrays. Adjusts the loop variables to be zero-based,
523 and calculates the loop bounds for callee allocated arrays.
524 Also fills in the descriptor, data and offset fields of info if known.
525 Returns the size of the array, or NULL for a callee allocated array. */
528 gfc_trans_allocate_temp_array (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
539 gcc_assert (info
->dimen
> 0);
540 /* Set the lower bound to zero. */
541 for (dim
= 0; dim
< info
->dimen
; dim
++)
543 n
= loop
->order
[dim
];
544 if (n
< loop
->temp_dim
)
545 gcc_assert (integer_zerop (loop
->from
[n
]));
548 /* Callee allocated arrays may not have a known bound yet. */
550 loop
->to
[n
] = fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
551 loop
->to
[n
], loop
->from
[n
]));
552 loop
->from
[n
] = gfc_index_zero_node
;
555 info
->delta
[dim
] = gfc_index_zero_node
;
556 info
->start
[dim
] = gfc_index_zero_node
;
557 info
->stride
[dim
] = gfc_index_one_node
;
558 info
->dim
[dim
] = dim
;
561 /* Initialize the descriptor. */
563 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
564 desc
= gfc_create_var (type
, "atmp");
565 GFC_DECL_PACKED_ARRAY (desc
) = 1;
567 info
->descriptor
= desc
;
568 size
= gfc_index_one_node
;
570 /* Fill in the array dtype. */
571 tmp
= gfc_conv_descriptor_dtype (desc
);
572 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
575 Fill in the bounds and stride. This is a packed array, so:
578 for (n = 0; n < rank; n++)
581 delta = ubound[n] + 1 - lbound[n];
584 size = size * sizeof(element);
587 for (n
= 0; n
< info
->dimen
; n
++)
589 if (loop
->to
[n
] == NULL_TREE
)
591 /* For a callee allocated array express the loop bounds in terms
592 of the descriptor fields. */
593 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
594 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
595 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
601 /* Store the stride and bound components in the descriptor. */
602 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
603 gfc_add_modify_expr (&loop
->pre
, tmp
, size
);
605 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
606 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
608 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
609 gfc_add_modify_expr (&loop
->pre
, tmp
, loop
->to
[n
]);
611 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
612 loop
->to
[n
], gfc_index_one_node
));
614 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
615 size
= gfc_evaluate_now (size
, &loop
->pre
);
618 /* Get the size of the array. */
621 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
,
622 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
624 gfc_trans_allocate_array_storage (loop
, info
, size
, nelem
);
626 if (info
->dimen
> loop
->temp_dim
)
627 loop
->temp_dim
= info
->dimen
;
633 /* Make sure offset is a variable. */
636 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
639 /* We should have already created the offset variable. We cannot
640 create it here because we may be in an inner scope. */
641 gcc_assert (*offsetvar
!= NULL_TREE
);
642 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
643 *poffset
= *offsetvar
;
644 TREE_USED (*offsetvar
) = 1;
648 /* Assign an element of an array constructor. */
651 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree pointer
,
652 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
657 gfc_conv_expr (se
, expr
);
659 /* Store the value. */
660 tmp
= gfc_build_indirect_ref (pointer
);
661 tmp
= gfc_build_array_ref (tmp
, offset
);
662 if (expr
->ts
.type
== BT_CHARACTER
)
664 gfc_conv_string_parameter (se
);
665 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
667 /* The temporary is an array of pointers. */
668 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
669 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
673 /* The temporary is an array of string values. */
674 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
675 /* We know the temporary and the value will be the same length,
676 so can use memcpy. */
677 args
= gfc_chainon_list (NULL_TREE
, tmp
);
678 args
= gfc_chainon_list (args
, se
->expr
);
679 args
= gfc_chainon_list (args
, se
->string_length
);
680 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
681 tmp
= gfc_build_function_call (tmp
, args
);
682 gfc_add_expr_to_block (&se
->pre
, tmp
);
687 /* TODO: Should the frontend already have done this conversion? */
688 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
689 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
692 gfc_add_block_to_block (pblock
, &se
->pre
);
693 gfc_add_block_to_block (pblock
, &se
->post
);
697 /* Add the contents of an array to the constructor. */
700 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
701 tree type ATTRIBUTE_UNUSED
,
702 tree pointer
, gfc_expr
* expr
,
703 tree
* poffset
, tree
* offsetvar
)
711 /* We need this to be a variable so we can increment it. */
712 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
714 gfc_init_se (&se
, NULL
);
716 /* Walk the array expression. */
717 ss
= gfc_walk_expr (expr
);
718 gcc_assert (ss
!= gfc_ss_terminator
);
720 /* Initialize the scalarizer. */
721 gfc_init_loopinfo (&loop
);
722 gfc_add_ss_to_loop (&loop
, ss
);
724 /* Initialize the loop. */
725 gfc_conv_ss_startstride (&loop
);
726 gfc_conv_loop_setup (&loop
);
728 /* Make the loop body. */
729 gfc_mark_ss_chain_used (ss
, 1);
730 gfc_start_scalarized_body (&loop
, &body
);
731 gfc_copy_loopinfo_to_se (&se
, &loop
);
734 if (expr
->ts
.type
== BT_CHARACTER
)
735 gfc_todo_error ("character arrays in constructors");
737 gfc_trans_array_ctor_element (&body
, pointer
, *poffset
, &se
, expr
);
738 gcc_assert (se
.ss
== gfc_ss_terminator
);
740 /* Increment the offset. */
741 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
742 gfc_add_modify_expr (&body
, *poffset
, tmp
);
744 /* Finish the loop. */
745 gfc_trans_scalarizing_loops (&loop
, &body
);
746 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
747 tmp
= gfc_finish_block (&loop
.pre
);
748 gfc_add_expr_to_block (pblock
, tmp
);
750 gfc_cleanup_loop (&loop
);
754 /* Assign the values to the elements of an array constructor. */
757 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
758 tree pointer
, gfc_constructor
* c
,
759 tree
* poffset
, tree
* offsetvar
)
766 for (; c
; c
= c
->next
)
768 /* If this is an iterator or an array, the offset must be a variable. */
769 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
770 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
772 gfc_start_block (&body
);
774 if (c
->expr
->expr_type
== EXPR_ARRAY
)
776 /* Array constructors can be nested. */
777 gfc_trans_array_constructor_value (&body
, type
, pointer
,
778 c
->expr
->value
.constructor
,
781 else if (c
->expr
->rank
> 0)
783 gfc_trans_array_constructor_subarray (&body
, type
, pointer
,
784 c
->expr
, poffset
, offsetvar
);
788 /* This code really upsets the gimplifier so don't bother for now. */
795 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
803 gfc_init_se (&se
, NULL
);
804 gfc_trans_array_ctor_element (&body
, pointer
, *poffset
, &se
,
807 *poffset
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
808 *poffset
, gfc_index_one_node
));
812 /* Collect multiple scalar constants into a constructor. */
820 /* Count the number of consecutive scalar constants. */
821 while (p
&& !(p
->iterator
822 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
824 gfc_init_se (&se
, NULL
);
825 gfc_conv_constant (&se
, p
->expr
);
826 if (p
->expr
->ts
.type
== BT_CHARACTER
827 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
828 (TREE_TYPE (pointer
)))))
830 /* For constant character array constructors we build
831 an array of pointers. */
832 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
836 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
841 bound
= build_int_cst (NULL_TREE
, n
- 1);
842 /* Create an array type to hold them. */
843 tmptype
= build_range_type (gfc_array_index_type
,
844 gfc_index_zero_node
, bound
);
845 tmptype
= build_array_type (type
, tmptype
);
847 init
= build1 (CONSTRUCTOR
, tmptype
, nreverse (list
));
848 TREE_CONSTANT (init
) = 1;
849 TREE_INVARIANT (init
) = 1;
850 TREE_STATIC (init
) = 1;
851 /* Create a static variable to hold the data. */
852 tmp
= gfc_create_var (tmptype
, "data");
853 TREE_STATIC (tmp
) = 1;
854 TREE_CONSTANT (tmp
) = 1;
855 TREE_INVARIANT (tmp
) = 1;
856 DECL_INITIAL (tmp
) = init
;
859 /* Use BUILTIN_MEMCPY to assign the values. */
860 tmp
= gfc_build_indirect_ref (pointer
);
861 tmp
= gfc_build_array_ref (tmp
, *poffset
);
862 tmp
= gfc_build_addr_expr (NULL
, tmp
);
863 init
= gfc_build_addr_expr (NULL
, init
);
865 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
866 bound
= build_int_cst (NULL_TREE
, n
* size
);
867 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
868 tmp
= gfc_chainon_list (tmp
, init
);
869 tmp
= gfc_chainon_list (tmp
, bound
);
870 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_MEMCPY
],
872 gfc_add_expr_to_block (&body
, tmp
);
874 *poffset
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
877 if (!INTEGER_CST_P (*poffset
))
879 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
880 *poffset
= *offsetvar
;
884 /* The frontend should already have done any expansions. */
892 loopbody
= gfc_finish_block (&body
);
894 gfc_init_se (&se
, NULL
);
895 gfc_conv_expr (&se
, c
->iterator
->var
);
896 gfc_add_block_to_block (pblock
, &se
.pre
);
899 /* Initialize the loop. */
900 gfc_init_se (&se
, NULL
);
901 gfc_conv_expr_val (&se
, c
->iterator
->start
);
902 gfc_add_block_to_block (pblock
, &se
.pre
);
903 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
905 gfc_init_se (&se
, NULL
);
906 gfc_conv_expr_val (&se
, c
->iterator
->end
);
907 gfc_add_block_to_block (pblock
, &se
.pre
);
908 end
= gfc_evaluate_now (se
.expr
, pblock
);
910 gfc_init_se (&se
, NULL
);
911 gfc_conv_expr_val (&se
, c
->iterator
->step
);
912 gfc_add_block_to_block (pblock
, &se
.pre
);
913 step
= gfc_evaluate_now (se
.expr
, pblock
);
915 /* Generate the loop body. */
916 exit_label
= gfc_build_label_decl (NULL_TREE
);
917 gfc_start_block (&body
);
919 /* Generate the exit condition. */
920 end
= build2 (GT_EXPR
, boolean_type_node
, loopvar
, end
);
921 tmp
= build1_v (GOTO_EXPR
, exit_label
);
922 TREE_USED (exit_label
) = 1;
923 tmp
= build3_v (COND_EXPR
, end
, tmp
, build_empty_stmt ());
924 gfc_add_expr_to_block (&body
, tmp
);
926 /* The main loop body. */
927 gfc_add_expr_to_block (&body
, loopbody
);
929 /* Increment the loop variable. */
930 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
931 gfc_add_modify_expr (&body
, loopvar
, tmp
);
933 /* Finish the loop. */
934 tmp
= gfc_finish_block (&body
);
935 tmp
= build1_v (LOOP_EXPR
, tmp
);
936 gfc_add_expr_to_block (pblock
, tmp
);
938 /* Add the exit label. */
939 tmp
= build1_v (LABEL_EXPR
, exit_label
);
940 gfc_add_expr_to_block (pblock
, tmp
);
944 /* Pass the code as is. */
945 tmp
= gfc_finish_block (&body
);
946 gfc_add_expr_to_block (pblock
, tmp
);
952 /* Get the size of an expression. Returns -1 if the size isn't constant.
953 Implied do loops with non-constant bounds are tricky because we must only
954 evaluate the bounds once. */
957 gfc_get_array_cons_size (mpz_t
* size
, gfc_constructor
* c
)
963 mpz_set_ui (*size
, 0);
967 for (; c
; c
= c
->next
)
969 if (c
->expr
->expr_type
== EXPR_ARRAY
)
971 /* A nested array constructor. */
972 gfc_get_array_cons_size (&len
, c
->expr
->value
.constructor
);
973 if (mpz_sgn (len
) < 0)
975 mpz_set (*size
, len
);
983 if (c
->expr
->rank
> 0)
985 mpz_set_si (*size
, -1);
997 if (i
->start
->expr_type
!= EXPR_CONSTANT
998 || i
->end
->expr_type
!= EXPR_CONSTANT
999 || i
->step
->expr_type
!= EXPR_CONSTANT
)
1001 mpz_set_si (*size
, -1);
1007 mpz_add (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1008 mpz_tdiv_q (val
, val
, i
->step
->value
.integer
);
1009 mpz_add_ui (val
, val
, 1);
1010 mpz_mul (len
, len
, val
);
1012 mpz_add (*size
, *size
, len
);
1019 /* Figure out the string length of a variable reference expression.
1020 Used by get_array_ctor_strlen. */
1023 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1028 /* Don't bother if we already know the length is a constant. */
1029 if (*len
&& INTEGER_CST_P (*len
))
1032 ts
= &expr
->symtree
->n
.sym
->ts
;
1033 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1038 /* Array references don't change teh sting length. */
1042 /* Use the length of the component. */
1043 ts
= &ref
->u
.c
.component
->ts
;
1047 /* TODO: Substrings are tricky because we can't evaluate the
1048 expression more than once. For now we just give up, and hope
1049 we can figure it out elsewhere. */
1054 *len
= ts
->cl
->backend_decl
;
1058 /* Figure out the string length of a character array constructor.
1059 Returns TRUE if all elements are character constants. */
1062 get_array_ctor_strlen (gfc_constructor
* c
, tree
* len
)
1067 for (; c
; c
= c
->next
)
1069 switch (c
->expr
->expr_type
)
1072 if (!(*len
&& INTEGER_CST_P (*len
)))
1073 *len
= build_int_cstu (gfc_charlen_type_node
,
1074 c
->expr
->value
.character
.length
);
1078 if (!get_array_ctor_strlen (c
->expr
->value
.constructor
, len
))
1084 get_array_ctor_var_strlen (c
->expr
, len
);
1089 /* TODO: For now we just ignore anything we don't know how to
1090 handle, and hope we can figure it out a different way. */
1099 /* Array constructors are handled by constructing a temporary, then using that
1100 within the scalarization loop. This is not optimal, but seems by far the
1104 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1113 ss
->data
.info
.dimen
= loop
->dimen
;
1115 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1117 const_string
= get_array_ctor_strlen (ss
->expr
->value
.constructor
,
1118 &ss
->string_length
);
1119 if (!ss
->string_length
)
1120 gfc_todo_error ("complex character array constructors");
1122 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1124 type
= build_pointer_type (type
);
1128 const_string
= TRUE
;
1129 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1132 size
= gfc_trans_allocate_temp_array (loop
, &ss
->data
.info
, type
);
1134 desc
= ss
->data
.info
.descriptor
;
1135 offset
= gfc_index_zero_node
;
1136 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1137 TREE_USED (offsetvar
) = 0;
1138 gfc_trans_array_constructor_value (&loop
->pre
, type
,
1140 ss
->expr
->value
.constructor
, &offset
,
1143 if (TREE_USED (offsetvar
))
1144 pushdecl (offsetvar
);
1146 gcc_assert (INTEGER_CST_P (offset
));
1148 /* Disable bound checking for now because it's probably broken. */
1149 if (flag_bounds_check
)
1157 /* Add the pre and post chains for all the scalar expressions in a SS chain
1158 to loop. This is called after the loop parameters have been calculated,
1159 but before the actual scalarizing loops. */
1162 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1167 /* TODO: This can generate bad code if there are ordering dependencies.
1168 eg. a callee allocated function and an unknown size constructor. */
1169 gcc_assert (ss
!= NULL
);
1171 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1178 /* Scalar expression. Evaluate this now. This includes elemental
1179 dimension indices, but not array section bounds. */
1180 gfc_init_se (&se
, NULL
);
1181 gfc_conv_expr (&se
, ss
->expr
);
1182 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1184 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1186 /* Move the evaluation of scalar expressions outside the
1187 scalarization loop. */
1189 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1190 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1191 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1194 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1196 ss
->data
.scalar
.expr
= se
.expr
;
1197 ss
->string_length
= se
.string_length
;
1200 case GFC_SS_REFERENCE
:
1201 /* Scalar reference. Evaluate this now. */
1202 gfc_init_se (&se
, NULL
);
1203 gfc_conv_expr_reference (&se
, ss
->expr
);
1204 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1205 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1207 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1208 ss
->string_length
= se
.string_length
;
1211 case GFC_SS_SECTION
:
1213 /* Scalarized expression. Evaluate any scalar subscripts. */
1214 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1216 /* Add the expressions for scalar subscripts. */
1217 if (ss
->data
.info
.subscript
[n
])
1218 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1222 case GFC_SS_INTRINSIC
:
1223 gfc_add_intrinsic_ss_code (loop
, ss
);
1226 case GFC_SS_FUNCTION
:
1227 /* Array function return value. We call the function and save its
1228 result in a temporary for use inside the loop. */
1229 gfc_init_se (&se
, NULL
);
1232 gfc_conv_expr (&se
, ss
->expr
);
1233 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1234 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1237 case GFC_SS_CONSTRUCTOR
:
1238 gfc_trans_array_constructor (loop
, ss
);
1242 case GFC_SS_COMPONENT
:
1243 /* Do nothing. These are handled elsewhere. */
1253 /* Translate expressions for the descriptor and data pointer of a SS. */
1257 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1262 /* Get the descriptor for the array to be scalarized. */
1263 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1264 gfc_init_se (&se
, NULL
);
1265 se
.descriptor_only
= 1;
1266 gfc_conv_expr_lhs (&se
, ss
->expr
);
1267 gfc_add_block_to_block (block
, &se
.pre
);
1268 ss
->data
.info
.descriptor
= se
.expr
;
1269 ss
->string_length
= se
.string_length
;
1273 /* Also the data pointer. */
1274 tmp
= gfc_conv_array_data (se
.expr
);
1275 /* If this is a variable or address of a variable we use it directly.
1276 Otherwise we must evaluate it now to to avoid break dependency
1277 analysis by pulling the expressions for elemental array indices
1280 || (TREE_CODE (tmp
) == ADDR_EXPR
1281 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1282 tmp
= gfc_evaluate_now (tmp
, block
);
1283 ss
->data
.info
.data
= tmp
;
1285 tmp
= gfc_conv_array_offset (se
.expr
);
1286 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1291 /* Initialize a gfc_loopinfo structure. */
1294 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1298 memset (loop
, 0, sizeof (gfc_loopinfo
));
1299 gfc_init_block (&loop
->pre
);
1300 gfc_init_block (&loop
->post
);
1302 /* Initially scalarize in order. */
1303 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1306 loop
->ss
= gfc_ss_terminator
;
1310 /* Copies the loop variable info to a gfc_se sructure. Does not copy the SS
1314 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1320 /* Return an expression for the data pointer of an array. */
1323 gfc_conv_array_data (tree descriptor
)
1327 type
= TREE_TYPE (descriptor
);
1328 if (GFC_ARRAY_TYPE_P (type
))
1330 if (TREE_CODE (type
) == POINTER_TYPE
)
1334 /* Descriptorless arrays. */
1335 return gfc_build_addr_expr (NULL
, descriptor
);
1339 return gfc_conv_descriptor_data (descriptor
);
1343 /* Return an expression for the base offset of an array. */
1346 gfc_conv_array_offset (tree descriptor
)
1350 type
= TREE_TYPE (descriptor
);
1351 if (GFC_ARRAY_TYPE_P (type
))
1352 return GFC_TYPE_ARRAY_OFFSET (type
);
1354 return gfc_conv_descriptor_offset (descriptor
);
1358 /* Get an expression for the array stride. */
1361 gfc_conv_array_stride (tree descriptor
, int dim
)
1366 type
= TREE_TYPE (descriptor
);
1368 /* For descriptorless arrays use the array size. */
1369 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1370 if (tmp
!= NULL_TREE
)
1373 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1378 /* Like gfc_conv_array_stride, but for the lower bound. */
1381 gfc_conv_array_lbound (tree descriptor
, int dim
)
1386 type
= TREE_TYPE (descriptor
);
1388 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1389 if (tmp
!= NULL_TREE
)
1392 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1397 /* Like gfc_conv_array_stride, but for the upper bound. */
1400 gfc_conv_array_ubound (tree descriptor
, int dim
)
1405 type
= TREE_TYPE (descriptor
);
1407 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1408 if (tmp
!= NULL_TREE
)
1411 /* This should only ever happen when passing an assumed shape array
1412 as an actual parameter. The value will never be used. */
1413 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1414 return gfc_index_zero_node
;
1416 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1421 /* Translate an array reference. The descriptor should be in se->expr.
1422 Do not use this function, it wil be removed soon. */
1426 gfc_conv_array_index_ref (gfc_se
* se
, tree pointer
, tree
* indices
,
1427 tree offset
, int dimen
)
1434 array
= gfc_build_indirect_ref (pointer
);
1437 for (n
= 0; n
< dimen
; n
++)
1439 /* index = index + stride[n]*indices[n] */
1440 tmp
= gfc_conv_array_stride (se
->expr
, n
);
1441 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, indices
[n
], tmp
));
1443 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1446 /* Result = data[index]. */
1447 tmp
= gfc_build_array_ref (array
, index
);
1449 /* Check we've used the correct number of dimensions. */
1450 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) != ARRAY_TYPE
);
1456 /* Generate code to perform an array index bound check. */
1459 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
)
1465 if (!flag_bounds_check
)
1468 index
= gfc_evaluate_now (index
, &se
->pre
);
1469 /* Check lower bound. */
1470 tmp
= gfc_conv_array_lbound (descriptor
, n
);
1471 fault
= fold (build2 (LT_EXPR
, boolean_type_node
, index
, tmp
));
1472 /* Check upper bound. */
1473 tmp
= gfc_conv_array_ubound (descriptor
, n
);
1474 cond
= fold (build2 (GT_EXPR
, boolean_type_node
, index
, tmp
));
1475 fault
= fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1477 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1483 /* A reference to an array vector subscript. Uses recursion to handle nested
1484 vector subscripts. */
1487 gfc_conv_vector_array_index (gfc_se
* se
, tree index
, gfc_ss
* ss
)
1490 tree indices
[GFC_MAX_DIMENSIONS
];
1495 gcc_assert (ss
&& ss
->type
== GFC_SS_VECTOR
);
1497 /* Save the descriptor. */
1498 descsave
= se
->expr
;
1499 info
= &ss
->data
.info
;
1500 se
->expr
= info
->descriptor
;
1502 ar
= &info
->ref
->u
.ar
;
1503 for (n
= 0; n
< ar
->dimen
; n
++)
1505 switch (ar
->dimen_type
[n
])
1508 gcc_assert (info
->subscript
[n
] != gfc_ss_terminator
1509 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
1510 indices
[n
] = info
->subscript
[n
]->data
.scalar
.expr
;
1518 index
= gfc_conv_vector_array_index (se
, index
, info
->subscript
[n
]);
1521 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, n
);
1528 /* Get the index from the vector. */
1529 gfc_conv_array_index_ref (se
, info
->data
, indices
, info
->offset
, ar
->dimen
);
1531 /* Put the descriptor back. */
1532 se
->expr
= descsave
;
1538 /* Return the offset for an index. Performs bound checking for elemental
1539 dimensions. Single element references are processed seperately. */
1542 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
1543 gfc_array_ref
* ar
, tree stride
)
1547 /* Get the index into the array for this dimension. */
1550 gcc_assert (ar
->type
!= AR_ELEMENT
);
1551 if (ar
->dimen_type
[dim
] == DIMEN_ELEMENT
)
1553 gcc_assert (i
== -1);
1554 /* Elemental dimension. */
1555 gcc_assert (info
->subscript
[dim
]
1556 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
1557 /* We've already translated this value outside the loop. */
1558 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
1561 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, dim
);
1565 /* Scalarized dimension. */
1566 gcc_assert (info
&& se
->loop
);
1568 /* Multiply the loop variable by the stride and dela. */
1569 index
= se
->loop
->loopvar
[i
];
1570 index
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, index
,
1572 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
1575 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
1577 /* Handle vector subscripts. */
1578 index
= gfc_conv_vector_array_index (se
, index
,
1579 info
->subscript
[dim
]);
1581 gfc_trans_array_bound_check (se
, info
->descriptor
, index
,
1585 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
);
1590 /* Temporary array or derived type component. */
1591 gcc_assert (se
->loop
);
1592 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
1593 if (!integer_zerop (info
->delta
[i
]))
1594 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1595 index
, info
->delta
[i
]));
1598 /* Multiply by the stride. */
1599 index
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
));
1605 /* Build a scalarized reference to an array. */
1608 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1615 info
= &se
->ss
->data
.info
;
1617 n
= se
->loop
->order
[0];
1621 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
1623 /* Add the offset for this dimension to the stored offset for all other
1625 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
));
1627 tmp
= gfc_build_indirect_ref (info
->data
);
1628 se
->expr
= gfc_build_array_ref (tmp
, index
);
1632 /* Translate access of temporary array. */
1635 gfc_conv_tmp_array_ref (gfc_se
* se
)
1637 se
->string_length
= se
->ss
->string_length
;
1638 gfc_conv_scalarized_array_ref (se
, NULL
);
1642 /* Build an array reference. se->expr already holds the array descriptor.
1643 This should be either a variable, indirect variable reference or component
1644 reference. For arrays which do not have a descriptor, se->expr will be
1646 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1649 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1658 /* Handle scalarized references seperately. */
1659 if (ar
->type
!= AR_ELEMENT
)
1661 gfc_conv_scalarized_array_ref (se
, ar
);
1665 index
= gfc_index_zero_node
;
1667 fault
= gfc_index_zero_node
;
1669 /* Calculate the offsets from all the dimensions. */
1670 for (n
= 0; n
< ar
->dimen
; n
++)
1672 /* Calculate the index for this dimension. */
1673 gfc_init_se (&indexse
, NULL
);
1674 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
1675 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
1677 if (flag_bounds_check
)
1679 /* Check array bounds. */
1682 indexse
.expr
= gfc_evaluate_now (indexse
.expr
, &se
->pre
);
1684 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
1685 cond
= fold (build2 (LT_EXPR
, boolean_type_node
,
1686 indexse
.expr
, tmp
));
1688 fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1690 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
1691 cond
= fold (build2 (GT_EXPR
, boolean_type_node
,
1692 indexse
.expr
, tmp
));
1694 fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1697 /* Multiply the index by the stride. */
1698 stride
= gfc_conv_array_stride (se
->expr
, n
);
1699 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
1702 /* And add it to the total. */
1703 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1706 if (flag_bounds_check
)
1707 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1709 tmp
= gfc_conv_array_offset (se
->expr
);
1710 if (!integer_zerop (tmp
))
1711 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1713 /* Access the calculated element. */
1714 tmp
= gfc_conv_array_data (se
->expr
);
1715 tmp
= gfc_build_indirect_ref (tmp
);
1716 se
->expr
= gfc_build_array_ref (tmp
, index
);
1720 /* Generate the code to be executed immediately before entering a
1721 scalarization loop. */
1724 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
1725 stmtblock_t
* pblock
)
1734 /* This code will be executed before entering the scalarization loop
1735 for this dimension. */
1736 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1738 if ((ss
->useflags
& flag
) == 0)
1741 if (ss
->type
!= GFC_SS_SECTION
1742 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1743 && ss
->type
!= GFC_SS_COMPONENT
)
1746 info
= &ss
->data
.info
;
1748 if (dim
>= info
->dimen
)
1751 if (dim
== info
->dimen
- 1)
1753 /* For the outermost loop calculate the offset due to any
1754 elemental dimensions. It will have been initialized with the
1755 base offset of the array. */
1758 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
1760 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1763 gfc_init_se (&se
, NULL
);
1765 se
.expr
= info
->descriptor
;
1766 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
1767 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
1770 gfc_add_block_to_block (pblock
, &se
.pre
);
1772 info
->offset
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1773 info
->offset
, index
));
1774 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1778 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1781 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
1783 /* Calculate the stride of the innermost loop. Hopefully this will
1784 allow the backend optimizers to do their stuff more effectively.
1786 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
1790 /* Add the offset for the previous loop dimension. */
1795 ar
= &info
->ref
->u
.ar
;
1796 i
= loop
->order
[dim
+ 1];
1804 gfc_init_se (&se
, NULL
);
1806 se
.expr
= info
->descriptor
;
1807 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1808 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
1810 gfc_add_block_to_block (pblock
, &se
.pre
);
1811 info
->offset
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1812 info
->offset
, index
));
1813 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1816 /* Remeber this offset for the second loop. */
1817 if (dim
== loop
->temp_dim
- 1)
1818 info
->saved_offset
= info
->offset
;
1823 /* Start a scalarized expression. Creates a scope and declares loop
1827 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
1833 gcc_assert (!loop
->array_parameter
);
1835 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
1837 n
= loop
->order
[dim
];
1839 gfc_start_block (&loop
->code
[n
]);
1841 /* Create the loop variable. */
1842 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
1844 if (dim
< loop
->temp_dim
)
1848 /* Calculate values that will be constant within this loop. */
1849 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
1851 gfc_start_block (pbody
);
1855 /* Generates the actual loop code for a scalarization loop. */
1858 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
1859 stmtblock_t
* pbody
)
1867 loopbody
= gfc_finish_block (pbody
);
1869 /* Initialize the loopvar. */
1870 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
1872 exit_label
= gfc_build_label_decl (NULL_TREE
);
1874 /* Generate the loop body. */
1875 gfc_init_block (&block
);
1877 /* The exit condition. */
1878 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
1879 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1880 TREE_USED (exit_label
) = 1;
1881 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1882 gfc_add_expr_to_block (&block
, tmp
);
1884 /* The main body. */
1885 gfc_add_expr_to_block (&block
, loopbody
);
1887 /* Increment the loopvar. */
1888 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1889 loop
->loopvar
[n
], gfc_index_one_node
);
1890 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
1892 /* Build the loop. */
1893 tmp
= gfc_finish_block (&block
);
1894 tmp
= build1_v (LOOP_EXPR
, tmp
);
1895 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1897 /* Add the exit label. */
1898 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1899 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1903 /* Finishes and generates the loops for a scalarized expression. */
1906 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1911 stmtblock_t
*pblock
;
1915 /* Generate the loops. */
1916 for (dim
= 0; dim
< loop
->dimen
; dim
++)
1918 n
= loop
->order
[dim
];
1919 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1920 loop
->loopvar
[n
] = NULL_TREE
;
1921 pblock
= &loop
->code
[n
];
1924 tmp
= gfc_finish_block (pblock
);
1925 gfc_add_expr_to_block (&loop
->pre
, tmp
);
1927 /* Clear all the used flags. */
1928 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
1933 /* Finish the main body of a scalarized expression, and start the secondary
1937 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1941 stmtblock_t
*pblock
;
1945 /* We finish as many loops as are used by the temporary. */
1946 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
1948 n
= loop
->order
[dim
];
1949 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1950 loop
->loopvar
[n
] = NULL_TREE
;
1951 pblock
= &loop
->code
[n
];
1954 /* We don't want to finish the outermost loop entirely. */
1955 n
= loop
->order
[loop
->temp_dim
- 1];
1956 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1958 /* Restore the initial offsets. */
1959 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1961 if ((ss
->useflags
& 2) == 0)
1964 if (ss
->type
!= GFC_SS_SECTION
1965 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1966 && ss
->type
!= GFC_SS_COMPONENT
)
1969 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
1972 /* Restart all the inner loops we just finished. */
1973 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
1975 n
= loop
->order
[dim
];
1977 gfc_start_block (&loop
->code
[n
]);
1979 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
1981 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
1984 /* Start a block for the secondary copying code. */
1985 gfc_start_block (body
);
1989 /* Calculate the upper bound of an array section. */
1992 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2001 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2003 /* For vector array subscripts we want the size of the vector. */
2004 dim
= ss
->data
.info
.dim
[n
];
2006 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2008 vecss
= vecss
->data
.info
.subscript
[dim
];
2009 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2010 dim
= vecss
->data
.info
.dim
[0];
2013 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2014 end
= vecss
->data
.info
.ref
->u
.ar
.end
[dim
];
2015 desc
= vecss
->data
.info
.descriptor
;
2019 /* The upper bound was specified. */
2020 gfc_init_se (&se
, NULL
);
2021 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2022 gfc_add_block_to_block (pblock
, &se
.pre
);
2027 /* No upper bound was specified, so use the bound of the array. */
2028 bound
= gfc_conv_array_ubound (desc
, dim
);
2035 /* Calculate the lower bound of an array section. */
2038 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2048 info
= &ss
->data
.info
;
2052 /* For vector array subscripts we want the size of the vector. */
2054 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2056 vecss
= vecss
->data
.info
.subscript
[dim
];
2057 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2058 /* Get the descriptors for the vector subscripts as well. */
2059 if (!vecss
->data
.info
.descriptor
)
2060 gfc_conv_ss_descriptor (&loop
->pre
, vecss
, !loop
->array_parameter
);
2061 dim
= vecss
->data
.info
.dim
[0];
2064 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2065 start
= vecss
->data
.info
.ref
->u
.ar
.start
[dim
];
2066 stride
= vecss
->data
.info
.ref
->u
.ar
.stride
[dim
];
2067 desc
= vecss
->data
.info
.descriptor
;
2069 /* Calculate the start of the range. For vector subscripts this will
2070 be the range of the vector. */
2073 /* Specified section start. */
2074 gfc_init_se (&se
, NULL
);
2075 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2076 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2077 info
->start
[n
] = se
.expr
;
2081 /* No lower bound specified so use the bound of the array. */
2082 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2084 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2086 /* Calculate the stride. */
2088 info
->stride
[n
] = gfc_index_one_node
;
2091 gfc_init_se (&se
, NULL
);
2092 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2093 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2094 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2099 /* Calculates the range start and stride for a SS chain. Also gets the
2100 descriptor and data pointer. The range of vector subscripts is the size
2101 of the vector. Array bounds are also checked. */
2104 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2113 /* Determine the rank of the loop. */
2115 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2119 case GFC_SS_SECTION
:
2120 case GFC_SS_CONSTRUCTOR
:
2121 case GFC_SS_FUNCTION
:
2122 case GFC_SS_COMPONENT
:
2123 loop
->dimen
= ss
->data
.info
.dimen
;
2131 if (loop
->dimen
== 0)
2132 gfc_todo_error ("Unable to determine rank of expression");
2135 /* Loop over all the SS in the chain. */
2136 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2138 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2139 ss
->shape
= ss
->expr
->shape
;
2143 case GFC_SS_SECTION
:
2144 /* Get the descriptor for the array. */
2145 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2147 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2148 gfc_conv_section_startstride (loop
, ss
, n
);
2151 case GFC_SS_CONSTRUCTOR
:
2152 case GFC_SS_FUNCTION
:
2153 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2155 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2156 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2165 /* The rest is just runtime bound checking. */
2166 if (flag_bounds_check
)
2172 tree size
[GFC_MAX_DIMENSIONS
];
2176 gfc_start_block (&block
);
2178 fault
= integer_zero_node
;
2179 for (n
= 0; n
< loop
->dimen
; n
++)
2180 size
[n
] = NULL_TREE
;
2182 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2184 if (ss
->type
!= GFC_SS_SECTION
)
2187 /* TODO: range checking for mapped dimensions. */
2188 info
= &ss
->data
.info
;
2190 /* This only checks scalarized dimensions, elemental dimensions are
2192 for (n
= 0; n
< loop
->dimen
; n
++)
2196 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2199 vecss
= vecss
->data
.info
.subscript
[dim
];
2200 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2201 dim
= vecss
->data
.info
.dim
[0];
2203 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2205 desc
= vecss
->data
.info
.descriptor
;
2207 /* Check lower bound. */
2208 bound
= gfc_conv_array_lbound (desc
, dim
);
2209 tmp
= info
->start
[n
];
2210 tmp
= fold (build2 (LT_EXPR
, boolean_type_node
, tmp
, bound
));
2211 fault
= fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2214 /* Check the upper bound. */
2215 bound
= gfc_conv_array_ubound (desc
, dim
);
2216 end
= gfc_conv_section_upper_bound (ss
, n
, &block
);
2217 tmp
= fold (build2 (GT_EXPR
, boolean_type_node
, end
, bound
));
2218 fault
= fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2221 /* Check the section sizes match. */
2222 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2224 tmp
= fold (build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2226 /* We remember the size of the first section, and check all the
2227 others against this. */
2231 fold (build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]));
2233 build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, tmp
);
2236 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2239 gfc_trans_runtime_check (fault
, gfc_strconst_bounds
, &block
);
2241 tmp
= gfc_finish_block (&block
);
2242 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2247 /* Return true if the two SS could be aliased, i.e. both point to the same data
2249 /* TODO: resolve aliases based on frontend expressions. */
2252 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2259 lsym
= lss
->expr
->symtree
->n
.sym
;
2260 rsym
= rss
->expr
->symtree
->n
.sym
;
2261 if (gfc_symbols_could_alias (lsym
, rsym
))
2264 if (rsym
->ts
.type
!= BT_DERIVED
2265 && lsym
->ts
.type
!= BT_DERIVED
)
2268 /* For derived types we must check all the component types. We can ignore
2269 array references as these will have the same base type as the previous
2271 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2273 if (lref
->type
!= REF_COMPONENT
)
2276 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2279 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2282 if (rref
->type
!= REF_COMPONENT
)
2285 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2290 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2292 if (rref
->type
!= REF_COMPONENT
)
2295 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2303 /* Resolve array data dependencies. Creates a temporary if required. */
2304 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2308 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2318 loop
->temp_ss
= NULL
;
2319 aref
= dest
->data
.info
.ref
;
2322 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2324 if (ss
->type
!= GFC_SS_SECTION
)
2327 if (gfc_could_be_alias (dest
, ss
))
2333 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
2335 lref
= dest
->expr
->ref
;
2336 rref
= ss
->expr
->ref
;
2338 nDepend
= gfc_dep_resolver (lref
, rref
);
2340 /* TODO : loop shifting. */
2343 /* Mark the dimensions for LOOP SHIFTING */
2344 for (n
= 0; n
< loop
->dimen
; n
++)
2346 int dim
= dest
->data
.info
.dim
[n
];
2348 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2350 else if (! gfc_is_same_range (&lref
->u
.ar
,
2351 &rref
->u
.ar
, dim
, 0))
2355 /* Put all the dimensions with dependencies in the
2358 for (n
= 0; n
< loop
->dimen
; n
++)
2360 gcc_assert (loop
->order
[n
] == n
);
2362 loop
->order
[dim
++] = n
;
2365 for (n
= 0; n
< loop
->dimen
; n
++)
2368 loop
->order
[dim
++] = n
;
2371 gcc_assert (dim
== loop
->dimen
);
2380 loop
->temp_ss
= gfc_get_ss ();
2381 loop
->temp_ss
->type
= GFC_SS_TEMP
;
2382 loop
->temp_ss
->data
.temp
.type
=
2383 gfc_get_element_type (TREE_TYPE (dest
->data
.info
.descriptor
));
2384 loop
->temp_ss
->string_length
= NULL_TREE
;
2385 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
2386 loop
->temp_ss
->next
= gfc_ss_terminator
;
2387 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
2390 loop
->temp_ss
= NULL
;
2394 /* Initialize the scalarization loop. Creates the loop variables. Determines
2395 the range of the loop variables. Creates a temporary if required.
2396 Calculates how to transform from loop variables to array indices for each
2397 expression. Also generates code for scalar expressions which have been
2398 moved outside the loop. */
2401 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
2406 gfc_ss_info
*specinfo
;
2410 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
2415 for (n
= 0; n
< loop
->dimen
; n
++)
2418 /* We use one SS term, and use that to determine the bounds of the
2419 loop for this dimension. We try to pick the simplest term. */
2420 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2424 /* The frontend has worked out the size for us. */
2429 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
2431 /* An unknown size constructor will always be rank one.
2432 Higher rank constructors will either have known shape,
2433 or still be wrapped in a call to reshape. */
2434 gcc_assert (loop
->dimen
== 1);
2435 /* Try to figure out the size of the constructor. */
2436 /* TODO: avoid this by making the frontend set the shape. */
2437 gfc_get_array_cons_size (&i
, ss
->expr
->value
.constructor
);
2438 /* A negative value means we failed. */
2439 if (mpz_sgn (i
) > 0)
2441 mpz_sub_ui (i
, i
, 1);
2443 gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2449 /* TODO: Pick the best bound if we have a choice between a
2450 function and something else. */
2451 if (ss
->type
== GFC_SS_FUNCTION
)
2457 if (ss
->type
!= GFC_SS_SECTION
)
2461 specinfo
= &loopspec
[n
]->data
.info
;
2464 info
= &ss
->data
.info
;
2466 /* Criteria for choosing a loop specifier (most important first):
2474 /* TODO: Is != constructor correct? */
2475 else if (loopspec
[n
]->type
!= GFC_SS_CONSTRUCTOR
)
2477 if (integer_onep (info
->stride
[n
])
2478 && !integer_onep (specinfo
->stride
[n
]))
2480 else if (INTEGER_CST_P (info
->stride
[n
])
2481 && !INTEGER_CST_P (specinfo
->stride
[n
]))
2483 else if (INTEGER_CST_P (info
->start
[n
])
2484 && !INTEGER_CST_P (specinfo
->start
[n
]))
2486 /* We don't work out the upper bound.
2487 else if (INTEGER_CST_P (info->finish[n])
2488 && ! INTEGER_CST_P (specinfo->finish[n]))
2489 loopspec[n] = ss; */
2494 gfc_todo_error ("Unable to find scalarization loop specifier");
2496 info
= &loopspec
[n
]->data
.info
;
2498 /* Set the extents of this range. */
2499 cshape
= loopspec
[n
]->shape
;
2500 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
2501 && INTEGER_CST_P (info
->stride
[n
]))
2503 loop
->from
[n
] = info
->start
[n
];
2504 mpz_set (i
, cshape
[n
]);
2505 mpz_sub_ui (i
, i
, 1);
2506 /* To = from + (size - 1) * stride. */
2507 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2508 if (!integer_onep (info
->stride
[n
]))
2509 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
,
2510 tmp
, info
->stride
[n
]));
2511 loop
->to
[n
] = fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2512 loop
->from
[n
], tmp
));
2516 loop
->from
[n
] = info
->start
[n
];
2517 switch (loopspec
[n
]->type
)
2519 case GFC_SS_CONSTRUCTOR
:
2520 gcc_assert (info
->dimen
== 1);
2521 gcc_assert (loop
->to
[n
]);
2524 case GFC_SS_SECTION
:
2525 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
2529 case GFC_SS_FUNCTION
:
2530 /* The loop bound will be set when we generate the call. */
2531 gcc_assert (loop
->to
[n
] == NULL_TREE
);
2539 /* Transform everything so we have a simple incrementing variable. */
2540 if (integer_onep (info
->stride
[n
]))
2541 info
->delta
[n
] = gfc_index_zero_node
;
2544 /* Set the delta for this section. */
2545 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
2546 /* Number of iterations is (end - start + step) / step.
2547 with start = 0, this simplifies to
2549 for (i = 0; i<=last; i++){...}; */
2550 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
2551 loop
->to
[n
], loop
->from
[n
]));
2552 tmp
= fold (build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
2553 tmp
, info
->stride
[n
]));
2554 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2555 /* Make the loop variable start at 0. */
2556 loop
->from
[n
] = gfc_index_zero_node
;
2560 /* Add all the scalar code that can be taken out of the loops.
2561 This may include calculating the loop bounds, so do it before
2562 allocating the temporary. */
2563 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
2565 /* If we want a temporary then create it. */
2566 if (loop
->temp_ss
!= NULL
)
2568 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
2569 tmp
= loop
->temp_ss
->data
.temp
.type
;
2570 len
= loop
->temp_ss
->string_length
;
2571 n
= loop
->temp_ss
->data
.temp
.dimen
;
2572 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
2573 loop
->temp_ss
->type
= GFC_SS_SECTION
;
2574 loop
->temp_ss
->data
.info
.dimen
= n
;
2575 gfc_trans_allocate_temp_array (loop
, &loop
->temp_ss
->data
.info
, tmp
);
2578 for (n
= 0; n
< loop
->temp_dim
; n
++)
2579 loopspec
[loop
->order
[n
]] = NULL
;
2583 /* For array parameters we don't have loop variables, so don't calculate the
2585 if (loop
->array_parameter
)
2588 /* Calculate the translation from loop variables to array indices. */
2589 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2591 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
2594 info
= &ss
->data
.info
;
2596 for (n
= 0; n
< info
->dimen
; n
++)
2600 /* If we are specifying the range the delta is already set. */
2601 if (loopspec
[n
] != ss
)
2603 /* Calculate the offset relative to the loop variable.
2604 First multiply by the stride. */
2605 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
,
2606 loop
->from
[n
], info
->stride
[n
]));
2608 /* Then subtract this from our starting value. */
2609 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
2610 info
->start
[n
], tmp
));
2612 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2619 /* Fills in an array descriptor, and returns the size of the array. The size
2620 will be a simple_val, ie a variable or a constant. Also calculates the
2621 offset of the base. Returns the size of the array.
2625 for (n = 0; n < rank; n++)
2627 a.lbound[n] = specified_lower_bound;
2628 offset = offset + a.lbond[n] * stride;
2630 a.ubound[n] = specified_upper_bound;
2631 a.stride[n] = stride;
2632 size = ubound + size; //size = ubound + 1 - lbound
2633 stride = stride * size;
2640 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
2641 gfc_expr
** lower
, gfc_expr
** upper
,
2642 stmtblock_t
* pblock
)
2653 type
= TREE_TYPE (descriptor
);
2655 stride
= gfc_index_one_node
;
2656 offset
= gfc_index_zero_node
;
2658 /* Set the dtype. */
2659 tmp
= gfc_conv_descriptor_dtype (descriptor
);
2660 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
2662 for (n
= 0; n
< rank
; n
++)
2664 /* We have 3 possibilities for determining the size of the array:
2665 lower == NULL => lbound = 1, ubound = upper[n]
2666 upper[n] = NULL => lbound = 1, ubound = lower[n]
2667 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2670 /* Set lower bound. */
2671 gfc_init_se (&se
, NULL
);
2673 se
.expr
= gfc_index_one_node
;
2676 gcc_assert (lower
[n
]);
2679 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
2680 gfc_add_block_to_block (pblock
, &se
.pre
);
2684 se
.expr
= gfc_index_one_node
;
2688 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
2689 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2691 /* Work out the offset for this component. */
2692 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
));
2693 offset
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
2695 /* Start the calculation for the size of this dimension. */
2696 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
2697 gfc_index_one_node
, se
.expr
);
2699 /* Set upper bound. */
2700 gfc_init_se (&se
, NULL
);
2701 gcc_assert (ubound
);
2702 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
2703 gfc_add_block_to_block (pblock
, &se
.pre
);
2705 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
2706 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2708 /* Store the stride. */
2709 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
2710 gfc_add_modify_expr (pblock
, tmp
, stride
);
2712 /* Calculate the size of this dimension. */
2713 size
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
));
2715 /* Multiply the stride by the number of elements in this dimension. */
2716 stride
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
));
2717 stride
= gfc_evaluate_now (stride
, pblock
);
2720 /* The stride is the number of elements in the array, so multiply by the
2721 size of an element to get the total size. */
2722 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2723 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
));
2725 if (poffset
!= NULL
)
2727 offset
= gfc_evaluate_now (offset
, pblock
);
2731 size
= gfc_evaluate_now (size
, pblock
);
2736 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2737 the work for an ALLOCATE statement. */
2741 gfc_array_allocate (gfc_se
* se
, gfc_ref
* ref
, tree pstat
)
2751 /* Figure out the size of the array. */
2752 switch (ref
->u
.ar
.type
)
2756 upper
= ref
->u
.ar
.start
;
2760 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
2762 lower
= ref
->u
.ar
.as
->lower
;
2763 upper
= ref
->u
.ar
.as
->upper
;
2767 lower
= ref
->u
.ar
.start
;
2768 upper
= ref
->u
.ar
.end
;
2776 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
2777 lower
, upper
, &se
->pre
);
2779 /* Allocate memory to store the data. */
2780 tmp
= gfc_conv_descriptor_data (se
->expr
);
2781 pointer
= gfc_build_addr_expr (NULL
, tmp
);
2782 pointer
= gfc_evaluate_now (pointer
, &se
->pre
);
2784 if (TYPE_PRECISION (gfc_array_index_type
) == 32)
2785 allocate
= gfor_fndecl_allocate
;
2786 else if (TYPE_PRECISION (gfc_array_index_type
) == 64)
2787 allocate
= gfor_fndecl_allocate64
;
2791 tmp
= gfc_chainon_list (NULL_TREE
, pointer
);
2792 tmp
= gfc_chainon_list (tmp
, size
);
2793 tmp
= gfc_chainon_list (tmp
, pstat
);
2794 tmp
= gfc_build_function_call (allocate
, tmp
);
2795 gfc_add_expr_to_block (&se
->pre
, tmp
);
2797 pointer
= gfc_conv_descriptor_data (se
->expr
);
2799 tmp
= gfc_conv_descriptor_offset (se
->expr
);
2800 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
2804 /* Deallocate an array variable. Also used when an allocated variable goes
2809 gfc_array_deallocate (tree descriptor
)
2815 gfc_start_block (&block
);
2816 /* Get a pointer to the data. */
2817 tmp
= gfc_conv_descriptor_data (descriptor
);
2818 tmp
= gfc_build_addr_expr (NULL
, tmp
);
2819 var
= gfc_create_var (TREE_TYPE (tmp
), "ptr");
2820 gfc_add_modify_expr (&block
, var
, tmp
);
2822 /* Parameter is the address of the data component. */
2823 tmp
= gfc_chainon_list (NULL_TREE
, var
);
2824 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
2825 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
2826 gfc_add_expr_to_block (&block
, tmp
);
2828 return gfc_finish_block (&block
);
2832 /* Create an array constructor from an initialization expression.
2833 We assume the frontend already did any expansions and conversions. */
2836 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
2844 unsigned HOST_WIDE_INT lo
;
2848 switch (expr
->expr_type
)
2851 case EXPR_STRUCTURE
:
2852 /* A single scalar or derived type value. Create an array with all
2853 elements equal to that value. */
2854 gfc_init_se (&se
, NULL
);
2856 if (expr
->expr_type
== EXPR_CONSTANT
)
2857 gfc_conv_constant (&se
, expr
);
2859 gfc_conv_structure (&se
, expr
, 1);
2861 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2862 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2863 hi
= TREE_INT_CST_HIGH (tmp
);
2864 lo
= TREE_INT_CST_LOW (tmp
);
2868 /* This will probably eat buckets of memory for large arrays. */
2869 while (hi
!= 0 || lo
!= 0)
2871 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
2879 /* Create a list of all the elements. */
2880 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2884 /* Problems occur when we get something like
2885 integer :: a(lots) = (/(i, i=1,lots)/) */
2886 /* TODO: Unexpanded array initializers. */
2888 ("Possible frontend bug: array constructor not expanded");
2890 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2891 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2895 if (mpz_cmp_si (c
->repeat
, 0) != 0)
2899 mpz_set (maxval
, c
->repeat
);
2900 mpz_add (maxval
, c
->n
.offset
, maxval
);
2901 mpz_sub_ui (maxval
, maxval
, 1);
2902 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2903 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2905 mpz_add_ui (maxval
, c
->n
.offset
, 1);
2906 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2909 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2911 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
2917 gfc_init_se (&se
, NULL
);
2918 switch (c
->expr
->expr_type
)
2921 gfc_conv_constant (&se
, c
->expr
);
2922 if (range
== NULL_TREE
)
2923 list
= tree_cons (index
, se
.expr
, list
);
2926 if (index
!= NULL_TREE
)
2927 list
= tree_cons (index
, se
.expr
, list
);
2928 list
= tree_cons (range
, se
.expr
, list
);
2932 case EXPR_STRUCTURE
:
2933 gfc_conv_structure (&se
, c
->expr
, 1);
2934 list
= tree_cons (index
, se
.expr
, list
);
2941 /* We created the list in reverse order. */
2942 list
= nreverse (list
);
2949 /* Create a constructor from the list of elements. */
2950 tmp
= build1 (CONSTRUCTOR
, type
, list
);
2951 TREE_CONSTANT (tmp
) = 1;
2952 TREE_INVARIANT (tmp
) = 1;
2957 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2958 returns the size (in elements) of the array. */
2961 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
2962 stmtblock_t
* pblock
)
2977 size
= gfc_index_one_node
;
2978 offset
= gfc_index_zero_node
;
2979 for (dim
= 0; dim
< as
->rank
; dim
++)
2981 /* Evaluate non-constant array bound expressions. */
2982 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2983 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
2985 gfc_init_se (&se
, NULL
);
2986 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
2987 gfc_add_block_to_block (pblock
, &se
.pre
);
2988 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
2990 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2991 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
2993 gfc_init_se (&se
, NULL
);
2994 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
2995 gfc_add_block_to_block (pblock
, &se
.pre
);
2996 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
2998 /* The offset of this dimension. offset = offset - lbound * stride. */
2999 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
));
3000 offset
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
3002 /* The size of this dimension, and the stride of the next. */
3003 if (dim
+ 1 < as
->rank
)
3004 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3008 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3010 /* Calculate stride = size * (ubound + 1 - lbound). */
3011 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
3012 gfc_index_one_node
, lbound
));
3013 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
));
3014 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
3016 gfc_add_modify_expr (pblock
, stride
, tmp
);
3018 stride
= gfc_evaluate_now (tmp
, pblock
);
3029 /* Generate code to initialize/allocate an array variable. */
3032 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3042 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3044 /* Do nothing for USEd variables. */
3045 if (sym
->attr
.use_assoc
)
3048 type
= TREE_TYPE (decl
);
3049 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3050 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3052 gfc_start_block (&block
);
3054 /* Evaluate character string length. */
3055 if (sym
->ts
.type
== BT_CHARACTER
3056 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3058 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3060 /* Emit a DECL_EXPR for this variable, which will cause the
3061 gimplifier to allocate storage, and all that good stuff. */
3062 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3063 gfc_add_expr_to_block (&block
, tmp
);
3068 gfc_add_expr_to_block (&block
, fnbody
);
3069 return gfc_finish_block (&block
);
3072 type
= TREE_TYPE (type
);
3074 gcc_assert (!sym
->attr
.use_assoc
);
3075 gcc_assert (!TREE_STATIC (decl
));
3076 gcc_assert (!sym
->module
[0]);
3078 if (sym
->ts
.type
== BT_CHARACTER
3079 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3080 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3082 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3084 /* The size is the number of elements in the array, so multiply by the
3085 size of an element to get the total size. */
3086 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3087 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
3089 /* Allocate memory to hold the data. */
3090 tmp
= gfc_chainon_list (NULL_TREE
, size
);
3092 if (gfc_index_integer_kind
== 4)
3093 fndecl
= gfor_fndecl_internal_malloc
;
3094 else if (gfc_index_integer_kind
== 8)
3095 fndecl
= gfor_fndecl_internal_malloc64
;
3098 tmp
= gfc_build_function_call (fndecl
, tmp
);
3099 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
3100 gfc_add_modify_expr (&block
, decl
, tmp
);
3102 /* Set offset of the array. */
3103 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3104 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3107 /* Automatic arrays should not have initializers. */
3108 gcc_assert (!sym
->value
);
3110 gfc_add_expr_to_block (&block
, fnbody
);
3112 /* Free the temporary. */
3113 tmp
= convert (pvoid_type_node
, decl
);
3114 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3115 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3116 gfc_add_expr_to_block (&block
, tmp
);
3118 return gfc_finish_block (&block
);
3122 /* Generate entry and exit code for g77 calling convention arrays. */
3125 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3134 gfc_get_backend_locus (&loc
);
3135 gfc_set_backend_locus (&sym
->declared_at
);
3137 /* Descriptor type. */
3138 parm
= sym
->backend_decl
;
3139 type
= TREE_TYPE (parm
);
3140 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3142 gfc_start_block (&block
);
3144 if (sym
->ts
.type
== BT_CHARACTER
3145 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3146 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3148 /* Evaluate the bounds of the array. */
3149 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3151 /* Set the offset. */
3152 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3153 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3155 /* Set the pointer itself if we aren't using the parameter directly. */
3156 if (TREE_CODE (parm
) != PARM_DECL
)
3158 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3159 gfc_add_modify_expr (&block
, parm
, tmp
);
3161 tmp
= gfc_finish_block (&block
);
3163 gfc_set_backend_locus (&loc
);
3165 gfc_start_block (&block
);
3166 /* Add the initialization code to the start of the function. */
3167 gfc_add_expr_to_block (&block
, tmp
);
3168 gfc_add_expr_to_block (&block
, body
);
3170 return gfc_finish_block (&block
);
3174 /* Modify the descriptor of an array parameter so that it has the
3175 correct lower bound. Also move the upper bound accordingly.
3176 If the array is not packed, it will be copied into a temporary.
3177 For each dimension we set the new lower and upper bounds. Then we copy the
3178 stride and calculate the offset for this dimension. We also work out
3179 what the stride of a packed array would be, and see it the two match.
3180 If the array need repacking, we set the stride to the values we just
3181 calculated, recalculate the offset and copy the array data.
3182 Code is also added to copy the data back at the end of the function.
3186 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3193 stmtblock_t cleanup
;
3211 /* Do nothing for pointer and allocatable arrays. */
3212 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3215 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3216 return gfc_trans_g77_array (sym
, body
);
3218 gfc_get_backend_locus (&loc
);
3219 gfc_set_backend_locus (&sym
->declared_at
);
3221 /* Descriptor type. */
3222 type
= TREE_TYPE (tmpdesc
);
3223 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3224 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3225 dumdesc
= gfc_build_indirect_ref (dumdesc
);
3226 gfc_start_block (&block
);
3228 if (sym
->ts
.type
== BT_CHARACTER
3229 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3230 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3232 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3234 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3235 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3237 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3239 /* For non-constant shape arrays we only check if the first dimension
3240 is contiguous. Repacking higher dimensions wouldn't gain us
3241 anything as we still don't know the array stride. */
3242 partial
= gfc_create_var (boolean_type_node
, "partial");
3243 TREE_USED (partial
) = 1;
3244 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3245 tmp
= fold (build2 (EQ_EXPR
, boolean_type_node
, tmp
, integer_one_node
));
3246 gfc_add_modify_expr (&block
, partial
, tmp
);
3250 partial
= NULL_TREE
;
3253 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3254 here, however I think it does the right thing. */
3257 /* Set the first stride. */
3258 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3259 stride
= gfc_evaluate_now (stride
, &block
);
3261 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, integer_zero_node
);
3262 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3263 gfc_index_one_node
, stride
);
3264 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3265 gfc_add_modify_expr (&block
, stride
, tmp
);
3267 /* Allow the user to disable array repacking. */
3268 stmt_unpacked
= NULL_TREE
;
3272 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3273 /* A library call to repack the array if necessary. */
3274 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3275 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3276 stmt_unpacked
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3278 stride
= gfc_index_one_node
;
3281 /* This is for the case where the array data is used directly without
3282 calling the repack function. */
3283 if (no_repack
|| partial
!= NULL_TREE
)
3284 stmt_packed
= gfc_conv_descriptor_data (dumdesc
);
3286 stmt_packed
= NULL_TREE
;
3288 /* Assign the data pointer. */
3289 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3291 /* Don't repack unknown shape arrays when the first stride is 1. */
3292 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3293 stmt_packed
, stmt_unpacked
);
3296 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3297 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
3299 offset
= gfc_index_zero_node
;
3300 size
= gfc_index_one_node
;
3302 /* Evaluate the bounds of the array. */
3303 for (n
= 0; n
< sym
->as
->rank
; n
++)
3305 if (checkparm
|| !sym
->as
->upper
[n
])
3307 /* Get the bounds of the actual parameter. */
3308 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3309 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3313 dubound
= NULL_TREE
;
3314 dlbound
= NULL_TREE
;
3317 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3318 if (!INTEGER_CST_P (lbound
))
3320 gfc_init_se (&se
, NULL
);
3321 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3322 gfc_array_index_type
);
3323 gfc_add_block_to_block (&block
, &se
.pre
);
3324 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3327 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3328 /* Set the desired upper bound. */
3329 if (sym
->as
->upper
[n
])
3331 /* We know what we want the upper bound to be. */
3332 if (!INTEGER_CST_P (ubound
))
3334 gfc_init_se (&se
, NULL
);
3335 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3336 gfc_array_index_type
);
3337 gfc_add_block_to_block (&block
, &se
.pre
);
3338 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3341 /* Check the sizes match. */
3344 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3346 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
3348 stride
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3350 tmp
= fold (build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride
));
3351 gfc_trans_runtime_check (tmp
, gfc_strconst_bounds
, &block
);
3356 /* For assumed shape arrays move the upper bound by the same amount
3357 as the lower bound. */
3358 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3359 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
));
3360 gfc_add_modify_expr (&block
, ubound
, tmp
);
3362 /* The offset of this dimension. offset = offset - lbound * stride. */
3363 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
));
3364 offset
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
3366 /* The size of this dimension, and the stride of the next. */
3367 if (n
+ 1 < sym
->as
->rank
)
3369 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3371 if (no_repack
|| partial
!= NULL_TREE
)
3374 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
3377 /* Figure out the stride if not a known constant. */
3378 if (!INTEGER_CST_P (stride
))
3381 stmt_packed
= NULL_TREE
;
3384 /* Calculate stride = size * (ubound + 1 - lbound). */
3385 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
3386 gfc_index_one_node
, lbound
));
3387 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
3389 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
,
3394 /* Assign the stride. */
3395 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3396 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
3397 stmt_unpacked
, stmt_packed
);
3399 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
3400 gfc_add_modify_expr (&block
, stride
, tmp
);
3405 /* Set the offset. */
3406 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3407 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3409 stmt
= gfc_finish_block (&block
);
3411 gfc_start_block (&block
);
3413 /* Only do the entry/initialization code if the arg is present. */
3414 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3415 optional_arg
= sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
;
3418 tmp
= gfc_conv_expr_present (sym
);
3419 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3421 gfc_add_expr_to_block (&block
, stmt
);
3423 /* Add the main function body. */
3424 gfc_add_expr_to_block (&block
, body
);
3429 gfc_start_block (&cleanup
);
3431 if (sym
->attr
.intent
!= INTENT_IN
)
3433 /* Copy the data back. */
3434 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
3435 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
3436 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3437 gfc_add_expr_to_block (&cleanup
, tmp
);
3440 /* Free the temporary. */
3441 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
3442 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3443 gfc_add_expr_to_block (&cleanup
, tmp
);
3445 stmt
= gfc_finish_block (&cleanup
);
3447 /* Only do the cleanup if the array was repacked. */
3448 tmp
= gfc_build_indirect_ref (dumdesc
);
3449 tmp
= gfc_conv_descriptor_data (tmp
);
3450 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
3451 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3455 tmp
= gfc_conv_expr_present (sym
);
3456 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3458 gfc_add_expr_to_block (&block
, stmt
);
3460 /* We don't need to free any memory allocated by internal_pack as it will
3461 be freed at the end of the function by pop_context. */
3462 return gfc_finish_block (&block
);
3466 /* Convert an array for passing as an actual parameter. Expressions and
3467 vector subscripts are evaluated and stored in a temporary, which is then
3468 passed. For whole arrays the descriptor is passed. For array sections
3469 a modified copy of the descriptor is passed, but using the original data.
3470 Also used for array pointer assignments by setting se->direct_byref. */
3473 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
3489 gcc_assert (ss
!= gfc_ss_terminator
);
3491 /* TODO: Pass constant array constructors without a temporary. */
3492 /* Special case things we know we can pass easily. */
3493 switch (expr
->expr_type
)
3496 /* If we have a linear array section, we can pass it directly.
3497 Otherwise we need to copy it into a temporary. */
3499 /* Find the SS for the array section. */
3501 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
3502 secss
= secss
->next
;
3504 gcc_assert (secss
!= gfc_ss_terminator
);
3507 for (n
= 0; n
< secss
->data
.info
.dimen
; n
++)
3509 vss
= secss
->data
.info
.subscript
[secss
->data
.info
.dim
[n
]];
3510 if (vss
&& vss
->type
== GFC_SS_VECTOR
)
3514 info
= &secss
->data
.info
;
3516 /* Get the descriptor for the array. */
3517 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
3518 desc
= info
->descriptor
;
3519 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
3521 /* Create a new descriptor if the array doesn't have one. */
3524 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
3526 else if (se
->direct_byref
)
3531 gcc_assert (ref
->u
.ar
.type
== AR_SECTION
);
3534 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3536 /* Detect passing the full array as a section. This could do
3537 even more checking, but it doesn't seem worth it. */
3538 if (ref
->u
.ar
.start
[n
]
3540 || (ref
->u
.ar
.stride
[n
]
3541 && !gfc_expr_is_one (ref
->u
.ar
.stride
[n
], 0)))
3549 /* Check for substring references. */
3551 if (!need_tmp
&& ref
&& expr
->ts
.type
== BT_CHARACTER
)
3555 if (ref
->type
== REF_SUBSTRING
)
3557 /* In general character substrings need a copy. Character
3558 array strides are expressed as multiples of the element
3559 size (consistent with other array types), not in
3568 if (se
->direct_byref
)
3570 /* Copy the descriptor for pointer assignments. */
3571 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
3573 else if (se
->want_pointer
)
3575 /* We pass full arrays directly. This means that pointers and
3576 allocatable arrays should also work. */
3577 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3584 if (expr
->ts
.type
== BT_CHARACTER
)
3585 se
->string_length
= gfc_get_expr_charlen (expr
);
3592 /* A transformational function return value will be a temporary
3593 array descriptor. We still need to go through the scalarizer
3594 to create the descriptor. Elemental functions ar handled as
3595 arbitary expressions, i.e. copy to a temporary. */
3597 /* Look for the SS for this function. */
3598 while (secss
!= gfc_ss_terminator
3599 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
3600 secss
= secss
->next
;
3602 if (se
->direct_byref
)
3604 gcc_assert (secss
!= gfc_ss_terminator
);
3606 /* For pointer assignments pass the descriptor directly. */
3608 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3609 gfc_conv_expr (se
, expr
);
3613 if (secss
== gfc_ss_terminator
)
3615 /* Elemental function. */
3621 /* Transformational function. */
3622 info
= &secss
->data
.info
;
3628 /* Something complicated. Copy it into a temporary. */
3636 gfc_init_loopinfo (&loop
);
3638 /* Associate the SS with the loop. */
3639 gfc_add_ss_to_loop (&loop
, ss
);
3641 /* Tell the scalarizer not to bother creating loop variables, etc. */
3643 loop
.array_parameter
= 1;
3645 gcc_assert (se
->want_pointer
&& !se
->direct_byref
);
3647 /* Setup the scalarizing loops and bounds. */
3648 gfc_conv_ss_startstride (&loop
);
3652 /* Tell the scalarizer to make a temporary. */
3653 loop
.temp_ss
= gfc_get_ss ();
3654 loop
.temp_ss
->type
= GFC_SS_TEMP
;
3655 loop
.temp_ss
->next
= gfc_ss_terminator
;
3656 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
3657 /* ... which can hold our string, if present. */
3658 if (expr
->ts
.type
== BT_CHARACTER
)
3659 se
->string_length
= loop
.temp_ss
->string_length
3660 = TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
3662 loop
.temp_ss
->string_length
= NULL
;
3663 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
3664 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3667 gfc_conv_loop_setup (&loop
);
3671 /* Copy into a temporary and pass that. We don't need to copy the data
3672 back because expressions and vector subscripts must be INTENT_IN. */
3673 /* TODO: Optimize passing function return values. */
3677 /* Start the copying loops. */
3678 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3679 gfc_mark_ss_chain_used (ss
, 1);
3680 gfc_start_scalarized_body (&loop
, &block
);
3682 /* Copy each data element. */
3683 gfc_init_se (&lse
, NULL
);
3684 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3685 gfc_init_se (&rse
, NULL
);
3686 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3688 lse
.ss
= loop
.temp_ss
;
3691 gfc_conv_scalarized_array_ref (&lse
, NULL
);
3692 gfc_conv_expr_val (&rse
, expr
);
3694 gfc_add_block_to_block (&block
, &rse
.pre
);
3695 gfc_add_block_to_block (&block
, &lse
.pre
);
3697 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
3699 /* Finish the copying loops. */
3700 gfc_trans_scalarizing_loops (&loop
, &block
);
3702 /* Set the first stride component to zero to indicate a temporary. */
3703 desc
= loop
.temp_ss
->data
.info
.descriptor
;
3704 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[0]);
3705 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3707 gcc_assert (is_gimple_lvalue (desc
));
3708 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3710 else if (expr
->expr_type
== EXPR_FUNCTION
)
3712 desc
= info
->descriptor
;
3714 if (se
->want_pointer
)
3715 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3719 if (expr
->ts
.type
== BT_CHARACTER
)
3720 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3724 /* We pass sections without copying to a temporary. Make a new
3725 descriptor and point it at the section we want. The loop variable
3726 limits will be the limits of the section.
3727 A function may decide to repack the array to speed up access, but
3728 we're not bothered about that here. */
3737 /* Set the string_length for a character array. */
3738 if (expr
->ts
.type
== BT_CHARACTER
)
3739 se
->string_length
= gfc_get_expr_charlen (expr
);
3741 desc
= info
->descriptor
;
3742 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
3743 if (se
->direct_byref
)
3745 /* For pointer assignments we fill in the destination. */
3747 parmtype
= TREE_TYPE (parm
);
3751 /* Otherwise make a new one. */
3752 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3753 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
3754 loop
.from
, loop
.to
, 0);
3755 parm
= gfc_create_var (parmtype
, "parm");
3758 offset
= gfc_index_zero_node
;
3761 /* The following can be somewhat confusing. We have two
3762 descriptors, a new one and the original array.
3763 {parm, parmtype, dim} refer to the new one.
3764 {desc, type, n, secss, loop} refer to the original, which maybe
3765 a descriptorless array.
3766 The bounds of the scaralization are the bounds of the section.
3767 We don't have to worry about numeric overflows when calculating
3768 the offsets because all elements are within the array data. */
3770 /* Set the dtype. */
3771 tmp
= gfc_conv_descriptor_dtype (parm
);
3772 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
3774 if (se
->direct_byref
)
3775 base
= gfc_index_zero_node
;
3779 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3781 stride
= gfc_conv_array_stride (desc
, n
);
3783 /* Work out the offset. */
3784 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3786 gcc_assert (info
->subscript
[n
]
3787 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
3788 start
= info
->subscript
[n
]->data
.scalar
.expr
;
3792 /* Check we haven't somehow got out of sync. */
3793 gcc_assert (info
->dim
[dim
] == n
);
3795 /* Evaluate and remember the start of the section. */
3796 start
= info
->start
[dim
];
3797 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
3800 tmp
= gfc_conv_array_lbound (desc
, n
);
3801 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
));
3803 tmp
= fold (build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
));
3804 offset
= fold (build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
));
3806 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3808 /* For elemental dimensions, we only need the offset. */
3812 /* Vector subscripts need copying and are handled elsewhere. */
3813 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
3815 /* Set the new lower bound. */
3816 from
= loop
.from
[dim
];
3818 if (!integer_onep (from
))
3820 /* Make sure the new section starts at 1. */
3821 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
3822 gfc_index_one_node
, from
));
3823 to
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
));
3824 from
= gfc_index_one_node
;
3826 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
3827 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
3829 /* Set the new upper bound. */
3830 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
3831 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
3833 /* Multiply the stride by the section stride to get the
3835 stride
= fold (build2 (MULT_EXPR
, gfc_array_index_type
,
3836 stride
, info
->stride
[dim
]));
3838 if (se
->direct_byref
)
3839 base
= fold (build2 (MINUS_EXPR
, TREE_TYPE (base
),
3842 /* Store the new stride. */
3843 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
3844 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
3849 /* Point the data pointer at the first element in the section. */
3850 tmp
= gfc_conv_array_data (desc
);
3851 tmp
= gfc_build_indirect_ref (tmp
);
3852 tmp
= gfc_build_array_ref (tmp
, offset
);
3853 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
3855 tmp
= gfc_conv_descriptor_data (parm
);
3856 gfc_add_modify_expr (&loop
.pre
, tmp
,
3857 fold_convert (TREE_TYPE (tmp
), offset
));
3859 if (se
->direct_byref
)
3861 /* Set the offset. */
3862 tmp
= gfc_conv_descriptor_offset (parm
);
3863 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
3867 /* Only the callee knows what the correct offset it, so just set
3869 tmp
= gfc_conv_descriptor_offset (parm
);
3870 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3873 if (!se
->direct_byref
)
3875 /* Get a pointer to the new descriptor. */
3876 if (se
->want_pointer
)
3877 se
->expr
= gfc_build_addr_expr (NULL
, parm
);
3883 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3884 gfc_add_block_to_block (&se
->post
, &loop
.post
);
3886 /* Cleanup the scalarizer. */
3887 gfc_cleanup_loop (&loop
);
3891 /* Convert an array for passing as an actual parameter. */
3892 /* TODO: Optimize passing g77 arrays. */
3895 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
3904 /* Passing address of the array if it is not pointer or assumed-shape. */
3905 if (expr
->expr_type
== EXPR_VARIABLE
3906 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
3908 sym
= expr
->symtree
->n
.sym
;
3909 tmp
= gfc_get_symbol_decl (sym
);
3910 if (sym
->ts
.type
== BT_CHARACTER
)
3911 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3912 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
3913 && !sym
->attr
.allocatable
)
3915 /* Some variables are declared directly, others are declared as
3916 pointers and allocated on the heap. */
3917 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
3920 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
3923 if (sym
->attr
.allocatable
)
3925 se
->expr
= gfc_conv_array_data (tmp
);
3930 se
->want_pointer
= 1;
3931 gfc_conv_expr_descriptor (se
, expr
, ss
);
3936 /* Repack the array. */
3937 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3938 ptr
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3939 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
3942 gfc_start_block (&block
);
3944 /* Copy the data back. */
3945 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3946 tmp
= gfc_chainon_list (tmp
, ptr
);
3947 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3948 gfc_add_expr_to_block (&block
, tmp
);
3950 /* Free the temporary. */
3951 tmp
= convert (pvoid_type_node
, ptr
);
3952 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3953 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3954 gfc_add_expr_to_block (&block
, tmp
);
3956 stmt
= gfc_finish_block (&block
);
3958 gfc_init_block (&block
);
3959 /* Only if it was repacked. This code needs to be executed before the
3960 loop cleanup code. */
3961 tmp
= gfc_build_indirect_ref (desc
);
3962 tmp
= gfc_conv_array_data (tmp
);
3963 tmp
= build2 (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
3964 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3966 gfc_add_expr_to_block (&block
, tmp
);
3967 gfc_add_block_to_block (&block
, &se
->post
);
3969 gfc_init_block (&se
->post
);
3970 gfc_add_block_to_block (&se
->post
, &block
);
3975 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3978 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
3985 stmtblock_t fnblock
;
3988 /* Make sure the frontend gets these right. */
3989 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3991 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
3993 gfc_init_block (&fnblock
);
3995 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
);
3996 if (sym
->ts
.type
== BT_CHARACTER
3997 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3998 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
4000 /* Parameter and use associated variables don't need anything special. */
4001 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
4003 gfc_add_expr_to_block (&fnblock
, body
);
4005 return gfc_finish_block (&fnblock
);
4008 gfc_get_backend_locus (&loc
);
4009 gfc_set_backend_locus (&sym
->declared_at
);
4010 descriptor
= sym
->backend_decl
;
4012 if (TREE_STATIC (descriptor
))
4014 /* SAVEd variables are not freed on exit. */
4015 gfc_trans_static_array_pointer (sym
);
4019 /* Get the descriptor type. */
4020 type
= TREE_TYPE (sym
->backend_decl
);
4021 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
4023 /* NULLIFY the data pointer. */
4024 tmp
= gfc_conv_descriptor_data (descriptor
);
4025 gfc_add_modify_expr (&fnblock
, tmp
,
4026 convert (TREE_TYPE (tmp
), integer_zero_node
));
4028 gfc_add_expr_to_block (&fnblock
, body
);
4030 gfc_set_backend_locus (&loc
);
4031 /* Allocatable arrays need to be freed when they go out of scope. */
4032 if (sym
->attr
.allocatable
)
4034 gfc_start_block (&block
);
4036 /* Deallocate if still allocated at the end of the procedure. */
4037 deallocate
= gfc_array_deallocate (descriptor
);
4039 tmp
= gfc_conv_descriptor_data (descriptor
);
4040 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, integer_zero_node
);
4041 tmp
= build3_v (COND_EXPR
, tmp
, deallocate
, build_empty_stmt ());
4042 gfc_add_expr_to_block (&block
, tmp
);
4044 tmp
= gfc_finish_block (&block
);
4045 gfc_add_expr_to_block (&fnblock
, tmp
);
4048 return gfc_finish_block (&fnblock
);
4051 /************ Expression Walking Functions ******************/
4053 /* Walk a variable reference.
4055 Possible extension - multiple component subscripts.
4056 x(:,:) = foo%a(:)%b(:)
4058 forall (i=..., j=...)
4059 x(i,j) = foo%a(j)%b(i)
4061 This adds a fair amout of complexity because you need to deal with more
4062 than one ref. Maybe handle in a similar manner to vector subscripts.
4063 Maybe not worth the effort. */
4067 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4075 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4077 /* We're only interested in array sections. */
4078 if (ref
->type
!= REF_ARRAY
)
4085 /* TODO: Take elemental array references out of scalarization
4090 newss
= gfc_get_ss ();
4091 newss
->type
= GFC_SS_SECTION
;
4094 newss
->data
.info
.dimen
= ar
->as
->rank
;
4095 newss
->data
.info
.ref
= ref
;
4097 /* Make sure array is the same as array(:,:), this way
4098 we don't need to special case all the time. */
4099 ar
->dimen
= ar
->as
->rank
;
4100 for (n
= 0; n
< ar
->dimen
; n
++)
4102 newss
->data
.info
.dim
[n
] = n
;
4103 ar
->dimen_type
[n
] = DIMEN_RANGE
;
4105 gcc_assert (ar
->start
[n
] == NULL
);
4106 gcc_assert (ar
->end
[n
] == NULL
);
4107 gcc_assert (ar
->stride
[n
] == NULL
);
4112 newss
= gfc_get_ss ();
4113 newss
->type
= GFC_SS_SECTION
;
4116 newss
->data
.info
.dimen
= 0;
4117 newss
->data
.info
.ref
= ref
;
4121 /* We add SS chains for all the subscripts in the section. */
4122 for (n
= 0; n
< ar
->dimen
; n
++)
4126 switch (ar
->dimen_type
[n
])
4129 /* Add SS for elemental (scalar) subscripts. */
4130 gcc_assert (ar
->start
[n
]);
4131 indexss
= gfc_get_ss ();
4132 indexss
->type
= GFC_SS_SCALAR
;
4133 indexss
->expr
= ar
->start
[n
];
4134 indexss
->next
= gfc_ss_terminator
;
4135 indexss
->loop_chain
= gfc_ss_terminator
;
4136 newss
->data
.info
.subscript
[n
] = indexss
;
4140 /* We don't add anything for sections, just remember this
4141 dimension for later. */
4142 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4143 newss
->data
.info
.dimen
++;
4147 /* Get a SS for the vector. This will not be added to the
4149 indexss
= gfc_walk_expr (ar
->start
[n
]);
4150 if (indexss
== gfc_ss_terminator
)
4151 internal_error ("scalar vector subscript???");
4153 /* We currently only handle really simple vector
4155 if (indexss
->next
!= gfc_ss_terminator
)
4156 gfc_todo_error ("vector subscript expressions");
4157 indexss
->loop_chain
= gfc_ss_terminator
;
4159 /* Mark this as a vector subscript. We don't add this
4160 directly into the chain, but as a subscript of the
4161 existing SS for this term. */
4162 indexss
->type
= GFC_SS_VECTOR
;
4163 newss
->data
.info
.subscript
[n
] = indexss
;
4164 /* Also remember this dimension. */
4165 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4166 newss
->data
.info
.dimen
++;
4170 /* We should know what sort of section it is by now. */
4174 /* We should have at least one non-elemental dimension. */
4175 gcc_assert (newss
->data
.info
.dimen
> 0);
4180 /* We should know what sort of section it is by now. */
4189 /* Walk an expression operator. If only one operand of a binary expression is
4190 scalar, we must also add the scalar term to the SS chain. */
4193 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4199 head
= gfc_walk_subexpr (ss
, expr
->op1
);
4200 if (expr
->op2
== NULL
)
4203 head2
= gfc_walk_subexpr (head
, expr
->op2
);
4205 /* All operands are scalar. Pass back and let the caller deal with it. */
4209 /* All operands require scalarization. */
4210 if (head
!= ss
&& (expr
->op2
== NULL
|| head2
!= head
))
4213 /* One of the operands needs scalarization, the other is scalar.
4214 Create a gfc_ss for the scalar expression. */
4215 newss
= gfc_get_ss ();
4216 newss
->type
= GFC_SS_SCALAR
;
4219 /* First operand is scalar. We build the chain in reverse order, so
4220 add the scarar SS after the second operand. */
4222 while (head
&& head
->next
!= ss
)
4224 /* Check we haven't somehow broken the chain. */
4228 newss
->expr
= expr
->op1
;
4230 else /* head2 == head */
4232 gcc_assert (head2
== head
);
4233 /* Second operand is scalar. */
4234 newss
->next
= head2
;
4236 newss
->expr
= expr
->op2
;
4243 /* Reverse a SS chain. */
4246 gfc_reverse_ss (gfc_ss
* ss
)
4251 gcc_assert (ss
!= NULL
);
4253 head
= gfc_ss_terminator
;
4254 while (ss
!= gfc_ss_terminator
)
4257 /* Check we didn't somehow break the chain. */
4258 gcc_assert (next
!= NULL
);
4268 /* Walk the arguments of an elemental function. */
4271 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_expr
* expr
,
4274 gfc_actual_arglist
*arg
;
4280 head
= gfc_ss_terminator
;
4283 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4288 newss
= gfc_walk_subexpr (head
, arg
->expr
);
4291 /* Scalar argument. */
4292 newss
= gfc_get_ss ();
4294 newss
->expr
= arg
->expr
;
4304 while (tail
->next
!= gfc_ss_terminator
)
4311 /* If all the arguments are scalar we don't need the argument SS. */
4312 gfc_free_ss_chain (head
);
4317 /* Add it onto the existing chain. */
4323 /* Walk a function call. Scalar functions are passed back, and taken out of
4324 scalarization loops. For elemental functions we walk their arguments.
4325 The result of functions returning arrays is stored in a temporary outside
4326 the loop, so that the function is only called once. Hence we do not need
4327 to walk their arguments. */
4330 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4333 gfc_intrinsic_sym
*isym
;
4336 isym
= expr
->value
.function
.isym
;
4338 /* Handle intrinsic functions separately. */
4340 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
4342 sym
= expr
->value
.function
.esym
;
4344 sym
= expr
->symtree
->n
.sym
;
4346 /* A function that returns arrays. */
4347 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
4349 newss
= gfc_get_ss ();
4350 newss
->type
= GFC_SS_FUNCTION
;
4353 newss
->data
.info
.dimen
= expr
->rank
;
4357 /* Walk the parameters of an elemental function. For now we always pass
4359 if (sym
->attr
.elemental
)
4360 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_REFERENCE
);
4362 /* Scalar functions are OK as these are evaluated outside the scalarisation
4363 loop. Pass back and let the caller deal with it. */
4368 /* An array temporary is constructed for array constructors. */
4371 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
4376 newss
= gfc_get_ss ();
4377 newss
->type
= GFC_SS_CONSTRUCTOR
;
4380 newss
->data
.info
.dimen
= expr
->rank
;
4381 for (n
= 0; n
< expr
->rank
; n
++)
4382 newss
->data
.info
.dim
[n
] = n
;
4388 /* Walk an expression. Add walked expressions to the head of the SS chain.
4389 A wholy scalar expression will not be added. */
4392 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
4396 switch (expr
->expr_type
)
4399 head
= gfc_walk_variable_expr (ss
, expr
);
4403 head
= gfc_walk_op_expr (ss
, expr
);
4407 head
= gfc_walk_function_expr (ss
, expr
);
4412 case EXPR_STRUCTURE
:
4413 /* Pass back and let the caller deal with it. */
4417 head
= gfc_walk_array_constructor (ss
, expr
);
4420 case EXPR_SUBSTRING
:
4421 /* Pass back and let the caller deal with it. */
4425 internal_error ("bad expression type during walk (%d)",
4432 /* Entry point for expression walking.
4433 A return value equal to the passed chain means this is
4434 a scalar expression. It is up to the caller to take whatever action is
4435 necessary to translate these. */
4438 gfc_walk_expr (gfc_expr
* expr
)
4442 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
4443 return gfc_reverse_ss (res
);