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
442 gfc_trans_allocate_array_storage (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
443 tree size
, tree nelem
)
451 desc
= info
->descriptor
;
452 data
= gfc_conv_descriptor_data (desc
);
453 onstack
= gfc_can_put_var_on_stack (size
);
456 /* Make a temporary variable to hold the data. */
457 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
459 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
460 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)), tmp
);
461 tmp
= gfc_create_var (tmp
, "A");
462 tmp
= gfc_build_addr_expr (TREE_TYPE (data
), tmp
);
463 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
465 info
->offset
= gfc_index_zero_node
;
470 /* Allocate memory to hold the data. */
471 args
= gfc_chainon_list (NULL_TREE
, size
);
473 if (gfc_index_integer_kind
== 4)
474 tmp
= gfor_fndecl_internal_malloc
;
475 else if (gfc_index_integer_kind
== 8)
476 tmp
= gfor_fndecl_internal_malloc64
;
479 tmp
= gfc_build_function_call (tmp
, args
);
480 tmp
= convert (TREE_TYPE (data
), tmp
);
481 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
484 info
->offset
= gfc_index_zero_node
;
487 /* The offset is zero because we create temporaries with a zero
489 tmp
= gfc_conv_descriptor_offset (desc
);
490 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
494 /* Free the temporary. */
495 tmp
= convert (pvoid_type_node
, info
->data
);
496 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
497 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
498 gfc_add_expr_to_block (&loop
->post
, tmp
);
503 /* Generate code to allocate and initialize the descriptor for a temporary
504 array. Fills in the descriptor, data and offset fields of info. Also
505 adjusts the loop variables to be zero-based. Returns the size of the
509 gfc_trans_allocate_temp_array (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
510 tree eltype
, tree string_length
)
520 assert (info
->dimen
> 0);
521 /* Set the lower bound to zero. */
522 for (dim
= 0; dim
< info
->dimen
; dim
++)
524 n
= loop
->order
[dim
];
525 if (n
< loop
->temp_dim
)
526 assert (integer_zerop (loop
->from
[n
]));
529 loop
->to
[n
] = fold (build (MINUS_EXPR
, gfc_array_index_type
,
530 loop
->to
[n
], loop
->from
[n
]));
531 loop
->from
[n
] = gfc_index_zero_node
;
534 info
->delta
[dim
] = gfc_index_zero_node
;
535 info
->start
[dim
] = gfc_index_zero_node
;
536 info
->stride
[dim
] = gfc_index_one_node
;
537 info
->dim
[dim
] = dim
;
540 /* Initialize the descriptor. */
542 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
543 desc
= gfc_create_var (type
, "atmp");
544 GFC_DECL_PACKED_ARRAY (desc
) = 1;
546 info
->descriptor
= desc
;
547 size
= gfc_index_one_node
;
549 /* Fill in the array dtype. */
550 tmp
= gfc_conv_descriptor_dtype (desc
);
551 gfc_add_modify_expr (&loop
->pre
, tmp
,
552 GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (desc
)));
555 Fill in the bounds and stride. This is a packed array, so:
558 for (n = 0; n < rank; n++)
561 delta = ubound[n] + 1 - lbound[n];
564 size = size * sizeof(element);
567 for (n
= 0; n
< info
->dimen
; n
++)
569 /* Store the stride and bound components in the descriptor. */
570 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
571 gfc_add_modify_expr (&loop
->pre
, tmp
, size
);
573 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
574 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
576 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
577 gfc_add_modify_expr (&loop
->pre
, tmp
, loop
->to
[n
]);
579 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
580 loop
->to
[n
], gfc_index_one_node
));
582 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
583 size
= gfc_evaluate_now (size
, &loop
->pre
);
586 /* TODO: Where does the string length go? */
588 gfc_todo_error ("temporary arrays of strings");
590 /* Get the size of the array. */
592 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
,
593 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
595 gfc_trans_allocate_array_storage (loop
, info
, size
, nelem
);
597 if (info
->dimen
> loop
->temp_dim
)
598 loop
->temp_dim
= info
->dimen
;
604 /* Make sure offset is a variable. */
607 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
610 /* We should have already created the offset variable. We cannot
611 create it here because we may be in an inner scope. */
612 assert (*offsetvar
!= NULL_TREE
);
613 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
614 *poffset
= *offsetvar
;
615 TREE_USED (*offsetvar
) = 1;
619 /* Add the contents of an array to the constructor. */
622 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
623 tree type ATTRIBUTE_UNUSED
,
624 tree pointer
, gfc_expr
* expr
,
625 tree
* poffset
, tree
* offsetvar
)
633 /* We need this to be a variable so we can increment it. */
634 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
636 gfc_init_se (&se
, NULL
);
638 /* Walk the array expression. */
639 ss
= gfc_walk_expr (expr
);
640 assert (ss
!= gfc_ss_terminator
);
642 /* Initialize the scalarizer. */
643 gfc_init_loopinfo (&loop
);
644 gfc_add_ss_to_loop (&loop
, ss
);
646 /* Initialize the loop. */
647 gfc_conv_ss_startstride (&loop
);
648 gfc_conv_loop_setup (&loop
);
650 /* Make the loop body. */
651 gfc_mark_ss_chain_used (ss
, 1);
652 gfc_start_scalarized_body (&loop
, &body
);
653 gfc_copy_loopinfo_to_se (&se
, &loop
);
656 gfc_conv_expr (&se
, expr
);
657 gfc_add_block_to_block (&body
, &se
.pre
);
659 /* Store the value. */
660 tmp
= gfc_build_indirect_ref (pointer
);
661 tmp
= gfc_build_array_ref (tmp
, *poffset
);
662 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
664 /* Increment the offset. */
665 tmp
= build (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
666 gfc_add_modify_expr (&body
, *poffset
, tmp
);
668 /* Finish the loop. */
669 gfc_add_block_to_block (&body
, &se
.post
);
670 assert (se
.ss
== gfc_ss_terminator
);
671 gfc_trans_scalarizing_loops (&loop
, &body
);
672 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
673 tmp
= gfc_finish_block (&loop
.pre
);
674 gfc_add_expr_to_block (pblock
, tmp
);
676 gfc_cleanup_loop (&loop
);
680 /* Assign the values to the elements of an array constructor. */
683 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
684 tree pointer
, gfc_constructor
* c
,
685 tree
* poffset
, tree
* offsetvar
)
693 for (; c
; c
= c
->next
)
695 /* If this is an iterator or an array, the offset must be a variable. */
696 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
697 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
699 gfc_start_block (&body
);
701 if (c
->expr
->expr_type
== EXPR_ARRAY
)
703 /* Array constructors can be nested. */
704 gfc_trans_array_constructor_value (&body
, type
, pointer
,
705 c
->expr
->value
.constructor
,
708 else if (c
->expr
->rank
> 0)
710 gfc_trans_array_constructor_subarray (&body
, type
, pointer
,
711 c
->expr
, poffset
, offsetvar
);
715 /* This code really upsets the gimplifier so don't bother for now. */
722 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
730 gfc_init_se (&se
, NULL
);
731 gfc_conv_expr (&se
, c
->expr
);
732 gfc_add_block_to_block (&body
, &se
.pre
);
734 ref
= gfc_build_indirect_ref (pointer
);
735 ref
= gfc_build_array_ref (ref
, *poffset
);
736 gfc_add_modify_expr (&body
, ref
,
737 fold_convert (TREE_TYPE (ref
), se
.expr
));
738 gfc_add_block_to_block (&body
, &se
.post
);
740 *poffset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
741 *poffset
, gfc_index_one_node
));
745 /* Collect multiple scalar constants into a constructor. */
753 /* Count the number of consecutive scalar constants. */
754 while (p
&& !(p
->iterator
755 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
757 gfc_init_se (&se
, NULL
);
758 gfc_conv_constant (&se
, p
->expr
);
759 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
764 bound
= build_int_2 (n
- 1, 0);
765 /* Create an array type to hold them. */
766 tmptype
= build_range_type (gfc_array_index_type
,
767 gfc_index_zero_node
, bound
);
768 tmptype
= build_array_type (type
, tmptype
);
770 init
= build1 (CONSTRUCTOR
, tmptype
, nreverse (list
));
771 TREE_CONSTANT (init
) = 1;
772 TREE_INVARIANT (init
) = 1;
773 TREE_STATIC (init
) = 1;
774 /* Create a static variable to hold the data. */
775 tmp
= gfc_create_var (tmptype
, "data");
776 TREE_STATIC (tmp
) = 1;
777 TREE_CONSTANT (tmp
) = 1;
778 TREE_INVARIANT (tmp
) = 1;
779 DECL_INITIAL (tmp
) = init
;
782 /* Use BUILTIN_MEMCPY to assign the values. */
783 tmp
= gfc_build_indirect_ref (pointer
);
784 tmp
= gfc_build_array_ref (tmp
, *poffset
);
785 tmp
= gfc_build_addr_expr (NULL
, tmp
);
786 init
= gfc_build_addr_expr (NULL
, init
);
788 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
789 bound
= build_int_2 (n
* size
, 0);
790 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
791 tmp
= gfc_chainon_list (tmp
, init
);
792 tmp
= gfc_chainon_list (tmp
, bound
);
793 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_MEMCPY
],
795 gfc_add_expr_to_block (&body
, tmp
);
797 *poffset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
800 if (!INTEGER_CST_P (*poffset
))
802 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
803 *poffset
= *offsetvar
;
807 /* The frontend should already have done any expansions. */
815 loopbody
= gfc_finish_block (&body
);
817 gfc_init_se (&se
, NULL
);
818 gfc_conv_expr (&se
, c
->iterator
->var
);
819 gfc_add_block_to_block (pblock
, &se
.pre
);
822 /* Initialize the loop. */
823 gfc_init_se (&se
, NULL
);
824 gfc_conv_expr_val (&se
, c
->iterator
->start
);
825 gfc_add_block_to_block (pblock
, &se
.pre
);
826 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
828 gfc_init_se (&se
, NULL
);
829 gfc_conv_expr_val (&se
, c
->iterator
->end
);
830 gfc_add_block_to_block (pblock
, &se
.pre
);
831 end
= gfc_evaluate_now (se
.expr
, pblock
);
833 gfc_init_se (&se
, NULL
);
834 gfc_conv_expr_val (&se
, c
->iterator
->step
);
835 gfc_add_block_to_block (pblock
, &se
.pre
);
836 step
= gfc_evaluate_now (se
.expr
, pblock
);
838 /* Generate the loop body. */
839 exit_label
= gfc_build_label_decl (NULL_TREE
);
840 gfc_start_block (&body
);
842 /* Generate the exit condition. */
843 end
= build (GT_EXPR
, boolean_type_node
, loopvar
, end
);
844 tmp
= build1_v (GOTO_EXPR
, exit_label
);
845 TREE_USED (exit_label
) = 1;
846 tmp
= build_v (COND_EXPR
, end
, tmp
, build_empty_stmt ());
847 gfc_add_expr_to_block (&body
, tmp
);
849 /* The main loop body. */
850 gfc_add_expr_to_block (&body
, loopbody
);
852 /* Increment the loop variable. */
853 tmp
= build (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
854 gfc_add_modify_expr (&body
, loopvar
, tmp
);
856 /* Finish the loop. */
857 tmp
= gfc_finish_block (&body
);
858 tmp
= build_v (LOOP_EXPR
, tmp
);
859 gfc_add_expr_to_block (pblock
, tmp
);
861 /* Add the exit label. */
862 tmp
= build1_v (LABEL_EXPR
, exit_label
);
863 gfc_add_expr_to_block (pblock
, tmp
);
867 /* Pass the code as is. */
868 tmp
= gfc_finish_block (&body
);
869 gfc_add_expr_to_block (pblock
, tmp
);
875 /* Get the size of an expression. Returns -1 if the size isn't constant.
876 Implied do loops with non-constant bounds are tricky because we must only
877 evaluate the bounds once. */
880 gfc_get_array_cons_size (mpz_t
* size
, gfc_constructor
* c
)
886 mpz_set_ui (*size
, 0);
890 for (; c
; c
= c
->next
)
892 if (c
->expr
->expr_type
== EXPR_ARRAY
)
894 /* A nested array constructor. */
895 gfc_get_array_cons_size (&len
, c
->expr
->value
.constructor
);
896 if (mpz_sgn (len
) < 0)
898 mpz_set (*size
, len
);
906 if (c
->expr
->rank
> 0)
908 mpz_set_si (*size
, -1);
920 if (i
->start
->expr_type
!= EXPR_CONSTANT
921 || i
->end
->expr_type
!= EXPR_CONSTANT
922 || i
->step
->expr_type
!= EXPR_CONSTANT
)
924 mpz_set_si (*size
, -1);
930 mpz_add (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
931 mpz_tdiv_q (val
, val
, i
->step
->value
.integer
);
932 mpz_add_ui (val
, val
, 1);
933 mpz_mul (len
, len
, val
);
935 mpz_add (*size
, *size
, len
);
942 /* Array constructors are handled by constructing a temporary, then using that
943 within the scalarization loop. This is not optimal, but seems by far the
947 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
955 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
956 gfc_todo_error ("Character string array constructors");
957 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
958 ss
->data
.info
.dimen
= loop
->dimen
;
960 gfc_trans_allocate_temp_array (loop
, &ss
->data
.info
, type
, NULL_TREE
);
962 desc
= ss
->data
.info
.descriptor
;
963 offset
= gfc_index_zero_node
;
964 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
965 TREE_USED (offsetvar
) = 0;
966 gfc_trans_array_constructor_value (&loop
->pre
, type
,
968 ss
->expr
->value
.constructor
, &offset
,
971 if (TREE_USED (offsetvar
))
972 pushdecl (offsetvar
);
974 assert (INTEGER_CST_P (offset
));
976 /* Disable bound checking for now because it's probably broken. */
977 if (flag_bounds_check
)
985 /* Add the pre and post chains for all the scalar expressions in a SS chain
986 to loop. This is called after the loop parameters have been calculated,
987 but before the actual scalarizing loops. */
991 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
998 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1005 /* Scalar expression. Evaluate this now. This includes elemental
1006 dimension indices, but not array section bounds. */
1007 gfc_init_se (&se
, NULL
);
1008 gfc_conv_expr (&se
, ss
->expr
);
1009 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1011 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1013 /* Move the evaluation of scalar expressions outside the
1014 scalarization loop. */
1016 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1017 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1018 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1021 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1023 ss
->data
.scalar
.expr
= se
.expr
;
1024 ss
->data
.scalar
.string_length
= se
.string_length
;
1027 case GFC_SS_REFERENCE
:
1028 /* Scalar reference. Evaluate this now. */
1029 gfc_init_se (&se
, NULL
);
1030 gfc_conv_expr_reference (&se
, ss
->expr
);
1031 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1032 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1034 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1035 ss
->data
.scalar
.string_length
= se
.string_length
;
1038 case GFC_SS_SECTION
:
1040 /* Scalarized expression. Evaluate any scalar subscripts. */
1041 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1043 /* Add the expressions for scalar subscripts. */
1044 if (ss
->data
.info
.subscript
[n
])
1045 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1049 case GFC_SS_INTRINSIC
:
1050 gfc_add_intrinsic_ss_code (loop
, ss
);
1053 case GFC_SS_FUNCTION
:
1054 /* Array function return value. We call the function and save its
1055 result in a temporary for use inside the loop. */
1056 gfc_init_se (&se
, NULL
);
1059 gfc_conv_expr (&se
, ss
->expr
);
1060 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1061 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1064 case GFC_SS_CONSTRUCTOR
:
1065 gfc_trans_array_constructor (loop
, ss
);
1075 /* Translate expressions for the descriptor and data pointer of a SS. */
1079 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1084 /* Get the descriptor for the array to be scalarized. */
1085 assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1086 gfc_init_se (&se
, NULL
);
1087 se
.descriptor_only
= 1;
1088 gfc_conv_expr_lhs (&se
, ss
->expr
);
1089 gfc_add_block_to_block (block
, &se
.pre
);
1090 ss
->data
.info
.descriptor
= se
.expr
;
1094 /* Also the data pointer. */
1095 tmp
= gfc_conv_array_data (se
.expr
);
1096 /* If this is a variable or address of a variable we use it directly.
1097 Otherwise we must evaluate it now to to avoid break dependency
1098 analysis by pulling the expressions for elemental array indices
1101 || (TREE_CODE (tmp
) == ADDR_EXPR
1102 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1103 tmp
= gfc_evaluate_now (tmp
, block
);
1104 ss
->data
.info
.data
= tmp
;
1106 tmp
= gfc_conv_array_offset (se
.expr
);
1107 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1112 /* Initialise a gfc_loopinfo structure. */
1115 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1119 memset (loop
, 0, sizeof (gfc_loopinfo
));
1120 gfc_init_block (&loop
->pre
);
1121 gfc_init_block (&loop
->post
);
1123 /* Initially scalarize in order. */
1124 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1127 loop
->ss
= gfc_ss_terminator
;
1131 /* Copies the loop variable info to a gfc_se sructure. Does not copy the SS
1135 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1141 /* Return an expression for the data pointer of an array. */
1144 gfc_conv_array_data (tree descriptor
)
1148 type
= TREE_TYPE (descriptor
);
1149 if (GFC_ARRAY_TYPE_P (type
))
1151 if (TREE_CODE (type
) == POINTER_TYPE
)
1155 /* Descriptorless arrays. */
1156 return gfc_build_addr_expr (NULL
, descriptor
);
1160 return gfc_conv_descriptor_data (descriptor
);
1164 /* Return an expression for the base offset of an array. */
1167 gfc_conv_array_offset (tree descriptor
)
1171 type
= TREE_TYPE (descriptor
);
1172 if (GFC_ARRAY_TYPE_P (type
))
1173 return GFC_TYPE_ARRAY_OFFSET (type
);
1175 return gfc_conv_descriptor_offset (descriptor
);
1179 /* Get an expression for the array stride. */
1182 gfc_conv_array_stride (tree descriptor
, int dim
)
1187 type
= TREE_TYPE (descriptor
);
1189 /* For descriptorless arrays use the array size. */
1190 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1191 if (tmp
!= NULL_TREE
)
1194 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1199 /* Like gfc_conv_array_stride, but for the lower bound. */
1202 gfc_conv_array_lbound (tree descriptor
, int dim
)
1207 type
= TREE_TYPE (descriptor
);
1209 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1210 if (tmp
!= NULL_TREE
)
1213 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1218 /* Like gfc_conv_array_stride, but for the upper bound. */
1221 gfc_conv_array_ubound (tree descriptor
, int dim
)
1226 type
= TREE_TYPE (descriptor
);
1228 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1229 if (tmp
!= NULL_TREE
)
1232 /* This should only ever happen when passing an assumed shape array
1233 as an actual parameter. The value will never be used. */
1234 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1235 return gfc_index_zero_node
;
1237 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1242 /* Translate an array reference. The descriptor should be in se->expr.
1243 Do not use this function, it wil be removed soon. */
1247 gfc_conv_array_index_ref (gfc_se
* se
, tree pointer
, tree
* indices
,
1248 tree offset
, int dimen
)
1255 array
= gfc_build_indirect_ref (pointer
);
1258 for (n
= 0; n
< dimen
; n
++)
1260 /* index = index + stride[n]*indices[n] */
1261 tmp
= gfc_conv_array_stride (se
->expr
, n
);
1262 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, indices
[n
], tmp
));
1264 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1267 /* Result = data[index]. */
1268 tmp
= gfc_build_array_ref (array
, index
);
1270 /* Check we've used the correct number of dimensions. */
1271 assert (TREE_CODE (TREE_TYPE (tmp
)) != ARRAY_TYPE
);
1277 /* Generate code to perform an array index bound check. */
1280 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
)
1286 if (!flag_bounds_check
)
1289 index
= gfc_evaluate_now (index
, &se
->pre
);
1290 /* Check lower bound. */
1291 tmp
= gfc_conv_array_lbound (descriptor
, n
);
1292 fault
= fold (build (LT_EXPR
, boolean_type_node
, index
, tmp
));
1293 /* Check upper bound. */
1294 tmp
= gfc_conv_array_ubound (descriptor
, n
);
1295 cond
= fold (build (GT_EXPR
, boolean_type_node
, index
, tmp
));
1296 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1298 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1304 /* A reference to an array vector subscript. Uses recursion to handle nested
1305 vector subscripts. */
1308 gfc_conv_vector_array_index (gfc_se
* se
, tree index
, gfc_ss
* ss
)
1311 tree indices
[GFC_MAX_DIMENSIONS
];
1316 assert (ss
&& ss
->type
== GFC_SS_VECTOR
);
1318 /* Save the descriptor. */
1319 descsave
= se
->expr
;
1320 info
= &ss
->data
.info
;
1321 se
->expr
= info
->descriptor
;
1323 ar
= &info
->ref
->u
.ar
;
1324 for (n
= 0; n
< ar
->dimen
; n
++)
1326 switch (ar
->dimen_type
[n
])
1329 assert (info
->subscript
[n
] != gfc_ss_terminator
1330 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
1331 indices
[n
] = info
->subscript
[n
]->data
.scalar
.expr
;
1339 index
= gfc_conv_vector_array_index (se
, index
, info
->subscript
[n
]);
1342 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, n
);
1349 /* Get the index from the vector. */
1350 gfc_conv_array_index_ref (se
, info
->data
, indices
, info
->offset
, ar
->dimen
);
1352 /* Put the descriptor back. */
1353 se
->expr
= descsave
;
1359 /* Return the offset for an index. Performs bound checking for elemental
1360 dimensions. Single element references are processed seperately. */
1363 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
1364 gfc_array_ref
* ar
, tree stride
)
1368 /* Get the index into the array for this dimension. */
1371 assert (ar
->type
!= AR_ELEMENT
);
1372 if (ar
->dimen_type
[dim
] == DIMEN_ELEMENT
)
1375 /* Elemental dimension. */
1376 assert (info
->subscript
[dim
]
1377 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
1378 /* We've already translated this value outside the loop. */
1379 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
1382 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, dim
);
1386 /* Scalarized dimension. */
1387 assert (info
&& se
->loop
);
1389 /* Multiply the loop variable by the stride and dela. */
1390 index
= se
->loop
->loopvar
[i
];
1391 index
= fold (build (MULT_EXPR
, gfc_array_index_type
, index
,
1393 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
,
1396 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
1398 /* Handle vector subscripts. */
1399 index
= gfc_conv_vector_array_index (se
, index
,
1400 info
->subscript
[dim
]);
1402 gfc_trans_array_bound_check (se
, info
->descriptor
, index
,
1406 assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
);
1411 /* Temporary array. */
1413 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
1416 /* Multiply by the stride. */
1417 index
= fold (build (MULT_EXPR
, gfc_array_index_type
, index
, stride
));
1423 /* Build a scalarized reference to an array. */
1426 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1433 info
= &se
->ss
->data
.info
;
1435 n
= se
->loop
->order
[0];
1439 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
1441 /* Add the offset for this dimension to the stored offset for all other
1443 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
));
1445 tmp
= gfc_build_indirect_ref (info
->data
);
1446 se
->expr
= gfc_build_array_ref (tmp
, index
);
1450 /* Translate access of temporary array. */
1453 gfc_conv_tmp_array_ref (gfc_se
* se
)
1457 desc
= se
->ss
->data
.info
.descriptor
;
1458 /* TODO: We need the string length for string variables. */
1460 gfc_conv_scalarized_array_ref (se
, NULL
);
1464 /* Build an array reference. se->expr already holds the array descriptor.
1465 This should be either a variable, indirect variable reference or component
1466 reference. For arrays which do not have a descriptor, se->expr will be
1468 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1471 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1480 /* Handle scalarized references seperately. */
1481 if (ar
->type
!= AR_ELEMENT
)
1483 gfc_conv_scalarized_array_ref (se
, ar
);
1487 index
= gfc_index_zero_node
;
1489 fault
= gfc_index_zero_node
;
1491 /* Calculate the offsets from all the dimensions. */
1492 for (n
= 0; n
< ar
->dimen
; n
++)
1494 /* Calculate the index for this demension. */
1495 gfc_init_se (&indexse
, NULL
);
1496 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
1497 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
1499 if (flag_bounds_check
)
1501 /* Check array bounds. */
1504 indexse
.expr
= gfc_evaluate_now (indexse
.expr
, &se
->pre
);
1506 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
1507 cond
= fold (build (LT_EXPR
, boolean_type_node
, indexse
.expr
, tmp
));
1509 fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1511 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
1512 cond
= fold (build (GT_EXPR
, boolean_type_node
, indexse
.expr
, tmp
));
1514 fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1517 /* Multiply the index by the stride. */
1518 stride
= gfc_conv_array_stride (se
->expr
, n
);
1519 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
1522 /* And add it to the total. */
1523 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1526 if (flag_bounds_check
)
1527 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1529 tmp
= gfc_conv_array_offset (se
->expr
);
1530 if (!integer_zerop (tmp
))
1531 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1533 /* Access the calculated element. */
1534 tmp
= gfc_conv_array_data (se
->expr
);
1535 tmp
= gfc_build_indirect_ref (tmp
);
1536 se
->expr
= gfc_build_array_ref (tmp
, index
);
1540 /* Generate the code to be executed immediately before entering a
1541 scalarization loop. */
1544 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
1545 stmtblock_t
* pblock
)
1554 /* This code will be executed before entering the scalarization loop
1555 for this dimension. */
1556 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1558 if ((ss
->useflags
& flag
) == 0)
1561 if (ss
->type
!= GFC_SS_SECTION
1562 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
)
1565 info
= &ss
->data
.info
;
1567 if (dim
>= info
->dimen
)
1570 if (dim
== info
->dimen
- 1)
1572 /* For the outermost loop calculate the offset due to any
1573 elemental dimensions. It will have been initialized with the
1574 base offset of the array. */
1577 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
1579 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1582 gfc_init_se (&se
, NULL
);
1584 se
.expr
= info
->descriptor
;
1585 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
1586 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
1589 gfc_add_block_to_block (pblock
, &se
.pre
);
1591 info
->offset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
1592 info
->offset
, index
));
1593 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1597 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1600 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
1602 /* Calculate the stride of the innermost loop. Hopefully this will
1603 allow the backend optimizers to do their stuff more effectively.
1605 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
1609 /* Add the offset for the previous loop dimension. */
1614 ar
= &info
->ref
->u
.ar
;
1615 i
= loop
->order
[dim
+ 1];
1623 gfc_init_se (&se
, NULL
);
1625 se
.expr
= info
->descriptor
;
1626 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1627 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
1629 gfc_add_block_to_block (pblock
, &se
.pre
);
1630 info
->offset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
1631 info
->offset
, index
));
1632 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1635 /* Remeber this offset for the second loop. */
1636 if (dim
== loop
->temp_dim
- 1)
1637 info
->saved_offset
= info
->offset
;
1642 /* Start a scalarized expression. Creates a scope and declares loop
1646 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
1652 assert (!loop
->array_parameter
);
1654 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
1656 n
= loop
->order
[dim
];
1658 gfc_start_block (&loop
->code
[n
]);
1660 /* Create the loop variable. */
1661 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
1663 if (dim
< loop
->temp_dim
)
1667 /* Calculate values that will be constant within this loop. */
1668 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
1670 gfc_start_block (pbody
);
1674 /* Generates the actual loop code for a scalarization loop. */
1677 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
1678 stmtblock_t
* pbody
)
1686 loopbody
= gfc_finish_block (pbody
);
1688 /* Initialize the loopvar. */
1689 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
1691 exit_label
= gfc_build_label_decl (NULL_TREE
);
1693 /* Generate the loop body. */
1694 gfc_init_block (&block
);
1696 /* The exit condition. */
1697 cond
= build (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
1698 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1699 TREE_USED (exit_label
) = 1;
1700 tmp
= build_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1701 gfc_add_expr_to_block (&block
, tmp
);
1703 /* The main body. */
1704 gfc_add_expr_to_block (&block
, loopbody
);
1706 /* Increment the loopvar. */
1707 tmp
= build (PLUS_EXPR
, gfc_array_index_type
,
1708 loop
->loopvar
[n
], gfc_index_one_node
);
1709 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
1711 /* Build the loop. */
1712 tmp
= gfc_finish_block (&block
);
1713 tmp
= build_v (LOOP_EXPR
, tmp
);
1714 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1716 /* Add the exit label. */
1717 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1718 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1722 /* Finishes and generates the loops for a scalarized expression. */
1725 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1730 stmtblock_t
*pblock
;
1734 /* Generate the loops. */
1735 for (dim
= 0; dim
< loop
->dimen
; dim
++)
1737 n
= loop
->order
[dim
];
1738 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1739 loop
->loopvar
[n
] = NULL_TREE
;
1740 pblock
= &loop
->code
[n
];
1743 tmp
= gfc_finish_block (pblock
);
1744 gfc_add_expr_to_block (&loop
->pre
, tmp
);
1746 /* Clear all the used flags. */
1747 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
1752 /* Finish the main body of a scalarized expression, and start the secondary
1756 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1760 stmtblock_t
*pblock
;
1764 /* We finish as many loops as are used by the temporary. */
1765 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
1767 n
= loop
->order
[dim
];
1768 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1769 loop
->loopvar
[n
] = NULL_TREE
;
1770 pblock
= &loop
->code
[n
];
1773 /* We don't want to finish the outermost loop entirely. */
1774 n
= loop
->order
[loop
->temp_dim
- 1];
1775 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1777 /* Restore the initial offsets. */
1778 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1780 if ((ss
->useflags
& 2) == 0)
1783 if (ss
->type
!= GFC_SS_SECTION
1784 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
)
1787 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
1790 /* Restart all the inner loops we just finished. */
1791 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
1793 n
= loop
->order
[dim
];
1795 gfc_start_block (&loop
->code
[n
]);
1797 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
1799 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
1802 /* Start a block for the secondary copying code. */
1803 gfc_start_block (body
);
1807 /* Calculate the upper bound of an array section. */
1810 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
1819 assert (ss
->type
== GFC_SS_SECTION
);
1821 /* For vector array subscripts we want the size of the vector. */
1822 dim
= ss
->data
.info
.dim
[n
];
1824 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
1826 vecss
= vecss
->data
.info
.subscript
[dim
];
1827 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
1828 dim
= vecss
->data
.info
.dim
[0];
1831 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
1832 end
= vecss
->data
.info
.ref
->u
.ar
.end
[dim
];
1833 desc
= vecss
->data
.info
.descriptor
;
1837 /* The upper bound was specified. */
1838 gfc_init_se (&se
, NULL
);
1839 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
1840 gfc_add_block_to_block (pblock
, &se
.pre
);
1845 /* No upper bound was specified, so use the bound of the array. */
1846 bound
= gfc_conv_array_ubound (desc
, dim
);
1853 /* Calculate the lower bound of an array section. */
1856 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
1866 info
= &ss
->data
.info
;
1870 /* For vector array subscripts we want the size of the vector. */
1872 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
1874 vecss
= vecss
->data
.info
.subscript
[dim
];
1875 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
1876 /* Get the descriptors for the vector subscripts as well. */
1877 if (!vecss
->data
.info
.descriptor
)
1878 gfc_conv_ss_descriptor (&loop
->pre
, vecss
, !loop
->array_parameter
);
1879 dim
= vecss
->data
.info
.dim
[0];
1882 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
1883 start
= vecss
->data
.info
.ref
->u
.ar
.start
[dim
];
1884 stride
= vecss
->data
.info
.ref
->u
.ar
.stride
[dim
];
1885 desc
= vecss
->data
.info
.descriptor
;
1887 /* Calculate the start of the range. For vector subscripts this will
1888 be the range of the vector. */
1891 /* Specified section start. */
1892 gfc_init_se (&se
, NULL
);
1893 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
1894 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1895 info
->start
[n
] = se
.expr
;
1899 /* No lower bound specified so use the bound of the array. */
1900 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
1902 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
1904 /* Calculate the stride. */
1906 info
->stride
[n
] = gfc_index_one_node
;
1909 gfc_init_se (&se
, NULL
);
1910 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
1911 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1912 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
1917 /* Calculates the range start and stride for a SS chain. Also gets the
1918 descriptor and data pointer. The range of vector subscripts is the size
1919 of the vector. Array bounds are also checked. */
1922 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
1931 /* Determine the rank of the loop. */
1933 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
1937 case GFC_SS_SECTION
:
1938 case GFC_SS_CONSTRUCTOR
:
1939 case GFC_SS_FUNCTION
:
1940 loop
->dimen
= ss
->data
.info
.dimen
;
1948 if (loop
->dimen
== 0)
1949 gfc_todo_error ("Unable to determine rank of expression");
1952 /* Loop over all the SS in the chain. */
1953 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1957 case GFC_SS_SECTION
:
1958 /* Get the descriptor for the array. */
1959 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
1961 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
1962 gfc_conv_section_startstride (loop
, ss
, n
);
1965 case GFC_SS_CONSTRUCTOR
:
1966 case GFC_SS_FUNCTION
:
1967 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
1969 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
1970 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1979 /* The rest is just runtime bound checking. */
1980 if (flag_bounds_check
)
1986 tree size
[GFC_MAX_DIMENSIONS
];
1990 gfc_start_block (&block
);
1992 fault
= integer_zero_node
;
1993 for (n
= 0; n
< loop
->dimen
; n
++)
1994 size
[n
] = NULL_TREE
;
1996 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1998 if (ss
->type
!= GFC_SS_SECTION
)
2001 /* TODO: range checking for mapped dimensions. */
2002 info
= &ss
->data
.info
;
2004 /* This only checks scalarized dimensions, elemental dimensions are
2006 for (n
= 0; n
< loop
->dimen
; n
++)
2010 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2013 vecss
= vecss
->data
.info
.subscript
[dim
];
2014 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2015 dim
= vecss
->data
.info
.dim
[0];
2017 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2019 desc
= vecss
->data
.info
.descriptor
;
2021 /* Check lower bound. */
2022 bound
= gfc_conv_array_lbound (desc
, dim
);
2023 tmp
= info
->start
[n
];
2024 tmp
= fold (build (LT_EXPR
, boolean_type_node
, tmp
, bound
));
2025 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2028 /* Check the upper bound. */
2029 bound
= gfc_conv_array_ubound (desc
, dim
);
2030 end
= gfc_conv_section_upper_bound (ss
, n
, &block
);
2031 tmp
= fold (build (GT_EXPR
, boolean_type_node
, end
, bound
));
2032 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2035 /* Check the section sizes match. */
2036 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, end
,
2038 tmp
= fold (build (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2040 /* We remember the size of the first section, and check all the
2041 others against this. */
2045 fold (build (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]));
2047 build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, tmp
);
2050 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2053 gfc_trans_runtime_check (fault
, gfc_strconst_bounds
, &block
);
2055 tmp
= gfc_finish_block (&block
);
2056 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2061 /* Return true if the two SS could be aliased, ie. both point to the same data
2063 /* TODO: resolve aliases based on frontend expressions. */
2066 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2073 lsym
= lss
->expr
->symtree
->n
.sym
;
2074 rsym
= rss
->expr
->symtree
->n
.sym
;
2075 if (gfc_symbols_could_alias (lsym
, rsym
))
2078 if (rsym
->ts
.type
!= BT_DERIVED
2079 && lsym
->ts
.type
!= BT_DERIVED
)
2082 /* For derived types we must check all the component types. We can ignore
2083 array references as these will have the same base type as the previous
2085 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2087 if (lref
->type
!= REF_COMPONENT
)
2090 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2093 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2096 if (rref
->type
!= REF_COMPONENT
)
2099 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2104 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2106 if (rref
->type
!= REF_COMPONENT
)
2109 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2117 /* Resolve array data dependencies. Creates a temporary if required. */
2118 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2122 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2132 loop
->temp_ss
= NULL
;
2133 aref
= dest
->data
.info
.ref
;
2136 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2138 if (ss
->type
!= GFC_SS_SECTION
)
2141 if (gfc_could_be_alias (dest
, ss
))
2147 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
2149 lref
= dest
->expr
->ref
;
2150 rref
= ss
->expr
->ref
;
2152 nDepend
= gfc_dep_resolver (lref
, rref
);
2154 /* TODO : loop shifting. */
2157 /* Mark the dimensions for LOOP SHIFTING */
2158 for (n
= 0; n
< loop
->dimen
; n
++)
2160 int dim
= dest
->data
.info
.dim
[n
];
2162 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2164 else if (! gfc_is_same_range (&lref
->u
.ar
,
2165 &rref
->u
.ar
, dim
, 0))
2169 /* Put all the dimensions with dependencies in the
2172 for (n
= 0; n
< loop
->dimen
; n
++)
2174 assert (loop
->order
[n
] == n
);
2176 loop
->order
[dim
++] = n
;
2179 for (n
= 0; n
< loop
->dimen
; n
++)
2182 loop
->order
[dim
++] = n
;
2185 assert (dim
== loop
->dimen
);
2194 loop
->temp_ss
= gfc_get_ss ();
2195 loop
->temp_ss
->type
= GFC_SS_TEMP
;
2196 loop
->temp_ss
->data
.temp
.type
=
2197 gfc_get_element_type (TREE_TYPE (dest
->data
.info
.descriptor
));
2198 loop
->temp_ss
->data
.temp
.string_length
= NULL_TREE
;
2199 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
2200 loop
->temp_ss
->next
= gfc_ss_terminator
;
2201 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
2204 loop
->temp_ss
= NULL
;
2208 /* Initialise the scalarization loop. Creates the loop variables. Determines
2209 the range of the loop variables. Creates a temporary if required.
2210 Calculates how to transform from loop variables to array indices for each
2211 expression. Also generates code for scalar expressions which have been
2212 moved outside the loop. */
2215 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
2220 gfc_ss_info
*specinfo
;
2224 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
2229 for (n
= 0; n
< loop
->dimen
; n
++)
2232 /* We use one SS term, and use that to determine the bounds of the
2233 loop for this dimension. We try to pick the simplest term. */
2234 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2236 if (ss
->expr
&& ss
->expr
->shape
)
2238 /* The frontend has worked out the size for us. */
2243 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
2245 /* Try to figure out the size of the constructor. */
2246 /* TODO: avoid this by making the frontend set the shape. */
2247 gfc_get_array_cons_size (&i
, ss
->expr
->value
.constructor
);
2248 /* A negative value means we failed. */
2249 if (mpz_sgn (i
) > 0)
2251 mpz_sub_ui (i
, i
, 1);
2253 gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2259 /* We don't know how to handle functions yet.
2260 This may not be possible in all cases. */
2261 if (ss
->type
!= GFC_SS_SECTION
)
2264 info
= &ss
->data
.info
;
2267 specinfo
= &loopspec
[n
]->data
.info
;
2270 info
= &ss
->data
.info
;
2272 /* Criteria for choosing a loop specifier (most important first):
2280 else if (loopspec
[n
]->type
!= GFC_SS_CONSTRUCTOR
)
2282 if (integer_onep (info
->stride
[n
])
2283 && !integer_onep (specinfo
->stride
[n
]))
2285 else if (INTEGER_CST_P (info
->stride
[n
])
2286 && !INTEGER_CST_P (specinfo
->stride
[n
]))
2288 else if (INTEGER_CST_P (info
->start
[n
])
2289 && !INTEGER_CST_P (specinfo
->start
[n
]))
2291 /* We don't work out the upper bound.
2292 else if (INTEGER_CST_P (info->finish[n])
2293 && ! INTEGER_CST_P (specinfo->finish[n]))
2294 loopspec[n] = ss; */
2299 gfc_todo_error ("Unable to find scalarization loop specifier");
2301 info
= &loopspec
[n
]->data
.info
;
2303 /* Set the extents of this range. */
2304 cshape
= loopspec
[n
]->expr
->shape
;
2305 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
2306 && INTEGER_CST_P (info
->stride
[n
]))
2308 loop
->from
[n
] = info
->start
[n
];
2309 mpz_set (i
, cshape
[n
]);
2310 mpz_sub_ui (i
, i
, 1);
2311 /* To = from + (size - 1) * stride. */
2312 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2313 if (!integer_onep (info
->stride
[n
]))
2315 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
,
2316 tmp
, info
->stride
[n
]));
2318 loop
->to
[n
] = fold (build (PLUS_EXPR
, gfc_array_index_type
,
2319 loop
->from
[n
], tmp
));
2323 loop
->from
[n
] = info
->start
[n
];
2324 switch (loopspec
[n
]->type
)
2326 case GFC_SS_CONSTRUCTOR
:
2327 assert (info
->dimen
== 1);
2328 assert (loop
->to
[n
]);
2331 case GFC_SS_SECTION
:
2332 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
2341 /* Transform everything so we have a simple incrementing variable. */
2342 if (integer_onep (info
->stride
[n
]))
2343 info
->delta
[n
] = gfc_index_zero_node
;
2346 /* Set the delta for this section. */
2347 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
2348 /* Number of iterations is (end - start + step) / step.
2349 with start = 0, this simplifies to
2351 for (i = 0; i<=last; i++){...}; */
2352 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, loop
->to
[n
],
2354 tmp
= fold (build (TRUNC_DIV_EXPR
, gfc_array_index_type
, tmp
,
2356 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2357 /* Make the loop variable start at 0. */
2358 loop
->from
[n
] = gfc_index_zero_node
;
2362 /* If we want a temporary then create it. */
2363 if (loop
->temp_ss
!= NULL
)
2365 assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
2366 tmp
= loop
->temp_ss
->data
.temp
.type
;
2367 len
= loop
->temp_ss
->data
.temp
.string_length
;
2368 n
= loop
->temp_ss
->data
.temp
.dimen
;
2369 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
2370 loop
->temp_ss
->type
= GFC_SS_SECTION
;
2371 loop
->temp_ss
->data
.info
.dimen
= n
;
2372 gfc_trans_allocate_temp_array (loop
, &loop
->temp_ss
->data
.info
,
2376 /* Add all the scalar code that can be taken out of the loops. */
2377 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
2379 for (n
= 0; n
< loop
->temp_dim
; n
++)
2380 loopspec
[loop
->order
[n
]] = NULL
;
2384 /* For array parameters we don't have loop variables, so don't calculate the
2386 if (loop
->array_parameter
)
2389 /* Calculate the translation from loop variables to array indices. */
2390 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2392 if (ss
->type
!= GFC_SS_SECTION
)
2395 info
= &ss
->data
.info
;
2397 for (n
= 0; n
< info
->dimen
; n
++)
2401 /* If we are specifying the range the delta may already be set. */
2402 if (loopspec
[n
] != ss
)
2404 /* Calculate the offset relative to the loop variable.
2405 First multiply by the stride. */
2406 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
,
2407 loop
->from
[n
], info
->stride
[n
]));
2409 /* Then subtract this from our starting value. */
2410 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
2411 info
->start
[n
], tmp
));
2413 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2420 /* Fills in an array descriptor, and returns the size of the array. The size
2421 will be a simple_val, ie a variable or a constant. Also calculates the
2422 offset of the base. Returns the size of the arrary.
2426 for (n = 0; n < rank; n++)
2428 a.lbound[n] = specified_lower_bound;
2429 offset = offset + a.lbond[n] * stride;
2431 a.ubound[n] = specified_upper_bound;
2432 a.stride[n] = stride;
2433 size = ubound + size; //size = ubound + 1 - lbound
2434 stride = stride * size;
2441 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
2442 gfc_expr
** lower
, gfc_expr
** upper
,
2443 stmtblock_t
* pblock
)
2454 type
= TREE_TYPE (descriptor
);
2456 stride
= gfc_index_one_node
;
2457 offset
= gfc_index_zero_node
;
2459 /* Set the dtype. */
2460 tmp
= gfc_conv_descriptor_dtype (descriptor
);
2461 gfc_add_modify_expr (pblock
, tmp
,
2462 GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (descriptor
)));
2464 for (n
= 0; n
< rank
; n
++)
2466 /* We have 3 possibilities for determining the size of the array:
2467 lower == NULL => lbound = 1, ubound = upper[n]
2468 upper[n] = NULL => lbound = 1, ubound = lower[n]
2469 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2472 /* Set lower bound. */
2473 gfc_init_se (&se
, NULL
);
2475 se
.expr
= gfc_index_one_node
;
2481 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
2482 gfc_add_block_to_block (pblock
, &se
.pre
);
2486 se
.expr
= gfc_index_one_node
;
2490 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
2491 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2493 /* Work out the offset for this component. */
2494 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
));
2495 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
2497 /* Start the calculation for the size of this dimension. */
2498 size
= build (MINUS_EXPR
, gfc_array_index_type
,
2499 gfc_index_one_node
, se
.expr
);
2501 /* Set upper bound. */
2502 gfc_init_se (&se
, NULL
);
2504 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
2505 gfc_add_block_to_block (pblock
, &se
.pre
);
2507 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
2508 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2510 /* Store the stride. */
2511 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
2512 gfc_add_modify_expr (pblock
, tmp
, stride
);
2514 /* Calculate the size of this dimension. */
2515 size
= fold (build (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
));
2517 /* Multiply the stride by the number of elements in this dimension. */
2518 stride
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
, size
));
2519 stride
= gfc_evaluate_now (stride
, pblock
);
2522 /* The stride is the number of elements in the array, so multiply by the
2523 size of an element to get the total size. */
2524 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2525 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
));
2527 if (poffset
!= NULL
)
2529 offset
= gfc_evaluate_now (offset
, pblock
);
2533 size
= gfc_evaluate_now (size
, pblock
);
2538 /* Initialises the descriptor and generates a call to _gfor_allocate. Does
2539 the work for an ALLOCATE statement. */
2543 gfc_array_allocate (gfc_se
* se
, gfc_ref
* ref
, tree pstat
)
2553 /* Figure out the size of the array. */
2554 switch (ref
->u
.ar
.type
)
2558 upper
= ref
->u
.ar
.start
;
2562 assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
2564 lower
= ref
->u
.ar
.as
->lower
;
2565 upper
= ref
->u
.ar
.as
->upper
;
2569 lower
= ref
->u
.ar
.start
;
2570 upper
= ref
->u
.ar
.end
;
2578 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
2579 lower
, upper
, &se
->pre
);
2581 /* Allocate memory to store the data. */
2582 tmp
= gfc_conv_descriptor_data (se
->expr
);
2583 pointer
= gfc_build_addr_expr (NULL
, tmp
);
2584 pointer
= gfc_evaluate_now (pointer
, &se
->pre
);
2586 if (gfc_array_index_type
== gfc_int4_type_node
)
2587 allocate
= gfor_fndecl_allocate
;
2588 else if (gfc_array_index_type
== gfc_int8_type_node
)
2589 allocate
= gfor_fndecl_allocate64
;
2593 tmp
= gfc_chainon_list (NULL_TREE
, pointer
);
2594 tmp
= gfc_chainon_list (tmp
, size
);
2595 tmp
= gfc_chainon_list (tmp
, pstat
);
2596 tmp
= gfc_build_function_call (allocate
, tmp
);
2597 gfc_add_expr_to_block (&se
->pre
, tmp
);
2599 pointer
= gfc_conv_descriptor_data (se
->expr
);
2601 tmp
= gfc_conv_descriptor_offset (se
->expr
);
2602 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
2606 /* Deallocate an array variable. Also used when an allocated variable goes
2611 gfc_array_deallocate (tree descriptor
)
2617 gfc_start_block (&block
);
2618 /* Get a pointer to the data. */
2619 tmp
= gfc_conv_descriptor_data (descriptor
);
2620 tmp
= gfc_build_addr_expr (NULL
, tmp
);
2621 var
= gfc_create_var (TREE_TYPE (tmp
), "ptr");
2622 gfc_add_modify_expr (&block
, var
, tmp
);
2624 /* Parameter is the address of the data component. */
2625 tmp
= gfc_chainon_list (NULL_TREE
, var
);
2626 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
2627 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
2628 gfc_add_expr_to_block (&block
, tmp
);
2630 return gfc_finish_block (&block
);
2634 /* Create an array constructor from an initialization expression.
2635 We assume the frontend already did any expansions and conversions. */
2638 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
2646 unsigned HOST_WIDE_INT lo
;
2650 switch (expr
->expr_type
)
2653 case EXPR_STRUCTURE
:
2654 /* A single scalar or derived type value. Create an array with all
2655 elements equal to that value. */
2656 gfc_init_se (&se
, NULL
);
2657 gfc_conv_expr (&se
, expr
);
2659 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2660 assert (tmp
&& INTEGER_CST_P (tmp
));
2661 hi
= TREE_INT_CST_HIGH (tmp
);
2662 lo
= TREE_INT_CST_LOW (tmp
);
2666 /* This will probably eat buckets of memory for large arrays. */
2667 while (hi
!= 0 || lo
!= 0)
2669 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
2677 /* Create a list of all the elements. */
2678 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2682 /* Problems occur when we get something like
2683 integer :: a(lots) = (/(i, i=1,lots)/) */
2684 /* TODO: Unexpanded array initializers. */
2686 ("Possible frontend bug: array constructor not expanded");
2688 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2689 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2693 if (mpz_cmp_si (c
->repeat
, 0) != 0)
2697 mpz_set (maxval
, c
->repeat
);
2698 mpz_add (maxval
, c
->n
.offset
, maxval
);
2699 mpz_sub_ui (maxval
, maxval
, 1);
2700 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2701 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2703 mpz_add_ui (maxval
, c
->n
.offset
, 1);
2704 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2707 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2709 range
= build (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
2715 gfc_init_se (&se
, NULL
);
2716 switch (c
->expr
->expr_type
)
2719 gfc_conv_constant (&se
, c
->expr
);
2720 if (range
== NULL_TREE
)
2721 list
= tree_cons (index
, se
.expr
, list
);
2724 if (index
!= NULL_TREE
)
2725 list
= tree_cons (index
, se
.expr
, list
);
2726 list
= tree_cons (range
, se
.expr
, list
);
2730 case EXPR_STRUCTURE
:
2731 gfc_conv_structure (&se
, c
->expr
, 1);
2732 list
= tree_cons (index
, se
.expr
, list
);
2739 /* We created the list in reverse order. */
2740 list
= nreverse (list
);
2747 /* Create a constructor from the list of elements. */
2748 tmp
= build1 (CONSTRUCTOR
, type
, list
);
2749 TREE_CONSTANT (tmp
) = 1;
2750 TREE_INVARIANT (tmp
) = 1;
2755 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2756 returns the size (in elements) of the array. */
2759 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
2760 stmtblock_t
* pblock
)
2775 size
= gfc_index_one_node
;
2776 offset
= gfc_index_zero_node
;
2777 for (dim
= 0; dim
< as
->rank
; dim
++)
2779 /* Evaluate non-constant array bound expressions. */
2780 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2781 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
2783 gfc_init_se (&se
, NULL
);
2784 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
2785 gfc_add_block_to_block (pblock
, &se
.pre
);
2786 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
2788 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2789 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
2791 gfc_init_se (&se
, NULL
);
2792 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
2793 gfc_add_block_to_block (pblock
, &se
.pre
);
2794 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
2796 /* The offset of this dimension. offset = offset - lbound * stride. */
2797 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, lbound
, size
));
2798 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
2800 /* The size of this dimension, and the stride of the next. */
2801 if (dim
+ 1 < as
->rank
)
2802 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
2806 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
2808 /* Calculate stride = size * (ubound + 1 - lbound). */
2809 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
2810 gfc_index_one_node
, lbound
));
2811 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
));
2812 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2814 gfc_add_modify_expr (pblock
, stride
, tmp
);
2816 stride
= gfc_evaluate_now (tmp
, pblock
);
2827 /* Generate code to initialize/allocate an array variable. */
2830 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
2841 assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
2843 /* Do nothing for USEd variables. */
2844 if (sym
->attr
.use_assoc
)
2847 type
= TREE_TYPE (decl
);
2848 assert (GFC_ARRAY_TYPE_P (type
));
2849 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
2851 gfc_start_block (&block
);
2853 /* Evaluate character string length. */
2854 if (sym
->ts
.type
== BT_CHARACTER
2855 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2857 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2859 DECL_DEFER_OUTPUT (decl
) = 1;
2861 /* Generate code to allocate the automatic variable. It will be
2862 freed automatically. */
2863 tmp
= gfc_build_addr_expr (NULL
, decl
);
2864 args
= gfc_chainon_list (NULL_TREE
, tmp
);
2865 args
= gfc_chainon_list (args
, sym
->ts
.cl
->backend_decl
);
2866 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_STACK_ALLOC
],
2868 gfc_add_expr_to_block (&block
, tmp
);
2873 gfc_add_expr_to_block (&block
, fnbody
);
2874 return gfc_finish_block (&block
);
2877 type
= TREE_TYPE (type
);
2879 assert (!sym
->attr
.use_assoc
);
2880 assert (!TREE_STATIC (decl
));
2881 assert (!sym
->module
[0]);
2883 if (sym
->ts
.type
== BT_CHARACTER
2884 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2885 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2887 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
2889 /* The size is the number of elements in the array, so multiply by the
2890 size of an element to get the total size. */
2891 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2892 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2894 /* Allocate memory to hold the data. */
2895 tmp
= gfc_chainon_list (NULL_TREE
, size
);
2897 if (gfc_index_integer_kind
== 4)
2898 fndecl
= gfor_fndecl_internal_malloc
;
2899 else if (gfc_index_integer_kind
== 8)
2900 fndecl
= gfor_fndecl_internal_malloc64
;
2903 tmp
= gfc_build_function_call (fndecl
, tmp
);
2904 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
2905 gfc_add_modify_expr (&block
, decl
, tmp
);
2907 /* Set offset of the array. */
2908 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
2909 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
2912 /* Automatic arrays should not have initializers. */
2913 assert (!sym
->value
);
2915 gfc_add_expr_to_block (&block
, fnbody
);
2917 /* Free the temporary. */
2918 tmp
= convert (pvoid_type_node
, decl
);
2919 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
2920 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2921 gfc_add_expr_to_block (&block
, tmp
);
2923 return gfc_finish_block (&block
);
2927 /* Generate entry and exit code for g77 calling convention arrays. */
2930 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
2939 gfc_get_backend_locus (&loc
);
2940 gfc_set_backend_locus (&sym
->declared_at
);
2942 /* Descriptor type. */
2943 parm
= sym
->backend_decl
;
2944 type
= TREE_TYPE (parm
);
2945 assert (GFC_ARRAY_TYPE_P (type
));
2947 gfc_start_block (&block
);
2949 if (sym
->ts
.type
== BT_CHARACTER
2950 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2951 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2953 /* Evaluate the bounds of the array. */
2954 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
2956 /* Set the offset. */
2957 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
2958 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
2960 /* Set the pointer itself if we aren't using the parameter dirtectly. */
2961 if (TREE_CODE (parm
) != PARM_DECL
)
2963 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
2964 gfc_add_modify_expr (&block
, parm
, tmp
);
2966 tmp
= gfc_finish_block (&block
);
2968 gfc_set_backend_locus (&loc
);
2970 gfc_start_block (&block
);
2971 /* Add the initialization code to the start of the function. */
2972 gfc_add_expr_to_block (&block
, tmp
);
2973 gfc_add_expr_to_block (&block
, body
);
2975 return gfc_finish_block (&block
);
2979 /* Modify the descriptor of an array parameter so that it has the
2980 correct lower bound. Also move the upper bound accordingly.
2981 If the array is not packed, it will be copied into a temporary.
2982 For each dimension we set the new lower and upper bounds. Then we copy the
2983 stride and calculate the offset for this dimension. We also work out
2984 what the stride of a packed array would be, and see it the two match.
2985 If the array need repacking, we set the stride to the values we just
2986 calculated, recalculate the offset and copy the array data.
2987 Code is also added to copy the data back at the end of the function.
2991 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
2998 stmtblock_t cleanup
;
3015 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3016 return gfc_trans_g77_array (sym
, body
);
3018 gfc_get_backend_locus (&loc
);
3019 gfc_set_backend_locus (&sym
->declared_at
);
3021 /* Descriptor type. */
3022 type
= TREE_TYPE (tmpdesc
);
3023 assert (GFC_ARRAY_TYPE_P (type
));
3024 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3025 dumdesc
= gfc_build_indirect_ref (dumdesc
);
3026 gfc_start_block (&block
);
3028 if (sym
->ts
.type
== BT_CHARACTER
3029 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3030 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3032 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3034 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3035 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3037 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3039 /* For non-constant shape arrays we only check if the first dimension
3040 is contiguous. Repacking higher dimensions wouldn't gain us
3041 anything as we still don't know the array stride. */
3042 partial
= gfc_create_var (boolean_type_node
, "partial");
3043 TREE_USED (partial
) = 1;
3044 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3045 tmp
= fold (build (EQ_EXPR
, boolean_type_node
, tmp
, integer_one_node
));
3046 gfc_add_modify_expr (&block
, partial
, tmp
);
3050 partial
= NULL_TREE
;
3053 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3054 here, however I think it does the right thing. */
3057 /* Set the first stride. */
3058 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3059 stride
= gfc_evaluate_now (stride
, &block
);
3061 tmp
= build (EQ_EXPR
, boolean_type_node
, stride
, integer_zero_node
);
3062 tmp
= build (COND_EXPR
, gfc_array_index_type
, tmp
,
3063 gfc_index_one_node
, stride
);
3064 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3065 gfc_add_modify_expr (&block
, stride
, tmp
);
3067 /* Allow the user to disable array repacking. */
3068 stmt_unpacked
= NULL_TREE
;
3072 assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3073 /* A library call to repack the array if neccessary. */
3074 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3075 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3076 stmt_unpacked
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3078 stride
= gfc_index_one_node
;
3081 /* This is for the case where the array data is used directly without
3082 calling the repack function. */
3083 if (no_repack
|| partial
!= NULL_TREE
)
3084 stmt_packed
= gfc_conv_descriptor_data (dumdesc
);
3086 stmt_packed
= NULL_TREE
;
3088 /* Assign the data pointer. */
3089 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3091 /* Don't repack unknown shape arrays when the first stride is 1. */
3092 tmp
= build (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3093 stmt_packed
, stmt_unpacked
);
3096 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3097 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
3099 offset
= gfc_index_zero_node
;
3100 size
= gfc_index_one_node
;
3102 /* Evaluate the bounds of the array. */
3103 for (n
= 0; n
< sym
->as
->rank
; n
++)
3105 if (checkparm
|| !sym
->as
->upper
[n
])
3107 /* Get the bounds of the actual parameter. */
3108 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3109 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3113 dubound
= NULL_TREE
;
3114 dlbound
= NULL_TREE
;
3117 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3118 if (!INTEGER_CST_P (lbound
))
3120 gfc_init_se (&se
, NULL
);
3121 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3122 gfc_array_index_type
);
3123 gfc_add_block_to_block (&block
, &se
.pre
);
3124 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3127 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3128 /* Set the desired upper bound. */
3129 if (sym
->as
->upper
[n
])
3131 /* We know what we want the upper bound to be. */
3132 if (!INTEGER_CST_P (ubound
))
3134 gfc_init_se (&se
, NULL
);
3135 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3136 gfc_array_index_type
);
3137 gfc_add_block_to_block (&block
, &se
.pre
);
3138 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3141 /* Check the sizes match. */
3144 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3146 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, ubound
,
3148 stride
= build (MINUS_EXPR
, gfc_array_index_type
, dubound
,
3150 tmp
= fold (build (NE_EXPR
, gfc_array_index_type
, tmp
, stride
));
3151 gfc_trans_runtime_check (tmp
, gfc_strconst_bounds
, &block
);
3156 /* For assumed shape arrays move the upper bound by the same amount
3157 as the lower bound. */
3158 tmp
= build (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3159 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
));
3160 gfc_add_modify_expr (&block
, ubound
, tmp
);
3162 /* The offset of this dimension. offset = offset - lbound * stride. */
3163 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
));
3164 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
3166 /* The size of this dimension, and the stride of the next. */
3167 if (n
+ 1 < sym
->as
->rank
)
3169 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3171 if (no_repack
|| partial
!= NULL_TREE
)
3174 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
3177 /* Figure out the stride if not a known constant. */
3178 if (!INTEGER_CST_P (stride
))
3181 stmt_packed
= NULL_TREE
;
3184 /* Calculate stride = size * (ubound + 1 - lbound). */
3185 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
3186 gfc_index_one_node
, lbound
));
3187 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
3189 size
= fold (build (MULT_EXPR
, gfc_array_index_type
,
3194 /* Assign the stride. */
3195 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3197 tmp
= build (COND_EXPR
, gfc_array_index_type
, partial
,
3198 stmt_unpacked
, stmt_packed
);
3201 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
3202 gfc_add_modify_expr (&block
, stride
, tmp
);
3207 /* Set the offset. */
3208 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3209 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3211 stmt
= gfc_finish_block (&block
);
3213 gfc_start_block (&block
);
3215 /* Only do the entry/initialization code if the arg is present. */
3216 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3217 if (sym
->attr
.optional
)
3219 tmp
= gfc_conv_expr_present (sym
);
3220 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3222 gfc_add_expr_to_block (&block
, stmt
);
3224 /* Add the main function body. */
3225 gfc_add_expr_to_block (&block
, body
);
3230 gfc_start_block (&cleanup
);
3232 if (sym
->attr
.intent
!= INTENT_IN
)
3234 /* Copy the data back. */
3235 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
3236 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
3237 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3238 gfc_add_expr_to_block (&cleanup
, tmp
);
3241 /* Free the temporary. */
3242 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
3243 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3244 gfc_add_expr_to_block (&cleanup
, tmp
);
3246 stmt
= gfc_finish_block (&cleanup
);
3248 /* Only do the cleanup if the array was repacked. */
3249 tmp
= gfc_build_indirect_ref (dumdesc
);
3250 tmp
= gfc_conv_descriptor_data (tmp
);
3251 tmp
= build (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
3252 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3254 if (sym
->attr
.optional
)
3256 tmp
= gfc_conv_expr_present (sym
);
3257 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3259 gfc_add_expr_to_block (&block
, stmt
);
3261 /* We don't need to free any memory allocated by internal_pack as it will
3262 be freed at the end of the function by pop_context. */
3263 return gfc_finish_block (&block
);
3267 /* Convert an array for passing as an actual parameter. Expressions and
3268 vector subscripts are evaluated and stored in a temporary, which is then
3269 passed. For whole arrays the descriptor is passed. For array sections
3270 a modified copy of the descriptor is passed, but using the original data.
3271 Also used for array pointer assignments by setting se->direct_byref. */
3274 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
3288 assert (ss
!= gfc_ss_terminator
);
3290 /* TODO: Pass constant array constructors without a temporary. */
3291 /* If we have a linear array section, we can pass it directly. Otherwise
3292 we need to copy it into a temporary. */
3293 if (expr
->expr_type
== EXPR_VARIABLE
)
3297 /* Find the SS for the array section. */
3299 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
3300 secss
= secss
->next
;
3302 assert (secss
!= gfc_ss_terminator
);
3305 for (n
= 0; n
< secss
->data
.info
.dimen
; n
++)
3307 vss
= secss
->data
.info
.subscript
[secss
->data
.info
.dim
[n
]];
3308 if (vss
&& vss
->type
== GFC_SS_VECTOR
)
3312 info
= &secss
->data
.info
;
3314 /* Get the descriptor for the array. */
3315 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
3316 desc
= info
->descriptor
;
3317 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
3319 /* Create a new descriptor if the array doesn't have one. */
3322 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
3324 else if (se
->direct_byref
)
3328 assert (info
->ref
->u
.ar
.type
== AR_SECTION
);
3331 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3333 /* Detect passing the full array as a section. This could do
3334 even more checking, but it doesn't seem worth it. */
3335 if (info
->ref
->u
.ar
.start
[n
]
3336 || info
->ref
->u
.ar
.end
[n
]
3337 || (info
->ref
->u
.ar
.stride
[n
]
3338 && !gfc_expr_is_one (info
->ref
->u
.ar
.stride
[n
], 0)))
3347 if (se
->direct_byref
)
3349 /* Copy the descriptor for pointer assignments. */
3350 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
3352 else if (se
->want_pointer
)
3354 /* We pass full arrays directly. This means that pointers and
3355 allocatable arrays should also work. */
3356 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3372 gfc_init_loopinfo (&loop
);
3374 /* Associate the SS with the loop. */
3375 gfc_add_ss_to_loop (&loop
, ss
);
3377 /* Tell the scalarizer not to bother creating loop variables, etc. */
3379 loop
.array_parameter
= 1;
3381 assert (se
->want_pointer
&& !se
->direct_byref
);
3383 /* Setup the scalarizing loops and bounds. */
3384 gfc_conv_ss_startstride (&loop
);
3388 /* Tell the scalarizer to make a temporary. */
3389 loop
.temp_ss
= gfc_get_ss ();
3390 loop
.temp_ss
->type
= GFC_SS_TEMP
;
3391 loop
.temp_ss
->next
= gfc_ss_terminator
;
3392 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
3393 loop
.temp_ss
->data
.temp
.string_length
= NULL
;
3394 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
3395 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3398 gfc_conv_loop_setup (&loop
);
3402 /* Copy into a temporary and pass that. We don't need to copy the data
3403 back because expressions and vector subscripts must be INTENT_IN. */
3404 /* TODO: Optimize passing function return values. */
3408 /* Start the copying loops. */
3409 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3410 gfc_mark_ss_chain_used (ss
, 1);
3411 gfc_start_scalarized_body (&loop
, &block
);
3413 /* Copy each data element. */
3414 gfc_init_se (&lse
, NULL
);
3415 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3416 gfc_init_se (&rse
, NULL
);
3417 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3419 lse
.ss
= loop
.temp_ss
;
3422 gfc_conv_scalarized_array_ref (&lse
, NULL
);
3423 gfc_conv_expr_val (&rse
, expr
);
3425 gfc_add_block_to_block (&block
, &rse
.pre
);
3426 gfc_add_block_to_block (&block
, &lse
.pre
);
3428 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
3430 /* Finish the copying loops. */
3431 gfc_trans_scalarizing_loops (&loop
, &block
);
3433 /* Set the first stride component to zero to indicate a temporary. */
3434 desc
= loop
.temp_ss
->data
.info
.descriptor
;
3435 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[0]);
3436 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3438 assert (is_gimple_lvalue (desc
));
3439 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3443 /* We pass sections without copying to a temporary. A function may
3444 decide to repack the array to speed up access, but we're not
3445 bothered about that here. */
3454 /* Otherwise make a new descriptor and point it at the section we
3455 want. The loop variable limits will be the limits of the section.
3457 desc
= info
->descriptor
;
3458 assert (secss
&& secss
!= gfc_ss_terminator
);
3459 if (se
->direct_byref
)
3461 /* For pointer assignments we fill in the destination. */
3463 parmtype
= TREE_TYPE (parm
);
3467 /* Otherwise make a new one. */
3468 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3469 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
3470 loop
.from
, loop
.to
, 0);
3471 parm
= gfc_create_var (parmtype
, "parm");
3474 offset
= gfc_index_zero_node
;
3477 /* The following can be somewhat confusing. We have two
3478 descriptors, a new one and the original array.
3479 {parm, parmtype, dim} refer to the new one.
3480 {desc, type, n, secss, loop} refer to the original, which maybe
3481 a descriptorless array.
3482 The bounds of the scaralization are the bounds of the section.
3483 We don't have to worry about numeric overflows when calculating
3484 the offsets because all elements are within the array data. */
3486 /* Set the dtype. */
3487 tmp
= gfc_conv_descriptor_dtype (parm
);
3488 gfc_add_modify_expr (&loop
.pre
, tmp
, GFC_TYPE_ARRAY_DTYPE (parmtype
));
3490 if (se
->direct_byref
)
3491 base
= gfc_index_zero_node
;
3495 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3497 stride
= gfc_conv_array_stride (desc
, n
);
3499 /* Work out the offset. */
3500 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3502 assert (info
->subscript
[n
]
3503 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
3504 start
= info
->subscript
[n
]->data
.scalar
.expr
;
3508 /* Check we haven't somehow got out of sync. */
3509 assert (info
->dim
[dim
] == n
);
3511 /* Evaluate and remember the start of the section. */
3512 start
= info
->start
[dim
];
3513 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
3516 tmp
= gfc_conv_array_lbound (desc
, n
);
3517 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
));
3519 tmp
= fold (build (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
));
3520 offset
= fold (build (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
));
3522 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3524 /* For elemental dimensions, we only need the offset. */
3528 /* Vector subscripts need copying and are handled elsewhere. */
3529 assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
3531 /* Set the new lower bound. */
3532 from
= loop
.from
[dim
];
3534 if (!integer_onep (from
))
3536 /* Make sure the new section starts at 1. */
3537 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
3538 gfc_index_one_node
, from
));
3539 to
= fold (build (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
));
3540 from
= gfc_index_one_node
;
3542 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
3543 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
3545 /* Set the new upper bound. */
3546 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
3547 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
3549 /* Multiply the stride by the section stride to get the
3551 stride
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
,
3552 info
->stride
[dim
]));
3554 if (se
->direct_byref
)
3556 base
= fold (build (MINUS_EXPR
, TREE_TYPE (base
),
3560 /* Store the new stride. */
3561 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
3562 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
3567 /* Point the data pointer at the first element in the section. */
3568 tmp
= gfc_conv_array_data (desc
);
3569 tmp
= gfc_build_indirect_ref (tmp
);
3570 tmp
= gfc_build_array_ref (tmp
, offset
);
3571 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
3573 tmp
= gfc_conv_descriptor_data (parm
);
3574 gfc_add_modify_expr (&loop
.pre
, tmp
,
3575 fold_convert (TREE_TYPE (tmp
), offset
));
3577 if (se
->direct_byref
)
3579 /* Set the offset. */
3580 tmp
= gfc_conv_descriptor_offset (parm
);
3581 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
3585 /* Only the callee knows what the correct offset it, so just set
3587 tmp
= gfc_conv_descriptor_offset (parm
);
3588 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3591 if (!se
->direct_byref
)
3593 /* Get a pointer to the new descriptor. */
3594 if (se
->want_pointer
)
3595 se
->expr
= gfc_build_addr_expr (NULL
, parm
);
3601 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3602 gfc_add_block_to_block (&se
->post
, &loop
.post
);
3604 /* Cleanup the scalarizer. */
3605 gfc_cleanup_loop (&loop
);
3609 /* Convert an array for passing as an actual parameter. */
3610 /* TODO: Optimize passing g77 arrays. */
3613 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
3622 /* Passing address of the array if it is not pointer or assumed-shape. */
3623 if (expr
->expr_type
== EXPR_VARIABLE
3624 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
3626 sym
= expr
->symtree
->n
.sym
;
3627 tmp
= gfc_get_symbol_decl (sym
);
3628 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
3629 && !sym
->attr
.allocatable
)
3631 if (!sym
->attr
.dummy
)
3632 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
3637 if (sym
->attr
.allocatable
)
3639 se
->expr
= gfc_conv_array_data (tmp
);
3644 se
->want_pointer
= 1;
3645 gfc_conv_expr_descriptor (se
, expr
, ss
);
3650 /* Repack the array. */
3651 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3652 ptr
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3653 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
3656 gfc_start_block (&block
);
3658 /* Copy the data back. */
3659 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3660 tmp
= gfc_chainon_list (tmp
, ptr
);
3661 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3662 gfc_add_expr_to_block (&block
, tmp
);
3664 /* Free the temporary. */
3665 tmp
= convert (pvoid_type_node
, ptr
);
3666 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3667 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3668 gfc_add_expr_to_block (&block
, tmp
);
3670 stmt
= gfc_finish_block (&block
);
3672 gfc_init_block (&block
);
3673 /* Only if it was repacked. This code needs to be executed before the
3674 loop cleanup code. */
3675 tmp
= gfc_build_indirect_ref (desc
);
3676 tmp
= gfc_conv_array_data (tmp
);
3677 tmp
= build (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
3678 tmp
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3680 gfc_add_expr_to_block (&block
, tmp
);
3681 gfc_add_block_to_block (&block
, &se
->post
);
3683 gfc_init_block (&se
->post
);
3684 gfc_add_block_to_block (&se
->post
, &block
);
3689 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3692 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
3699 stmtblock_t fnblock
;
3702 /* Make sure the frontend gets these right. */
3703 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3705 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
3707 gfc_init_block (&fnblock
);
3709 assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
);
3710 if (sym
->ts
.type
== BT_CHARACTER
3711 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3712 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
3714 /* Parameter variables don't need anything special. */
3715 if (sym
->attr
.dummy
)
3717 gfc_add_expr_to_block (&fnblock
, body
);
3719 return gfc_finish_block (&fnblock
);
3722 gfc_get_backend_locus (&loc
);
3723 gfc_set_backend_locus (&sym
->declared_at
);
3724 descriptor
= sym
->backend_decl
;
3726 if (TREE_STATIC (descriptor
))
3728 /* SAVEd variables are not freed on exit. */
3729 gfc_trans_static_array_pointer (sym
);
3733 /* Get the descriptor type. */
3734 type
= TREE_TYPE (sym
->backend_decl
);
3735 assert (GFC_DESCRIPTOR_TYPE_P (type
));
3737 /* NULLIFY the data pointer. */
3738 tmp
= gfc_conv_descriptor_data (descriptor
);
3739 gfc_add_modify_expr (&fnblock
, tmp
,
3740 convert (TREE_TYPE (tmp
), integer_zero_node
));
3742 gfc_add_expr_to_block (&fnblock
, body
);
3744 gfc_set_backend_locus (&loc
);
3745 /* Allocatable arrays need to be freed when they go out of scope. */
3746 if (sym
->attr
.allocatable
)
3748 gfc_start_block (&block
);
3750 /* Deallocate if still allocated at the end of the procedure. */
3751 deallocate
= gfc_array_deallocate (descriptor
);
3753 tmp
= gfc_conv_descriptor_data (descriptor
);
3754 tmp
= build (NE_EXPR
, boolean_type_node
, tmp
, integer_zero_node
);
3755 tmp
= build_v (COND_EXPR
, tmp
, deallocate
, build_empty_stmt ());
3756 gfc_add_expr_to_block (&block
, tmp
);
3758 tmp
= gfc_finish_block (&block
);
3759 gfc_add_expr_to_block (&fnblock
, tmp
);
3762 return gfc_finish_block (&fnblock
);
3765 /************ Expression Walking Functions ******************/
3767 /* Walk a variable reference.
3769 Possible extension - multiple component subscripts.
3770 x(:,:) = foo%a(:)%b(:)
3772 forall (i=..., j=...)
3773 x(i,j) = foo%a(j)%b(i)
3775 This adds a fair amout of complexity because you need to deal with more
3776 than one ref. Maybe handle in a similar manner to vector subscripts.
3777 Maybe not worth the effort. */
3781 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
3789 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3791 /* We're only interested in array sections. */
3792 if (ref
->type
!= REF_ARRAY
)
3799 /* TODO: Take elemental array references out of scalarization
3804 newss
= gfc_get_ss ();
3805 newss
->type
= GFC_SS_SECTION
;
3808 newss
->data
.info
.dimen
= ar
->as
->rank
;
3809 newss
->data
.info
.ref
= ref
;
3811 /* Make sure array is the same as array(:,:), this way
3812 we don't need to special case all the time. */
3813 ar
->dimen
= ar
->as
->rank
;
3814 for (n
= 0; n
< ar
->dimen
; n
++)
3816 newss
->data
.info
.dim
[n
] = n
;
3817 ar
->dimen_type
[n
] = DIMEN_RANGE
;
3819 assert (ar
->start
[n
] == NULL
);
3820 assert (ar
->end
[n
] == NULL
);
3821 assert (ar
->stride
[n
] == NULL
);
3826 newss
= gfc_get_ss ();
3827 newss
->type
= GFC_SS_SECTION
;
3830 newss
->data
.info
.dimen
= 0;
3831 newss
->data
.info
.ref
= ref
;
3835 /* We add SS chains for all the subscripts in the section. */
3836 for (n
= 0; n
< ar
->dimen
; n
++)
3840 switch (ar
->dimen_type
[n
])
3843 /* Add SS for elemental (scalar) subscripts. */
3844 assert (ar
->start
[n
]);
3845 indexss
= gfc_get_ss ();
3846 indexss
->type
= GFC_SS_SCALAR
;
3847 indexss
->expr
= ar
->start
[n
];
3848 indexss
->next
= gfc_ss_terminator
;
3849 indexss
->loop_chain
= gfc_ss_terminator
;
3850 newss
->data
.info
.subscript
[n
] = indexss
;
3854 /* We don't add anything for sections, just remember this
3855 dimension for later. */
3856 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
3857 newss
->data
.info
.dimen
++;
3861 /* Get a SS for the vector. This will not be added to the
3863 indexss
= gfc_walk_expr (ar
->start
[n
]);
3864 if (indexss
== gfc_ss_terminator
)
3865 internal_error ("scalar vector subscript???");
3867 /* We currently only handle really simple vector
3869 if (indexss
->next
!= gfc_ss_terminator
)
3870 gfc_todo_error ("vector subscript expressions");
3871 indexss
->loop_chain
= gfc_ss_terminator
;
3873 /* Mark this as a vector subscript. We don't add this
3874 directly into the chain, but as a subscript of the
3875 existing SS for this term. */
3876 indexss
->type
= GFC_SS_VECTOR
;
3877 newss
->data
.info
.subscript
[n
] = indexss
;
3878 /* Also remember this dimension. */
3879 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
3880 newss
->data
.info
.dimen
++;
3884 /* We should know what sort of section it is by now. */
3888 /* We should have at least one non-elemental dimension. */
3889 assert (newss
->data
.info
.dimen
> 0);
3894 /* We should know what sort of section it is by now. */
3903 /* Walk an expression operator. If only one operand of a binary expression is
3904 scalar, we must also add the scalar term to the SS chain. */
3907 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
3913 head
= gfc_walk_subexpr (ss
, expr
->op1
);
3914 if (expr
->op2
== NULL
)
3917 head2
= gfc_walk_subexpr (head
, expr
->op2
);
3919 /* All operands are scalar. Pass back and let the caller deal with it. */
3923 /* All operands require scalarization. */
3924 if (head
!= ss
&& (expr
->op2
== NULL
|| head2
!= head
))
3927 /* One of the operands needs scalarization, the other is scalar.
3928 Create a gfc_ss for the scalar expression. */
3929 newss
= gfc_get_ss ();
3930 newss
->type
= GFC_SS_SCALAR
;
3933 /* First operand is scalar. We build the chain in reverse order, so
3934 add the scarar SS after the second operand. */
3936 while (head
&& head
->next
!= ss
)
3938 /* Check we haven't somehow broken the chain. */
3942 newss
->expr
= expr
->op1
;
3944 else /* head2 == head */
3946 assert (head2
== head
);
3947 /* Second operand is scalar. */
3948 newss
->next
= head2
;
3950 newss
->expr
= expr
->op2
;
3957 /* Reverse a SS chain. */
3960 gfc_reverse_ss (gfc_ss
* ss
)
3965 assert (ss
!= NULL
);
3967 head
= gfc_ss_terminator
;
3968 while (ss
!= gfc_ss_terminator
)
3971 assert (next
!= NULL
); /* Check we didn't somehow break the chain. */
3981 /* Walk the arguments of an elemental function. */
3984 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_expr
* expr
,
3987 gfc_actual_arglist
*arg
;
3993 head
= gfc_ss_terminator
;
3996 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4001 newss
= gfc_walk_subexpr (head
, arg
->expr
);
4004 /* Scalar argumet. */
4005 newss
= gfc_get_ss ();
4007 newss
->expr
= arg
->expr
;
4017 while (tail
->next
!= gfc_ss_terminator
)
4024 /* If all the arguments are scalar we don't need the argument SS. */
4025 gfc_free_ss_chain (head
);
4030 /* Add it onto the existing chain. */
4036 /* Walk a function call. Scalar functions are passed back, and taken out of
4037 scalarization loops. For elemental functions we walk their arguments.
4038 The result of functions returning arrays is stored in a temporary outside
4039 the loop, so that the function is only called once. Hence we do not need
4040 to walk their arguments. */
4043 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4046 gfc_intrinsic_sym
*isym
;
4049 isym
= expr
->value
.function
.isym
;
4051 /* Handle intrinsic functions separately. */
4053 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
4055 sym
= expr
->value
.function
.esym
;
4057 sym
= expr
->symtree
->n
.sym
;
4059 /* A function that returns arrays. */
4060 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
4062 newss
= gfc_get_ss ();
4063 newss
->type
= GFC_SS_FUNCTION
;
4066 newss
->data
.info
.dimen
= expr
->rank
;
4070 /* Walk the parameters of an elemental function. For now we always pass
4072 if (sym
->attr
.elemental
)
4073 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_REFERENCE
);
4075 /* Scalar functions are OK as these are evaluated outside the scalarisation
4076 loop. Pass back and let the caller deal with it. */
4081 /* An array temporary is constructed for array constructors. */
4084 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
4089 newss
= gfc_get_ss ();
4090 newss
->type
= GFC_SS_CONSTRUCTOR
;
4093 newss
->data
.info
.dimen
= expr
->rank
;
4094 for (n
= 0; n
< expr
->rank
; n
++)
4095 newss
->data
.info
.dim
[n
] = n
;
4101 /* Walk an expresson. Add walked expressions to the head of the SS chain.
4102 A wholy scalar expression will not be added. */
4105 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
4109 switch (expr
->expr_type
)
4112 head
= gfc_walk_variable_expr (ss
, expr
);
4116 head
= gfc_walk_op_expr (ss
, expr
);
4120 head
= gfc_walk_function_expr (ss
, expr
);
4125 case EXPR_STRUCTURE
:
4126 /* Pass back and let the caller deal with it. */
4130 head
= gfc_walk_array_constructor (ss
, expr
);
4133 case EXPR_SUBSTRING
:
4134 /* Pass back and let the caller deal with it. */
4138 internal_error ("bad expression type during walk (%d)",
4145 /* Entry point for expression walking.
4146 A return value equal to the passed chain means this is
4147 a scalar expression. It is up to the caller to take whatever action is
4148 neccessary to translate these. */
4151 gfc_walk_expr (gfc_expr
* expr
)
4155 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
4156 return gfc_reverse_ss (res
);