1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005 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"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss
*gfc_walk_subexpr (gfc_ss
*, gfc_expr
*);
98 /* The contents of this structure aren't actually used, just the address. */
99 static gfc_ss gfc_ss_terminator_var
;
100 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
102 unsigned HOST_WIDE_INT gfc_stack_space_left
;
105 /* Returns true if a variable of specified size should go on the stack. */
108 gfc_can_put_var_on_stack (tree size
)
110 unsigned HOST_WIDE_INT low
;
112 if (!INTEGER_CST_P (size
))
115 if (gfc_option
.flag_max_stack_var_size
< 0)
118 if (TREE_INT_CST_HIGH (size
) != 0)
121 low
= TREE_INT_CST_LOW (size
);
122 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
125 /* TODO: Set a per-function stack size limit. */
127 /* We should be a bit more clever with array temps. */
128 if (gfc_option
.flag_max_function_vars_size
>= 0)
130 if (low
> gfc_stack_space_left
)
133 gfc_stack_space_left
-= low
;
141 gfc_array_dataptr_type (tree desc
)
143 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
147 /* Build expressions to access the members of an array descriptor.
148 It's surprisingly easy to mess up here, so never access
149 an array descriptor by "brute force", always use these
150 functions. This also avoids problems if we change the format
151 of an array descriptor.
153 To understand these magic numbers, look at the comments
154 before gfc_build_array_type() in trans-types.c.
156 The code within these defines should be the only code which knows the format
157 of an array descriptor.
159 Any code just needing to read obtain the bounds of an array should use
160 gfc_conv_array_* rather than the following functions as these will return
161 know constant values, and work with arrays which do not have descriptors.
163 Don't forget to #undef these! */
166 #define OFFSET_FIELD 1
167 #define DTYPE_FIELD 2
168 #define DIMENSION_FIELD 3
170 #define STRIDE_SUBFIELD 0
171 #define LBOUND_SUBFIELD 1
172 #define UBOUND_SUBFIELD 2
175 gfc_conv_descriptor_data (tree desc
)
180 type
= TREE_TYPE (desc
);
181 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
183 field
= TYPE_FIELDS (type
);
184 gcc_assert (DATA_FIELD
== 0);
185 gcc_assert (field
!= NULL_TREE
186 && TREE_CODE (TREE_TYPE (field
)) == POINTER_TYPE
187 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == ARRAY_TYPE
);
189 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
193 gfc_conv_descriptor_offset (tree desc
)
198 type
= TREE_TYPE (desc
);
199 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
201 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
202 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
204 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
208 gfc_conv_descriptor_dtype (tree desc
)
213 type
= TREE_TYPE (desc
);
214 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
216 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
217 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
219 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
223 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
229 type
= TREE_TYPE (desc
);
230 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
232 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
233 gcc_assert (field
!= NULL_TREE
234 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
235 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
237 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
238 tmp
= gfc_build_array_ref (tmp
, dim
);
243 gfc_conv_descriptor_stride (tree desc
, tree dim
)
248 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
249 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
250 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
251 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
253 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
258 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
263 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
264 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
265 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
266 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
268 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
273 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
278 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
279 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
280 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
281 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
283 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
288 /* Build an null array descriptor constructor. */
291 gfc_build_null_descriptor (tree type
)
296 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
297 gcc_assert (DATA_FIELD
== 0);
298 field
= TYPE_FIELDS (type
);
300 /* Set a NULL data pointer. */
301 tmp
= tree_cons (field
, null_pointer_node
, NULL_TREE
);
302 tmp
= build1 (CONSTRUCTOR
, type
, tmp
);
303 TREE_CONSTANT (tmp
) = 1;
304 TREE_INVARIANT (tmp
) = 1;
305 /* All other fields are ignored. */
311 /* Cleanup those #defines. */
316 #undef DIMENSION_FIELD
317 #undef STRIDE_SUBFIELD
318 #undef LBOUND_SUBFIELD
319 #undef UBOUND_SUBFIELD
322 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
323 flags & 1 = Main loop body.
324 flags & 2 = temp copy loop. */
327 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
329 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
330 ss
->useflags
= flags
;
333 static void gfc_free_ss (gfc_ss
*);
336 /* Free a gfc_ss chain. */
339 gfc_free_ss_chain (gfc_ss
* ss
)
343 while (ss
!= gfc_ss_terminator
)
345 gcc_assert (ss
!= NULL
);
356 gfc_free_ss (gfc_ss
* ss
)
364 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
366 if (ss
->data
.info
.subscript
[n
])
367 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
379 /* Free all the SS associated with a loop. */
382 gfc_cleanup_loop (gfc_loopinfo
* loop
)
388 while (ss
!= gfc_ss_terminator
)
390 gcc_assert (ss
!= NULL
);
391 next
= ss
->loop_chain
;
398 /* Associate a SS chain with a loop. */
401 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
405 if (head
== gfc_ss_terminator
)
409 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
411 if (ss
->next
== gfc_ss_terminator
)
412 ss
->loop_chain
= loop
->ss
;
414 ss
->loop_chain
= ss
->next
;
416 gcc_assert (ss
== gfc_ss_terminator
);
421 /* Generate an initializer for a static pointer or allocatable array. */
424 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
428 gcc_assert (TREE_STATIC (sym
->backend_decl
));
429 /* Just zero the data member. */
430 type
= TREE_TYPE (sym
->backend_decl
);
431 DECL_INITIAL (sym
->backend_decl
) =gfc_build_null_descriptor (type
);
435 /* Generate code to allocate an array temporary, or create a variable to
436 hold the data. If size is NULL zero the descriptor so that so that the
437 callee will allocate the array. Also generates code to free the array
441 gfc_trans_allocate_array_storage (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
442 tree size
, tree nelem
)
450 desc
= info
->descriptor
;
451 data
= gfc_conv_descriptor_data (desc
);
452 if (size
== NULL_TREE
)
454 /* A callee allocated array. */
455 gfc_add_modify_expr (&loop
->pre
, data
, convert (TREE_TYPE (data
),
456 gfc_index_zero_node
));
458 info
->offset
= gfc_index_zero_node
;
463 /* Allocate the temporary. */
464 onstack
= gfc_can_put_var_on_stack (size
);
468 /* Make a temporary variable to hold the data. */
469 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
471 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
473 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
475 tmp
= gfc_create_var (tmp
, "A");
476 tmp
= gfc_build_addr_expr (TREE_TYPE (data
), tmp
);
477 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
479 info
->offset
= gfc_index_zero_node
;
484 /* Allocate memory to hold the data. */
485 args
= gfc_chainon_list (NULL_TREE
, size
);
487 if (gfc_index_integer_kind
== 4)
488 tmp
= gfor_fndecl_internal_malloc
;
489 else if (gfc_index_integer_kind
== 8)
490 tmp
= gfor_fndecl_internal_malloc64
;
493 tmp
= gfc_build_function_call (tmp
, args
);
494 tmp
= convert (TREE_TYPE (data
), tmp
);
495 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
498 info
->offset
= gfc_index_zero_node
;
502 /* The offset is zero because we create temporaries with a zero
504 tmp
= gfc_conv_descriptor_offset (desc
);
505 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
509 /* Free the temporary. */
510 tmp
= convert (pvoid_type_node
, info
->data
);
511 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
512 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
513 gfc_add_expr_to_block (&loop
->post
, tmp
);
518 /* Generate code to allocate and initialize the descriptor for a temporary
519 array. This is used for both temporaries needed by the scalarizer, and
520 functions returning arrays. Adjusts the loop variables to be zero-based,
521 and calculates the loop bounds for callee allocated arrays.
522 Also fills in the descriptor, data and offset fields of info if known.
523 Returns the size of the array, or NULL for a callee allocated array. */
526 gfc_trans_allocate_temp_array (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
537 gcc_assert (info
->dimen
> 0);
538 /* Set the lower bound to zero. */
539 for (dim
= 0; dim
< info
->dimen
; dim
++)
541 n
= loop
->order
[dim
];
542 if (n
< loop
->temp_dim
)
543 gcc_assert (integer_zerop (loop
->from
[n
]));
546 /* Callee allocated arrays may not have a known bound yet. */
548 loop
->to
[n
] = fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
549 loop
->to
[n
], loop
->from
[n
]));
550 loop
->from
[n
] = gfc_index_zero_node
;
553 info
->delta
[dim
] = gfc_index_zero_node
;
554 info
->start
[dim
] = gfc_index_zero_node
;
555 info
->stride
[dim
] = gfc_index_one_node
;
556 info
->dim
[dim
] = dim
;
559 /* Initialize the descriptor. */
561 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
562 desc
= gfc_create_var (type
, "atmp");
563 GFC_DECL_PACKED_ARRAY (desc
) = 1;
565 info
->descriptor
= desc
;
566 size
= gfc_index_one_node
;
568 /* Fill in the array dtype. */
569 tmp
= gfc_conv_descriptor_dtype (desc
);
570 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
573 Fill in the bounds and stride. This is a packed array, so:
576 for (n = 0; n < rank; n++)
579 delta = ubound[n] + 1 - lbound[n];
582 size = size * sizeof(element);
585 for (n
= 0; n
< info
->dimen
; n
++)
587 if (loop
->to
[n
] == NULL_TREE
)
589 /* For a callee allocated array express the loop bounds in terms
590 of the descriptor fields. */
591 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
592 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
593 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
599 /* Store the stride and bound components in the descriptor. */
600 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
601 gfc_add_modify_expr (&loop
->pre
, tmp
, size
);
603 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
604 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
606 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
607 gfc_add_modify_expr (&loop
->pre
, tmp
, loop
->to
[n
]);
609 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
610 loop
->to
[n
], gfc_index_one_node
));
612 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
613 size
= gfc_evaluate_now (size
, &loop
->pre
);
616 /* Get the size of the array. */
619 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
,
620 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
622 gfc_trans_allocate_array_storage (loop
, info
, size
, nelem
);
624 if (info
->dimen
> loop
->temp_dim
)
625 loop
->temp_dim
= info
->dimen
;
631 /* Make sure offset is a variable. */
634 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
637 /* We should have already created the offset variable. We cannot
638 create it here because we may be in an inner scope. */
639 gcc_assert (*offsetvar
!= NULL_TREE
);
640 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
641 *poffset
= *offsetvar
;
642 TREE_USED (*offsetvar
) = 1;
646 /* Assign an element of an array constructor. */
649 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree pointer
,
650 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
655 gfc_conv_expr (se
, expr
);
657 /* Store the value. */
658 tmp
= gfc_build_indirect_ref (pointer
);
659 tmp
= gfc_build_array_ref (tmp
, offset
);
660 if (expr
->ts
.type
== BT_CHARACTER
)
662 gfc_conv_string_parameter (se
);
663 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
665 /* The temporary is an array of pointers. */
666 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
667 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
671 /* The temporary is an array of string values. */
672 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
673 /* We know the temporary and the value will be the same length,
674 so can use memcpy. */
675 args
= gfc_chainon_list (NULL_TREE
, tmp
);
676 args
= gfc_chainon_list (args
, se
->expr
);
677 args
= gfc_chainon_list (args
, se
->string_length
);
678 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
679 tmp
= gfc_build_function_call (tmp
, args
);
680 gfc_add_expr_to_block (&se
->pre
, tmp
);
685 /* TODO: Should the frontend already have done this conversion? */
686 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
687 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
690 gfc_add_block_to_block (pblock
, &se
->pre
);
691 gfc_add_block_to_block (pblock
, &se
->post
);
695 /* Add the contents of an array to the constructor. */
698 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
699 tree type ATTRIBUTE_UNUSED
,
700 tree pointer
, gfc_expr
* expr
,
701 tree
* poffset
, tree
* offsetvar
)
709 /* We need this to be a variable so we can increment it. */
710 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
712 gfc_init_se (&se
, NULL
);
714 /* Walk the array expression. */
715 ss
= gfc_walk_expr (expr
);
716 gcc_assert (ss
!= gfc_ss_terminator
);
718 /* Initialize the scalarizer. */
719 gfc_init_loopinfo (&loop
);
720 gfc_add_ss_to_loop (&loop
, ss
);
722 /* Initialize the loop. */
723 gfc_conv_ss_startstride (&loop
);
724 gfc_conv_loop_setup (&loop
);
726 /* Make the loop body. */
727 gfc_mark_ss_chain_used (ss
, 1);
728 gfc_start_scalarized_body (&loop
, &body
);
729 gfc_copy_loopinfo_to_se (&se
, &loop
);
732 if (expr
->ts
.type
== BT_CHARACTER
)
733 gfc_todo_error ("character arrays in constructors");
735 gfc_trans_array_ctor_element (&body
, pointer
, *poffset
, &se
, expr
);
736 gcc_assert (se
.ss
== gfc_ss_terminator
);
738 /* Increment the offset. */
739 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
740 gfc_add_modify_expr (&body
, *poffset
, tmp
);
742 /* Finish the loop. */
743 gfc_trans_scalarizing_loops (&loop
, &body
);
744 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
745 tmp
= gfc_finish_block (&loop
.pre
);
746 gfc_add_expr_to_block (pblock
, tmp
);
748 gfc_cleanup_loop (&loop
);
752 /* Assign the values to the elements of an array constructor. */
755 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
756 tree pointer
, gfc_constructor
* c
,
757 tree
* poffset
, tree
* offsetvar
)
764 for (; c
; c
= c
->next
)
766 /* If this is an iterator or an array, the offset must be a variable. */
767 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
768 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
770 gfc_start_block (&body
);
772 if (c
->expr
->expr_type
== EXPR_ARRAY
)
774 /* Array constructors can be nested. */
775 gfc_trans_array_constructor_value (&body
, type
, pointer
,
776 c
->expr
->value
.constructor
,
779 else if (c
->expr
->rank
> 0)
781 gfc_trans_array_constructor_subarray (&body
, type
, pointer
,
782 c
->expr
, poffset
, offsetvar
);
786 /* This code really upsets the gimplifier so don't bother for now. */
793 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
801 gfc_init_se (&se
, NULL
);
802 gfc_trans_array_ctor_element (&body
, pointer
, *poffset
, &se
,
805 *poffset
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
806 *poffset
, gfc_index_one_node
));
810 /* Collect multiple scalar constants into a constructor. */
818 /* Count the number of consecutive scalar constants. */
819 while (p
&& !(p
->iterator
820 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
822 gfc_init_se (&se
, NULL
);
823 gfc_conv_constant (&se
, p
->expr
);
824 if (p
->expr
->ts
.type
== BT_CHARACTER
825 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
826 (TREE_TYPE (pointer
)))))
828 /* For constant character array constructors we build
829 an array of pointers. */
830 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
834 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
839 bound
= build_int_cst (NULL_TREE
, n
- 1);
840 /* Create an array type to hold them. */
841 tmptype
= build_range_type (gfc_array_index_type
,
842 gfc_index_zero_node
, bound
);
843 tmptype
= build_array_type (type
, tmptype
);
845 init
= build1 (CONSTRUCTOR
, tmptype
, nreverse (list
));
846 TREE_CONSTANT (init
) = 1;
847 TREE_INVARIANT (init
) = 1;
848 TREE_STATIC (init
) = 1;
849 /* Create a static variable to hold the data. */
850 tmp
= gfc_create_var (tmptype
, "data");
851 TREE_STATIC (tmp
) = 1;
852 TREE_CONSTANT (tmp
) = 1;
853 TREE_INVARIANT (tmp
) = 1;
854 DECL_INITIAL (tmp
) = init
;
857 /* Use BUILTIN_MEMCPY to assign the values. */
858 tmp
= gfc_build_indirect_ref (pointer
);
859 tmp
= gfc_build_array_ref (tmp
, *poffset
);
860 tmp
= gfc_build_addr_expr (NULL
, tmp
);
861 init
= gfc_build_addr_expr (NULL
, init
);
863 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
864 bound
= build_int_cst (NULL_TREE
, n
* size
);
865 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
866 tmp
= gfc_chainon_list (tmp
, init
);
867 tmp
= gfc_chainon_list (tmp
, bound
);
868 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_MEMCPY
],
870 gfc_add_expr_to_block (&body
, tmp
);
872 *poffset
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
875 if (!INTEGER_CST_P (*poffset
))
877 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
878 *poffset
= *offsetvar
;
882 /* The frontend should already have done any expansions. */
890 loopbody
= gfc_finish_block (&body
);
892 gfc_init_se (&se
, NULL
);
893 gfc_conv_expr (&se
, c
->iterator
->var
);
894 gfc_add_block_to_block (pblock
, &se
.pre
);
897 /* Initialize the loop. */
898 gfc_init_se (&se
, NULL
);
899 gfc_conv_expr_val (&se
, c
->iterator
->start
);
900 gfc_add_block_to_block (pblock
, &se
.pre
);
901 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
903 gfc_init_se (&se
, NULL
);
904 gfc_conv_expr_val (&se
, c
->iterator
->end
);
905 gfc_add_block_to_block (pblock
, &se
.pre
);
906 end
= gfc_evaluate_now (se
.expr
, pblock
);
908 gfc_init_se (&se
, NULL
);
909 gfc_conv_expr_val (&se
, c
->iterator
->step
);
910 gfc_add_block_to_block (pblock
, &se
.pre
);
911 step
= gfc_evaluate_now (se
.expr
, pblock
);
913 /* Generate the loop body. */
914 exit_label
= gfc_build_label_decl (NULL_TREE
);
915 gfc_start_block (&body
);
917 /* Generate the exit condition. */
918 end
= build2 (GT_EXPR
, boolean_type_node
, loopvar
, end
);
919 tmp
= build1_v (GOTO_EXPR
, exit_label
);
920 TREE_USED (exit_label
) = 1;
921 tmp
= build3_v (COND_EXPR
, end
, tmp
, build_empty_stmt ());
922 gfc_add_expr_to_block (&body
, tmp
);
924 /* The main loop body. */
925 gfc_add_expr_to_block (&body
, loopbody
);
927 /* Increment the loop variable. */
928 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
929 gfc_add_modify_expr (&body
, loopvar
, tmp
);
931 /* Finish the loop. */
932 tmp
= gfc_finish_block (&body
);
933 tmp
= build1_v (LOOP_EXPR
, tmp
);
934 gfc_add_expr_to_block (pblock
, tmp
);
936 /* Add the exit label. */
937 tmp
= build1_v (LABEL_EXPR
, exit_label
);
938 gfc_add_expr_to_block (pblock
, tmp
);
942 /* Pass the code as is. */
943 tmp
= gfc_finish_block (&body
);
944 gfc_add_expr_to_block (pblock
, tmp
);
950 /* Get the size of an expression. Returns -1 if the size isn't constant.
951 Implied do loops with non-constant bounds are tricky because we must only
952 evaluate the bounds once. */
955 gfc_get_array_cons_size (mpz_t
* size
, gfc_constructor
* c
)
961 mpz_set_ui (*size
, 0);
965 for (; c
; c
= c
->next
)
967 if (c
->expr
->expr_type
== EXPR_ARRAY
)
969 /* A nested array constructor. */
970 gfc_get_array_cons_size (&len
, c
->expr
->value
.constructor
);
971 if (mpz_sgn (len
) < 0)
973 mpz_set (*size
, len
);
981 if (c
->expr
->rank
> 0)
983 mpz_set_si (*size
, -1);
995 if (i
->start
->expr_type
!= EXPR_CONSTANT
996 || i
->end
->expr_type
!= EXPR_CONSTANT
997 || i
->step
->expr_type
!= EXPR_CONSTANT
)
999 mpz_set_si (*size
, -1);
1005 mpz_add (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1006 mpz_tdiv_q (val
, val
, i
->step
->value
.integer
);
1007 mpz_add_ui (val
, val
, 1);
1008 mpz_mul (len
, len
, val
);
1010 mpz_add (*size
, *size
, len
);
1017 /* Figure out the string length of a variable reference expression.
1018 Used by get_array_ctor_strlen. */
1021 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1026 /* Don't bother if we already know the length is a constant. */
1027 if (*len
&& INTEGER_CST_P (*len
))
1030 ts
= &expr
->symtree
->n
.sym
->ts
;
1031 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1036 /* Array references don't change teh sting length. */
1040 /* Use the length of the component. */
1041 ts
= &ref
->u
.c
.component
->ts
;
1045 /* TODO: Substrings are tricky because we can't evaluate the
1046 expression more than once. For now we just give up, and hope
1047 we can figure it out elsewhere. */
1052 *len
= ts
->cl
->backend_decl
;
1056 /* Figure out the string length of a character array constructor.
1057 Returns TRUE if all elements are character constants. */
1060 get_array_ctor_strlen (gfc_constructor
* c
, tree
* len
)
1065 for (; c
; c
= c
->next
)
1067 switch (c
->expr
->expr_type
)
1070 if (!(*len
&& INTEGER_CST_P (*len
)))
1071 *len
= build_int_cstu (gfc_charlen_type_node
,
1072 c
->expr
->value
.character
.length
);
1076 if (!get_array_ctor_strlen (c
->expr
->value
.constructor
, len
))
1082 get_array_ctor_var_strlen (c
->expr
, len
);
1087 /* TODO: For now we just ignore anything we don't know how to
1088 handle, and hope we can figure it out a different way. */
1097 /* Array constructors are handled by constructing a temporary, then using that
1098 within the scalarization loop. This is not optimal, but seems by far the
1102 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1111 ss
->data
.info
.dimen
= loop
->dimen
;
1113 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1115 const_string
= get_array_ctor_strlen (ss
->expr
->value
.constructor
,
1116 &ss
->string_length
);
1117 if (!ss
->string_length
)
1118 gfc_todo_error ("complex character array constructors");
1120 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1122 type
= build_pointer_type (type
);
1126 const_string
= TRUE
;
1127 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1130 size
= gfc_trans_allocate_temp_array (loop
, &ss
->data
.info
, type
);
1132 desc
= ss
->data
.info
.descriptor
;
1133 offset
= gfc_index_zero_node
;
1134 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1135 TREE_USED (offsetvar
) = 0;
1136 gfc_trans_array_constructor_value (&loop
->pre
, type
,
1138 ss
->expr
->value
.constructor
, &offset
,
1141 if (TREE_USED (offsetvar
))
1142 pushdecl (offsetvar
);
1144 gcc_assert (INTEGER_CST_P (offset
));
1146 /* Disable bound checking for now because it's probably broken. */
1147 if (flag_bounds_check
)
1155 /* Add the pre and post chains for all the scalar expressions in a SS chain
1156 to loop. This is called after the loop parameters have been calculated,
1157 but before the actual scalarizing loops. */
1160 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1165 /* TODO: This can generate bad code if there are ordering dependencies.
1166 eg. a callee allocated function and an unknown size constructor. */
1167 gcc_assert (ss
!= NULL
);
1169 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1176 /* Scalar expression. Evaluate this now. This includes elemental
1177 dimension indices, but not array section bounds. */
1178 gfc_init_se (&se
, NULL
);
1179 gfc_conv_expr (&se
, ss
->expr
);
1180 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1182 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1184 /* Move the evaluation of scalar expressions outside the
1185 scalarization loop. */
1187 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1188 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1189 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1192 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1194 ss
->data
.scalar
.expr
= se
.expr
;
1195 ss
->string_length
= se
.string_length
;
1198 case GFC_SS_REFERENCE
:
1199 /* Scalar reference. Evaluate this now. */
1200 gfc_init_se (&se
, NULL
);
1201 gfc_conv_expr_reference (&se
, ss
->expr
);
1202 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1203 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1205 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1206 ss
->string_length
= se
.string_length
;
1209 case GFC_SS_SECTION
:
1211 /* Scalarized expression. Evaluate any scalar subscripts. */
1212 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1214 /* Add the expressions for scalar subscripts. */
1215 if (ss
->data
.info
.subscript
[n
])
1216 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1220 case GFC_SS_INTRINSIC
:
1221 gfc_add_intrinsic_ss_code (loop
, ss
);
1224 case GFC_SS_FUNCTION
:
1225 /* Array function return value. We call the function and save its
1226 result in a temporary for use inside the loop. */
1227 gfc_init_se (&se
, NULL
);
1230 gfc_conv_expr (&se
, ss
->expr
);
1231 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1232 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1235 case GFC_SS_CONSTRUCTOR
:
1236 gfc_trans_array_constructor (loop
, ss
);
1240 case GFC_SS_COMPONENT
:
1241 /* Do nothing. These are handled elsewhere. */
1251 /* Translate expressions for the descriptor and data pointer of a SS. */
1255 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1260 /* Get the descriptor for the array to be scalarized. */
1261 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1262 gfc_init_se (&se
, NULL
);
1263 se
.descriptor_only
= 1;
1264 gfc_conv_expr_lhs (&se
, ss
->expr
);
1265 gfc_add_block_to_block (block
, &se
.pre
);
1266 ss
->data
.info
.descriptor
= se
.expr
;
1267 ss
->string_length
= se
.string_length
;
1271 /* Also the data pointer. */
1272 tmp
= gfc_conv_array_data (se
.expr
);
1273 /* If this is a variable or address of a variable we use it directly.
1274 Otherwise we must evaluate it now to to avoid break dependency
1275 analysis by pulling the expressions for elemental array indices
1278 || (TREE_CODE (tmp
) == ADDR_EXPR
1279 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1280 tmp
= gfc_evaluate_now (tmp
, block
);
1281 ss
->data
.info
.data
= tmp
;
1283 tmp
= gfc_conv_array_offset (se
.expr
);
1284 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1289 /* Initialize a gfc_loopinfo structure. */
1292 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1296 memset (loop
, 0, sizeof (gfc_loopinfo
));
1297 gfc_init_block (&loop
->pre
);
1298 gfc_init_block (&loop
->post
);
1300 /* Initially scalarize in order. */
1301 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1304 loop
->ss
= gfc_ss_terminator
;
1308 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1312 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1318 /* Return an expression for the data pointer of an array. */
1321 gfc_conv_array_data (tree descriptor
)
1325 type
= TREE_TYPE (descriptor
);
1326 if (GFC_ARRAY_TYPE_P (type
))
1328 if (TREE_CODE (type
) == POINTER_TYPE
)
1332 /* Descriptorless arrays. */
1333 return gfc_build_addr_expr (NULL
, descriptor
);
1337 return gfc_conv_descriptor_data (descriptor
);
1341 /* Return an expression for the base offset of an array. */
1344 gfc_conv_array_offset (tree descriptor
)
1348 type
= TREE_TYPE (descriptor
);
1349 if (GFC_ARRAY_TYPE_P (type
))
1350 return GFC_TYPE_ARRAY_OFFSET (type
);
1352 return gfc_conv_descriptor_offset (descriptor
);
1356 /* Get an expression for the array stride. */
1359 gfc_conv_array_stride (tree descriptor
, int dim
)
1364 type
= TREE_TYPE (descriptor
);
1366 /* For descriptorless arrays use the array size. */
1367 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1368 if (tmp
!= NULL_TREE
)
1371 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1376 /* Like gfc_conv_array_stride, but for the lower bound. */
1379 gfc_conv_array_lbound (tree descriptor
, int dim
)
1384 type
= TREE_TYPE (descriptor
);
1386 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1387 if (tmp
!= NULL_TREE
)
1390 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1395 /* Like gfc_conv_array_stride, but for the upper bound. */
1398 gfc_conv_array_ubound (tree descriptor
, int dim
)
1403 type
= TREE_TYPE (descriptor
);
1405 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1406 if (tmp
!= NULL_TREE
)
1409 /* This should only ever happen when passing an assumed shape array
1410 as an actual parameter. The value will never be used. */
1411 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1412 return gfc_index_zero_node
;
1414 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1419 /* Translate an array reference. The descriptor should be in se->expr.
1420 Do not use this function, it wil be removed soon. */
1424 gfc_conv_array_index_ref (gfc_se
* se
, tree pointer
, tree
* indices
,
1425 tree offset
, int dimen
)
1432 array
= gfc_build_indirect_ref (pointer
);
1435 for (n
= 0; n
< dimen
; n
++)
1437 /* index = index + stride[n]*indices[n] */
1438 tmp
= gfc_conv_array_stride (se
->expr
, n
);
1439 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, indices
[n
], tmp
));
1441 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1444 /* Result = data[index]. */
1445 tmp
= gfc_build_array_ref (array
, index
);
1447 /* Check we've used the correct number of dimensions. */
1448 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) != ARRAY_TYPE
);
1454 /* Generate code to perform an array index bound check. */
1457 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
)
1463 if (!flag_bounds_check
)
1466 index
= gfc_evaluate_now (index
, &se
->pre
);
1467 /* Check lower bound. */
1468 tmp
= gfc_conv_array_lbound (descriptor
, n
);
1469 fault
= fold (build2 (LT_EXPR
, boolean_type_node
, index
, tmp
));
1470 /* Check upper bound. */
1471 tmp
= gfc_conv_array_ubound (descriptor
, n
);
1472 cond
= fold (build2 (GT_EXPR
, boolean_type_node
, index
, tmp
));
1473 fault
= fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1475 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1481 /* A reference to an array vector subscript. Uses recursion to handle nested
1482 vector subscripts. */
1485 gfc_conv_vector_array_index (gfc_se
* se
, tree index
, gfc_ss
* ss
)
1488 tree indices
[GFC_MAX_DIMENSIONS
];
1493 gcc_assert (ss
&& ss
->type
== GFC_SS_VECTOR
);
1495 /* Save the descriptor. */
1496 descsave
= se
->expr
;
1497 info
= &ss
->data
.info
;
1498 se
->expr
= info
->descriptor
;
1500 ar
= &info
->ref
->u
.ar
;
1501 for (n
= 0; n
< ar
->dimen
; n
++)
1503 switch (ar
->dimen_type
[n
])
1506 gcc_assert (info
->subscript
[n
] != gfc_ss_terminator
1507 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
1508 indices
[n
] = info
->subscript
[n
]->data
.scalar
.expr
;
1516 index
= gfc_conv_vector_array_index (se
, index
, info
->subscript
[n
]);
1519 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, n
);
1526 /* Get the index from the vector. */
1527 gfc_conv_array_index_ref (se
, info
->data
, indices
, info
->offset
, ar
->dimen
);
1529 /* Put the descriptor back. */
1530 se
->expr
= descsave
;
1536 /* Return the offset for an index. Performs bound checking for elemental
1537 dimensions. Single element references are processed separately. */
1540 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
1541 gfc_array_ref
* ar
, tree stride
)
1545 /* Get the index into the array for this dimension. */
1548 gcc_assert (ar
->type
!= AR_ELEMENT
);
1549 if (ar
->dimen_type
[dim
] == DIMEN_ELEMENT
)
1551 gcc_assert (i
== -1);
1552 /* Elemental dimension. */
1553 gcc_assert (info
->subscript
[dim
]
1554 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
1555 /* We've already translated this value outside the loop. */
1556 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
1559 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, dim
);
1563 /* Scalarized dimension. */
1564 gcc_assert (info
&& se
->loop
);
1566 /* Multiply the loop variable by the stride and dela. */
1567 index
= se
->loop
->loopvar
[i
];
1568 index
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, index
,
1570 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
1573 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
1575 /* Handle vector subscripts. */
1576 index
= gfc_conv_vector_array_index (se
, index
,
1577 info
->subscript
[dim
]);
1579 gfc_trans_array_bound_check (se
, info
->descriptor
, index
,
1583 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
);
1588 /* Temporary array or derived type component. */
1589 gcc_assert (se
->loop
);
1590 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
1591 if (!integer_zerop (info
->delta
[i
]))
1592 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1593 index
, info
->delta
[i
]));
1596 /* Multiply by the stride. */
1597 index
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
));
1603 /* Build a scalarized reference to an array. */
1606 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1613 info
= &se
->ss
->data
.info
;
1615 n
= se
->loop
->order
[0];
1619 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
1621 /* Add the offset for this dimension to the stored offset for all other
1623 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
));
1625 tmp
= gfc_build_indirect_ref (info
->data
);
1626 se
->expr
= gfc_build_array_ref (tmp
, index
);
1630 /* Translate access of temporary array. */
1633 gfc_conv_tmp_array_ref (gfc_se
* se
)
1635 se
->string_length
= se
->ss
->string_length
;
1636 gfc_conv_scalarized_array_ref (se
, NULL
);
1640 /* Build an array reference. se->expr already holds the array descriptor.
1641 This should be either a variable, indirect variable reference or component
1642 reference. For arrays which do not have a descriptor, se->expr will be
1644 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1647 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1656 /* Handle scalarized references separately. */
1657 if (ar
->type
!= AR_ELEMENT
)
1659 gfc_conv_scalarized_array_ref (se
, ar
);
1663 index
= gfc_index_zero_node
;
1665 fault
= gfc_index_zero_node
;
1667 /* Calculate the offsets from all the dimensions. */
1668 for (n
= 0; n
< ar
->dimen
; n
++)
1670 /* Calculate the index for this dimension. */
1671 gfc_init_se (&indexse
, NULL
);
1672 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
1673 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
1675 if (flag_bounds_check
)
1677 /* Check array bounds. */
1680 indexse
.expr
= gfc_evaluate_now (indexse
.expr
, &se
->pre
);
1682 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
1683 cond
= fold (build2 (LT_EXPR
, boolean_type_node
,
1684 indexse
.expr
, tmp
));
1686 fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1688 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
1689 cond
= fold (build2 (GT_EXPR
, boolean_type_node
,
1690 indexse
.expr
, tmp
));
1692 fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1695 /* Multiply the index by the stride. */
1696 stride
= gfc_conv_array_stride (se
->expr
, n
);
1697 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
1700 /* And add it to the total. */
1701 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1704 if (flag_bounds_check
)
1705 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1707 tmp
= gfc_conv_array_offset (se
->expr
);
1708 if (!integer_zerop (tmp
))
1709 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1711 /* Access the calculated element. */
1712 tmp
= gfc_conv_array_data (se
->expr
);
1713 tmp
= gfc_build_indirect_ref (tmp
);
1714 se
->expr
= gfc_build_array_ref (tmp
, index
);
1718 /* Generate the code to be executed immediately before entering a
1719 scalarization loop. */
1722 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
1723 stmtblock_t
* pblock
)
1732 /* This code will be executed before entering the scalarization loop
1733 for this dimension. */
1734 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1736 if ((ss
->useflags
& flag
) == 0)
1739 if (ss
->type
!= GFC_SS_SECTION
1740 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1741 && ss
->type
!= GFC_SS_COMPONENT
)
1744 info
= &ss
->data
.info
;
1746 if (dim
>= info
->dimen
)
1749 if (dim
== info
->dimen
- 1)
1751 /* For the outermost loop calculate the offset due to any
1752 elemental dimensions. It will have been initialized with the
1753 base offset of the array. */
1756 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
1758 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1761 gfc_init_se (&se
, NULL
);
1763 se
.expr
= info
->descriptor
;
1764 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
1765 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
1768 gfc_add_block_to_block (pblock
, &se
.pre
);
1770 info
->offset
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1771 info
->offset
, index
));
1772 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1776 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1779 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
1781 /* Calculate the stride of the innermost loop. Hopefully this will
1782 allow the backend optimizers to do their stuff more effectively.
1784 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
1788 /* Add the offset for the previous loop dimension. */
1793 ar
= &info
->ref
->u
.ar
;
1794 i
= loop
->order
[dim
+ 1];
1802 gfc_init_se (&se
, NULL
);
1804 se
.expr
= info
->descriptor
;
1805 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1806 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
1808 gfc_add_block_to_block (pblock
, &se
.pre
);
1809 info
->offset
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1810 info
->offset
, index
));
1811 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1814 /* Remember this offset for the second loop. */
1815 if (dim
== loop
->temp_dim
- 1)
1816 info
->saved_offset
= info
->offset
;
1821 /* Start a scalarized expression. Creates a scope and declares loop
1825 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
1831 gcc_assert (!loop
->array_parameter
);
1833 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
1835 n
= loop
->order
[dim
];
1837 gfc_start_block (&loop
->code
[n
]);
1839 /* Create the loop variable. */
1840 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
1842 if (dim
< loop
->temp_dim
)
1846 /* Calculate values that will be constant within this loop. */
1847 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
1849 gfc_start_block (pbody
);
1853 /* Generates the actual loop code for a scalarization loop. */
1856 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
1857 stmtblock_t
* pbody
)
1865 loopbody
= gfc_finish_block (pbody
);
1867 /* Initialize the loopvar. */
1868 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
1870 exit_label
= gfc_build_label_decl (NULL_TREE
);
1872 /* Generate the loop body. */
1873 gfc_init_block (&block
);
1875 /* The exit condition. */
1876 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
1877 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1878 TREE_USED (exit_label
) = 1;
1879 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1880 gfc_add_expr_to_block (&block
, tmp
);
1882 /* The main body. */
1883 gfc_add_expr_to_block (&block
, loopbody
);
1885 /* Increment the loopvar. */
1886 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1887 loop
->loopvar
[n
], gfc_index_one_node
);
1888 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
1890 /* Build the loop. */
1891 tmp
= gfc_finish_block (&block
);
1892 tmp
= build1_v (LOOP_EXPR
, tmp
);
1893 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1895 /* Add the exit label. */
1896 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1897 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1901 /* Finishes and generates the loops for a scalarized expression. */
1904 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1909 stmtblock_t
*pblock
;
1913 /* Generate the loops. */
1914 for (dim
= 0; dim
< loop
->dimen
; dim
++)
1916 n
= loop
->order
[dim
];
1917 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1918 loop
->loopvar
[n
] = NULL_TREE
;
1919 pblock
= &loop
->code
[n
];
1922 tmp
= gfc_finish_block (pblock
);
1923 gfc_add_expr_to_block (&loop
->pre
, tmp
);
1925 /* Clear all the used flags. */
1926 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
1931 /* Finish the main body of a scalarized expression, and start the secondary
1935 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1939 stmtblock_t
*pblock
;
1943 /* We finish as many loops as are used by the temporary. */
1944 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
1946 n
= loop
->order
[dim
];
1947 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1948 loop
->loopvar
[n
] = NULL_TREE
;
1949 pblock
= &loop
->code
[n
];
1952 /* We don't want to finish the outermost loop entirely. */
1953 n
= loop
->order
[loop
->temp_dim
- 1];
1954 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1956 /* Restore the initial offsets. */
1957 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1959 if ((ss
->useflags
& 2) == 0)
1962 if (ss
->type
!= GFC_SS_SECTION
1963 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1964 && ss
->type
!= GFC_SS_COMPONENT
)
1967 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
1970 /* Restart all the inner loops we just finished. */
1971 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
1973 n
= loop
->order
[dim
];
1975 gfc_start_block (&loop
->code
[n
]);
1977 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
1979 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
1982 /* Start a block for the secondary copying code. */
1983 gfc_start_block (body
);
1987 /* Calculate the upper bound of an array section. */
1990 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
1999 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2001 /* For vector array subscripts we want the size of the vector. */
2002 dim
= ss
->data
.info
.dim
[n
];
2004 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2006 vecss
= vecss
->data
.info
.subscript
[dim
];
2007 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2008 dim
= vecss
->data
.info
.dim
[0];
2011 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2012 end
= vecss
->data
.info
.ref
->u
.ar
.end
[dim
];
2013 desc
= vecss
->data
.info
.descriptor
;
2017 /* The upper bound was specified. */
2018 gfc_init_se (&se
, NULL
);
2019 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2020 gfc_add_block_to_block (pblock
, &se
.pre
);
2025 /* No upper bound was specified, so use the bound of the array. */
2026 bound
= gfc_conv_array_ubound (desc
, dim
);
2033 /* Calculate the lower bound of an array section. */
2036 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2046 info
= &ss
->data
.info
;
2050 /* For vector array subscripts we want the size of the vector. */
2052 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2054 vecss
= vecss
->data
.info
.subscript
[dim
];
2055 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2056 /* Get the descriptors for the vector subscripts as well. */
2057 if (!vecss
->data
.info
.descriptor
)
2058 gfc_conv_ss_descriptor (&loop
->pre
, vecss
, !loop
->array_parameter
);
2059 dim
= vecss
->data
.info
.dim
[0];
2062 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2063 start
= vecss
->data
.info
.ref
->u
.ar
.start
[dim
];
2064 stride
= vecss
->data
.info
.ref
->u
.ar
.stride
[dim
];
2065 desc
= vecss
->data
.info
.descriptor
;
2067 /* Calculate the start of the range. For vector subscripts this will
2068 be the range of the vector. */
2071 /* Specified section start. */
2072 gfc_init_se (&se
, NULL
);
2073 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2074 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2075 info
->start
[n
] = se
.expr
;
2079 /* No lower bound specified so use the bound of the array. */
2080 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2082 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2084 /* Calculate the stride. */
2086 info
->stride
[n
] = gfc_index_one_node
;
2089 gfc_init_se (&se
, NULL
);
2090 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2091 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2092 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2097 /* Calculates the range start and stride for a SS chain. Also gets the
2098 descriptor and data pointer. The range of vector subscripts is the size
2099 of the vector. Array bounds are also checked. */
2102 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2111 /* Determine the rank of the loop. */
2113 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2117 case GFC_SS_SECTION
:
2118 case GFC_SS_CONSTRUCTOR
:
2119 case GFC_SS_FUNCTION
:
2120 case GFC_SS_COMPONENT
:
2121 loop
->dimen
= ss
->data
.info
.dimen
;
2129 if (loop
->dimen
== 0)
2130 gfc_todo_error ("Unable to determine rank of expression");
2133 /* Loop over all the SS in the chain. */
2134 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2136 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2137 ss
->shape
= ss
->expr
->shape
;
2141 case GFC_SS_SECTION
:
2142 /* Get the descriptor for the array. */
2143 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2145 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2146 gfc_conv_section_startstride (loop
, ss
, n
);
2149 case GFC_SS_CONSTRUCTOR
:
2150 case GFC_SS_FUNCTION
:
2151 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2153 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2154 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2163 /* The rest is just runtime bound checking. */
2164 if (flag_bounds_check
)
2170 tree size
[GFC_MAX_DIMENSIONS
];
2174 gfc_start_block (&block
);
2176 fault
= integer_zero_node
;
2177 for (n
= 0; n
< loop
->dimen
; n
++)
2178 size
[n
] = NULL_TREE
;
2180 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2182 if (ss
->type
!= GFC_SS_SECTION
)
2185 /* TODO: range checking for mapped dimensions. */
2186 info
= &ss
->data
.info
;
2188 /* This only checks scalarized dimensions, elemental dimensions are
2190 for (n
= 0; n
< loop
->dimen
; n
++)
2194 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2197 vecss
= vecss
->data
.info
.subscript
[dim
];
2198 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2199 dim
= vecss
->data
.info
.dim
[0];
2201 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2203 desc
= vecss
->data
.info
.descriptor
;
2205 /* Check lower bound. */
2206 bound
= gfc_conv_array_lbound (desc
, dim
);
2207 tmp
= info
->start
[n
];
2208 tmp
= fold (build2 (LT_EXPR
, boolean_type_node
, tmp
, bound
));
2209 fault
= fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2212 /* Check the upper bound. */
2213 bound
= gfc_conv_array_ubound (desc
, dim
);
2214 end
= gfc_conv_section_upper_bound (ss
, n
, &block
);
2215 tmp
= fold (build2 (GT_EXPR
, boolean_type_node
, end
, bound
));
2216 fault
= fold (build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2219 /* Check the section sizes match. */
2220 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2222 tmp
= fold (build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2224 /* We remember the size of the first section, and check all the
2225 others against this. */
2229 fold (build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]));
2231 build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, tmp
);
2234 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2237 gfc_trans_runtime_check (fault
, gfc_strconst_bounds
, &block
);
2239 tmp
= gfc_finish_block (&block
);
2240 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2245 /* Return true if the two SS could be aliased, i.e. both point to the same data
2247 /* TODO: resolve aliases based on frontend expressions. */
2250 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2257 lsym
= lss
->expr
->symtree
->n
.sym
;
2258 rsym
= rss
->expr
->symtree
->n
.sym
;
2259 if (gfc_symbols_could_alias (lsym
, rsym
))
2262 if (rsym
->ts
.type
!= BT_DERIVED
2263 && lsym
->ts
.type
!= BT_DERIVED
)
2266 /* For derived types we must check all the component types. We can ignore
2267 array references as these will have the same base type as the previous
2269 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2271 if (lref
->type
!= REF_COMPONENT
)
2274 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2277 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2280 if (rref
->type
!= REF_COMPONENT
)
2283 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2288 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2290 if (rref
->type
!= REF_COMPONENT
)
2293 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2301 /* Resolve array data dependencies. Creates a temporary if required. */
2302 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2306 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2316 loop
->temp_ss
= NULL
;
2317 aref
= dest
->data
.info
.ref
;
2320 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2322 if (ss
->type
!= GFC_SS_SECTION
)
2325 if (gfc_could_be_alias (dest
, ss
))
2331 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
2333 lref
= dest
->expr
->ref
;
2334 rref
= ss
->expr
->ref
;
2336 nDepend
= gfc_dep_resolver (lref
, rref
);
2338 /* TODO : loop shifting. */
2341 /* Mark the dimensions for LOOP SHIFTING */
2342 for (n
= 0; n
< loop
->dimen
; n
++)
2344 int dim
= dest
->data
.info
.dim
[n
];
2346 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2348 else if (! gfc_is_same_range (&lref
->u
.ar
,
2349 &rref
->u
.ar
, dim
, 0))
2353 /* Put all the dimensions with dependencies in the
2356 for (n
= 0; n
< loop
->dimen
; n
++)
2358 gcc_assert (loop
->order
[n
] == n
);
2360 loop
->order
[dim
++] = n
;
2363 for (n
= 0; n
< loop
->dimen
; n
++)
2366 loop
->order
[dim
++] = n
;
2369 gcc_assert (dim
== loop
->dimen
);
2378 loop
->temp_ss
= gfc_get_ss ();
2379 loop
->temp_ss
->type
= GFC_SS_TEMP
;
2380 loop
->temp_ss
->data
.temp
.type
=
2381 gfc_get_element_type (TREE_TYPE (dest
->data
.info
.descriptor
));
2382 loop
->temp_ss
->string_length
= NULL_TREE
;
2383 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
2384 loop
->temp_ss
->next
= gfc_ss_terminator
;
2385 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
2388 loop
->temp_ss
= NULL
;
2392 /* Initialize the scalarization loop. Creates the loop variables. Determines
2393 the range of the loop variables. Creates a temporary if required.
2394 Calculates how to transform from loop variables to array indices for each
2395 expression. Also generates code for scalar expressions which have been
2396 moved outside the loop. */
2399 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
2404 gfc_ss_info
*specinfo
;
2408 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
2413 for (n
= 0; n
< loop
->dimen
; n
++)
2416 /* We use one SS term, and use that to determine the bounds of the
2417 loop for this dimension. We try to pick the simplest term. */
2418 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2422 /* The frontend has worked out the size for us. */
2427 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
2429 /* An unknown size constructor will always be rank one.
2430 Higher rank constructors will either have known shape,
2431 or still be wrapped in a call to reshape. */
2432 gcc_assert (loop
->dimen
== 1);
2433 /* Try to figure out the size of the constructor. */
2434 /* TODO: avoid this by making the frontend set the shape. */
2435 gfc_get_array_cons_size (&i
, ss
->expr
->value
.constructor
);
2436 /* A negative value means we failed. */
2437 if (mpz_sgn (i
) > 0)
2439 mpz_sub_ui (i
, i
, 1);
2441 gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2447 /* TODO: Pick the best bound if we have a choice between a
2448 function and something else. */
2449 if (ss
->type
== GFC_SS_FUNCTION
)
2455 if (ss
->type
!= GFC_SS_SECTION
)
2459 specinfo
= &loopspec
[n
]->data
.info
;
2462 info
= &ss
->data
.info
;
2464 /* Criteria for choosing a loop specifier (most important first):
2472 /* TODO: Is != constructor correct? */
2473 else if (loopspec
[n
]->type
!= GFC_SS_CONSTRUCTOR
)
2475 if (integer_onep (info
->stride
[n
])
2476 && !integer_onep (specinfo
->stride
[n
]))
2478 else if (INTEGER_CST_P (info
->stride
[n
])
2479 && !INTEGER_CST_P (specinfo
->stride
[n
]))
2481 else if (INTEGER_CST_P (info
->start
[n
])
2482 && !INTEGER_CST_P (specinfo
->start
[n
]))
2484 /* We don't work out the upper bound.
2485 else if (INTEGER_CST_P (info->finish[n])
2486 && ! INTEGER_CST_P (specinfo->finish[n]))
2487 loopspec[n] = ss; */
2492 gfc_todo_error ("Unable to find scalarization loop specifier");
2494 info
= &loopspec
[n
]->data
.info
;
2496 /* Set the extents of this range. */
2497 cshape
= loopspec
[n
]->shape
;
2498 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
2499 && INTEGER_CST_P (info
->stride
[n
]))
2501 loop
->from
[n
] = info
->start
[n
];
2502 mpz_set (i
, cshape
[n
]);
2503 mpz_sub_ui (i
, i
, 1);
2504 /* To = from + (size - 1) * stride. */
2505 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2506 if (!integer_onep (info
->stride
[n
]))
2507 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
,
2508 tmp
, info
->stride
[n
]));
2509 loop
->to
[n
] = fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2510 loop
->from
[n
], tmp
));
2514 loop
->from
[n
] = info
->start
[n
];
2515 switch (loopspec
[n
]->type
)
2517 case GFC_SS_CONSTRUCTOR
:
2518 gcc_assert (info
->dimen
== 1);
2519 gcc_assert (loop
->to
[n
]);
2522 case GFC_SS_SECTION
:
2523 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
2527 case GFC_SS_FUNCTION
:
2528 /* The loop bound will be set when we generate the call. */
2529 gcc_assert (loop
->to
[n
] == NULL_TREE
);
2537 /* Transform everything so we have a simple incrementing variable. */
2538 if (integer_onep (info
->stride
[n
]))
2539 info
->delta
[n
] = gfc_index_zero_node
;
2542 /* Set the delta for this section. */
2543 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
2544 /* Number of iterations is (end - start + step) / step.
2545 with start = 0, this simplifies to
2547 for (i = 0; i<=last; i++){...}; */
2548 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
2549 loop
->to
[n
], loop
->from
[n
]));
2550 tmp
= fold (build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
2551 tmp
, info
->stride
[n
]));
2552 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2553 /* Make the loop variable start at 0. */
2554 loop
->from
[n
] = gfc_index_zero_node
;
2558 /* Add all the scalar code that can be taken out of the loops.
2559 This may include calculating the loop bounds, so do it before
2560 allocating the temporary. */
2561 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
2563 /* If we want a temporary then create it. */
2564 if (loop
->temp_ss
!= NULL
)
2566 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
2567 tmp
= loop
->temp_ss
->data
.temp
.type
;
2568 len
= loop
->temp_ss
->string_length
;
2569 n
= loop
->temp_ss
->data
.temp
.dimen
;
2570 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
2571 loop
->temp_ss
->type
= GFC_SS_SECTION
;
2572 loop
->temp_ss
->data
.info
.dimen
= n
;
2573 gfc_trans_allocate_temp_array (loop
, &loop
->temp_ss
->data
.info
, tmp
);
2576 for (n
= 0; n
< loop
->temp_dim
; n
++)
2577 loopspec
[loop
->order
[n
]] = NULL
;
2581 /* For array parameters we don't have loop variables, so don't calculate the
2583 if (loop
->array_parameter
)
2586 /* Calculate the translation from loop variables to array indices. */
2587 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2589 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
2592 info
= &ss
->data
.info
;
2594 for (n
= 0; n
< info
->dimen
; n
++)
2598 /* If we are specifying the range the delta is already set. */
2599 if (loopspec
[n
] != ss
)
2601 /* Calculate the offset relative to the loop variable.
2602 First multiply by the stride. */
2603 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
,
2604 loop
->from
[n
], info
->stride
[n
]));
2606 /* Then subtract this from our starting value. */
2607 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
2608 info
->start
[n
], tmp
));
2610 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2617 /* Fills in an array descriptor, and returns the size of the array. The size
2618 will be a simple_val, ie a variable or a constant. Also calculates the
2619 offset of the base. Returns the size of the array.
2623 for (n = 0; n < rank; n++)
2625 a.lbound[n] = specified_lower_bound;
2626 offset = offset + a.lbond[n] * stride;
2628 a.ubound[n] = specified_upper_bound;
2629 a.stride[n] = stride;
2630 size = ubound + size; //size = ubound + 1 - lbound
2631 stride = stride * size;
2638 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
2639 gfc_expr
** lower
, gfc_expr
** upper
,
2640 stmtblock_t
* pblock
)
2651 type
= TREE_TYPE (descriptor
);
2653 stride
= gfc_index_one_node
;
2654 offset
= gfc_index_zero_node
;
2656 /* Set the dtype. */
2657 tmp
= gfc_conv_descriptor_dtype (descriptor
);
2658 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
2660 for (n
= 0; n
< rank
; n
++)
2662 /* We have 3 possibilities for determining the size of the array:
2663 lower == NULL => lbound = 1, ubound = upper[n]
2664 upper[n] = NULL => lbound = 1, ubound = lower[n]
2665 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2668 /* Set lower bound. */
2669 gfc_init_se (&se
, NULL
);
2671 se
.expr
= gfc_index_one_node
;
2674 gcc_assert (lower
[n
]);
2677 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
2678 gfc_add_block_to_block (pblock
, &se
.pre
);
2682 se
.expr
= gfc_index_one_node
;
2686 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
2687 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2689 /* Work out the offset for this component. */
2690 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
));
2691 offset
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
2693 /* Start the calculation for the size of this dimension. */
2694 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
2695 gfc_index_one_node
, se
.expr
);
2697 /* Set upper bound. */
2698 gfc_init_se (&se
, NULL
);
2699 gcc_assert (ubound
);
2700 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
2701 gfc_add_block_to_block (pblock
, &se
.pre
);
2703 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
2704 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2706 /* Store the stride. */
2707 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
2708 gfc_add_modify_expr (pblock
, tmp
, stride
);
2710 /* Calculate the size of this dimension. */
2711 size
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
));
2713 /* Multiply the stride by the number of elements in this dimension. */
2714 stride
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
));
2715 stride
= gfc_evaluate_now (stride
, pblock
);
2718 /* The stride is the number of elements in the array, so multiply by the
2719 size of an element to get the total size. */
2720 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2721 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
));
2723 if (poffset
!= NULL
)
2725 offset
= gfc_evaluate_now (offset
, pblock
);
2729 size
= gfc_evaluate_now (size
, pblock
);
2734 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2735 the work for an ALLOCATE statement. */
2739 gfc_array_allocate (gfc_se
* se
, gfc_ref
* ref
, tree pstat
)
2749 /* Figure out the size of the array. */
2750 switch (ref
->u
.ar
.type
)
2754 upper
= ref
->u
.ar
.start
;
2758 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
2760 lower
= ref
->u
.ar
.as
->lower
;
2761 upper
= ref
->u
.ar
.as
->upper
;
2765 lower
= ref
->u
.ar
.start
;
2766 upper
= ref
->u
.ar
.end
;
2774 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
2775 lower
, upper
, &se
->pre
);
2777 /* Allocate memory to store the data. */
2778 tmp
= gfc_conv_descriptor_data (se
->expr
);
2779 pointer
= gfc_build_addr_expr (NULL
, tmp
);
2780 pointer
= gfc_evaluate_now (pointer
, &se
->pre
);
2782 if (TYPE_PRECISION (gfc_array_index_type
) == 32)
2783 allocate
= gfor_fndecl_allocate
;
2784 else if (TYPE_PRECISION (gfc_array_index_type
) == 64)
2785 allocate
= gfor_fndecl_allocate64
;
2789 tmp
= gfc_chainon_list (NULL_TREE
, pointer
);
2790 tmp
= gfc_chainon_list (tmp
, size
);
2791 tmp
= gfc_chainon_list (tmp
, pstat
);
2792 tmp
= gfc_build_function_call (allocate
, tmp
);
2793 gfc_add_expr_to_block (&se
->pre
, tmp
);
2795 pointer
= gfc_conv_descriptor_data (se
->expr
);
2797 tmp
= gfc_conv_descriptor_offset (se
->expr
);
2798 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
2802 /* Deallocate an array variable. Also used when an allocated variable goes
2807 gfc_array_deallocate (tree descriptor
)
2813 gfc_start_block (&block
);
2814 /* Get a pointer to the data. */
2815 tmp
= gfc_conv_descriptor_data (descriptor
);
2816 tmp
= gfc_build_addr_expr (NULL
, tmp
);
2817 var
= gfc_create_var (TREE_TYPE (tmp
), "ptr");
2818 gfc_add_modify_expr (&block
, var
, tmp
);
2820 /* Parameter is the address of the data component. */
2821 tmp
= gfc_chainon_list (NULL_TREE
, var
);
2822 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
2823 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
2824 gfc_add_expr_to_block (&block
, tmp
);
2826 return gfc_finish_block (&block
);
2830 /* Create an array constructor from an initialization expression.
2831 We assume the frontend already did any expansions and conversions. */
2834 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
2842 unsigned HOST_WIDE_INT lo
;
2846 switch (expr
->expr_type
)
2849 case EXPR_STRUCTURE
:
2850 /* A single scalar or derived type value. Create an array with all
2851 elements equal to that value. */
2852 gfc_init_se (&se
, NULL
);
2854 if (expr
->expr_type
== EXPR_CONSTANT
)
2855 gfc_conv_constant (&se
, expr
);
2857 gfc_conv_structure (&se
, expr
, 1);
2859 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2860 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2861 hi
= TREE_INT_CST_HIGH (tmp
);
2862 lo
= TREE_INT_CST_LOW (tmp
);
2866 /* This will probably eat buckets of memory for large arrays. */
2867 while (hi
!= 0 || lo
!= 0)
2869 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
2877 /* Create a list of all the elements. */
2878 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2882 /* Problems occur when we get something like
2883 integer :: a(lots) = (/(i, i=1,lots)/) */
2884 /* TODO: Unexpanded array initializers. */
2886 ("Possible frontend bug: array constructor not expanded");
2888 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2889 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2893 if (mpz_cmp_si (c
->repeat
, 0) != 0)
2897 mpz_set (maxval
, c
->repeat
);
2898 mpz_add (maxval
, c
->n
.offset
, maxval
);
2899 mpz_sub_ui (maxval
, maxval
, 1);
2900 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2901 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2903 mpz_add_ui (maxval
, c
->n
.offset
, 1);
2904 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2907 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2909 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
2915 gfc_init_se (&se
, NULL
);
2916 switch (c
->expr
->expr_type
)
2919 gfc_conv_constant (&se
, c
->expr
);
2920 if (range
== NULL_TREE
)
2921 list
= tree_cons (index
, se
.expr
, list
);
2924 if (index
!= NULL_TREE
)
2925 list
= tree_cons (index
, se
.expr
, list
);
2926 list
= tree_cons (range
, se
.expr
, list
);
2930 case EXPR_STRUCTURE
:
2931 gfc_conv_structure (&se
, c
->expr
, 1);
2932 list
= tree_cons (index
, se
.expr
, list
);
2939 /* We created the list in reverse order. */
2940 list
= nreverse (list
);
2947 /* Create a constructor from the list of elements. */
2948 tmp
= build1 (CONSTRUCTOR
, type
, list
);
2949 TREE_CONSTANT (tmp
) = 1;
2950 TREE_INVARIANT (tmp
) = 1;
2955 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2956 returns the size (in elements) of the array. */
2959 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
2960 stmtblock_t
* pblock
)
2975 size
= gfc_index_one_node
;
2976 offset
= gfc_index_zero_node
;
2977 for (dim
= 0; dim
< as
->rank
; dim
++)
2979 /* Evaluate non-constant array bound expressions. */
2980 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2981 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
2983 gfc_init_se (&se
, NULL
);
2984 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
2985 gfc_add_block_to_block (pblock
, &se
.pre
);
2986 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
2988 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2989 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
2991 gfc_init_se (&se
, NULL
);
2992 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
2993 gfc_add_block_to_block (pblock
, &se
.pre
);
2994 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
2996 /* The offset of this dimension. offset = offset - lbound * stride. */
2997 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
));
2998 offset
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
3000 /* The size of this dimension, and the stride of the next. */
3001 if (dim
+ 1 < as
->rank
)
3002 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3006 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3008 /* Calculate stride = size * (ubound + 1 - lbound). */
3009 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
3010 gfc_index_one_node
, lbound
));
3011 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
));
3012 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
3014 gfc_add_modify_expr (pblock
, stride
, tmp
);
3016 stride
= gfc_evaluate_now (tmp
, pblock
);
3027 /* Generate code to initialize/allocate an array variable. */
3030 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3040 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3042 /* Do nothing for USEd variables. */
3043 if (sym
->attr
.use_assoc
)
3046 type
= TREE_TYPE (decl
);
3047 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3048 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3050 gfc_start_block (&block
);
3052 /* Evaluate character string length. */
3053 if (sym
->ts
.type
== BT_CHARACTER
3054 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3056 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3058 /* Emit a DECL_EXPR for this variable, which will cause the
3059 gimplifier to allocate storage, and all that good stuff. */
3060 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3061 gfc_add_expr_to_block (&block
, tmp
);
3066 gfc_add_expr_to_block (&block
, fnbody
);
3067 return gfc_finish_block (&block
);
3070 type
= TREE_TYPE (type
);
3072 gcc_assert (!sym
->attr
.use_assoc
);
3073 gcc_assert (!TREE_STATIC (decl
));
3074 gcc_assert (!sym
->module
[0]);
3076 if (sym
->ts
.type
== BT_CHARACTER
3077 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3078 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3080 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3082 /* The size is the number of elements in the array, so multiply by the
3083 size of an element to get the total size. */
3084 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3085 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
3087 /* Allocate memory to hold the data. */
3088 tmp
= gfc_chainon_list (NULL_TREE
, size
);
3090 if (gfc_index_integer_kind
== 4)
3091 fndecl
= gfor_fndecl_internal_malloc
;
3092 else if (gfc_index_integer_kind
== 8)
3093 fndecl
= gfor_fndecl_internal_malloc64
;
3096 tmp
= gfc_build_function_call (fndecl
, tmp
);
3097 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
3098 gfc_add_modify_expr (&block
, decl
, tmp
);
3100 /* Set offset of the array. */
3101 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3102 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3105 /* Automatic arrays should not have initializers. */
3106 gcc_assert (!sym
->value
);
3108 gfc_add_expr_to_block (&block
, fnbody
);
3110 /* Free the temporary. */
3111 tmp
= convert (pvoid_type_node
, decl
);
3112 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3113 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3114 gfc_add_expr_to_block (&block
, tmp
);
3116 return gfc_finish_block (&block
);
3120 /* Generate entry and exit code for g77 calling convention arrays. */
3123 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3132 gfc_get_backend_locus (&loc
);
3133 gfc_set_backend_locus (&sym
->declared_at
);
3135 /* Descriptor type. */
3136 parm
= sym
->backend_decl
;
3137 type
= TREE_TYPE (parm
);
3138 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3140 gfc_start_block (&block
);
3142 if (sym
->ts
.type
== BT_CHARACTER
3143 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3144 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3146 /* Evaluate the bounds of the array. */
3147 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3149 /* Set the offset. */
3150 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3151 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3153 /* Set the pointer itself if we aren't using the parameter directly. */
3154 if (TREE_CODE (parm
) != PARM_DECL
)
3156 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3157 gfc_add_modify_expr (&block
, parm
, tmp
);
3159 tmp
= gfc_finish_block (&block
);
3161 gfc_set_backend_locus (&loc
);
3163 gfc_start_block (&block
);
3164 /* Add the initialization code to the start of the function. */
3165 gfc_add_expr_to_block (&block
, tmp
);
3166 gfc_add_expr_to_block (&block
, body
);
3168 return gfc_finish_block (&block
);
3172 /* Modify the descriptor of an array parameter so that it has the
3173 correct lower bound. Also move the upper bound accordingly.
3174 If the array is not packed, it will be copied into a temporary.
3175 For each dimension we set the new lower and upper bounds. Then we copy the
3176 stride and calculate the offset for this dimension. We also work out
3177 what the stride of a packed array would be, and see it the two match.
3178 If the array need repacking, we set the stride to the values we just
3179 calculated, recalculate the offset and copy the array data.
3180 Code is also added to copy the data back at the end of the function.
3184 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3191 stmtblock_t cleanup
;
3209 /* Do nothing for pointer and allocatable arrays. */
3210 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3213 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3214 return gfc_trans_g77_array (sym
, body
);
3216 gfc_get_backend_locus (&loc
);
3217 gfc_set_backend_locus (&sym
->declared_at
);
3219 /* Descriptor type. */
3220 type
= TREE_TYPE (tmpdesc
);
3221 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3222 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3223 dumdesc
= gfc_build_indirect_ref (dumdesc
);
3224 gfc_start_block (&block
);
3226 if (sym
->ts
.type
== BT_CHARACTER
3227 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3228 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3230 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3232 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3233 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3235 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3237 /* For non-constant shape arrays we only check if the first dimension
3238 is contiguous. Repacking higher dimensions wouldn't gain us
3239 anything as we still don't know the array stride. */
3240 partial
= gfc_create_var (boolean_type_node
, "partial");
3241 TREE_USED (partial
) = 1;
3242 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3243 tmp
= fold (build2 (EQ_EXPR
, boolean_type_node
, tmp
, integer_one_node
));
3244 gfc_add_modify_expr (&block
, partial
, tmp
);
3248 partial
= NULL_TREE
;
3251 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3252 here, however I think it does the right thing. */
3255 /* Set the first stride. */
3256 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3257 stride
= gfc_evaluate_now (stride
, &block
);
3259 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, integer_zero_node
);
3260 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3261 gfc_index_one_node
, stride
);
3262 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3263 gfc_add_modify_expr (&block
, stride
, tmp
);
3265 /* Allow the user to disable array repacking. */
3266 stmt_unpacked
= NULL_TREE
;
3270 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3271 /* A library call to repack the array if necessary. */
3272 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3273 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3274 stmt_unpacked
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3276 stride
= gfc_index_one_node
;
3279 /* This is for the case where the array data is used directly without
3280 calling the repack function. */
3281 if (no_repack
|| partial
!= NULL_TREE
)
3282 stmt_packed
= gfc_conv_descriptor_data (dumdesc
);
3284 stmt_packed
= NULL_TREE
;
3286 /* Assign the data pointer. */
3287 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3289 /* Don't repack unknown shape arrays when the first stride is 1. */
3290 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3291 stmt_packed
, stmt_unpacked
);
3294 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3295 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
3297 offset
= gfc_index_zero_node
;
3298 size
= gfc_index_one_node
;
3300 /* Evaluate the bounds of the array. */
3301 for (n
= 0; n
< sym
->as
->rank
; n
++)
3303 if (checkparm
|| !sym
->as
->upper
[n
])
3305 /* Get the bounds of the actual parameter. */
3306 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3307 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3311 dubound
= NULL_TREE
;
3312 dlbound
= NULL_TREE
;
3315 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3316 if (!INTEGER_CST_P (lbound
))
3318 gfc_init_se (&se
, NULL
);
3319 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3320 gfc_array_index_type
);
3321 gfc_add_block_to_block (&block
, &se
.pre
);
3322 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3325 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3326 /* Set the desired upper bound. */
3327 if (sym
->as
->upper
[n
])
3329 /* We know what we want the upper bound to be. */
3330 if (!INTEGER_CST_P (ubound
))
3332 gfc_init_se (&se
, NULL
);
3333 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3334 gfc_array_index_type
);
3335 gfc_add_block_to_block (&block
, &se
.pre
);
3336 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3339 /* Check the sizes match. */
3342 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3344 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
3346 stride
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3348 tmp
= fold (build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride
));
3349 gfc_trans_runtime_check (tmp
, gfc_strconst_bounds
, &block
);
3354 /* For assumed shape arrays move the upper bound by the same amount
3355 as the lower bound. */
3356 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3357 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
));
3358 gfc_add_modify_expr (&block
, ubound
, tmp
);
3360 /* The offset of this dimension. offset = offset - lbound * stride. */
3361 tmp
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
));
3362 offset
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
3364 /* The size of this dimension, and the stride of the next. */
3365 if (n
+ 1 < sym
->as
->rank
)
3367 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3369 if (no_repack
|| partial
!= NULL_TREE
)
3372 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
3375 /* Figure out the stride if not a known constant. */
3376 if (!INTEGER_CST_P (stride
))
3379 stmt_packed
= NULL_TREE
;
3382 /* Calculate stride = size * (ubound + 1 - lbound). */
3383 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
3384 gfc_index_one_node
, lbound
));
3385 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
3387 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
,
3392 /* Assign the stride. */
3393 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3394 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
3395 stmt_unpacked
, stmt_packed
);
3397 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
3398 gfc_add_modify_expr (&block
, stride
, tmp
);
3403 /* Set the offset. */
3404 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3405 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3407 stmt
= gfc_finish_block (&block
);
3409 gfc_start_block (&block
);
3411 /* Only do the entry/initialization code if the arg is present. */
3412 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3413 optional_arg
= sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
;
3416 tmp
= gfc_conv_expr_present (sym
);
3417 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3419 gfc_add_expr_to_block (&block
, stmt
);
3421 /* Add the main function body. */
3422 gfc_add_expr_to_block (&block
, body
);
3427 gfc_start_block (&cleanup
);
3429 if (sym
->attr
.intent
!= INTENT_IN
)
3431 /* Copy the data back. */
3432 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
3433 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
3434 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3435 gfc_add_expr_to_block (&cleanup
, tmp
);
3438 /* Free the temporary. */
3439 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
3440 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3441 gfc_add_expr_to_block (&cleanup
, tmp
);
3443 stmt
= gfc_finish_block (&cleanup
);
3445 /* Only do the cleanup if the array was repacked. */
3446 tmp
= gfc_build_indirect_ref (dumdesc
);
3447 tmp
= gfc_conv_descriptor_data (tmp
);
3448 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
3449 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3453 tmp
= gfc_conv_expr_present (sym
);
3454 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3456 gfc_add_expr_to_block (&block
, stmt
);
3458 /* We don't need to free any memory allocated by internal_pack as it will
3459 be freed at the end of the function by pop_context. */
3460 return gfc_finish_block (&block
);
3464 /* Convert an array for passing as an actual parameter. Expressions and
3465 vector subscripts are evaluated and stored in a temporary, which is then
3466 passed. For whole arrays the descriptor is passed. For array sections
3467 a modified copy of the descriptor is passed, but using the original data.
3468 Also used for array pointer assignments by setting se->direct_byref. */
3471 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
3487 gcc_assert (ss
!= gfc_ss_terminator
);
3489 /* TODO: Pass constant array constructors without a temporary. */
3490 /* Special case things we know we can pass easily. */
3491 switch (expr
->expr_type
)
3494 /* If we have a linear array section, we can pass it directly.
3495 Otherwise we need to copy it into a temporary. */
3497 /* Find the SS for the array section. */
3499 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
3500 secss
= secss
->next
;
3502 gcc_assert (secss
!= gfc_ss_terminator
);
3505 for (n
= 0; n
< secss
->data
.info
.dimen
; n
++)
3507 vss
= secss
->data
.info
.subscript
[secss
->data
.info
.dim
[n
]];
3508 if (vss
&& vss
->type
== GFC_SS_VECTOR
)
3512 info
= &secss
->data
.info
;
3514 /* Get the descriptor for the array. */
3515 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
3516 desc
= info
->descriptor
;
3517 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
3519 /* Create a new descriptor if the array doesn't have one. */
3522 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
3524 else if (se
->direct_byref
)
3529 gcc_assert (ref
->u
.ar
.type
== AR_SECTION
);
3532 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3534 /* Detect passing the full array as a section. This could do
3535 even more checking, but it doesn't seem worth it. */
3536 if (ref
->u
.ar
.start
[n
]
3538 || (ref
->u
.ar
.stride
[n
]
3539 && !gfc_expr_is_one (ref
->u
.ar
.stride
[n
], 0)))
3547 /* Check for substring references. */
3549 if (!need_tmp
&& ref
&& expr
->ts
.type
== BT_CHARACTER
)
3553 if (ref
->type
== REF_SUBSTRING
)
3555 /* In general character substrings need a copy. Character
3556 array strides are expressed as multiples of the element
3557 size (consistent with other array types), not in
3566 if (se
->direct_byref
)
3568 /* Copy the descriptor for pointer assignments. */
3569 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
3571 else if (se
->want_pointer
)
3573 /* We pass full arrays directly. This means that pointers and
3574 allocatable arrays should also work. */
3575 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3582 if (expr
->ts
.type
== BT_CHARACTER
)
3583 se
->string_length
= gfc_get_expr_charlen (expr
);
3590 /* A transformational function return value will be a temporary
3591 array descriptor. We still need to go through the scalarizer
3592 to create the descriptor. Elemental functions ar handled as
3593 arbitrary expressions, i.e. copy to a temporary. */
3595 /* Look for the SS for this function. */
3596 while (secss
!= gfc_ss_terminator
3597 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
3598 secss
= secss
->next
;
3600 if (se
->direct_byref
)
3602 gcc_assert (secss
!= gfc_ss_terminator
);
3604 /* For pointer assignments pass the descriptor directly. */
3606 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3607 gfc_conv_expr (se
, expr
);
3611 if (secss
== gfc_ss_terminator
)
3613 /* Elemental function. */
3619 /* Transformational function. */
3620 info
= &secss
->data
.info
;
3626 /* Something complicated. Copy it into a temporary. */
3634 gfc_init_loopinfo (&loop
);
3636 /* Associate the SS with the loop. */
3637 gfc_add_ss_to_loop (&loop
, ss
);
3639 /* Tell the scalarizer not to bother creating loop variables, etc. */
3641 loop
.array_parameter
= 1;
3643 gcc_assert (se
->want_pointer
&& !se
->direct_byref
);
3645 /* Setup the scalarizing loops and bounds. */
3646 gfc_conv_ss_startstride (&loop
);
3650 /* Tell the scalarizer to make a temporary. */
3651 loop
.temp_ss
= gfc_get_ss ();
3652 loop
.temp_ss
->type
= GFC_SS_TEMP
;
3653 loop
.temp_ss
->next
= gfc_ss_terminator
;
3654 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
3655 /* ... which can hold our string, if present. */
3656 if (expr
->ts
.type
== BT_CHARACTER
)
3657 se
->string_length
= loop
.temp_ss
->string_length
3658 = TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
3660 loop
.temp_ss
->string_length
= NULL
;
3661 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
3662 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3665 gfc_conv_loop_setup (&loop
);
3669 /* Copy into a temporary and pass that. We don't need to copy the data
3670 back because expressions and vector subscripts must be INTENT_IN. */
3671 /* TODO: Optimize passing function return values. */
3675 /* Start the copying loops. */
3676 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3677 gfc_mark_ss_chain_used (ss
, 1);
3678 gfc_start_scalarized_body (&loop
, &block
);
3680 /* Copy each data element. */
3681 gfc_init_se (&lse
, NULL
);
3682 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3683 gfc_init_se (&rse
, NULL
);
3684 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3686 lse
.ss
= loop
.temp_ss
;
3689 gfc_conv_scalarized_array_ref (&lse
, NULL
);
3690 gfc_conv_expr_val (&rse
, expr
);
3692 gfc_add_block_to_block (&block
, &rse
.pre
);
3693 gfc_add_block_to_block (&block
, &lse
.pre
);
3695 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
3697 /* Finish the copying loops. */
3698 gfc_trans_scalarizing_loops (&loop
, &block
);
3700 /* Set the first stride component to zero to indicate a temporary. */
3701 desc
= loop
.temp_ss
->data
.info
.descriptor
;
3702 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[0]);
3703 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3705 gcc_assert (is_gimple_lvalue (desc
));
3706 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3708 else if (expr
->expr_type
== EXPR_FUNCTION
)
3710 desc
= info
->descriptor
;
3712 if (se
->want_pointer
)
3713 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3717 if (expr
->ts
.type
== BT_CHARACTER
)
3718 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3722 /* We pass sections without copying to a temporary. Make a new
3723 descriptor and point it at the section we want. The loop variable
3724 limits will be the limits of the section.
3725 A function may decide to repack the array to speed up access, but
3726 we're not bothered about that here. */
3735 /* Set the string_length for a character array. */
3736 if (expr
->ts
.type
== BT_CHARACTER
)
3737 se
->string_length
= gfc_get_expr_charlen (expr
);
3739 desc
= info
->descriptor
;
3740 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
3741 if (se
->direct_byref
)
3743 /* For pointer assignments we fill in the destination. */
3745 parmtype
= TREE_TYPE (parm
);
3749 /* Otherwise make a new one. */
3750 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3751 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
3752 loop
.from
, loop
.to
, 0);
3753 parm
= gfc_create_var (parmtype
, "parm");
3756 offset
= gfc_index_zero_node
;
3759 /* The following can be somewhat confusing. We have two
3760 descriptors, a new one and the original array.
3761 {parm, parmtype, dim} refer to the new one.
3762 {desc, type, n, secss, loop} refer to the original, which maybe
3763 a descriptorless array.
3764 The bounds of the scalarization are the bounds of the section.
3765 We don't have to worry about numeric overflows when calculating
3766 the offsets because all elements are within the array data. */
3768 /* Set the dtype. */
3769 tmp
= gfc_conv_descriptor_dtype (parm
);
3770 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
3772 if (se
->direct_byref
)
3773 base
= gfc_index_zero_node
;
3777 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3779 stride
= gfc_conv_array_stride (desc
, n
);
3781 /* Work out the offset. */
3782 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3784 gcc_assert (info
->subscript
[n
]
3785 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
3786 start
= info
->subscript
[n
]->data
.scalar
.expr
;
3790 /* Check we haven't somehow got out of sync. */
3791 gcc_assert (info
->dim
[dim
] == n
);
3793 /* Evaluate and remember the start of the section. */
3794 start
= info
->start
[dim
];
3795 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
3798 tmp
= gfc_conv_array_lbound (desc
, n
);
3799 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
));
3801 tmp
= fold (build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
));
3802 offset
= fold (build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
));
3804 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3806 /* For elemental dimensions, we only need the offset. */
3810 /* Vector subscripts need copying and are handled elsewhere. */
3811 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
3813 /* Set the new lower bound. */
3814 from
= loop
.from
[dim
];
3816 if (!integer_onep (from
))
3818 /* Make sure the new section starts at 1. */
3819 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
3820 gfc_index_one_node
, from
));
3821 to
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
));
3822 from
= gfc_index_one_node
;
3824 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
3825 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
3827 /* Set the new upper bound. */
3828 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
3829 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
3831 /* Multiply the stride by the section stride to get the
3833 stride
= fold (build2 (MULT_EXPR
, gfc_array_index_type
,
3834 stride
, info
->stride
[dim
]));
3836 if (se
->direct_byref
)
3837 base
= fold (build2 (MINUS_EXPR
, TREE_TYPE (base
),
3840 /* Store the new stride. */
3841 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
3842 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
3847 /* Point the data pointer at the first element in the section. */
3848 tmp
= gfc_conv_array_data (desc
);
3849 tmp
= gfc_build_indirect_ref (tmp
);
3850 tmp
= gfc_build_array_ref (tmp
, offset
);
3851 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
3853 tmp
= gfc_conv_descriptor_data (parm
);
3854 gfc_add_modify_expr (&loop
.pre
, tmp
,
3855 fold_convert (TREE_TYPE (tmp
), offset
));
3857 if (se
->direct_byref
)
3859 /* Set the offset. */
3860 tmp
= gfc_conv_descriptor_offset (parm
);
3861 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
3865 /* Only the callee knows what the correct offset it, so just set
3867 tmp
= gfc_conv_descriptor_offset (parm
);
3868 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3871 if (!se
->direct_byref
)
3873 /* Get a pointer to the new descriptor. */
3874 if (se
->want_pointer
)
3875 se
->expr
= gfc_build_addr_expr (NULL
, parm
);
3881 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3882 gfc_add_block_to_block (&se
->post
, &loop
.post
);
3884 /* Cleanup the scalarizer. */
3885 gfc_cleanup_loop (&loop
);
3889 /* Convert an array for passing as an actual parameter. */
3890 /* TODO: Optimize passing g77 arrays. */
3893 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
3902 /* Passing address of the array if it is not pointer or assumed-shape. */
3903 if (expr
->expr_type
== EXPR_VARIABLE
3904 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
3906 sym
= expr
->symtree
->n
.sym
;
3907 tmp
= gfc_get_symbol_decl (sym
);
3908 if (sym
->ts
.type
== BT_CHARACTER
)
3909 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3910 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
3911 && !sym
->attr
.allocatable
)
3913 /* Some variables are declared directly, others are declared as
3914 pointers and allocated on the heap. */
3915 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
3918 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
3921 if (sym
->attr
.allocatable
)
3923 se
->expr
= gfc_conv_array_data (tmp
);
3928 se
->want_pointer
= 1;
3929 gfc_conv_expr_descriptor (se
, expr
, ss
);
3934 /* Repack the array. */
3935 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3936 ptr
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3937 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
3940 gfc_start_block (&block
);
3942 /* Copy the data back. */
3943 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3944 tmp
= gfc_chainon_list (tmp
, ptr
);
3945 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3946 gfc_add_expr_to_block (&block
, tmp
);
3948 /* Free the temporary. */
3949 tmp
= convert (pvoid_type_node
, ptr
);
3950 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3951 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3952 gfc_add_expr_to_block (&block
, tmp
);
3954 stmt
= gfc_finish_block (&block
);
3956 gfc_init_block (&block
);
3957 /* Only if it was repacked. This code needs to be executed before the
3958 loop cleanup code. */
3959 tmp
= gfc_build_indirect_ref (desc
);
3960 tmp
= gfc_conv_array_data (tmp
);
3961 tmp
= build2 (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
3962 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3964 gfc_add_expr_to_block (&block
, tmp
);
3965 gfc_add_block_to_block (&block
, &se
->post
);
3967 gfc_init_block (&se
->post
);
3968 gfc_add_block_to_block (&se
->post
, &block
);
3973 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3976 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
3983 stmtblock_t fnblock
;
3986 /* Make sure the frontend gets these right. */
3987 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3989 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
3991 gfc_init_block (&fnblock
);
3993 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
);
3994 if (sym
->ts
.type
== BT_CHARACTER
3995 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3996 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
3998 /* Parameter and use associated variables don't need anything special. */
3999 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
4001 gfc_add_expr_to_block (&fnblock
, body
);
4003 return gfc_finish_block (&fnblock
);
4006 gfc_get_backend_locus (&loc
);
4007 gfc_set_backend_locus (&sym
->declared_at
);
4008 descriptor
= sym
->backend_decl
;
4010 if (TREE_STATIC (descriptor
))
4012 /* SAVEd variables are not freed on exit. */
4013 gfc_trans_static_array_pointer (sym
);
4017 /* Get the descriptor type. */
4018 type
= TREE_TYPE (sym
->backend_decl
);
4019 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
4021 /* NULLIFY the data pointer. */
4022 tmp
= gfc_conv_descriptor_data (descriptor
);
4023 gfc_add_modify_expr (&fnblock
, tmp
,
4024 convert (TREE_TYPE (tmp
), integer_zero_node
));
4026 gfc_add_expr_to_block (&fnblock
, body
);
4028 gfc_set_backend_locus (&loc
);
4029 /* Allocatable arrays need to be freed when they go out of scope. */
4030 if (sym
->attr
.allocatable
)
4032 gfc_start_block (&block
);
4034 /* Deallocate if still allocated at the end of the procedure. */
4035 deallocate
= gfc_array_deallocate (descriptor
);
4037 tmp
= gfc_conv_descriptor_data (descriptor
);
4038 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, integer_zero_node
);
4039 tmp
= build3_v (COND_EXPR
, tmp
, deallocate
, build_empty_stmt ());
4040 gfc_add_expr_to_block (&block
, tmp
);
4042 tmp
= gfc_finish_block (&block
);
4043 gfc_add_expr_to_block (&fnblock
, tmp
);
4046 return gfc_finish_block (&fnblock
);
4049 /************ Expression Walking Functions ******************/
4051 /* Walk a variable reference.
4053 Possible extension - multiple component subscripts.
4054 x(:,:) = foo%a(:)%b(:)
4056 forall (i=..., j=...)
4057 x(i,j) = foo%a(j)%b(i)
4059 This adds a fair amout of complexity because you need to deal with more
4060 than one ref. Maybe handle in a similar manner to vector subscripts.
4061 Maybe not worth the effort. */
4065 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4073 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4075 /* We're only interested in array sections. */
4076 if (ref
->type
!= REF_ARRAY
)
4083 /* TODO: Take elemental array references out of scalarization
4088 newss
= gfc_get_ss ();
4089 newss
->type
= GFC_SS_SECTION
;
4092 newss
->data
.info
.dimen
= ar
->as
->rank
;
4093 newss
->data
.info
.ref
= ref
;
4095 /* Make sure array is the same as array(:,:), this way
4096 we don't need to special case all the time. */
4097 ar
->dimen
= ar
->as
->rank
;
4098 for (n
= 0; n
< ar
->dimen
; n
++)
4100 newss
->data
.info
.dim
[n
] = n
;
4101 ar
->dimen_type
[n
] = DIMEN_RANGE
;
4103 gcc_assert (ar
->start
[n
] == NULL
);
4104 gcc_assert (ar
->end
[n
] == NULL
);
4105 gcc_assert (ar
->stride
[n
] == NULL
);
4110 newss
= gfc_get_ss ();
4111 newss
->type
= GFC_SS_SECTION
;
4114 newss
->data
.info
.dimen
= 0;
4115 newss
->data
.info
.ref
= ref
;
4119 /* We add SS chains for all the subscripts in the section. */
4120 for (n
= 0; n
< ar
->dimen
; n
++)
4124 switch (ar
->dimen_type
[n
])
4127 /* Add SS for elemental (scalar) subscripts. */
4128 gcc_assert (ar
->start
[n
]);
4129 indexss
= gfc_get_ss ();
4130 indexss
->type
= GFC_SS_SCALAR
;
4131 indexss
->expr
= ar
->start
[n
];
4132 indexss
->next
= gfc_ss_terminator
;
4133 indexss
->loop_chain
= gfc_ss_terminator
;
4134 newss
->data
.info
.subscript
[n
] = indexss
;
4138 /* We don't add anything for sections, just remember this
4139 dimension for later. */
4140 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4141 newss
->data
.info
.dimen
++;
4145 /* Get a SS for the vector. This will not be added to the
4147 indexss
= gfc_walk_expr (ar
->start
[n
]);
4148 if (indexss
== gfc_ss_terminator
)
4149 internal_error ("scalar vector subscript???");
4151 /* We currently only handle really simple vector
4153 if (indexss
->next
!= gfc_ss_terminator
)
4154 gfc_todo_error ("vector subscript expressions");
4155 indexss
->loop_chain
= gfc_ss_terminator
;
4157 /* Mark this as a vector subscript. We don't add this
4158 directly into the chain, but as a subscript of the
4159 existing SS for this term. */
4160 indexss
->type
= GFC_SS_VECTOR
;
4161 newss
->data
.info
.subscript
[n
] = indexss
;
4162 /* Also remember this dimension. */
4163 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4164 newss
->data
.info
.dimen
++;
4168 /* We should know what sort of section it is by now. */
4172 /* We should have at least one non-elemental dimension. */
4173 gcc_assert (newss
->data
.info
.dimen
> 0);
4178 /* We should know what sort of section it is by now. */
4187 /* Walk an expression operator. If only one operand of a binary expression is
4188 scalar, we must also add the scalar term to the SS chain. */
4191 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4197 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
4198 if (expr
->value
.op
.op2
== NULL
)
4201 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
4203 /* All operands are scalar. Pass back and let the caller deal with it. */
4207 /* All operands require scalarization. */
4208 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
4211 /* One of the operands needs scalarization, the other is scalar.
4212 Create a gfc_ss for the scalar expression. */
4213 newss
= gfc_get_ss ();
4214 newss
->type
= GFC_SS_SCALAR
;
4217 /* First operand is scalar. We build the chain in reverse order, so
4218 add the scarar SS after the second operand. */
4220 while (head
&& head
->next
!= ss
)
4222 /* Check we haven't somehow broken the chain. */
4226 newss
->expr
= expr
->value
.op
.op1
;
4228 else /* head2 == head */
4230 gcc_assert (head2
== head
);
4231 /* Second operand is scalar. */
4232 newss
->next
= head2
;
4234 newss
->expr
= expr
->value
.op
.op2
;
4241 /* Reverse a SS chain. */
4244 gfc_reverse_ss (gfc_ss
* ss
)
4249 gcc_assert (ss
!= NULL
);
4251 head
= gfc_ss_terminator
;
4252 while (ss
!= gfc_ss_terminator
)
4255 /* Check we didn't somehow break the chain. */
4256 gcc_assert (next
!= NULL
);
4266 /* Walk the arguments of an elemental function. */
4269 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_expr
* expr
,
4272 gfc_actual_arglist
*arg
;
4278 head
= gfc_ss_terminator
;
4281 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4286 newss
= gfc_walk_subexpr (head
, arg
->expr
);
4289 /* Scalar argument. */
4290 newss
= gfc_get_ss ();
4292 newss
->expr
= arg
->expr
;
4302 while (tail
->next
!= gfc_ss_terminator
)
4309 /* If all the arguments are scalar we don't need the argument SS. */
4310 gfc_free_ss_chain (head
);
4315 /* Add it onto the existing chain. */
4321 /* Walk a function call. Scalar functions are passed back, and taken out of
4322 scalarization loops. For elemental functions we walk their arguments.
4323 The result of functions returning arrays is stored in a temporary outside
4324 the loop, so that the function is only called once. Hence we do not need
4325 to walk their arguments. */
4328 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4331 gfc_intrinsic_sym
*isym
;
4334 isym
= expr
->value
.function
.isym
;
4336 /* Handle intrinsic functions separately. */
4338 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
4340 sym
= expr
->value
.function
.esym
;
4342 sym
= expr
->symtree
->n
.sym
;
4344 /* A function that returns arrays. */
4345 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
4347 newss
= gfc_get_ss ();
4348 newss
->type
= GFC_SS_FUNCTION
;
4351 newss
->data
.info
.dimen
= expr
->rank
;
4355 /* Walk the parameters of an elemental function. For now we always pass
4357 if (sym
->attr
.elemental
)
4358 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_REFERENCE
);
4360 /* Scalar functions are OK as these are evaluated outside the scalarization
4361 loop. Pass back and let the caller deal with it. */
4366 /* An array temporary is constructed for array constructors. */
4369 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
4374 newss
= gfc_get_ss ();
4375 newss
->type
= GFC_SS_CONSTRUCTOR
;
4378 newss
->data
.info
.dimen
= expr
->rank
;
4379 for (n
= 0; n
< expr
->rank
; n
++)
4380 newss
->data
.info
.dim
[n
] = n
;
4386 /* Walk an expression. Add walked expressions to the head of the SS chain.
4387 A wholy scalar expression will not be added. */
4390 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
4394 switch (expr
->expr_type
)
4397 head
= gfc_walk_variable_expr (ss
, expr
);
4401 head
= gfc_walk_op_expr (ss
, expr
);
4405 head
= gfc_walk_function_expr (ss
, expr
);
4410 case EXPR_STRUCTURE
:
4411 /* Pass back and let the caller deal with it. */
4415 head
= gfc_walk_array_constructor (ss
, expr
);
4418 case EXPR_SUBSTRING
:
4419 /* Pass back and let the caller deal with it. */
4423 internal_error ("bad expression type during walk (%d)",
4430 /* Entry point for expression walking.
4431 A return value equal to the passed chain means this is
4432 a scalar expression. It is up to the caller to take whatever action is
4433 necessary to translate these. */
4436 gfc_walk_expr (gfc_expr
* expr
)
4440 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
4441 return gfc_reverse_ss (res
);