1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automaticaly 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"
93 #include "trans-stmt.h"
94 #include "trans-types.h"
95 #include "trans-array.h"
96 #include "trans-const.h"
97 #include "dependency.h"
99 static gfc_ss
*gfc_walk_subexpr (gfc_ss
*, gfc_expr
*);
101 /* The contents of this structure aren't actually used, just the address. */
102 static gfc_ss gfc_ss_terminator_var
;
103 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
105 unsigned HOST_WIDE_INT gfc_stack_space_left
;
108 /* Returns true if a variable of specified size should go on the stack. */
111 gfc_can_put_var_on_stack (tree size
)
113 unsigned HOST_WIDE_INT low
;
115 if (!INTEGER_CST_P (size
))
118 if (gfc_option
.flag_max_stack_var_size
< 0)
121 if (TREE_INT_CST_HIGH (size
) != 0)
124 low
= TREE_INT_CST_LOW (size
);
125 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
128 /* TODO: Set a per-function stack size limit. */
130 /* We should be a bit more clever with array temps. */
131 if (gfc_option
.flag_max_function_vars_size
>= 0)
133 if (low
> gfc_stack_space_left
)
136 gfc_stack_space_left
-= low
;
144 gfc_array_dataptr_type (tree desc
)
146 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
150 /* Build expressions to access the members of an array descriptor.
151 It's surprisingly easy to mess up here, so never access
152 an array descriptor by "brute force", always use these
153 functions. This also avoids problems if we change the format
154 of an array descriptor.
156 To understand these magic numbers, look at the comments
157 before gfc_build_array_type() in trans-types.c.
159 The code within these defines should be the only code which knows the format
160 of an array descriptor.
162 Any code just needing to read obtain the bounds of an array should use
163 gfc_conv_array_* rather than the following functions as these will return
164 know constant values, and work with arrays which do not have descriptors.
166 Don't forget to #undef these! */
169 #define OFFSET_FIELD 1
170 #define DTYPE_FIELD 2
171 #define DIMENSION_FIELD 3
173 #define STRIDE_SUBFIELD 0
174 #define LBOUND_SUBFIELD 1
175 #define UBOUND_SUBFIELD 2
178 gfc_conv_descriptor_data (tree desc
)
183 type
= TREE_TYPE (desc
);
184 assert (GFC_DESCRIPTOR_TYPE_P (type
));
186 field
= TYPE_FIELDS (type
);
187 assert (DATA_FIELD
== 0);
188 assert (field
!= NULL_TREE
189 && TREE_CODE (TREE_TYPE (field
)) == POINTER_TYPE
190 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == ARRAY_TYPE
);
192 return build (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
196 gfc_conv_descriptor_offset (tree desc
)
201 type
= TREE_TYPE (desc
);
202 assert (GFC_DESCRIPTOR_TYPE_P (type
));
204 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
205 assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
207 return build (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
211 gfc_conv_descriptor_dtype (tree desc
)
216 type
= TREE_TYPE (desc
);
217 assert (GFC_DESCRIPTOR_TYPE_P (type
));
219 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
220 assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
222 return build (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
226 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
232 type
= TREE_TYPE (desc
);
233 assert (GFC_DESCRIPTOR_TYPE_P (type
));
235 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
236 assert (field
!= NULL_TREE
237 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
238 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
240 tmp
= build (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
241 tmp
= gfc_build_array_ref (tmp
, dim
);
246 gfc_conv_descriptor_stride (tree desc
, tree dim
)
251 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
252 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
253 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
254 assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
256 tmp
= build (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
261 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
266 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
267 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
268 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
269 assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
271 tmp
= build (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
276 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
281 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
282 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
283 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
284 assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
286 tmp
= build (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
291 /* Build an null array descriptor constructor. */
294 gfc_build_null_descriptor (tree type
)
299 assert (GFC_DESCRIPTOR_TYPE_P (type
));
300 assert (DATA_FIELD
== 0);
301 field
= TYPE_FIELDS (type
);
303 /* Set a NULL data pointer. */
304 tmp
= tree_cons (field
, null_pointer_node
, NULL_TREE
);
305 tmp
= build1 (CONSTRUCTOR
, type
, tmp
);
306 TREE_CONSTANT (tmp
) = 1;
307 TREE_INVARIANT (tmp
) = 1;
308 /* All other fields are ignored. */
314 /* Cleanup those #defines. */
319 #undef DIMENSION_FIELD
320 #undef STRIDE_SUBFIELD
321 #undef LBOUND_SUBFIELD
322 #undef UBOUND_SUBFIELD
325 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
326 flags & 1 = Main loop body.
327 flags & 2 = temp copy loop. */
330 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
332 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
333 ss
->useflags
= flags
;
336 static void gfc_free_ss (gfc_ss
*);
339 /* Free a gfc_ss chain. */
342 gfc_free_ss_chain (gfc_ss
* ss
)
346 while (ss
!= gfc_ss_terminator
)
359 gfc_free_ss (gfc_ss
* ss
)
367 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
369 if (ss
->data
.info
.subscript
[n
])
370 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
382 /* Free all the SS associated with a loop. */
385 gfc_cleanup_loop (gfc_loopinfo
* loop
)
391 while (ss
!= gfc_ss_terminator
)
394 next
= ss
->loop_chain
;
401 /* Associate a SS chain with a loop. */
404 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
408 if (head
== gfc_ss_terminator
)
412 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
414 if (ss
->next
== gfc_ss_terminator
)
415 ss
->loop_chain
= loop
->ss
;
417 ss
->loop_chain
= ss
->next
;
419 assert (ss
== gfc_ss_terminator
);
424 /* Generate an initializer for a static pointer or allocatable array. */
427 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
431 assert (TREE_STATIC (sym
->backend_decl
));
432 /* Just zero the data member. */
433 type
= TREE_TYPE (sym
->backend_decl
);
434 DECL_INITIAL (sym
->backend_decl
) =gfc_build_null_descriptor (type
);
438 /* Generate code to allocate an array temporary, or create a variable to
439 hold the data. If size is NULL zero the descriptor so that so that the
440 callee will allocate the array. Also generates code to free the array
444 gfc_trans_allocate_array_storage (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
445 tree size
, tree nelem
)
453 desc
= info
->descriptor
;
454 data
= gfc_conv_descriptor_data (desc
);
455 if (size
== NULL_TREE
)
457 /* A callee allocated array. */
458 gfc_add_modify_expr (&loop
->pre
, data
, convert (TREE_TYPE (data
),
459 gfc_index_zero_node
));
461 info
->offset
= gfc_index_zero_node
;
466 /* Allocate the temporary. */
467 onstack
= gfc_can_put_var_on_stack (size
);
471 /* Make a temporary variable to hold the data. */
472 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
474 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
476 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
478 tmp
= gfc_create_var (tmp
, "A");
479 tmp
= gfc_build_addr_expr (TREE_TYPE (data
), tmp
);
480 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
482 info
->offset
= gfc_index_zero_node
;
487 /* Allocate memory to hold the data. */
488 args
= gfc_chainon_list (NULL_TREE
, size
);
490 if (gfc_index_integer_kind
== 4)
491 tmp
= gfor_fndecl_internal_malloc
;
492 else if (gfc_index_integer_kind
== 8)
493 tmp
= gfor_fndecl_internal_malloc64
;
496 tmp
= gfc_build_function_call (tmp
, args
);
497 tmp
= convert (TREE_TYPE (data
), tmp
);
498 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
501 info
->offset
= gfc_index_zero_node
;
505 /* The offset is zero because we create temporaries with a zero
507 tmp
= gfc_conv_descriptor_offset (desc
);
508 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
512 /* Free the temporary. */
513 tmp
= convert (pvoid_type_node
, info
->data
);
514 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
515 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
516 gfc_add_expr_to_block (&loop
->post
, tmp
);
521 /* Generate code to allocate and initialize the descriptor for a temporary
522 array. This is used for both temporaries needed by the scaparizer, and
523 functions returning arrays. Adjusts the loop variables to be zero-based,
524 and calculates the loop bounds for callee allocated arrays.
525 Also fills in the descriptor, data and offset fields of info if known.
526 Returns the size of the array, or NULL for a callee allocated array. */
529 gfc_trans_allocate_temp_array (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
530 tree eltype
, tree string_length
)
540 assert (info
->dimen
> 0);
541 /* Set the lower bound to zero. */
542 for (dim
= 0; dim
< info
->dimen
; dim
++)
544 n
= loop
->order
[dim
];
545 if (n
< loop
->temp_dim
)
546 assert (integer_zerop (loop
->from
[n
]));
549 /* Callee allocated arrays may not have a known bound yet. */
551 loop
->to
[n
] = fold (build (MINUS_EXPR
, gfc_array_index_type
,
552 loop
->to
[n
], loop
->from
[n
]));
553 loop
->from
[n
] = gfc_index_zero_node
;
556 info
->delta
[dim
] = gfc_index_zero_node
;
557 info
->start
[dim
] = gfc_index_zero_node
;
558 info
->stride
[dim
] = gfc_index_one_node
;
559 info
->dim
[dim
] = dim
;
562 /* Initialize the descriptor. */
564 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
565 desc
= gfc_create_var (type
, "atmp");
566 GFC_DECL_PACKED_ARRAY (desc
) = 1;
568 info
->descriptor
= desc
;
569 size
= gfc_index_one_node
;
571 /* Fill in the array dtype. */
572 tmp
= gfc_conv_descriptor_dtype (desc
);
573 gfc_add_modify_expr (&loop
->pre
, tmp
,
574 GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (desc
)));
577 Fill in the bounds and stride. This is a packed array, so:
580 for (n = 0; n < rank; n++)
583 delta = ubound[n] + 1 - lbound[n];
586 size = size * sizeof(element);
589 for (n
= 0; n
< info
->dimen
; n
++)
591 if (loop
->to
[n
] == NULL_TREE
)
593 /* For a callee allocated array express the loop bounds in terms
594 of the descriptor fields. */
595 tmp
= build (MINUS_EXPR
, gfc_array_index_type
,
596 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
597 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
603 /* Store the stride and bound components in the descriptor. */
604 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
605 gfc_add_modify_expr (&loop
->pre
, tmp
, size
);
607 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
608 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
610 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
611 gfc_add_modify_expr (&loop
->pre
, tmp
, loop
->to
[n
]);
613 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
614 loop
->to
[n
], gfc_index_one_node
));
616 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
617 size
= gfc_evaluate_now (size
, &loop
->pre
);
620 /* TODO: Where does the string length go? */
622 gfc_todo_error ("temporary arrays of strings");
624 /* Get the size of the array. */
627 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
,
628 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
630 gfc_trans_allocate_array_storage (loop
, info
, size
, nelem
);
632 if (info
->dimen
> loop
->temp_dim
)
633 loop
->temp_dim
= info
->dimen
;
639 /* Make sure offset is a variable. */
642 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
645 /* We should have already created the offset variable. We cannot
646 create it here because we may be in an inner scope. */
647 assert (*offsetvar
!= NULL_TREE
);
648 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
649 *poffset
= *offsetvar
;
650 TREE_USED (*offsetvar
) = 1;
654 /* Add the contents of an array to the constructor. */
657 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
658 tree type ATTRIBUTE_UNUSED
,
659 tree pointer
, gfc_expr
* expr
,
660 tree
* poffset
, tree
* offsetvar
)
668 /* We need this to be a variable so we can increment it. */
669 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
671 gfc_init_se (&se
, NULL
);
673 /* Walk the array expression. */
674 ss
= gfc_walk_expr (expr
);
675 assert (ss
!= gfc_ss_terminator
);
677 /* Initialize the scalarizer. */
678 gfc_init_loopinfo (&loop
);
679 gfc_add_ss_to_loop (&loop
, ss
);
681 /* Initialize the loop. */
682 gfc_conv_ss_startstride (&loop
);
683 gfc_conv_loop_setup (&loop
);
685 /* Make the loop body. */
686 gfc_mark_ss_chain_used (ss
, 1);
687 gfc_start_scalarized_body (&loop
, &body
);
688 gfc_copy_loopinfo_to_se (&se
, &loop
);
691 gfc_conv_expr (&se
, expr
);
692 gfc_add_block_to_block (&body
, &se
.pre
);
694 /* Store the value. */
695 tmp
= gfc_build_indirect_ref (pointer
);
696 tmp
= gfc_build_array_ref (tmp
, *poffset
);
697 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
699 /* Increment the offset. */
700 tmp
= build (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
701 gfc_add_modify_expr (&body
, *poffset
, tmp
);
703 /* Finish the loop. */
704 gfc_add_block_to_block (&body
, &se
.post
);
705 assert (se
.ss
== gfc_ss_terminator
);
706 gfc_trans_scalarizing_loops (&loop
, &body
);
707 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
708 tmp
= gfc_finish_block (&loop
.pre
);
709 gfc_add_expr_to_block (pblock
, tmp
);
711 gfc_cleanup_loop (&loop
);
715 /* Assign the values to the elements of an array constructor. */
718 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
719 tree pointer
, gfc_constructor
* c
,
720 tree
* poffset
, tree
* offsetvar
)
728 for (; c
; c
= c
->next
)
730 /* If this is an iterator or an array, the offset must be a variable. */
731 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
732 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
734 gfc_start_block (&body
);
736 if (c
->expr
->expr_type
== EXPR_ARRAY
)
738 /* Array constructors can be nested. */
739 gfc_trans_array_constructor_value (&body
, type
, pointer
,
740 c
->expr
->value
.constructor
,
743 else if (c
->expr
->rank
> 0)
745 gfc_trans_array_constructor_subarray (&body
, type
, pointer
,
746 c
->expr
, poffset
, offsetvar
);
750 /* This code really upsets the gimplifier so don't bother for now. */
757 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
765 gfc_init_se (&se
, NULL
);
766 gfc_conv_expr (&se
, c
->expr
);
767 gfc_add_block_to_block (&body
, &se
.pre
);
769 ref
= gfc_build_indirect_ref (pointer
);
770 ref
= gfc_build_array_ref (ref
, *poffset
);
771 gfc_add_modify_expr (&body
, ref
,
772 fold_convert (TREE_TYPE (ref
), se
.expr
));
773 gfc_add_block_to_block (&body
, &se
.post
);
775 *poffset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
776 *poffset
, gfc_index_one_node
));
780 /* Collect multiple scalar constants into a constructor. */
788 /* Count the number of consecutive scalar constants. */
789 while (p
&& !(p
->iterator
790 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
792 gfc_init_se (&se
, NULL
);
793 gfc_conv_constant (&se
, p
->expr
);
794 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
799 bound
= build_int_2 (n
- 1, 0);
800 /* Create an array type to hold them. */
801 tmptype
= build_range_type (gfc_array_index_type
,
802 gfc_index_zero_node
, bound
);
803 tmptype
= build_array_type (type
, tmptype
);
805 init
= build1 (CONSTRUCTOR
, tmptype
, nreverse (list
));
806 TREE_CONSTANT (init
) = 1;
807 TREE_INVARIANT (init
) = 1;
808 TREE_STATIC (init
) = 1;
809 /* Create a static variable to hold the data. */
810 tmp
= gfc_create_var (tmptype
, "data");
811 TREE_STATIC (tmp
) = 1;
812 TREE_CONSTANT (tmp
) = 1;
813 TREE_INVARIANT (tmp
) = 1;
814 DECL_INITIAL (tmp
) = init
;
817 /* Use BUILTIN_MEMCPY to assign the values. */
818 tmp
= gfc_build_indirect_ref (pointer
);
819 tmp
= gfc_build_array_ref (tmp
, *poffset
);
820 tmp
= gfc_build_addr_expr (NULL
, tmp
);
821 init
= gfc_build_addr_expr (NULL
, init
);
823 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
824 bound
= build_int_2 (n
* size
, 0);
825 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
826 tmp
= gfc_chainon_list (tmp
, init
);
827 tmp
= gfc_chainon_list (tmp
, bound
);
828 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_MEMCPY
],
830 gfc_add_expr_to_block (&body
, tmp
);
832 *poffset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
835 if (!INTEGER_CST_P (*poffset
))
837 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
838 *poffset
= *offsetvar
;
842 /* The frontend should already have done any expansions. */
850 loopbody
= gfc_finish_block (&body
);
852 gfc_init_se (&se
, NULL
);
853 gfc_conv_expr (&se
, c
->iterator
->var
);
854 gfc_add_block_to_block (pblock
, &se
.pre
);
857 /* Initialize the loop. */
858 gfc_init_se (&se
, NULL
);
859 gfc_conv_expr_val (&se
, c
->iterator
->start
);
860 gfc_add_block_to_block (pblock
, &se
.pre
);
861 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
863 gfc_init_se (&se
, NULL
);
864 gfc_conv_expr_val (&se
, c
->iterator
->end
);
865 gfc_add_block_to_block (pblock
, &se
.pre
);
866 end
= gfc_evaluate_now (se
.expr
, pblock
);
868 gfc_init_se (&se
, NULL
);
869 gfc_conv_expr_val (&se
, c
->iterator
->step
);
870 gfc_add_block_to_block (pblock
, &se
.pre
);
871 step
= gfc_evaluate_now (se
.expr
, pblock
);
873 /* Generate the loop body. */
874 exit_label
= gfc_build_label_decl (NULL_TREE
);
875 gfc_start_block (&body
);
877 /* Generate the exit condition. */
878 end
= build (GT_EXPR
, boolean_type_node
, loopvar
, end
);
879 tmp
= build1_v (GOTO_EXPR
, exit_label
);
880 TREE_USED (exit_label
) = 1;
881 tmp
= build_v (COND_EXPR
, end
, tmp
, build_empty_stmt ());
882 gfc_add_expr_to_block (&body
, tmp
);
884 /* The main loop body. */
885 gfc_add_expr_to_block (&body
, loopbody
);
887 /* Increment the loop variable. */
888 tmp
= build (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
889 gfc_add_modify_expr (&body
, loopvar
, tmp
);
891 /* Finish the loop. */
892 tmp
= gfc_finish_block (&body
);
893 tmp
= build_v (LOOP_EXPR
, tmp
);
894 gfc_add_expr_to_block (pblock
, tmp
);
896 /* Add the exit label. */
897 tmp
= build1_v (LABEL_EXPR
, exit_label
);
898 gfc_add_expr_to_block (pblock
, tmp
);
902 /* Pass the code as is. */
903 tmp
= gfc_finish_block (&body
);
904 gfc_add_expr_to_block (pblock
, tmp
);
910 /* Get the size of an expression. Returns -1 if the size isn't constant.
911 Implied do loops with non-constant bounds are tricky because we must only
912 evaluate the bounds once. */
915 gfc_get_array_cons_size (mpz_t
* size
, gfc_constructor
* c
)
921 mpz_set_ui (*size
, 0);
925 for (; c
; c
= c
->next
)
927 if (c
->expr
->expr_type
== EXPR_ARRAY
)
929 /* A nested array constructor. */
930 gfc_get_array_cons_size (&len
, c
->expr
->value
.constructor
);
931 if (mpz_sgn (len
) < 0)
933 mpz_set (*size
, len
);
941 if (c
->expr
->rank
> 0)
943 mpz_set_si (*size
, -1);
955 if (i
->start
->expr_type
!= EXPR_CONSTANT
956 || i
->end
->expr_type
!= EXPR_CONSTANT
957 || i
->step
->expr_type
!= EXPR_CONSTANT
)
959 mpz_set_si (*size
, -1);
965 mpz_add (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
966 mpz_tdiv_q (val
, val
, i
->step
->value
.integer
);
967 mpz_add_ui (val
, val
, 1);
968 mpz_mul (len
, len
, val
);
970 mpz_add (*size
, *size
, len
);
977 /* Array constructors are handled by constructing a temporary, then using that
978 within the scalarization loop. This is not optimal, but seems by far the
982 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
990 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
991 gfc_todo_error ("Character string array constructors");
992 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
993 ss
->data
.info
.dimen
= loop
->dimen
;
995 gfc_trans_allocate_temp_array (loop
, &ss
->data
.info
, type
, NULL_TREE
);
997 desc
= ss
->data
.info
.descriptor
;
998 offset
= gfc_index_zero_node
;
999 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1000 TREE_USED (offsetvar
) = 0;
1001 gfc_trans_array_constructor_value (&loop
->pre
, type
,
1003 ss
->expr
->value
.constructor
, &offset
,
1006 if (TREE_USED (offsetvar
))
1007 pushdecl (offsetvar
);
1009 assert (INTEGER_CST_P (offset
));
1011 /* Disable bound checking for now because it's probably broken. */
1012 if (flag_bounds_check
)
1020 /* Add the pre and post chains for all the scalar expressions in a SS chain
1021 to loop. This is called after the loop parameters have been calculated,
1022 but before the actual scalarizing loops. */
1025 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1030 /* TODO: This can generate bad code if there are ordering dependencies.
1031 eg. a callee allocated function and an unknown size constructor. */
1032 assert (ss
!= NULL
);
1034 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1041 /* Scalar expression. Evaluate this now. This includes elemental
1042 dimension indices, but not array section bounds. */
1043 gfc_init_se (&se
, NULL
);
1044 gfc_conv_expr (&se
, ss
->expr
);
1045 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1047 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1049 /* Move the evaluation of scalar expressions outside the
1050 scalarization loop. */
1052 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1053 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1054 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1057 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1059 ss
->data
.scalar
.expr
= se
.expr
;
1060 ss
->data
.scalar
.string_length
= se
.string_length
;
1063 case GFC_SS_REFERENCE
:
1064 /* Scalar reference. Evaluate this now. */
1065 gfc_init_se (&se
, NULL
);
1066 gfc_conv_expr_reference (&se
, ss
->expr
);
1067 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1068 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1070 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1071 ss
->data
.scalar
.string_length
= se
.string_length
;
1074 case GFC_SS_SECTION
:
1076 /* Scalarized expression. Evaluate any scalar subscripts. */
1077 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1079 /* Add the expressions for scalar subscripts. */
1080 if (ss
->data
.info
.subscript
[n
])
1081 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1085 case GFC_SS_INTRINSIC
:
1086 gfc_add_intrinsic_ss_code (loop
, ss
);
1089 case GFC_SS_FUNCTION
:
1090 /* Array function return value. We call the function and save its
1091 result in a temporary for use inside the loop. */
1092 gfc_init_se (&se
, NULL
);
1095 gfc_conv_expr (&se
, ss
->expr
);
1096 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1097 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1100 case GFC_SS_CONSTRUCTOR
:
1101 gfc_trans_array_constructor (loop
, ss
);
1105 case GFC_SS_COMPONENT
:
1106 /* Do nothing. These are handled elsewhere. */
1116 /* Translate expressions for the descriptor and data pointer of a SS. */
1120 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1125 /* Get the descriptor for the array to be scalarized. */
1126 assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1127 gfc_init_se (&se
, NULL
);
1128 se
.descriptor_only
= 1;
1129 gfc_conv_expr_lhs (&se
, ss
->expr
);
1130 gfc_add_block_to_block (block
, &se
.pre
);
1131 ss
->data
.info
.descriptor
= se
.expr
;
1135 /* Also the data pointer. */
1136 tmp
= gfc_conv_array_data (se
.expr
);
1137 /* If this is a variable or address of a variable we use it directly.
1138 Otherwise we must evaluate it now to to avoid break dependency
1139 analysis by pulling the expressions for elemental array indices
1142 || (TREE_CODE (tmp
) == ADDR_EXPR
1143 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1144 tmp
= gfc_evaluate_now (tmp
, block
);
1145 ss
->data
.info
.data
= tmp
;
1147 tmp
= gfc_conv_array_offset (se
.expr
);
1148 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1153 /* Initialise a gfc_loopinfo structure. */
1156 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1160 memset (loop
, 0, sizeof (gfc_loopinfo
));
1161 gfc_init_block (&loop
->pre
);
1162 gfc_init_block (&loop
->post
);
1164 /* Initially scalarize in order. */
1165 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1168 loop
->ss
= gfc_ss_terminator
;
1172 /* Copies the loop variable info to a gfc_se sructure. Does not copy the SS
1176 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1182 /* Return an expression for the data pointer of an array. */
1185 gfc_conv_array_data (tree descriptor
)
1189 type
= TREE_TYPE (descriptor
);
1190 if (GFC_ARRAY_TYPE_P (type
))
1192 if (TREE_CODE (type
) == POINTER_TYPE
)
1196 /* Descriptorless arrays. */
1197 return gfc_build_addr_expr (NULL
, descriptor
);
1201 return gfc_conv_descriptor_data (descriptor
);
1205 /* Return an expression for the base offset of an array. */
1208 gfc_conv_array_offset (tree descriptor
)
1212 type
= TREE_TYPE (descriptor
);
1213 if (GFC_ARRAY_TYPE_P (type
))
1214 return GFC_TYPE_ARRAY_OFFSET (type
);
1216 return gfc_conv_descriptor_offset (descriptor
);
1220 /* Get an expression for the array stride. */
1223 gfc_conv_array_stride (tree descriptor
, int dim
)
1228 type
= TREE_TYPE (descriptor
);
1230 /* For descriptorless arrays use the array size. */
1231 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1232 if (tmp
!= NULL_TREE
)
1235 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1240 /* Like gfc_conv_array_stride, but for the lower bound. */
1243 gfc_conv_array_lbound (tree descriptor
, int dim
)
1248 type
= TREE_TYPE (descriptor
);
1250 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1251 if (tmp
!= NULL_TREE
)
1254 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1259 /* Like gfc_conv_array_stride, but for the upper bound. */
1262 gfc_conv_array_ubound (tree descriptor
, int dim
)
1267 type
= TREE_TYPE (descriptor
);
1269 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1270 if (tmp
!= NULL_TREE
)
1273 /* This should only ever happen when passing an assumed shape array
1274 as an actual parameter. The value will never be used. */
1275 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1276 return gfc_index_zero_node
;
1278 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1283 /* Translate an array reference. The descriptor should be in se->expr.
1284 Do not use this function, it wil be removed soon. */
1288 gfc_conv_array_index_ref (gfc_se
* se
, tree pointer
, tree
* indices
,
1289 tree offset
, int dimen
)
1296 array
= gfc_build_indirect_ref (pointer
);
1299 for (n
= 0; n
< dimen
; n
++)
1301 /* index = index + stride[n]*indices[n] */
1302 tmp
= gfc_conv_array_stride (se
->expr
, n
);
1303 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, indices
[n
], tmp
));
1305 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1308 /* Result = data[index]. */
1309 tmp
= gfc_build_array_ref (array
, index
);
1311 /* Check we've used the correct number of dimensions. */
1312 assert (TREE_CODE (TREE_TYPE (tmp
)) != ARRAY_TYPE
);
1318 /* Generate code to perform an array index bound check. */
1321 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
)
1327 if (!flag_bounds_check
)
1330 index
= gfc_evaluate_now (index
, &se
->pre
);
1331 /* Check lower bound. */
1332 tmp
= gfc_conv_array_lbound (descriptor
, n
);
1333 fault
= fold (build (LT_EXPR
, boolean_type_node
, index
, tmp
));
1334 /* Check upper bound. */
1335 tmp
= gfc_conv_array_ubound (descriptor
, n
);
1336 cond
= fold (build (GT_EXPR
, boolean_type_node
, index
, tmp
));
1337 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1339 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1345 /* A reference to an array vector subscript. Uses recursion to handle nested
1346 vector subscripts. */
1349 gfc_conv_vector_array_index (gfc_se
* se
, tree index
, gfc_ss
* ss
)
1352 tree indices
[GFC_MAX_DIMENSIONS
];
1357 assert (ss
&& ss
->type
== GFC_SS_VECTOR
);
1359 /* Save the descriptor. */
1360 descsave
= se
->expr
;
1361 info
= &ss
->data
.info
;
1362 se
->expr
= info
->descriptor
;
1364 ar
= &info
->ref
->u
.ar
;
1365 for (n
= 0; n
< ar
->dimen
; n
++)
1367 switch (ar
->dimen_type
[n
])
1370 assert (info
->subscript
[n
] != gfc_ss_terminator
1371 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
1372 indices
[n
] = info
->subscript
[n
]->data
.scalar
.expr
;
1380 index
= gfc_conv_vector_array_index (se
, index
, info
->subscript
[n
]);
1383 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, n
);
1390 /* Get the index from the vector. */
1391 gfc_conv_array_index_ref (se
, info
->data
, indices
, info
->offset
, ar
->dimen
);
1393 /* Put the descriptor back. */
1394 se
->expr
= descsave
;
1400 /* Return the offset for an index. Performs bound checking for elemental
1401 dimensions. Single element references are processed seperately. */
1404 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
1405 gfc_array_ref
* ar
, tree stride
)
1409 /* Get the index into the array for this dimension. */
1412 assert (ar
->type
!= AR_ELEMENT
);
1413 if (ar
->dimen_type
[dim
] == DIMEN_ELEMENT
)
1416 /* Elemental dimension. */
1417 assert (info
->subscript
[dim
]
1418 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
1419 /* We've already translated this value outside the loop. */
1420 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
1423 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, dim
);
1427 /* Scalarized dimension. */
1428 assert (info
&& se
->loop
);
1430 /* Multiply the loop variable by the stride and dela. */
1431 index
= se
->loop
->loopvar
[i
];
1432 index
= fold (build (MULT_EXPR
, gfc_array_index_type
, index
,
1434 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
,
1437 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
1439 /* Handle vector subscripts. */
1440 index
= gfc_conv_vector_array_index (se
, index
,
1441 info
->subscript
[dim
]);
1443 gfc_trans_array_bound_check (se
, info
->descriptor
, index
,
1447 assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
);
1452 /* Temporary array or derived type component. */
1454 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
1455 if (!integer_zerop (info
->delta
[i
]))
1456 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
,
1460 /* Multiply by the stride. */
1461 index
= fold (build (MULT_EXPR
, gfc_array_index_type
, index
, stride
));
1467 /* Build a scalarized reference to an array. */
1470 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1477 info
= &se
->ss
->data
.info
;
1479 n
= se
->loop
->order
[0];
1483 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
1485 /* Add the offset for this dimension to the stored offset for all other
1487 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
));
1489 tmp
= gfc_build_indirect_ref (info
->data
);
1490 se
->expr
= gfc_build_array_ref (tmp
, index
);
1494 /* Translate access of temporary array. */
1497 gfc_conv_tmp_array_ref (gfc_se
* se
)
1501 desc
= se
->ss
->data
.info
.descriptor
;
1502 /* TODO: We need the string length for string variables. */
1504 gfc_conv_scalarized_array_ref (se
, NULL
);
1508 /* Build an array reference. se->expr already holds the array descriptor.
1509 This should be either a variable, indirect variable reference or component
1510 reference. For arrays which do not have a descriptor, se->expr will be
1512 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1515 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1524 /* Handle scalarized references seperately. */
1525 if (ar
->type
!= AR_ELEMENT
)
1527 gfc_conv_scalarized_array_ref (se
, ar
);
1531 index
= gfc_index_zero_node
;
1533 fault
= gfc_index_zero_node
;
1535 /* Calculate the offsets from all the dimensions. */
1536 for (n
= 0; n
< ar
->dimen
; n
++)
1538 /* Calculate the index for this demension. */
1539 gfc_init_se (&indexse
, NULL
);
1540 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
1541 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
1543 if (flag_bounds_check
)
1545 /* Check array bounds. */
1548 indexse
.expr
= gfc_evaluate_now (indexse
.expr
, &se
->pre
);
1550 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
1551 cond
= fold (build (LT_EXPR
, boolean_type_node
, indexse
.expr
, tmp
));
1553 fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1555 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
1556 cond
= fold (build (GT_EXPR
, boolean_type_node
, indexse
.expr
, tmp
));
1558 fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1561 /* Multiply the index by the stride. */
1562 stride
= gfc_conv_array_stride (se
->expr
, n
);
1563 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
1566 /* And add it to the total. */
1567 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1570 if (flag_bounds_check
)
1571 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1573 tmp
= gfc_conv_array_offset (se
->expr
);
1574 if (!integer_zerop (tmp
))
1575 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1577 /* Access the calculated element. */
1578 tmp
= gfc_conv_array_data (se
->expr
);
1579 tmp
= gfc_build_indirect_ref (tmp
);
1580 se
->expr
= gfc_build_array_ref (tmp
, index
);
1584 /* Generate the code to be executed immediately before entering a
1585 scalarization loop. */
1588 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
1589 stmtblock_t
* pblock
)
1598 /* This code will be executed before entering the scalarization loop
1599 for this dimension. */
1600 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1602 if ((ss
->useflags
& flag
) == 0)
1605 if (ss
->type
!= GFC_SS_SECTION
1606 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1607 && ss
->type
!= GFC_SS_COMPONENT
)
1610 info
= &ss
->data
.info
;
1612 if (dim
>= info
->dimen
)
1615 if (dim
== info
->dimen
- 1)
1617 /* For the outermost loop calculate the offset due to any
1618 elemental dimensions. It will have been initialized with the
1619 base offset of the array. */
1622 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
1624 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1627 gfc_init_se (&se
, NULL
);
1629 se
.expr
= info
->descriptor
;
1630 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
1631 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
1634 gfc_add_block_to_block (pblock
, &se
.pre
);
1636 info
->offset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
1637 info
->offset
, index
));
1638 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1642 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1645 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
1647 /* Calculate the stride of the innermost loop. Hopefully this will
1648 allow the backend optimizers to do their stuff more effectively.
1650 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
1654 /* Add the offset for the previous loop dimension. */
1659 ar
= &info
->ref
->u
.ar
;
1660 i
= loop
->order
[dim
+ 1];
1668 gfc_init_se (&se
, NULL
);
1670 se
.expr
= info
->descriptor
;
1671 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1672 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
1674 gfc_add_block_to_block (pblock
, &se
.pre
);
1675 info
->offset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
1676 info
->offset
, index
));
1677 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1680 /* Remeber this offset for the second loop. */
1681 if (dim
== loop
->temp_dim
- 1)
1682 info
->saved_offset
= info
->offset
;
1687 /* Start a scalarized expression. Creates a scope and declares loop
1691 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
1697 assert (!loop
->array_parameter
);
1699 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
1701 n
= loop
->order
[dim
];
1703 gfc_start_block (&loop
->code
[n
]);
1705 /* Create the loop variable. */
1706 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
1708 if (dim
< loop
->temp_dim
)
1712 /* Calculate values that will be constant within this loop. */
1713 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
1715 gfc_start_block (pbody
);
1719 /* Generates the actual loop code for a scalarization loop. */
1722 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
1723 stmtblock_t
* pbody
)
1731 loopbody
= gfc_finish_block (pbody
);
1733 /* Initialize the loopvar. */
1734 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
1736 exit_label
= gfc_build_label_decl (NULL_TREE
);
1738 /* Generate the loop body. */
1739 gfc_init_block (&block
);
1741 /* The exit condition. */
1742 cond
= build (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
1743 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1744 TREE_USED (exit_label
) = 1;
1745 tmp
= build_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1746 gfc_add_expr_to_block (&block
, tmp
);
1748 /* The main body. */
1749 gfc_add_expr_to_block (&block
, loopbody
);
1751 /* Increment the loopvar. */
1752 tmp
= build (PLUS_EXPR
, gfc_array_index_type
,
1753 loop
->loopvar
[n
], gfc_index_one_node
);
1754 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
1756 /* Build the loop. */
1757 tmp
= gfc_finish_block (&block
);
1758 tmp
= build_v (LOOP_EXPR
, tmp
);
1759 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1761 /* Add the exit label. */
1762 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1763 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1767 /* Finishes and generates the loops for a scalarized expression. */
1770 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1775 stmtblock_t
*pblock
;
1779 /* Generate the loops. */
1780 for (dim
= 0; dim
< loop
->dimen
; dim
++)
1782 n
= loop
->order
[dim
];
1783 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1784 loop
->loopvar
[n
] = NULL_TREE
;
1785 pblock
= &loop
->code
[n
];
1788 tmp
= gfc_finish_block (pblock
);
1789 gfc_add_expr_to_block (&loop
->pre
, tmp
);
1791 /* Clear all the used flags. */
1792 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
1797 /* Finish the main body of a scalarized expression, and start the secondary
1801 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1805 stmtblock_t
*pblock
;
1809 /* We finish as many loops as are used by the temporary. */
1810 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
1812 n
= loop
->order
[dim
];
1813 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1814 loop
->loopvar
[n
] = NULL_TREE
;
1815 pblock
= &loop
->code
[n
];
1818 /* We don't want to finish the outermost loop entirely. */
1819 n
= loop
->order
[loop
->temp_dim
- 1];
1820 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1822 /* Restore the initial offsets. */
1823 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1825 if ((ss
->useflags
& 2) == 0)
1828 if (ss
->type
!= GFC_SS_SECTION
1829 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1830 && ss
->type
!= GFC_SS_COMPONENT
)
1833 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
1836 /* Restart all the inner loops we just finished. */
1837 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
1839 n
= loop
->order
[dim
];
1841 gfc_start_block (&loop
->code
[n
]);
1843 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
1845 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
1848 /* Start a block for the secondary copying code. */
1849 gfc_start_block (body
);
1853 /* Calculate the upper bound of an array section. */
1856 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
1865 assert (ss
->type
== GFC_SS_SECTION
);
1867 /* For vector array subscripts we want the size of the vector. */
1868 dim
= ss
->data
.info
.dim
[n
];
1870 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
1872 vecss
= vecss
->data
.info
.subscript
[dim
];
1873 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
1874 dim
= vecss
->data
.info
.dim
[0];
1877 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
1878 end
= vecss
->data
.info
.ref
->u
.ar
.end
[dim
];
1879 desc
= vecss
->data
.info
.descriptor
;
1883 /* The upper bound was specified. */
1884 gfc_init_se (&se
, NULL
);
1885 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
1886 gfc_add_block_to_block (pblock
, &se
.pre
);
1891 /* No upper bound was specified, so use the bound of the array. */
1892 bound
= gfc_conv_array_ubound (desc
, dim
);
1899 /* Calculate the lower bound of an array section. */
1902 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
1912 info
= &ss
->data
.info
;
1916 /* For vector array subscripts we want the size of the vector. */
1918 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
1920 vecss
= vecss
->data
.info
.subscript
[dim
];
1921 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
1922 /* Get the descriptors for the vector subscripts as well. */
1923 if (!vecss
->data
.info
.descriptor
)
1924 gfc_conv_ss_descriptor (&loop
->pre
, vecss
, !loop
->array_parameter
);
1925 dim
= vecss
->data
.info
.dim
[0];
1928 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
1929 start
= vecss
->data
.info
.ref
->u
.ar
.start
[dim
];
1930 stride
= vecss
->data
.info
.ref
->u
.ar
.stride
[dim
];
1931 desc
= vecss
->data
.info
.descriptor
;
1933 /* Calculate the start of the range. For vector subscripts this will
1934 be the range of the vector. */
1937 /* Specified section start. */
1938 gfc_init_se (&se
, NULL
);
1939 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
1940 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1941 info
->start
[n
] = se
.expr
;
1945 /* No lower bound specified so use the bound of the array. */
1946 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
1948 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
1950 /* Calculate the stride. */
1952 info
->stride
[n
] = gfc_index_one_node
;
1955 gfc_init_se (&se
, NULL
);
1956 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
1957 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1958 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
1963 /* Calculates the range start and stride for a SS chain. Also gets the
1964 descriptor and data pointer. The range of vector subscripts is the size
1965 of the vector. Array bounds are also checked. */
1968 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
1977 /* Determine the rank of the loop. */
1979 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
1983 case GFC_SS_SECTION
:
1984 case GFC_SS_CONSTRUCTOR
:
1985 case GFC_SS_FUNCTION
:
1986 case GFC_SS_COMPONENT
:
1987 loop
->dimen
= ss
->data
.info
.dimen
;
1995 if (loop
->dimen
== 0)
1996 gfc_todo_error ("Unable to determine rank of expression");
1999 /* Loop over all the SS in the chain. */
2000 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2002 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2003 ss
->shape
= ss
->expr
->shape
;
2007 case GFC_SS_SECTION
:
2008 /* Get the descriptor for the array. */
2009 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2011 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2012 gfc_conv_section_startstride (loop
, ss
, n
);
2015 case GFC_SS_CONSTRUCTOR
:
2016 case GFC_SS_FUNCTION
:
2017 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2019 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2020 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2029 /* The rest is just runtime bound checking. */
2030 if (flag_bounds_check
)
2036 tree size
[GFC_MAX_DIMENSIONS
];
2040 gfc_start_block (&block
);
2042 fault
= integer_zero_node
;
2043 for (n
= 0; n
< loop
->dimen
; n
++)
2044 size
[n
] = NULL_TREE
;
2046 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2048 if (ss
->type
!= GFC_SS_SECTION
)
2051 /* TODO: range checking for mapped dimensions. */
2052 info
= &ss
->data
.info
;
2054 /* This only checks scalarized dimensions, elemental dimensions are
2056 for (n
= 0; n
< loop
->dimen
; n
++)
2060 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2063 vecss
= vecss
->data
.info
.subscript
[dim
];
2064 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2065 dim
= vecss
->data
.info
.dim
[0];
2067 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2069 desc
= vecss
->data
.info
.descriptor
;
2071 /* Check lower bound. */
2072 bound
= gfc_conv_array_lbound (desc
, dim
);
2073 tmp
= info
->start
[n
];
2074 tmp
= fold (build (LT_EXPR
, boolean_type_node
, tmp
, bound
));
2075 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2078 /* Check the upper bound. */
2079 bound
= gfc_conv_array_ubound (desc
, dim
);
2080 end
= gfc_conv_section_upper_bound (ss
, n
, &block
);
2081 tmp
= fold (build (GT_EXPR
, boolean_type_node
, end
, bound
));
2082 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2085 /* Check the section sizes match. */
2086 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, end
,
2088 tmp
= fold (build (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2090 /* We remember the size of the first section, and check all the
2091 others against this. */
2095 fold (build (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]));
2097 build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, tmp
);
2100 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2103 gfc_trans_runtime_check (fault
, gfc_strconst_bounds
, &block
);
2105 tmp
= gfc_finish_block (&block
);
2106 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2111 /* Return true if the two SS could be aliased, ie. both point to the same data
2113 /* TODO: resolve aliases based on frontend expressions. */
2116 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2123 lsym
= lss
->expr
->symtree
->n
.sym
;
2124 rsym
= rss
->expr
->symtree
->n
.sym
;
2125 if (gfc_symbols_could_alias (lsym
, rsym
))
2128 if (rsym
->ts
.type
!= BT_DERIVED
2129 && lsym
->ts
.type
!= BT_DERIVED
)
2132 /* For derived types we must check all the component types. We can ignore
2133 array references as these will have the same base type as the previous
2135 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2137 if (lref
->type
!= REF_COMPONENT
)
2140 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2143 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2146 if (rref
->type
!= REF_COMPONENT
)
2149 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2154 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2156 if (rref
->type
!= REF_COMPONENT
)
2159 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2167 /* Resolve array data dependencies. Creates a temporary if required. */
2168 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2172 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2182 loop
->temp_ss
= NULL
;
2183 aref
= dest
->data
.info
.ref
;
2186 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2188 if (ss
->type
!= GFC_SS_SECTION
)
2191 if (gfc_could_be_alias (dest
, ss
))
2197 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
2199 lref
= dest
->expr
->ref
;
2200 rref
= ss
->expr
->ref
;
2202 nDepend
= gfc_dep_resolver (lref
, rref
);
2204 /* TODO : loop shifting. */
2207 /* Mark the dimensions for LOOP SHIFTING */
2208 for (n
= 0; n
< loop
->dimen
; n
++)
2210 int dim
= dest
->data
.info
.dim
[n
];
2212 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2214 else if (! gfc_is_same_range (&lref
->u
.ar
,
2215 &rref
->u
.ar
, dim
, 0))
2219 /* Put all the dimensions with dependencies in the
2222 for (n
= 0; n
< loop
->dimen
; n
++)
2224 assert (loop
->order
[n
] == n
);
2226 loop
->order
[dim
++] = n
;
2229 for (n
= 0; n
< loop
->dimen
; n
++)
2232 loop
->order
[dim
++] = n
;
2235 assert (dim
== loop
->dimen
);
2244 loop
->temp_ss
= gfc_get_ss ();
2245 loop
->temp_ss
->type
= GFC_SS_TEMP
;
2246 loop
->temp_ss
->data
.temp
.type
=
2247 gfc_get_element_type (TREE_TYPE (dest
->data
.info
.descriptor
));
2248 loop
->temp_ss
->data
.temp
.string_length
= NULL_TREE
;
2249 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
2250 loop
->temp_ss
->next
= gfc_ss_terminator
;
2251 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
2254 loop
->temp_ss
= NULL
;
2258 /* Initialise the scalarization loop. Creates the loop variables. Determines
2259 the range of the loop variables. Creates a temporary if required.
2260 Calculates how to transform from loop variables to array indices for each
2261 expression. Also generates code for scalar expressions which have been
2262 moved outside the loop. */
2265 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
2270 gfc_ss_info
*specinfo
;
2274 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
2279 for (n
= 0; n
< loop
->dimen
; n
++)
2282 /* We use one SS term, and use that to determine the bounds of the
2283 loop for this dimension. We try to pick the simplest term. */
2284 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2288 /* The frontend has worked out the size for us. */
2293 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
2295 /* An unknown size constructor will always be rank one.
2296 Higher rank constructors will wither have known shape,
2297 or still be wrapped in a call to reshape. */
2298 assert (loop
->dimen
== 1);
2299 /* Try to figure out the size of the constructor. */
2300 /* TODO: avoid this by making the frontend set the shape. */
2301 gfc_get_array_cons_size (&i
, ss
->expr
->value
.constructor
);
2302 /* A negative value means we failed. */
2303 if (mpz_sgn (i
) > 0)
2305 mpz_sub_ui (i
, i
, 1);
2307 gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2313 /* TODO: Pick the best bound if we have a choice between a
2314 function and something else. */
2315 if (ss
->type
== GFC_SS_FUNCTION
)
2321 if (ss
->type
!= GFC_SS_SECTION
)
2325 specinfo
= &loopspec
[n
]->data
.info
;
2328 info
= &ss
->data
.info
;
2330 /* Criteria for choosing a loop specifier (most important first):
2338 /* TODO: Is != contructor correct? */
2339 else if (loopspec
[n
]->type
!= GFC_SS_CONSTRUCTOR
)
2341 if (integer_onep (info
->stride
[n
])
2342 && !integer_onep (specinfo
->stride
[n
]))
2344 else if (INTEGER_CST_P (info
->stride
[n
])
2345 && !INTEGER_CST_P (specinfo
->stride
[n
]))
2347 else if (INTEGER_CST_P (info
->start
[n
])
2348 && !INTEGER_CST_P (specinfo
->start
[n
]))
2350 /* We don't work out the upper bound.
2351 else if (INTEGER_CST_P (info->finish[n])
2352 && ! INTEGER_CST_P (specinfo->finish[n]))
2353 loopspec[n] = ss; */
2358 gfc_todo_error ("Unable to find scalarization loop specifier");
2360 info
= &loopspec
[n
]->data
.info
;
2362 /* Set the extents of this range. */
2363 cshape
= loopspec
[n
]->shape
;
2364 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
2365 && INTEGER_CST_P (info
->stride
[n
]))
2367 loop
->from
[n
] = info
->start
[n
];
2368 mpz_set (i
, cshape
[n
]);
2369 mpz_sub_ui (i
, i
, 1);
2370 /* To = from + (size - 1) * stride. */
2371 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2372 if (!integer_onep (info
->stride
[n
]))
2374 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
,
2375 tmp
, info
->stride
[n
]));
2377 loop
->to
[n
] = fold (build (PLUS_EXPR
, gfc_array_index_type
,
2378 loop
->from
[n
], tmp
));
2382 loop
->from
[n
] = info
->start
[n
];
2383 switch (loopspec
[n
]->type
)
2385 case GFC_SS_CONSTRUCTOR
:
2386 assert (info
->dimen
== 1);
2387 assert (loop
->to
[n
]);
2390 case GFC_SS_SECTION
:
2391 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
2395 case GFC_SS_FUNCTION
:
2396 /* The loop bound will be set when we generate the call. */
2397 assert (loop
->to
[n
] == NULL_TREE
);
2405 /* Transform everything so we have a simple incrementing variable. */
2406 if (integer_onep (info
->stride
[n
]))
2407 info
->delta
[n
] = gfc_index_zero_node
;
2410 /* Set the delta for this section. */
2411 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
2412 /* Number of iterations is (end - start + step) / step.
2413 with start = 0, this simplifies to
2415 for (i = 0; i<=last; i++){...}; */
2416 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, loop
->to
[n
],
2418 tmp
= fold (build (TRUNC_DIV_EXPR
, gfc_array_index_type
, tmp
,
2420 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2421 /* Make the loop variable start at 0. */
2422 loop
->from
[n
] = gfc_index_zero_node
;
2426 /* Add all the scalar code that can be taken out of the loops.
2427 This may include calculating the loop bounds, so do it before
2428 allocating the temporary. */
2429 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
2431 /* If we want a temporary then create it. */
2432 if (loop
->temp_ss
!= NULL
)
2434 assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
2435 tmp
= loop
->temp_ss
->data
.temp
.type
;
2436 len
= loop
->temp_ss
->data
.temp
.string_length
;
2437 n
= loop
->temp_ss
->data
.temp
.dimen
;
2438 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
2439 loop
->temp_ss
->type
= GFC_SS_SECTION
;
2440 loop
->temp_ss
->data
.info
.dimen
= n
;
2441 gfc_trans_allocate_temp_array (loop
, &loop
->temp_ss
->data
.info
,
2445 for (n
= 0; n
< loop
->temp_dim
; n
++)
2446 loopspec
[loop
->order
[n
]] = NULL
;
2450 /* For array parameters we don't have loop variables, so don't calculate the
2452 if (loop
->array_parameter
)
2455 /* Calculate the translation from loop variables to array indices. */
2456 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2458 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
2461 info
= &ss
->data
.info
;
2463 for (n
= 0; n
< info
->dimen
; n
++)
2467 /* If we are specifying the range the delta is already set. */
2468 if (loopspec
[n
] != ss
)
2470 /* Calculate the offset relative to the loop variable.
2471 First multiply by the stride. */
2472 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
,
2473 loop
->from
[n
], info
->stride
[n
]));
2475 /* Then subtract this from our starting value. */
2476 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
2477 info
->start
[n
], tmp
));
2479 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2486 /* Fills in an array descriptor, and returns the size of the array. The size
2487 will be a simple_val, ie a variable or a constant. Also calculates the
2488 offset of the base. Returns the size of the arrary.
2492 for (n = 0; n < rank; n++)
2494 a.lbound[n] = specified_lower_bound;
2495 offset = offset + a.lbond[n] * stride;
2497 a.ubound[n] = specified_upper_bound;
2498 a.stride[n] = stride;
2499 size = ubound + size; //size = ubound + 1 - lbound
2500 stride = stride * size;
2507 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
2508 gfc_expr
** lower
, gfc_expr
** upper
,
2509 stmtblock_t
* pblock
)
2520 type
= TREE_TYPE (descriptor
);
2522 stride
= gfc_index_one_node
;
2523 offset
= gfc_index_zero_node
;
2525 /* Set the dtype. */
2526 tmp
= gfc_conv_descriptor_dtype (descriptor
);
2527 gfc_add_modify_expr (pblock
, tmp
,
2528 GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (descriptor
)));
2530 for (n
= 0; n
< rank
; n
++)
2532 /* We have 3 possibilities for determining the size of the array:
2533 lower == NULL => lbound = 1, ubound = upper[n]
2534 upper[n] = NULL => lbound = 1, ubound = lower[n]
2535 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2538 /* Set lower bound. */
2539 gfc_init_se (&se
, NULL
);
2541 se
.expr
= gfc_index_one_node
;
2547 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
2548 gfc_add_block_to_block (pblock
, &se
.pre
);
2552 se
.expr
= gfc_index_one_node
;
2556 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
2557 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2559 /* Work out the offset for this component. */
2560 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
));
2561 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
2563 /* Start the calculation for the size of this dimension. */
2564 size
= build (MINUS_EXPR
, gfc_array_index_type
,
2565 gfc_index_one_node
, se
.expr
);
2567 /* Set upper bound. */
2568 gfc_init_se (&se
, NULL
);
2570 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
2571 gfc_add_block_to_block (pblock
, &se
.pre
);
2573 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
2574 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2576 /* Store the stride. */
2577 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
2578 gfc_add_modify_expr (pblock
, tmp
, stride
);
2580 /* Calculate the size of this dimension. */
2581 size
= fold (build (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
));
2583 /* Multiply the stride by the number of elements in this dimension. */
2584 stride
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
, size
));
2585 stride
= gfc_evaluate_now (stride
, pblock
);
2588 /* The stride is the number of elements in the array, so multiply by the
2589 size of an element to get the total size. */
2590 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2591 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
));
2593 if (poffset
!= NULL
)
2595 offset
= gfc_evaluate_now (offset
, pblock
);
2599 size
= gfc_evaluate_now (size
, pblock
);
2604 /* Initialises the descriptor and generates a call to _gfor_allocate. Does
2605 the work for an ALLOCATE statement. */
2609 gfc_array_allocate (gfc_se
* se
, gfc_ref
* ref
, tree pstat
)
2619 /* Figure out the size of the array. */
2620 switch (ref
->u
.ar
.type
)
2624 upper
= ref
->u
.ar
.start
;
2628 assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
2630 lower
= ref
->u
.ar
.as
->lower
;
2631 upper
= ref
->u
.ar
.as
->upper
;
2635 lower
= ref
->u
.ar
.start
;
2636 upper
= ref
->u
.ar
.end
;
2644 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
2645 lower
, upper
, &se
->pre
);
2647 /* Allocate memory to store the data. */
2648 tmp
= gfc_conv_descriptor_data (se
->expr
);
2649 pointer
= gfc_build_addr_expr (NULL
, tmp
);
2650 pointer
= gfc_evaluate_now (pointer
, &se
->pre
);
2652 if (gfc_array_index_type
== gfc_int4_type_node
)
2653 allocate
= gfor_fndecl_allocate
;
2654 else if (gfc_array_index_type
== gfc_int8_type_node
)
2655 allocate
= gfor_fndecl_allocate64
;
2659 tmp
= gfc_chainon_list (NULL_TREE
, pointer
);
2660 tmp
= gfc_chainon_list (tmp
, size
);
2661 tmp
= gfc_chainon_list (tmp
, pstat
);
2662 tmp
= gfc_build_function_call (allocate
, tmp
);
2663 gfc_add_expr_to_block (&se
->pre
, tmp
);
2665 pointer
= gfc_conv_descriptor_data (se
->expr
);
2667 tmp
= gfc_conv_descriptor_offset (se
->expr
);
2668 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
2672 /* Deallocate an array variable. Also used when an allocated variable goes
2677 gfc_array_deallocate (tree descriptor
)
2683 gfc_start_block (&block
);
2684 /* Get a pointer to the data. */
2685 tmp
= gfc_conv_descriptor_data (descriptor
);
2686 tmp
= gfc_build_addr_expr (NULL
, tmp
);
2687 var
= gfc_create_var (TREE_TYPE (tmp
), "ptr");
2688 gfc_add_modify_expr (&block
, var
, tmp
);
2690 /* Parameter is the address of the data component. */
2691 tmp
= gfc_chainon_list (NULL_TREE
, var
);
2692 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
2693 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
2694 gfc_add_expr_to_block (&block
, tmp
);
2696 return gfc_finish_block (&block
);
2700 /* Create an array constructor from an initialization expression.
2701 We assume the frontend already did any expansions and conversions. */
2704 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
2712 unsigned HOST_WIDE_INT lo
;
2716 switch (expr
->expr_type
)
2719 case EXPR_STRUCTURE
:
2720 /* A single scalar or derived type value. Create an array with all
2721 elements equal to that value. */
2722 gfc_init_se (&se
, NULL
);
2724 if (expr
->expr_type
== EXPR_CONSTANT
)
2725 gfc_conv_constant (&se
, expr
);
2727 gfc_conv_structure (&se
, expr
, 1);
2729 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2730 assert (tmp
&& INTEGER_CST_P (tmp
));
2731 hi
= TREE_INT_CST_HIGH (tmp
);
2732 lo
= TREE_INT_CST_LOW (tmp
);
2736 /* This will probably eat buckets of memory for large arrays. */
2737 while (hi
!= 0 || lo
!= 0)
2739 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
2747 /* Create a list of all the elements. */
2748 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2752 /* Problems occur when we get something like
2753 integer :: a(lots) = (/(i, i=1,lots)/) */
2754 /* TODO: Unexpanded array initializers. */
2756 ("Possible frontend bug: array constructor not expanded");
2758 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2759 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2763 if (mpz_cmp_si (c
->repeat
, 0) != 0)
2767 mpz_set (maxval
, c
->repeat
);
2768 mpz_add (maxval
, c
->n
.offset
, maxval
);
2769 mpz_sub_ui (maxval
, maxval
, 1);
2770 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2771 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2773 mpz_add_ui (maxval
, c
->n
.offset
, 1);
2774 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2777 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2779 range
= build (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
2785 gfc_init_se (&se
, NULL
);
2786 switch (c
->expr
->expr_type
)
2789 gfc_conv_constant (&se
, c
->expr
);
2790 if (range
== NULL_TREE
)
2791 list
= tree_cons (index
, se
.expr
, list
);
2794 if (index
!= NULL_TREE
)
2795 list
= tree_cons (index
, se
.expr
, list
);
2796 list
= tree_cons (range
, se
.expr
, list
);
2800 case EXPR_STRUCTURE
:
2801 gfc_conv_structure (&se
, c
->expr
, 1);
2802 list
= tree_cons (index
, se
.expr
, list
);
2809 /* We created the list in reverse order. */
2810 list
= nreverse (list
);
2817 /* Create a constructor from the list of elements. */
2818 tmp
= build1 (CONSTRUCTOR
, type
, list
);
2819 TREE_CONSTANT (tmp
) = 1;
2820 TREE_INVARIANT (tmp
) = 1;
2825 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2826 returns the size (in elements) of the array. */
2829 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
2830 stmtblock_t
* pblock
)
2845 size
= gfc_index_one_node
;
2846 offset
= gfc_index_zero_node
;
2847 for (dim
= 0; dim
< as
->rank
; dim
++)
2849 /* Evaluate non-constant array bound expressions. */
2850 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2851 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
2853 gfc_init_se (&se
, NULL
);
2854 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
2855 gfc_add_block_to_block (pblock
, &se
.pre
);
2856 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
2858 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2859 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
2861 gfc_init_se (&se
, NULL
);
2862 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
2863 gfc_add_block_to_block (pblock
, &se
.pre
);
2864 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
2866 /* The offset of this dimension. offset = offset - lbound * stride. */
2867 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, lbound
, size
));
2868 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
2870 /* The size of this dimension, and the stride of the next. */
2871 if (dim
+ 1 < as
->rank
)
2872 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
2876 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
2878 /* Calculate stride = size * (ubound + 1 - lbound). */
2879 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
2880 gfc_index_one_node
, lbound
));
2881 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
));
2882 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2884 gfc_add_modify_expr (pblock
, stride
, tmp
);
2886 stride
= gfc_evaluate_now (tmp
, pblock
);
2897 /* Generate code to initialize/allocate an array variable. */
2900 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
2911 assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
2913 /* Do nothing for USEd variables. */
2914 if (sym
->attr
.use_assoc
)
2917 type
= TREE_TYPE (decl
);
2918 assert (GFC_ARRAY_TYPE_P (type
));
2919 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
2921 gfc_start_block (&block
);
2923 /* Evaluate character string length. */
2924 if (sym
->ts
.type
== BT_CHARACTER
2925 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2927 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2929 DECL_DEFER_OUTPUT (decl
) = 1;
2931 /* Generate code to allocate the automatic variable. It will be
2932 freed automatically. */
2933 tmp
= gfc_build_addr_expr (NULL
, decl
);
2934 args
= gfc_chainon_list (NULL_TREE
, tmp
);
2935 args
= gfc_chainon_list (args
, sym
->ts
.cl
->backend_decl
);
2936 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_STACK_ALLOC
],
2938 gfc_add_expr_to_block (&block
, tmp
);
2943 gfc_add_expr_to_block (&block
, fnbody
);
2944 return gfc_finish_block (&block
);
2947 type
= TREE_TYPE (type
);
2949 assert (!sym
->attr
.use_assoc
);
2950 assert (!TREE_STATIC (decl
));
2951 assert (!sym
->module
[0]);
2953 if (sym
->ts
.type
== BT_CHARACTER
2954 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2955 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2957 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
2959 /* The size is the number of elements in the array, so multiply by the
2960 size of an element to get the total size. */
2961 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2962 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2964 /* Allocate memory to hold the data. */
2965 tmp
= gfc_chainon_list (NULL_TREE
, size
);
2967 if (gfc_index_integer_kind
== 4)
2968 fndecl
= gfor_fndecl_internal_malloc
;
2969 else if (gfc_index_integer_kind
== 8)
2970 fndecl
= gfor_fndecl_internal_malloc64
;
2973 tmp
= gfc_build_function_call (fndecl
, tmp
);
2974 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
2975 gfc_add_modify_expr (&block
, decl
, tmp
);
2977 /* Set offset of the array. */
2978 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
2979 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
2982 /* Automatic arrays should not have initializers. */
2983 assert (!sym
->value
);
2985 gfc_add_expr_to_block (&block
, fnbody
);
2987 /* Free the temporary. */
2988 tmp
= convert (pvoid_type_node
, decl
);
2989 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
2990 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2991 gfc_add_expr_to_block (&block
, tmp
);
2993 return gfc_finish_block (&block
);
2997 /* Generate entry and exit code for g77 calling convention arrays. */
3000 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3009 gfc_get_backend_locus (&loc
);
3010 gfc_set_backend_locus (&sym
->declared_at
);
3012 /* Descriptor type. */
3013 parm
= sym
->backend_decl
;
3014 type
= TREE_TYPE (parm
);
3015 assert (GFC_ARRAY_TYPE_P (type
));
3017 gfc_start_block (&block
);
3019 if (sym
->ts
.type
== BT_CHARACTER
3020 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3021 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3023 /* Evaluate the bounds of the array. */
3024 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3026 /* Set the offset. */
3027 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3028 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3030 /* Set the pointer itself if we aren't using the parameter dirtectly. */
3031 if (TREE_CODE (parm
) != PARM_DECL
)
3033 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3034 gfc_add_modify_expr (&block
, parm
, tmp
);
3036 tmp
= gfc_finish_block (&block
);
3038 gfc_set_backend_locus (&loc
);
3040 gfc_start_block (&block
);
3041 /* Add the initialization code to the start of the function. */
3042 gfc_add_expr_to_block (&block
, tmp
);
3043 gfc_add_expr_to_block (&block
, body
);
3045 return gfc_finish_block (&block
);
3049 /* Modify the descriptor of an array parameter so that it has the
3050 correct lower bound. Also move the upper bound accordingly.
3051 If the array is not packed, it will be copied into a temporary.
3052 For each dimension we set the new lower and upper bounds. Then we copy the
3053 stride and calculate the offset for this dimension. We also work out
3054 what the stride of a packed array would be, and see it the two match.
3055 If the array need repacking, we set the stride to the values we just
3056 calculated, recalculate the offset and copy the array data.
3057 Code is also added to copy the data back at the end of the function.
3061 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3068 stmtblock_t cleanup
;
3085 /* Do nothing for pointer and allocatable arrays. */
3086 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3089 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3090 return gfc_trans_g77_array (sym
, body
);
3092 gfc_get_backend_locus (&loc
);
3093 gfc_set_backend_locus (&sym
->declared_at
);
3095 /* Descriptor type. */
3096 type
= TREE_TYPE (tmpdesc
);
3097 assert (GFC_ARRAY_TYPE_P (type
));
3098 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3099 dumdesc
= gfc_build_indirect_ref (dumdesc
);
3100 gfc_start_block (&block
);
3102 if (sym
->ts
.type
== BT_CHARACTER
3103 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3104 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3106 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3108 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3109 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3111 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3113 /* For non-constant shape arrays we only check if the first dimension
3114 is contiguous. Repacking higher dimensions wouldn't gain us
3115 anything as we still don't know the array stride. */
3116 partial
= gfc_create_var (boolean_type_node
, "partial");
3117 TREE_USED (partial
) = 1;
3118 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3119 tmp
= fold (build (EQ_EXPR
, boolean_type_node
, tmp
, integer_one_node
));
3120 gfc_add_modify_expr (&block
, partial
, tmp
);
3124 partial
= NULL_TREE
;
3127 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3128 here, however I think it does the right thing. */
3131 /* Set the first stride. */
3132 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3133 stride
= gfc_evaluate_now (stride
, &block
);
3135 tmp
= build (EQ_EXPR
, boolean_type_node
, stride
, integer_zero_node
);
3136 tmp
= build (COND_EXPR
, gfc_array_index_type
, tmp
,
3137 gfc_index_one_node
, stride
);
3138 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3139 gfc_add_modify_expr (&block
, stride
, tmp
);
3141 /* Allow the user to disable array repacking. */
3142 stmt_unpacked
= NULL_TREE
;
3146 assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3147 /* A library call to repack the array if neccessary. */
3148 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3149 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3150 stmt_unpacked
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3152 stride
= gfc_index_one_node
;
3155 /* This is for the case where the array data is used directly without
3156 calling the repack function. */
3157 if (no_repack
|| partial
!= NULL_TREE
)
3158 stmt_packed
= gfc_conv_descriptor_data (dumdesc
);
3160 stmt_packed
= NULL_TREE
;
3162 /* Assign the data pointer. */
3163 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3165 /* Don't repack unknown shape arrays when the first stride is 1. */
3166 tmp
= build (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3167 stmt_packed
, stmt_unpacked
);
3170 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3171 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
3173 offset
= gfc_index_zero_node
;
3174 size
= gfc_index_one_node
;
3176 /* Evaluate the bounds of the array. */
3177 for (n
= 0; n
< sym
->as
->rank
; n
++)
3179 if (checkparm
|| !sym
->as
->upper
[n
])
3181 /* Get the bounds of the actual parameter. */
3182 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3183 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3187 dubound
= NULL_TREE
;
3188 dlbound
= NULL_TREE
;
3191 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3192 if (!INTEGER_CST_P (lbound
))
3194 gfc_init_se (&se
, NULL
);
3195 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3196 gfc_array_index_type
);
3197 gfc_add_block_to_block (&block
, &se
.pre
);
3198 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3201 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3202 /* Set the desired upper bound. */
3203 if (sym
->as
->upper
[n
])
3205 /* We know what we want the upper bound to be. */
3206 if (!INTEGER_CST_P (ubound
))
3208 gfc_init_se (&se
, NULL
);
3209 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3210 gfc_array_index_type
);
3211 gfc_add_block_to_block (&block
, &se
.pre
);
3212 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3215 /* Check the sizes match. */
3218 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3220 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, ubound
,
3222 stride
= build (MINUS_EXPR
, gfc_array_index_type
, dubound
,
3224 tmp
= fold (build (NE_EXPR
, gfc_array_index_type
, tmp
, stride
));
3225 gfc_trans_runtime_check (tmp
, gfc_strconst_bounds
, &block
);
3230 /* For assumed shape arrays move the upper bound by the same amount
3231 as the lower bound. */
3232 tmp
= build (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3233 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
));
3234 gfc_add_modify_expr (&block
, ubound
, tmp
);
3236 /* The offset of this dimension. offset = offset - lbound * stride. */
3237 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
));
3238 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
3240 /* The size of this dimension, and the stride of the next. */
3241 if (n
+ 1 < sym
->as
->rank
)
3243 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3245 if (no_repack
|| partial
!= NULL_TREE
)
3248 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
3251 /* Figure out the stride if not a known constant. */
3252 if (!INTEGER_CST_P (stride
))
3255 stmt_packed
= NULL_TREE
;
3258 /* Calculate stride = size * (ubound + 1 - lbound). */
3259 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
3260 gfc_index_one_node
, lbound
));
3261 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
3263 size
= fold (build (MULT_EXPR
, gfc_array_index_type
,
3268 /* Assign the stride. */
3269 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3271 tmp
= build (COND_EXPR
, gfc_array_index_type
, partial
,
3272 stmt_unpacked
, stmt_packed
);
3275 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
3276 gfc_add_modify_expr (&block
, stride
, tmp
);
3281 /* Set the offset. */
3282 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3283 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3285 stmt
= gfc_finish_block (&block
);
3287 gfc_start_block (&block
);
3289 /* Only do the entry/initialization code if the arg is present. */
3290 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3291 if (sym
->attr
.optional
)
3293 tmp
= gfc_conv_expr_present (sym
);
3294 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3296 gfc_add_expr_to_block (&block
, stmt
);
3298 /* Add the main function body. */
3299 gfc_add_expr_to_block (&block
, body
);
3304 gfc_start_block (&cleanup
);
3306 if (sym
->attr
.intent
!= INTENT_IN
)
3308 /* Copy the data back. */
3309 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
3310 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
3311 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3312 gfc_add_expr_to_block (&cleanup
, tmp
);
3315 /* Free the temporary. */
3316 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
3317 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3318 gfc_add_expr_to_block (&cleanup
, tmp
);
3320 stmt
= gfc_finish_block (&cleanup
);
3322 /* Only do the cleanup if the array was repacked. */
3323 tmp
= gfc_build_indirect_ref (dumdesc
);
3324 tmp
= gfc_conv_descriptor_data (tmp
);
3325 tmp
= build (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
3326 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3328 if (sym
->attr
.optional
)
3330 tmp
= gfc_conv_expr_present (sym
);
3331 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3333 gfc_add_expr_to_block (&block
, stmt
);
3335 /* We don't need to free any memory allocated by internal_pack as it will
3336 be freed at the end of the function by pop_context. */
3337 return gfc_finish_block (&block
);
3341 /* Convert an array for passing as an actual parameter. Expressions and
3342 vector subscripts are evaluated and stored in a temporary, which is then
3343 passed. For whole arrays the descriptor is passed. For array sections
3344 a modified copy of the descriptor is passed, but using the original data.
3345 Also used for array pointer assignments by setting se->direct_byref. */
3348 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
3363 assert (ss
!= gfc_ss_terminator
);
3365 /* TODO: Pass constant array constructors without a temporary. */
3366 /* Special case things we know we can pass easily. */
3367 switch (expr
->expr_type
)
3370 /* If we have a linear array section, we can pass it directly.
3371 Otherwise we need to copy it into a temporary. */
3373 /* Find the SS for the array section. */
3375 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
3376 secss
= secss
->next
;
3378 assert (secss
!= gfc_ss_terminator
);
3381 for (n
= 0; n
< secss
->data
.info
.dimen
; n
++)
3383 vss
= secss
->data
.info
.subscript
[secss
->data
.info
.dim
[n
]];
3384 if (vss
&& vss
->type
== GFC_SS_VECTOR
)
3388 info
= &secss
->data
.info
;
3390 /* Get the descriptor for the array. */
3391 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
3392 desc
= info
->descriptor
;
3393 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
3395 /* Create a new descriptor if the array doesn't have one. */
3398 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
3400 else if (se
->direct_byref
)
3404 assert (info
->ref
->u
.ar
.type
== AR_SECTION
);
3407 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3409 /* Detect passing the full array as a section. This could do
3410 even more checking, but it doesn't seem worth it. */
3411 if (info
->ref
->u
.ar
.start
[n
]
3412 || info
->ref
->u
.ar
.end
[n
]
3413 || (info
->ref
->u
.ar
.stride
[n
]
3414 && !gfc_expr_is_one (info
->ref
->u
.ar
.stride
[n
], 0)))
3423 if (se
->direct_byref
)
3425 /* Copy the descriptor for pointer assignments. */
3426 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
3428 else if (se
->want_pointer
)
3430 /* We pass full arrays directly. This means that pointers and
3431 allocatable arrays should also work. */
3432 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3438 if (expr
->ts
.type
== BT_CHARACTER
)
3439 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3445 /* A transformational function return value will be a temporary
3446 array descriptor. We still need to go through the scalarizer
3447 to create the descriptor. Elemental functions ar handled as
3448 arbitary expressions, ie. copy to a temporary. */
3450 /* Look for the SS for this function. */
3451 while (secss
!= gfc_ss_terminator
3452 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
3453 secss
= secss
->next
;
3455 if (se
->direct_byref
)
3457 assert (secss
!= gfc_ss_terminator
);
3459 /* For pointer assignments pass the descriptor directly. */
3461 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3462 gfc_conv_expr (se
, expr
);
3466 if (secss
== gfc_ss_terminator
)
3468 /* Elemental function. */
3474 /* Transformational function. */
3475 info
= &secss
->data
.info
;
3481 /* Something complicated. Copy it into a temporary. */
3489 gfc_init_loopinfo (&loop
);
3491 /* Associate the SS with the loop. */
3492 gfc_add_ss_to_loop (&loop
, ss
);
3494 /* Tell the scalarizer not to bother creating loop variables, etc. */
3496 loop
.array_parameter
= 1;
3498 assert (se
->want_pointer
&& !se
->direct_byref
);
3500 /* Setup the scalarizing loops and bounds. */
3501 gfc_conv_ss_startstride (&loop
);
3505 /* Tell the scalarizer to make a temporary. */
3506 loop
.temp_ss
= gfc_get_ss ();
3507 loop
.temp_ss
->type
= GFC_SS_TEMP
;
3508 loop
.temp_ss
->next
= gfc_ss_terminator
;
3509 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
3510 /* Which can hold our string, if present. */
3511 if (expr
->ts
.type
== BT_CHARACTER
)
3512 se
->string_length
= loop
.temp_ss
->data
.temp
.string_length
3513 = TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
3515 loop
.temp_ss
->data
.temp
.string_length
= NULL
;
3516 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
3517 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3520 gfc_conv_loop_setup (&loop
);
3524 /* Copy into a temporary and pass that. We don't need to copy the data
3525 back because expressions and vector subscripts must be INTENT_IN. */
3526 /* TODO: Optimize passing function return values. */
3530 /* Start the copying loops. */
3531 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3532 gfc_mark_ss_chain_used (ss
, 1);
3533 gfc_start_scalarized_body (&loop
, &block
);
3535 /* Copy each data element. */
3536 gfc_init_se (&lse
, NULL
);
3537 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3538 gfc_init_se (&rse
, NULL
);
3539 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3541 lse
.ss
= loop
.temp_ss
;
3544 gfc_conv_scalarized_array_ref (&lse
, NULL
);
3545 gfc_conv_expr_val (&rse
, expr
);
3547 gfc_add_block_to_block (&block
, &rse
.pre
);
3548 gfc_add_block_to_block (&block
, &lse
.pre
);
3550 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
3552 /* Finish the copying loops. */
3553 gfc_trans_scalarizing_loops (&loop
, &block
);
3555 /* Set the first stride component to zero to indicate a temporary. */
3556 desc
= loop
.temp_ss
->data
.info
.descriptor
;
3557 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[0]);
3558 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3560 assert (is_gimple_lvalue (desc
));
3561 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3563 else if (expr
->expr_type
== EXPR_FUNCTION
)
3565 desc
= info
->descriptor
;
3567 if (se
->want_pointer
)
3568 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3572 if (expr
->ts
.type
== BT_CHARACTER
)
3573 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3577 /* We pass sections without copying to a temporary. Make a new
3578 descriptor and point it at the section we want. The loop variable
3579 limits will be the limits of the section.
3580 A function may decide to repack the array to speed up access, but
3581 we're not bothered about that here. */
3590 /* Set the string_length for a character array. */
3591 if (expr
->ts
.type
== BT_CHARACTER
)
3592 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3594 desc
= info
->descriptor
;
3595 assert (secss
&& secss
!= gfc_ss_terminator
);
3596 if (se
->direct_byref
)
3598 /* For pointer assignments we fill in the destination. */
3600 parmtype
= TREE_TYPE (parm
);
3604 /* Otherwise make a new one. */
3605 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3606 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
3607 loop
.from
, loop
.to
, 0);
3608 parm
= gfc_create_var (parmtype
, "parm");
3611 offset
= gfc_index_zero_node
;
3614 /* The following can be somewhat confusing. We have two
3615 descriptors, a new one and the original array.
3616 {parm, parmtype, dim} refer to the new one.
3617 {desc, type, n, secss, loop} refer to the original, which maybe
3618 a descriptorless array.
3619 The bounds of the scaralization are the bounds of the section.
3620 We don't have to worry about numeric overflows when calculating
3621 the offsets because all elements are within the array data. */
3623 /* Set the dtype. */
3624 tmp
= gfc_conv_descriptor_dtype (parm
);
3625 gfc_add_modify_expr (&loop
.pre
, tmp
, GFC_TYPE_ARRAY_DTYPE (parmtype
));
3627 if (se
->direct_byref
)
3628 base
= gfc_index_zero_node
;
3632 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3634 stride
= gfc_conv_array_stride (desc
, n
);
3636 /* Work out the offset. */
3637 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3639 assert (info
->subscript
[n
]
3640 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
3641 start
= info
->subscript
[n
]->data
.scalar
.expr
;
3645 /* Check we haven't somehow got out of sync. */
3646 assert (info
->dim
[dim
] == n
);
3648 /* Evaluate and remember the start of the section. */
3649 start
= info
->start
[dim
];
3650 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
3653 tmp
= gfc_conv_array_lbound (desc
, n
);
3654 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
));
3656 tmp
= fold (build (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
));
3657 offset
= fold (build (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
));
3659 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3661 /* For elemental dimensions, we only need the offset. */
3665 /* Vector subscripts need copying and are handled elsewhere. */
3666 assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
3668 /* Set the new lower bound. */
3669 from
= loop
.from
[dim
];
3671 if (!integer_onep (from
))
3673 /* Make sure the new section starts at 1. */
3674 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
3675 gfc_index_one_node
, from
));
3676 to
= fold (build (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
));
3677 from
= gfc_index_one_node
;
3679 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
3680 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
3682 /* Set the new upper bound. */
3683 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
3684 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
3686 /* Multiply the stride by the section stride to get the
3688 stride
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
,
3689 info
->stride
[dim
]));
3691 if (se
->direct_byref
)
3693 base
= fold (build (MINUS_EXPR
, TREE_TYPE (base
),
3697 /* Store the new stride. */
3698 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
3699 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
3704 /* Point the data pointer at the first element in the section. */
3705 tmp
= gfc_conv_array_data (desc
);
3706 tmp
= gfc_build_indirect_ref (tmp
);
3707 tmp
= gfc_build_array_ref (tmp
, offset
);
3708 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
3710 tmp
= gfc_conv_descriptor_data (parm
);
3711 gfc_add_modify_expr (&loop
.pre
, tmp
,
3712 fold_convert (TREE_TYPE (tmp
), offset
));
3714 if (se
->direct_byref
)
3716 /* Set the offset. */
3717 tmp
= gfc_conv_descriptor_offset (parm
);
3718 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
3722 /* Only the callee knows what the correct offset it, so just set
3724 tmp
= gfc_conv_descriptor_offset (parm
);
3725 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3728 if (!se
->direct_byref
)
3730 /* Get a pointer to the new descriptor. */
3731 if (se
->want_pointer
)
3732 se
->expr
= gfc_build_addr_expr (NULL
, parm
);
3738 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3739 gfc_add_block_to_block (&se
->post
, &loop
.post
);
3741 /* Cleanup the scalarizer. */
3742 gfc_cleanup_loop (&loop
);
3746 /* Convert an array for passing as an actual parameter. */
3747 /* TODO: Optimize passing g77 arrays. */
3750 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
3759 /* Passing address of the array if it is not pointer or assumed-shape. */
3760 if (expr
->expr_type
== EXPR_VARIABLE
3761 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
3763 sym
= expr
->symtree
->n
.sym
;
3764 tmp
= gfc_get_symbol_decl (sym
);
3765 if (sym
->ts
.type
== BT_CHARACTER
)
3766 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3767 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
3768 && !sym
->attr
.allocatable
)
3770 if (!sym
->attr
.dummy
)
3771 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
3776 if (sym
->attr
.allocatable
)
3778 se
->expr
= gfc_conv_array_data (tmp
);
3783 se
->want_pointer
= 1;
3784 gfc_conv_expr_descriptor (se
, expr
, ss
);
3789 /* Repack the array. */
3790 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3791 ptr
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3792 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
3795 gfc_start_block (&block
);
3797 /* Copy the data back. */
3798 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3799 tmp
= gfc_chainon_list (tmp
, ptr
);
3800 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3801 gfc_add_expr_to_block (&block
, tmp
);
3803 /* Free the temporary. */
3804 tmp
= convert (pvoid_type_node
, ptr
);
3805 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3806 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3807 gfc_add_expr_to_block (&block
, tmp
);
3809 stmt
= gfc_finish_block (&block
);
3811 gfc_init_block (&block
);
3812 /* Only if it was repacked. This code needs to be executed before the
3813 loop cleanup code. */
3814 tmp
= gfc_build_indirect_ref (desc
);
3815 tmp
= gfc_conv_array_data (tmp
);
3816 tmp
= build (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
3817 tmp
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3819 gfc_add_expr_to_block (&block
, tmp
);
3820 gfc_add_block_to_block (&block
, &se
->post
);
3822 gfc_init_block (&se
->post
);
3823 gfc_add_block_to_block (&se
->post
, &block
);
3828 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3831 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
3838 stmtblock_t fnblock
;
3841 /* Make sure the frontend gets these right. */
3842 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3844 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
3846 gfc_init_block (&fnblock
);
3848 assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
);
3849 if (sym
->ts
.type
== BT_CHARACTER
3850 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3851 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
3853 /* Parameter variables don't need anything special. */
3854 if (sym
->attr
.dummy
)
3856 gfc_add_expr_to_block (&fnblock
, body
);
3858 return gfc_finish_block (&fnblock
);
3861 gfc_get_backend_locus (&loc
);
3862 gfc_set_backend_locus (&sym
->declared_at
);
3863 descriptor
= sym
->backend_decl
;
3865 if (TREE_STATIC (descriptor
))
3867 /* SAVEd variables are not freed on exit. */
3868 gfc_trans_static_array_pointer (sym
);
3872 /* Get the descriptor type. */
3873 type
= TREE_TYPE (sym
->backend_decl
);
3874 assert (GFC_DESCRIPTOR_TYPE_P (type
));
3876 /* NULLIFY the data pointer. */
3877 tmp
= gfc_conv_descriptor_data (descriptor
);
3878 gfc_add_modify_expr (&fnblock
, tmp
,
3879 convert (TREE_TYPE (tmp
), integer_zero_node
));
3881 gfc_add_expr_to_block (&fnblock
, body
);
3883 gfc_set_backend_locus (&loc
);
3884 /* Allocatable arrays need to be freed when they go out of scope. */
3885 if (sym
->attr
.allocatable
)
3887 gfc_start_block (&block
);
3889 /* Deallocate if still allocated at the end of the procedure. */
3890 deallocate
= gfc_array_deallocate (descriptor
);
3892 tmp
= gfc_conv_descriptor_data (descriptor
);
3893 tmp
= build (NE_EXPR
, boolean_type_node
, tmp
, integer_zero_node
);
3894 tmp
= build_v (COND_EXPR
, tmp
, deallocate
, build_empty_stmt ());
3895 gfc_add_expr_to_block (&block
, tmp
);
3897 tmp
= gfc_finish_block (&block
);
3898 gfc_add_expr_to_block (&fnblock
, tmp
);
3901 return gfc_finish_block (&fnblock
);
3904 /************ Expression Walking Functions ******************/
3906 /* Walk a variable reference.
3908 Possible extension - multiple component subscripts.
3909 x(:,:) = foo%a(:)%b(:)
3911 forall (i=..., j=...)
3912 x(i,j) = foo%a(j)%b(i)
3914 This adds a fair amout of complexity because you need to deal with more
3915 than one ref. Maybe handle in a similar manner to vector subscripts.
3916 Maybe not worth the effort. */
3920 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
3928 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3930 /* We're only interested in array sections. */
3931 if (ref
->type
!= REF_ARRAY
)
3938 /* TODO: Take elemental array references out of scalarization
3943 newss
= gfc_get_ss ();
3944 newss
->type
= GFC_SS_SECTION
;
3947 newss
->data
.info
.dimen
= ar
->as
->rank
;
3948 newss
->data
.info
.ref
= ref
;
3950 /* Make sure array is the same as array(:,:), this way
3951 we don't need to special case all the time. */
3952 ar
->dimen
= ar
->as
->rank
;
3953 for (n
= 0; n
< ar
->dimen
; n
++)
3955 newss
->data
.info
.dim
[n
] = n
;
3956 ar
->dimen_type
[n
] = DIMEN_RANGE
;
3958 assert (ar
->start
[n
] == NULL
);
3959 assert (ar
->end
[n
] == NULL
);
3960 assert (ar
->stride
[n
] == NULL
);
3965 newss
= gfc_get_ss ();
3966 newss
->type
= GFC_SS_SECTION
;
3969 newss
->data
.info
.dimen
= 0;
3970 newss
->data
.info
.ref
= ref
;
3974 /* We add SS chains for all the subscripts in the section. */
3975 for (n
= 0; n
< ar
->dimen
; n
++)
3979 switch (ar
->dimen_type
[n
])
3982 /* Add SS for elemental (scalar) subscripts. */
3983 assert (ar
->start
[n
]);
3984 indexss
= gfc_get_ss ();
3985 indexss
->type
= GFC_SS_SCALAR
;
3986 indexss
->expr
= ar
->start
[n
];
3987 indexss
->next
= gfc_ss_terminator
;
3988 indexss
->loop_chain
= gfc_ss_terminator
;
3989 newss
->data
.info
.subscript
[n
] = indexss
;
3993 /* We don't add anything for sections, just remember this
3994 dimension for later. */
3995 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
3996 newss
->data
.info
.dimen
++;
4000 /* Get a SS for the vector. This will not be added to the
4002 indexss
= gfc_walk_expr (ar
->start
[n
]);
4003 if (indexss
== gfc_ss_terminator
)
4004 internal_error ("scalar vector subscript???");
4006 /* We currently only handle really simple vector
4008 if (indexss
->next
!= gfc_ss_terminator
)
4009 gfc_todo_error ("vector subscript expressions");
4010 indexss
->loop_chain
= gfc_ss_terminator
;
4012 /* Mark this as a vector subscript. We don't add this
4013 directly into the chain, but as a subscript of the
4014 existing SS for this term. */
4015 indexss
->type
= GFC_SS_VECTOR
;
4016 newss
->data
.info
.subscript
[n
] = indexss
;
4017 /* Also remember this dimension. */
4018 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4019 newss
->data
.info
.dimen
++;
4023 /* We should know what sort of section it is by now. */
4027 /* We should have at least one non-elemental dimension. */
4028 assert (newss
->data
.info
.dimen
> 0);
4033 /* We should know what sort of section it is by now. */
4042 /* Walk an expression operator. If only one operand of a binary expression is
4043 scalar, we must also add the scalar term to the SS chain. */
4046 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4052 head
= gfc_walk_subexpr (ss
, expr
->op1
);
4053 if (expr
->op2
== NULL
)
4056 head2
= gfc_walk_subexpr (head
, expr
->op2
);
4058 /* All operands are scalar. Pass back and let the caller deal with it. */
4062 /* All operands require scalarization. */
4063 if (head
!= ss
&& (expr
->op2
== NULL
|| head2
!= head
))
4066 /* One of the operands needs scalarization, the other is scalar.
4067 Create a gfc_ss for the scalar expression. */
4068 newss
= gfc_get_ss ();
4069 newss
->type
= GFC_SS_SCALAR
;
4072 /* First operand is scalar. We build the chain in reverse order, so
4073 add the scarar SS after the second operand. */
4075 while (head
&& head
->next
!= ss
)
4077 /* Check we haven't somehow broken the chain. */
4081 newss
->expr
= expr
->op1
;
4083 else /* head2 == head */
4085 assert (head2
== head
);
4086 /* Second operand is scalar. */
4087 newss
->next
= head2
;
4089 newss
->expr
= expr
->op2
;
4096 /* Reverse a SS chain. */
4099 gfc_reverse_ss (gfc_ss
* ss
)
4104 assert (ss
!= NULL
);
4106 head
= gfc_ss_terminator
;
4107 while (ss
!= gfc_ss_terminator
)
4110 assert (next
!= NULL
); /* Check we didn't somehow break the chain. */
4120 /* Walk the arguments of an elemental function. */
4123 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_expr
* expr
,
4126 gfc_actual_arglist
*arg
;
4132 head
= gfc_ss_terminator
;
4135 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4140 newss
= gfc_walk_subexpr (head
, arg
->expr
);
4143 /* Scalar argumet. */
4144 newss
= gfc_get_ss ();
4146 newss
->expr
= arg
->expr
;
4156 while (tail
->next
!= gfc_ss_terminator
)
4163 /* If all the arguments are scalar we don't need the argument SS. */
4164 gfc_free_ss_chain (head
);
4169 /* Add it onto the existing chain. */
4175 /* Walk a function call. Scalar functions are passed back, and taken out of
4176 scalarization loops. For elemental functions we walk their arguments.
4177 The result of functions returning arrays is stored in a temporary outside
4178 the loop, so that the function is only called once. Hence we do not need
4179 to walk their arguments. */
4182 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4185 gfc_intrinsic_sym
*isym
;
4188 isym
= expr
->value
.function
.isym
;
4190 /* Handle intrinsic functions separately. */
4192 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
4194 sym
= expr
->value
.function
.esym
;
4196 sym
= expr
->symtree
->n
.sym
;
4198 /* A function that returns arrays. */
4199 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
4201 newss
= gfc_get_ss ();
4202 newss
->type
= GFC_SS_FUNCTION
;
4205 newss
->data
.info
.dimen
= expr
->rank
;
4209 /* Walk the parameters of an elemental function. For now we always pass
4211 if (sym
->attr
.elemental
)
4212 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_REFERENCE
);
4214 /* Scalar functions are OK as these are evaluated outside the scalarisation
4215 loop. Pass back and let the caller deal with it. */
4220 /* An array temporary is constructed for array constructors. */
4223 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
4228 newss
= gfc_get_ss ();
4229 newss
->type
= GFC_SS_CONSTRUCTOR
;
4232 newss
->data
.info
.dimen
= expr
->rank
;
4233 for (n
= 0; n
< expr
->rank
; n
++)
4234 newss
->data
.info
.dim
[n
] = n
;
4240 /* Walk an expresson. Add walked expressions to the head of the SS chain.
4241 A wholy scalar expression will not be added. */
4244 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
4248 switch (expr
->expr_type
)
4251 head
= gfc_walk_variable_expr (ss
, expr
);
4255 head
= gfc_walk_op_expr (ss
, expr
);
4259 head
= gfc_walk_function_expr (ss
, expr
);
4264 case EXPR_STRUCTURE
:
4265 /* Pass back and let the caller deal with it. */
4269 head
= gfc_walk_array_constructor (ss
, expr
);
4272 case EXPR_SUBSTRING
:
4273 /* Pass back and let the caller deal with it. */
4277 internal_error ("bad expression type during walk (%d)",
4284 /* Entry point for expression walking.
4285 A return value equal to the passed chain means this is
4286 a scalar expression. It is up to the caller to take whatever action is
4287 neccessary to translate these. */
4290 gfc_walk_expr (gfc_expr
* expr
)
4294 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
4295 return gfc_reverse_ss (res
);