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_cst (NULL_TREE
, 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_cst (NULL_TREE
, 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
)
2910 assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
2912 /* Do nothing for USEd variables. */
2913 if (sym
->attr
.use_assoc
)
2916 type
= TREE_TYPE (decl
);
2917 assert (GFC_ARRAY_TYPE_P (type
));
2918 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
2920 gfc_start_block (&block
);
2922 /* Evaluate character string length. */
2923 if (sym
->ts
.type
== BT_CHARACTER
2924 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2926 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2928 /* Emit a DECL_EXPR for this variable, which will cause the
2929 gimplifier to allocate stoage, and all that good stuff. */
2930 tmp
= build (DECL_EXPR
, TREE_TYPE (decl
), decl
);
2931 gfc_add_expr_to_block (&block
, tmp
);
2936 gfc_add_expr_to_block (&block
, fnbody
);
2937 return gfc_finish_block (&block
);
2940 type
= TREE_TYPE (type
);
2942 assert (!sym
->attr
.use_assoc
);
2943 assert (!TREE_STATIC (decl
));
2944 assert (!sym
->module
[0]);
2946 if (sym
->ts
.type
== BT_CHARACTER
2947 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2948 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2950 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
2952 /* The size is the number of elements in the array, so multiply by the
2953 size of an element to get the total size. */
2954 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2955 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2957 /* Allocate memory to hold the data. */
2958 tmp
= gfc_chainon_list (NULL_TREE
, size
);
2960 if (gfc_index_integer_kind
== 4)
2961 fndecl
= gfor_fndecl_internal_malloc
;
2962 else if (gfc_index_integer_kind
== 8)
2963 fndecl
= gfor_fndecl_internal_malloc64
;
2966 tmp
= gfc_build_function_call (fndecl
, tmp
);
2967 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
2968 gfc_add_modify_expr (&block
, decl
, tmp
);
2970 /* Set offset of the array. */
2971 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
2972 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
2975 /* Automatic arrays should not have initializers. */
2976 assert (!sym
->value
);
2978 gfc_add_expr_to_block (&block
, fnbody
);
2980 /* Free the temporary. */
2981 tmp
= convert (pvoid_type_node
, decl
);
2982 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
2983 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2984 gfc_add_expr_to_block (&block
, tmp
);
2986 return gfc_finish_block (&block
);
2990 /* Generate entry and exit code for g77 calling convention arrays. */
2993 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3002 gfc_get_backend_locus (&loc
);
3003 gfc_set_backend_locus (&sym
->declared_at
);
3005 /* Descriptor type. */
3006 parm
= sym
->backend_decl
;
3007 type
= TREE_TYPE (parm
);
3008 assert (GFC_ARRAY_TYPE_P (type
));
3010 gfc_start_block (&block
);
3012 if (sym
->ts
.type
== BT_CHARACTER
3013 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3014 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3016 /* Evaluate the bounds of the array. */
3017 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3019 /* Set the offset. */
3020 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3021 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3023 /* Set the pointer itself if we aren't using the parameter dirtectly. */
3024 if (TREE_CODE (parm
) != PARM_DECL
)
3026 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3027 gfc_add_modify_expr (&block
, parm
, tmp
);
3029 tmp
= gfc_finish_block (&block
);
3031 gfc_set_backend_locus (&loc
);
3033 gfc_start_block (&block
);
3034 /* Add the initialization code to the start of the function. */
3035 gfc_add_expr_to_block (&block
, tmp
);
3036 gfc_add_expr_to_block (&block
, body
);
3038 return gfc_finish_block (&block
);
3042 /* Modify the descriptor of an array parameter so that it has the
3043 correct lower bound. Also move the upper bound accordingly.
3044 If the array is not packed, it will be copied into a temporary.
3045 For each dimension we set the new lower and upper bounds. Then we copy the
3046 stride and calculate the offset for this dimension. We also work out
3047 what the stride of a packed array would be, and see it the two match.
3048 If the array need repacking, we set the stride to the values we just
3049 calculated, recalculate the offset and copy the array data.
3050 Code is also added to copy the data back at the end of the function.
3054 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3061 stmtblock_t cleanup
;
3079 /* Do nothing for pointer and allocatable arrays. */
3080 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3083 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3084 return gfc_trans_g77_array (sym
, body
);
3086 gfc_get_backend_locus (&loc
);
3087 gfc_set_backend_locus (&sym
->declared_at
);
3089 /* Descriptor type. */
3090 type
= TREE_TYPE (tmpdesc
);
3091 assert (GFC_ARRAY_TYPE_P (type
));
3092 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3093 dumdesc
= gfc_build_indirect_ref (dumdesc
);
3094 gfc_start_block (&block
);
3096 if (sym
->ts
.type
== BT_CHARACTER
3097 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3098 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3100 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3102 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3103 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3105 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3107 /* For non-constant shape arrays we only check if the first dimension
3108 is contiguous. Repacking higher dimensions wouldn't gain us
3109 anything as we still don't know the array stride. */
3110 partial
= gfc_create_var (boolean_type_node
, "partial");
3111 TREE_USED (partial
) = 1;
3112 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3113 tmp
= fold (build (EQ_EXPR
, boolean_type_node
, tmp
, integer_one_node
));
3114 gfc_add_modify_expr (&block
, partial
, tmp
);
3118 partial
= NULL_TREE
;
3121 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3122 here, however I think it does the right thing. */
3125 /* Set the first stride. */
3126 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3127 stride
= gfc_evaluate_now (stride
, &block
);
3129 tmp
= build (EQ_EXPR
, boolean_type_node
, stride
, integer_zero_node
);
3130 tmp
= build (COND_EXPR
, gfc_array_index_type
, tmp
,
3131 gfc_index_one_node
, stride
);
3132 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3133 gfc_add_modify_expr (&block
, stride
, tmp
);
3135 /* Allow the user to disable array repacking. */
3136 stmt_unpacked
= NULL_TREE
;
3140 assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3141 /* A library call to repack the array if neccessary. */
3142 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3143 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3144 stmt_unpacked
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3146 stride
= gfc_index_one_node
;
3149 /* This is for the case where the array data is used directly without
3150 calling the repack function. */
3151 if (no_repack
|| partial
!= NULL_TREE
)
3152 stmt_packed
= gfc_conv_descriptor_data (dumdesc
);
3154 stmt_packed
= NULL_TREE
;
3156 /* Assign the data pointer. */
3157 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3159 /* Don't repack unknown shape arrays when the first stride is 1. */
3160 tmp
= build (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3161 stmt_packed
, stmt_unpacked
);
3164 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3165 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
3167 offset
= gfc_index_zero_node
;
3168 size
= gfc_index_one_node
;
3170 /* Evaluate the bounds of the array. */
3171 for (n
= 0; n
< sym
->as
->rank
; n
++)
3173 if (checkparm
|| !sym
->as
->upper
[n
])
3175 /* Get the bounds of the actual parameter. */
3176 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3177 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3181 dubound
= NULL_TREE
;
3182 dlbound
= NULL_TREE
;
3185 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3186 if (!INTEGER_CST_P (lbound
))
3188 gfc_init_se (&se
, NULL
);
3189 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3190 gfc_array_index_type
);
3191 gfc_add_block_to_block (&block
, &se
.pre
);
3192 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3195 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3196 /* Set the desired upper bound. */
3197 if (sym
->as
->upper
[n
])
3199 /* We know what we want the upper bound to be. */
3200 if (!INTEGER_CST_P (ubound
))
3202 gfc_init_se (&se
, NULL
);
3203 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3204 gfc_array_index_type
);
3205 gfc_add_block_to_block (&block
, &se
.pre
);
3206 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3209 /* Check the sizes match. */
3212 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3214 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, ubound
,
3216 stride
= build (MINUS_EXPR
, gfc_array_index_type
, dubound
,
3218 tmp
= fold (build (NE_EXPR
, gfc_array_index_type
, tmp
, stride
));
3219 gfc_trans_runtime_check (tmp
, gfc_strconst_bounds
, &block
);
3224 /* For assumed shape arrays move the upper bound by the same amount
3225 as the lower bound. */
3226 tmp
= build (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3227 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
));
3228 gfc_add_modify_expr (&block
, ubound
, tmp
);
3230 /* The offset of this dimension. offset = offset - lbound * stride. */
3231 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
));
3232 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
3234 /* The size of this dimension, and the stride of the next. */
3235 if (n
+ 1 < sym
->as
->rank
)
3237 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3239 if (no_repack
|| partial
!= NULL_TREE
)
3242 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
3245 /* Figure out the stride if not a known constant. */
3246 if (!INTEGER_CST_P (stride
))
3249 stmt_packed
= NULL_TREE
;
3252 /* Calculate stride = size * (ubound + 1 - lbound). */
3253 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
3254 gfc_index_one_node
, lbound
));
3255 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
3257 size
= fold (build (MULT_EXPR
, gfc_array_index_type
,
3262 /* Assign the stride. */
3263 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3265 tmp
= build (COND_EXPR
, gfc_array_index_type
, partial
,
3266 stmt_unpacked
, stmt_packed
);
3269 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
3270 gfc_add_modify_expr (&block
, stride
, tmp
);
3275 /* Set the offset. */
3276 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3277 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3279 stmt
= gfc_finish_block (&block
);
3281 gfc_start_block (&block
);
3283 /* Only do the entry/initialization code if the arg is present. */
3284 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3285 optional_arg
= sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
;
3288 tmp
= gfc_conv_expr_present (sym
);
3289 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3291 gfc_add_expr_to_block (&block
, stmt
);
3293 /* Add the main function body. */
3294 gfc_add_expr_to_block (&block
, body
);
3299 gfc_start_block (&cleanup
);
3301 if (sym
->attr
.intent
!= INTENT_IN
)
3303 /* Copy the data back. */
3304 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
3305 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
3306 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3307 gfc_add_expr_to_block (&cleanup
, tmp
);
3310 /* Free the temporary. */
3311 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
3312 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3313 gfc_add_expr_to_block (&cleanup
, tmp
);
3315 stmt
= gfc_finish_block (&cleanup
);
3317 /* Only do the cleanup if the array was repacked. */
3318 tmp
= gfc_build_indirect_ref (dumdesc
);
3319 tmp
= gfc_conv_descriptor_data (tmp
);
3320 tmp
= build (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
3321 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3325 tmp
= gfc_conv_expr_present (sym
);
3326 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3328 gfc_add_expr_to_block (&block
, stmt
);
3330 /* We don't need to free any memory allocated by internal_pack as it will
3331 be freed at the end of the function by pop_context. */
3332 return gfc_finish_block (&block
);
3336 /* Convert an array for passing as an actual parameter. Expressions and
3337 vector subscripts are evaluated and stored in a temporary, which is then
3338 passed. For whole arrays the descriptor is passed. For array sections
3339 a modified copy of the descriptor is passed, but using the original data.
3340 Also used for array pointer assignments by setting se->direct_byref. */
3343 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
3358 assert (ss
!= gfc_ss_terminator
);
3360 /* TODO: Pass constant array constructors without a temporary. */
3361 /* Special case things we know we can pass easily. */
3362 switch (expr
->expr_type
)
3365 /* If we have a linear array section, we can pass it directly.
3366 Otherwise we need to copy it into a temporary. */
3368 /* Find the SS for the array section. */
3370 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
3371 secss
= secss
->next
;
3373 assert (secss
!= gfc_ss_terminator
);
3376 for (n
= 0; n
< secss
->data
.info
.dimen
; n
++)
3378 vss
= secss
->data
.info
.subscript
[secss
->data
.info
.dim
[n
]];
3379 if (vss
&& vss
->type
== GFC_SS_VECTOR
)
3383 info
= &secss
->data
.info
;
3385 /* Get the descriptor for the array. */
3386 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
3387 desc
= info
->descriptor
;
3388 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
3390 /* Create a new descriptor if the array doesn't have one. */
3393 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
3395 else if (se
->direct_byref
)
3399 assert (info
->ref
->u
.ar
.type
== AR_SECTION
);
3402 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3404 /* Detect passing the full array as a section. This could do
3405 even more checking, but it doesn't seem worth it. */
3406 if (info
->ref
->u
.ar
.start
[n
]
3407 || info
->ref
->u
.ar
.end
[n
]
3408 || (info
->ref
->u
.ar
.stride
[n
]
3409 && !gfc_expr_is_one (info
->ref
->u
.ar
.stride
[n
], 0)))
3418 if (se
->direct_byref
)
3420 /* Copy the descriptor for pointer assignments. */
3421 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
3423 else if (se
->want_pointer
)
3425 /* We pass full arrays directly. This means that pointers and
3426 allocatable arrays should also work. */
3427 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3433 if (expr
->ts
.type
== BT_CHARACTER
)
3434 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3440 /* A transformational function return value will be a temporary
3441 array descriptor. We still need to go through the scalarizer
3442 to create the descriptor. Elemental functions ar handled as
3443 arbitary expressions, ie. copy to a temporary. */
3445 /* Look for the SS for this function. */
3446 while (secss
!= gfc_ss_terminator
3447 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
3448 secss
= secss
->next
;
3450 if (se
->direct_byref
)
3452 assert (secss
!= gfc_ss_terminator
);
3454 /* For pointer assignments pass the descriptor directly. */
3456 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3457 gfc_conv_expr (se
, expr
);
3461 if (secss
== gfc_ss_terminator
)
3463 /* Elemental function. */
3469 /* Transformational function. */
3470 info
= &secss
->data
.info
;
3476 /* Something complicated. Copy it into a temporary. */
3484 gfc_init_loopinfo (&loop
);
3486 /* Associate the SS with the loop. */
3487 gfc_add_ss_to_loop (&loop
, ss
);
3489 /* Tell the scalarizer not to bother creating loop variables, etc. */
3491 loop
.array_parameter
= 1;
3493 assert (se
->want_pointer
&& !se
->direct_byref
);
3495 /* Setup the scalarizing loops and bounds. */
3496 gfc_conv_ss_startstride (&loop
);
3500 /* Tell the scalarizer to make a temporary. */
3501 loop
.temp_ss
= gfc_get_ss ();
3502 loop
.temp_ss
->type
= GFC_SS_TEMP
;
3503 loop
.temp_ss
->next
= gfc_ss_terminator
;
3504 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
3505 /* Which can hold our string, if present. */
3506 if (expr
->ts
.type
== BT_CHARACTER
)
3507 se
->string_length
= loop
.temp_ss
->data
.temp
.string_length
3508 = TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
3510 loop
.temp_ss
->data
.temp
.string_length
= NULL
;
3511 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
3512 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3515 gfc_conv_loop_setup (&loop
);
3519 /* Copy into a temporary and pass that. We don't need to copy the data
3520 back because expressions and vector subscripts must be INTENT_IN. */
3521 /* TODO: Optimize passing function return values. */
3525 /* Start the copying loops. */
3526 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3527 gfc_mark_ss_chain_used (ss
, 1);
3528 gfc_start_scalarized_body (&loop
, &block
);
3530 /* Copy each data element. */
3531 gfc_init_se (&lse
, NULL
);
3532 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3533 gfc_init_se (&rse
, NULL
);
3534 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3536 lse
.ss
= loop
.temp_ss
;
3539 gfc_conv_scalarized_array_ref (&lse
, NULL
);
3540 gfc_conv_expr_val (&rse
, expr
);
3542 gfc_add_block_to_block (&block
, &rse
.pre
);
3543 gfc_add_block_to_block (&block
, &lse
.pre
);
3545 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
3547 /* Finish the copying loops. */
3548 gfc_trans_scalarizing_loops (&loop
, &block
);
3550 /* Set the first stride component to zero to indicate a temporary. */
3551 desc
= loop
.temp_ss
->data
.info
.descriptor
;
3552 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[0]);
3553 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3555 assert (is_gimple_lvalue (desc
));
3556 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3558 else if (expr
->expr_type
== EXPR_FUNCTION
)
3560 desc
= info
->descriptor
;
3562 if (se
->want_pointer
)
3563 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3567 if (expr
->ts
.type
== BT_CHARACTER
)
3568 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3572 /* We pass sections without copying to a temporary. Make a new
3573 descriptor and point it at the section we want. The loop variable
3574 limits will be the limits of the section.
3575 A function may decide to repack the array to speed up access, but
3576 we're not bothered about that here. */
3585 /* Set the string_length for a character array. */
3586 if (expr
->ts
.type
== BT_CHARACTER
)
3587 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3589 desc
= info
->descriptor
;
3590 assert (secss
&& secss
!= gfc_ss_terminator
);
3591 if (se
->direct_byref
)
3593 /* For pointer assignments we fill in the destination. */
3595 parmtype
= TREE_TYPE (parm
);
3599 /* Otherwise make a new one. */
3600 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3601 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
3602 loop
.from
, loop
.to
, 0);
3603 parm
= gfc_create_var (parmtype
, "parm");
3606 offset
= gfc_index_zero_node
;
3609 /* The following can be somewhat confusing. We have two
3610 descriptors, a new one and the original array.
3611 {parm, parmtype, dim} refer to the new one.
3612 {desc, type, n, secss, loop} refer to the original, which maybe
3613 a descriptorless array.
3614 The bounds of the scaralization are the bounds of the section.
3615 We don't have to worry about numeric overflows when calculating
3616 the offsets because all elements are within the array data. */
3618 /* Set the dtype. */
3619 tmp
= gfc_conv_descriptor_dtype (parm
);
3620 gfc_add_modify_expr (&loop
.pre
, tmp
, GFC_TYPE_ARRAY_DTYPE (parmtype
));
3622 if (se
->direct_byref
)
3623 base
= gfc_index_zero_node
;
3627 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3629 stride
= gfc_conv_array_stride (desc
, n
);
3631 /* Work out the offset. */
3632 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3634 assert (info
->subscript
[n
]
3635 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
3636 start
= info
->subscript
[n
]->data
.scalar
.expr
;
3640 /* Check we haven't somehow got out of sync. */
3641 assert (info
->dim
[dim
] == n
);
3643 /* Evaluate and remember the start of the section. */
3644 start
= info
->start
[dim
];
3645 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
3648 tmp
= gfc_conv_array_lbound (desc
, n
);
3649 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
));
3651 tmp
= fold (build (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
));
3652 offset
= fold (build (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
));
3654 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3656 /* For elemental dimensions, we only need the offset. */
3660 /* Vector subscripts need copying and are handled elsewhere. */
3661 assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
3663 /* Set the new lower bound. */
3664 from
= loop
.from
[dim
];
3666 if (!integer_onep (from
))
3668 /* Make sure the new section starts at 1. */
3669 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
3670 gfc_index_one_node
, from
));
3671 to
= fold (build (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
));
3672 from
= gfc_index_one_node
;
3674 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
3675 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
3677 /* Set the new upper bound. */
3678 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
3679 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
3681 /* Multiply the stride by the section stride to get the
3683 stride
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
,
3684 info
->stride
[dim
]));
3686 if (se
->direct_byref
)
3688 base
= fold (build (MINUS_EXPR
, TREE_TYPE (base
),
3692 /* Store the new stride. */
3693 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
3694 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
3699 /* Point the data pointer at the first element in the section. */
3700 tmp
= gfc_conv_array_data (desc
);
3701 tmp
= gfc_build_indirect_ref (tmp
);
3702 tmp
= gfc_build_array_ref (tmp
, offset
);
3703 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
3705 tmp
= gfc_conv_descriptor_data (parm
);
3706 gfc_add_modify_expr (&loop
.pre
, tmp
,
3707 fold_convert (TREE_TYPE (tmp
), offset
));
3709 if (se
->direct_byref
)
3711 /* Set the offset. */
3712 tmp
= gfc_conv_descriptor_offset (parm
);
3713 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
3717 /* Only the callee knows what the correct offset it, so just set
3719 tmp
= gfc_conv_descriptor_offset (parm
);
3720 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3723 if (!se
->direct_byref
)
3725 /* Get a pointer to the new descriptor. */
3726 if (se
->want_pointer
)
3727 se
->expr
= gfc_build_addr_expr (NULL
, parm
);
3733 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3734 gfc_add_block_to_block (&se
->post
, &loop
.post
);
3736 /* Cleanup the scalarizer. */
3737 gfc_cleanup_loop (&loop
);
3741 /* Convert an array for passing as an actual parameter. */
3742 /* TODO: Optimize passing g77 arrays. */
3745 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
3754 /* Passing address of the array if it is not pointer or assumed-shape. */
3755 if (expr
->expr_type
== EXPR_VARIABLE
3756 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
3758 sym
= expr
->symtree
->n
.sym
;
3759 tmp
= gfc_get_symbol_decl (sym
);
3760 if (sym
->ts
.type
== BT_CHARACTER
)
3761 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3762 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
3763 && !sym
->attr
.allocatable
)
3765 if (!sym
->attr
.dummy
)
3766 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
3771 if (sym
->attr
.allocatable
)
3773 se
->expr
= gfc_conv_array_data (tmp
);
3778 se
->want_pointer
= 1;
3779 gfc_conv_expr_descriptor (se
, expr
, ss
);
3784 /* Repack the array. */
3785 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3786 ptr
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3787 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
3790 gfc_start_block (&block
);
3792 /* Copy the data back. */
3793 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3794 tmp
= gfc_chainon_list (tmp
, ptr
);
3795 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3796 gfc_add_expr_to_block (&block
, tmp
);
3798 /* Free the temporary. */
3799 tmp
= convert (pvoid_type_node
, ptr
);
3800 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3801 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3802 gfc_add_expr_to_block (&block
, tmp
);
3804 stmt
= gfc_finish_block (&block
);
3806 gfc_init_block (&block
);
3807 /* Only if it was repacked. This code needs to be executed before the
3808 loop cleanup code. */
3809 tmp
= gfc_build_indirect_ref (desc
);
3810 tmp
= gfc_conv_array_data (tmp
);
3811 tmp
= build (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
3812 tmp
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3814 gfc_add_expr_to_block (&block
, tmp
);
3815 gfc_add_block_to_block (&block
, &se
->post
);
3817 gfc_init_block (&se
->post
);
3818 gfc_add_block_to_block (&se
->post
, &block
);
3823 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3826 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
3833 stmtblock_t fnblock
;
3836 /* Make sure the frontend gets these right. */
3837 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3839 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
3841 gfc_init_block (&fnblock
);
3843 assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
);
3844 if (sym
->ts
.type
== BT_CHARACTER
3845 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3846 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
3848 /* Parameter variables don't need anything special. */
3849 if (sym
->attr
.dummy
)
3851 gfc_add_expr_to_block (&fnblock
, body
);
3853 return gfc_finish_block (&fnblock
);
3856 gfc_get_backend_locus (&loc
);
3857 gfc_set_backend_locus (&sym
->declared_at
);
3858 descriptor
= sym
->backend_decl
;
3860 if (TREE_STATIC (descriptor
))
3862 /* SAVEd variables are not freed on exit. */
3863 gfc_trans_static_array_pointer (sym
);
3867 /* Get the descriptor type. */
3868 type
= TREE_TYPE (sym
->backend_decl
);
3869 assert (GFC_DESCRIPTOR_TYPE_P (type
));
3871 /* NULLIFY the data pointer. */
3872 tmp
= gfc_conv_descriptor_data (descriptor
);
3873 gfc_add_modify_expr (&fnblock
, tmp
,
3874 convert (TREE_TYPE (tmp
), integer_zero_node
));
3876 gfc_add_expr_to_block (&fnblock
, body
);
3878 gfc_set_backend_locus (&loc
);
3879 /* Allocatable arrays need to be freed when they go out of scope. */
3880 if (sym
->attr
.allocatable
)
3882 gfc_start_block (&block
);
3884 /* Deallocate if still allocated at the end of the procedure. */
3885 deallocate
= gfc_array_deallocate (descriptor
);
3887 tmp
= gfc_conv_descriptor_data (descriptor
);
3888 tmp
= build (NE_EXPR
, boolean_type_node
, tmp
, integer_zero_node
);
3889 tmp
= build_v (COND_EXPR
, tmp
, deallocate
, build_empty_stmt ());
3890 gfc_add_expr_to_block (&block
, tmp
);
3892 tmp
= gfc_finish_block (&block
);
3893 gfc_add_expr_to_block (&fnblock
, tmp
);
3896 return gfc_finish_block (&fnblock
);
3899 /************ Expression Walking Functions ******************/
3901 /* Walk a variable reference.
3903 Possible extension - multiple component subscripts.
3904 x(:,:) = foo%a(:)%b(:)
3906 forall (i=..., j=...)
3907 x(i,j) = foo%a(j)%b(i)
3909 This adds a fair amout of complexity because you need to deal with more
3910 than one ref. Maybe handle in a similar manner to vector subscripts.
3911 Maybe not worth the effort. */
3915 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
3923 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3925 /* We're only interested in array sections. */
3926 if (ref
->type
!= REF_ARRAY
)
3933 /* TODO: Take elemental array references out of scalarization
3938 newss
= gfc_get_ss ();
3939 newss
->type
= GFC_SS_SECTION
;
3942 newss
->data
.info
.dimen
= ar
->as
->rank
;
3943 newss
->data
.info
.ref
= ref
;
3945 /* Make sure array is the same as array(:,:), this way
3946 we don't need to special case all the time. */
3947 ar
->dimen
= ar
->as
->rank
;
3948 for (n
= 0; n
< ar
->dimen
; n
++)
3950 newss
->data
.info
.dim
[n
] = n
;
3951 ar
->dimen_type
[n
] = DIMEN_RANGE
;
3953 assert (ar
->start
[n
] == NULL
);
3954 assert (ar
->end
[n
] == NULL
);
3955 assert (ar
->stride
[n
] == NULL
);
3960 newss
= gfc_get_ss ();
3961 newss
->type
= GFC_SS_SECTION
;
3964 newss
->data
.info
.dimen
= 0;
3965 newss
->data
.info
.ref
= ref
;
3969 /* We add SS chains for all the subscripts in the section. */
3970 for (n
= 0; n
< ar
->dimen
; n
++)
3974 switch (ar
->dimen_type
[n
])
3977 /* Add SS for elemental (scalar) subscripts. */
3978 assert (ar
->start
[n
]);
3979 indexss
= gfc_get_ss ();
3980 indexss
->type
= GFC_SS_SCALAR
;
3981 indexss
->expr
= ar
->start
[n
];
3982 indexss
->next
= gfc_ss_terminator
;
3983 indexss
->loop_chain
= gfc_ss_terminator
;
3984 newss
->data
.info
.subscript
[n
] = indexss
;
3988 /* We don't add anything for sections, just remember this
3989 dimension for later. */
3990 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
3991 newss
->data
.info
.dimen
++;
3995 /* Get a SS for the vector. This will not be added to the
3997 indexss
= gfc_walk_expr (ar
->start
[n
]);
3998 if (indexss
== gfc_ss_terminator
)
3999 internal_error ("scalar vector subscript???");
4001 /* We currently only handle really simple vector
4003 if (indexss
->next
!= gfc_ss_terminator
)
4004 gfc_todo_error ("vector subscript expressions");
4005 indexss
->loop_chain
= gfc_ss_terminator
;
4007 /* Mark this as a vector subscript. We don't add this
4008 directly into the chain, but as a subscript of the
4009 existing SS for this term. */
4010 indexss
->type
= GFC_SS_VECTOR
;
4011 newss
->data
.info
.subscript
[n
] = indexss
;
4012 /* Also remember this dimension. */
4013 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4014 newss
->data
.info
.dimen
++;
4018 /* We should know what sort of section it is by now. */
4022 /* We should have at least one non-elemental dimension. */
4023 assert (newss
->data
.info
.dimen
> 0);
4028 /* We should know what sort of section it is by now. */
4037 /* Walk an expression operator. If only one operand of a binary expression is
4038 scalar, we must also add the scalar term to the SS chain. */
4041 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4047 head
= gfc_walk_subexpr (ss
, expr
->op1
);
4048 if (expr
->op2
== NULL
)
4051 head2
= gfc_walk_subexpr (head
, expr
->op2
);
4053 /* All operands are scalar. Pass back and let the caller deal with it. */
4057 /* All operands require scalarization. */
4058 if (head
!= ss
&& (expr
->op2
== NULL
|| head2
!= head
))
4061 /* One of the operands needs scalarization, the other is scalar.
4062 Create a gfc_ss for the scalar expression. */
4063 newss
= gfc_get_ss ();
4064 newss
->type
= GFC_SS_SCALAR
;
4067 /* First operand is scalar. We build the chain in reverse order, so
4068 add the scarar SS after the second operand. */
4070 while (head
&& head
->next
!= ss
)
4072 /* Check we haven't somehow broken the chain. */
4076 newss
->expr
= expr
->op1
;
4078 else /* head2 == head */
4080 assert (head2
== head
);
4081 /* Second operand is scalar. */
4082 newss
->next
= head2
;
4084 newss
->expr
= expr
->op2
;
4091 /* Reverse a SS chain. */
4094 gfc_reverse_ss (gfc_ss
* ss
)
4099 assert (ss
!= NULL
);
4101 head
= gfc_ss_terminator
;
4102 while (ss
!= gfc_ss_terminator
)
4105 assert (next
!= NULL
); /* Check we didn't somehow break the chain. */
4115 /* Walk the arguments of an elemental function. */
4118 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_expr
* expr
,
4121 gfc_actual_arglist
*arg
;
4127 head
= gfc_ss_terminator
;
4130 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4135 newss
= gfc_walk_subexpr (head
, arg
->expr
);
4138 /* Scalar argumet. */
4139 newss
= gfc_get_ss ();
4141 newss
->expr
= arg
->expr
;
4151 while (tail
->next
!= gfc_ss_terminator
)
4158 /* If all the arguments are scalar we don't need the argument SS. */
4159 gfc_free_ss_chain (head
);
4164 /* Add it onto the existing chain. */
4170 /* Walk a function call. Scalar functions are passed back, and taken out of
4171 scalarization loops. For elemental functions we walk their arguments.
4172 The result of functions returning arrays is stored in a temporary outside
4173 the loop, so that the function is only called once. Hence we do not need
4174 to walk their arguments. */
4177 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4180 gfc_intrinsic_sym
*isym
;
4183 isym
= expr
->value
.function
.isym
;
4185 /* Handle intrinsic functions separately. */
4187 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
4189 sym
= expr
->value
.function
.esym
;
4191 sym
= expr
->symtree
->n
.sym
;
4193 /* A function that returns arrays. */
4194 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
4196 newss
= gfc_get_ss ();
4197 newss
->type
= GFC_SS_FUNCTION
;
4200 newss
->data
.info
.dimen
= expr
->rank
;
4204 /* Walk the parameters of an elemental function. For now we always pass
4206 if (sym
->attr
.elemental
)
4207 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_REFERENCE
);
4209 /* Scalar functions are OK as these are evaluated outside the scalarisation
4210 loop. Pass back and let the caller deal with it. */
4215 /* An array temporary is constructed for array constructors. */
4218 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
4223 newss
= gfc_get_ss ();
4224 newss
->type
= GFC_SS_CONSTRUCTOR
;
4227 newss
->data
.info
.dimen
= expr
->rank
;
4228 for (n
= 0; n
< expr
->rank
; n
++)
4229 newss
->data
.info
.dim
[n
] = n
;
4235 /* Walk an expresson. Add walked expressions to the head of the SS chain.
4236 A wholy scalar expression will not be added. */
4239 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
4243 switch (expr
->expr_type
)
4246 head
= gfc_walk_variable_expr (ss
, expr
);
4250 head
= gfc_walk_op_expr (ss
, expr
);
4254 head
= gfc_walk_function_expr (ss
, expr
);
4259 case EXPR_STRUCTURE
:
4260 /* Pass back and let the caller deal with it. */
4264 head
= gfc_walk_array_constructor (ss
, expr
);
4267 case EXPR_SUBSTRING
:
4268 /* Pass back and let the caller deal with it. */
4272 internal_error ("bad expression type during walk (%d)",
4279 /* Entry point for expression walking.
4280 A return value equal to the passed chain means this is
4281 a scalar expression. It is up to the caller to take whatever action is
4282 neccessary to translate these. */
4285 gfc_walk_expr (gfc_expr
* expr
)
4289 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
4290 return gfc_reverse_ss (res
);