1 /* Array translation routines
2 Copyright (C) 2002, 2003 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 GNU G95.
8 GNU G95 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU G95 is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU G95; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
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-simple.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 actualy 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
);
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
);
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
);
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
);
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
);
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
);
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
);
291 /* Generate an initializer for a static pointer or allocatable array. */
294 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
300 assert (TREE_STATIC (sym
->backend_decl
));
301 /* Just zero the data member. */
302 type
= TREE_TYPE (sym
->backend_decl
);
303 assert (GFC_DESCRIPTOR_TYPE_P (type
));
304 assert (DATA_FIELD
== 0);
305 field
= TYPE_FIELDS (type
);
307 tmp
= tree_cons (field
, null_pointer_node
, NULL_TREE
);
308 tmp
= build1 (CONSTRUCTOR
, type
, tmp
);
309 TREE_CONSTANT (tmp
) = 1;
310 TREE_INVARIANT (tmp
) = 1;
311 DECL_INITIAL (sym
->backend_decl
) = tmp
;
315 /* Cleanup those #defines. */
320 #undef DIMENSION_FIELD
321 #undef STRIDE_SUBFIELD
322 #undef LBOUND_SUBFIELD
323 #undef UBOUND_SUBFIELD
326 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
327 flags & 1 = Main loop body.
328 flags & 2 = temp copy loop. */
331 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
333 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
334 ss
->useflags
= flags
;
337 static void gfc_free_ss (gfc_ss
*);
340 /* Free a gfc_ss chain. */
343 gfc_free_ss_chain (gfc_ss
* ss
)
347 while (ss
!= gfc_ss_terminator
)
360 gfc_free_ss (gfc_ss
* ss
)
368 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
370 if (ss
->data
.info
.subscript
[n
])
371 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
383 /* Free all the SS associated with a loop. */
386 gfc_cleanup_loop (gfc_loopinfo
* loop
)
392 while (ss
!= gfc_ss_terminator
)
395 next
= ss
->loop_chain
;
402 /* Associate a SS chain with a loop. */
405 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
409 if (head
== gfc_ss_terminator
)
413 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
415 if (ss
->next
== gfc_ss_terminator
)
416 ss
->loop_chain
= loop
->ss
;
418 ss
->loop_chain
= ss
->next
;
420 assert (ss
== gfc_ss_terminator
);
425 /* Generate code to allocate an array temporary, or create a variable to
429 gfc_trans_allocate_array_storage (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
430 tree size
, tree nelem
)
438 desc
= info
->descriptor
;
439 data
= gfc_conv_descriptor_data (desc
);
440 onstack
= gfc_can_put_var_on_stack (size
);
443 /* Make a temporary variable to hold the data. */
444 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
446 tmp
= build_range_type (gfc_array_index_type
, integer_zero_node
, tmp
);
447 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)), tmp
);
448 tmp
= gfc_create_var (tmp
, "A");
449 tmp
= gfc_build_addr_expr (TREE_TYPE (data
), tmp
);
450 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
452 info
->offset
= gfc_index_zero_node
;
457 /* Allocate memory to hold the data. */
458 args
= gfc_chainon_list (NULL_TREE
, size
);
460 if (gfc_index_integer_kind
== 4)
461 tmp
= gfor_fndecl_internal_malloc
;
462 else if (gfc_index_integer_kind
== 8)
463 tmp
= gfor_fndecl_internal_malloc64
;
466 tmp
= gfc_build_function_call (tmp
, args
);
467 tmp
= convert (TREE_TYPE (data
), tmp
);
468 gfc_add_modify_expr (&loop
->pre
, data
, tmp
);
471 info
->offset
= gfc_index_zero_node
;
474 /* The offset is zero because we create temporaries with a zero
476 tmp
= gfc_conv_descriptor_offset (desc
);
477 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
481 /* Free the temporary. */
482 tmp
= convert (pvoid_type_node
, info
->data
);
483 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
484 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
485 gfc_add_expr_to_block (&loop
->post
, tmp
);
490 /* Generate code to allocate and initialize the descriptor for a temporary
491 array. Fills in the descriptor, data and offset fields of info. Also
492 adjusts the loop variables to be zero-based. Returns the size of the
496 gfc_trans_allocate_temp_array (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
497 tree eltype
, tree string_length
)
507 assert (info
->dimen
> 0);
508 /* Set the lower bound to zero. */
509 for (dim
= 0; dim
< info
->dimen
; dim
++)
511 n
= loop
->order
[dim
];
512 if (n
< loop
->temp_dim
)
513 assert (integer_zerop (loop
->from
[n
]));
516 loop
->to
[n
] = fold (build (MINUS_EXPR
, gfc_array_index_type
,
517 loop
->to
[n
], loop
->from
[n
]));
518 loop
->from
[n
] = integer_zero_node
;
521 info
->delta
[dim
] = integer_zero_node
;
522 info
->start
[dim
] = integer_zero_node
;
523 info
->stride
[dim
] = integer_one_node
;
524 info
->dim
[dim
] = dim
;
527 /* Initialise the descriptor. */
529 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
530 desc
= gfc_create_var (type
, "atmp");
531 GFC_DECL_PACKED_ARRAY (desc
) = 1;
533 info
->descriptor
= desc
;
534 size
= integer_one_node
;
536 /* Fill in the array dtype. */
537 tmp
= gfc_conv_descriptor_dtype (desc
);
538 gfc_add_modify_expr (&loop
->pre
, tmp
,
539 GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (desc
)));
541 /* Fill in the bounds and stride. This is a packed array, so:
543 for (n = 0; n < rank; n++)
546 delta = ubound[n] + 1 - lbound[n];
549 size = size * sizeof(element); */
550 for (n
= 0; n
< info
->dimen
; n
++)
552 /* Store the stride and bound components in the descriptor. */
553 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
554 gfc_add_modify_expr (&loop
->pre
, tmp
, size
);
556 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
557 gfc_add_modify_expr (&loop
->pre
, tmp
, integer_zero_node
);
559 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
560 gfc_add_modify_expr (&loop
->pre
, tmp
, loop
->to
[n
]);
562 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
563 loop
->to
[n
], integer_one_node
));
565 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
566 size
= gfc_evaluate_now (size
, &loop
->pre
);
569 /* TODO: Where does the string length go? */
571 gfc_todo_error ("temporary arrays of strings");
573 /* Get the size of the array. */
575 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
,
576 TYPE_SIZE_UNIT (gfc_get_element_type (type
))));
578 gfc_trans_allocate_array_storage (loop
, info
, size
, nelem
);
580 if (info
->dimen
> loop
->temp_dim
)
581 loop
->temp_dim
= info
->dimen
;
587 /* Make sure offset is a variable. */
590 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
593 /* We should have already created the offset variable. We cannot
594 create it here because we may be in an inner scopde. */
595 assert (*offsetvar
!= NULL_TREE
);
596 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
597 *poffset
= *offsetvar
;
598 TREE_USED (*offsetvar
) = 1;
602 /* Add the contents of an array to the constructor. */
605 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
606 tree type ATTRIBUTE_UNUSED
,
607 tree pointer
, gfc_expr
* expr
,
608 tree
* poffset
, tree
* offsetvar
)
616 /* We need this to be a variable so we can increment it. */
617 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
619 gfc_init_se (&se
, NULL
);
621 /* Walk the array expression. */
622 ss
= gfc_walk_expr (expr
);
623 assert (ss
!= gfc_ss_terminator
);
625 /* Initialize the scalarizer. */
626 gfc_init_loopinfo (&loop
);
627 gfc_add_ss_to_loop (&loop
, ss
);
629 /* Initialize the loop. */
630 gfc_conv_ss_startstride (&loop
);
631 gfc_conv_loop_setup (&loop
);
633 /* Make the loop body. */
634 gfc_mark_ss_chain_used (ss
, 1);
635 gfc_start_scalarized_body (&loop
, &body
);
636 gfc_copy_loopinfo_to_se (&se
, &loop
);
639 gfc_conv_expr (&se
, expr
);
640 gfc_add_block_to_block (&body
, &se
.pre
);
642 /* Store the value. */
643 tmp
= gfc_build_indirect_ref (pointer
);
644 tmp
= gfc_build_array_ref (tmp
, *poffset
);
645 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
647 /* Increment the offset. */
648 tmp
= build (PLUS_EXPR
, gfc_array_index_type
, *poffset
, integer_one_node
);
649 gfc_add_modify_expr (&body
, *poffset
, tmp
);
651 /* Finish the loop. */
652 gfc_add_block_to_block (&body
, &se
.post
);
653 assert (se
.ss
== gfc_ss_terminator
);
654 gfc_trans_scalarizing_loops (&loop
, &body
);
655 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
656 tmp
= gfc_finish_block (&loop
.pre
);
657 gfc_add_expr_to_block (pblock
, tmp
);
659 gfc_cleanup_loop (&loop
);
663 /* Assign the values to the elements of an array constructor. */
666 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
667 tree pointer
, gfc_constructor
* c
,
668 tree
* poffset
, tree
* offsetvar
)
676 for (; c
; c
= c
->next
)
678 /* If this is an iterator or an array, the offset must be a variable. */
679 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
680 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
682 gfc_start_block (&body
);
684 if (c
->expr
->expr_type
== EXPR_ARRAY
)
686 /* Array constructors can be nested. */
687 gfc_trans_array_constructor_value (&body
, type
, pointer
,
688 c
->expr
->value
.constructor
,
691 else if (c
->expr
->rank
> 0)
693 gfc_trans_array_constructor_subarray (&body
, type
, pointer
,
694 c
->expr
, poffset
, offsetvar
);
698 /* This code really upsets the gimplifier so don't bother for now. */
705 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
713 gfc_init_se (&se
, NULL
);
714 gfc_conv_expr (&se
, c
->expr
);
715 gfc_add_block_to_block (&body
, &se
.pre
);
717 ref
= gfc_build_indirect_ref (pointer
);
718 ref
= gfc_build_array_ref (ref
, *poffset
);
719 gfc_add_modify_expr (&body
, ref
, se
.expr
);
720 gfc_add_block_to_block (&body
, &se
.post
);
722 *poffset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
723 *poffset
, integer_one_node
));
727 /* Collect multiple scalar constants into a constructor. */
735 /* Count the number of consecutive scalar constants. */
736 while (p
&& !(p
->iterator
737 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
739 gfc_init_se (&se
, NULL
);
740 gfc_conv_constant (&se
, p
->expr
);
741 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
746 bound
= build_int_2 (n
- 1, 0);
747 /* Create an array type to hold them. */
748 tmptype
= build_range_type (gfc_array_index_type
,
749 integer_zero_node
, bound
);
750 tmptype
= build_array_type (type
, tmptype
);
752 init
= build1 (CONSTRUCTOR
, tmptype
, nreverse (list
));
753 TREE_CONSTANT (init
) = 1;
754 TREE_INVARIANT (init
) = 1;
755 TREE_STATIC (init
) = 1;
756 /* Create a static variable to hold the data. */
757 tmp
= gfc_create_var (tmptype
, "data");
758 TREE_STATIC (tmp
) = 1;
759 TREE_CONSTANT (tmp
) = 1;
760 TREE_INVARIANT (tmp
) = 1;
761 DECL_INITIAL (tmp
) = init
;
764 /* Use BUILTIN_MEMCPY to assign the values. */
765 tmp
= gfc_build_indirect_ref (pointer
);
766 tmp
= gfc_build_array_ref (tmp
, *poffset
);
767 tmp
= gfc_build_addr_expr (NULL
, tmp
);
768 init
= gfc_build_addr_expr (NULL
, init
);
770 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
771 bound
= build_int_2 (n
* size
, 0);
772 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
773 tmp
= gfc_chainon_list (tmp
, init
);
774 tmp
= gfc_chainon_list (tmp
, bound
);
775 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_MEMCPY
],
777 gfc_add_expr_to_block (&body
, tmp
);
779 *poffset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
782 if (!INTEGER_CST_P (*poffset
))
784 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
785 *poffset
= *offsetvar
;
789 /* The frontend should already have done any expansions. */
797 loopbody
= gfc_finish_block (&body
);
799 gfc_init_se (&se
, NULL
);
800 gfc_conv_expr (&se
, c
->iterator
->var
);
801 gfc_add_block_to_block (pblock
, &se
.pre
);
804 /* Initialize thie loop. */
805 gfc_init_se (&se
, NULL
);
806 gfc_conv_expr_val (&se
, c
->iterator
->start
);
807 gfc_add_block_to_block (pblock
, &se
.pre
);
808 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
810 gfc_init_se (&se
, NULL
);
811 gfc_conv_expr_val (&se
, c
->iterator
->end
);
812 gfc_add_block_to_block (pblock
, &se
.pre
);
813 end
= gfc_evaluate_now (se
.expr
, pblock
);
815 gfc_init_se (&se
, NULL
);
816 gfc_conv_expr_val (&se
, c
->iterator
->step
);
817 gfc_add_block_to_block (pblock
, &se
.pre
);
818 step
= gfc_evaluate_now (se
.expr
, pblock
);
820 /* Generate the loop body. */
821 exit_label
= gfc_build_label_decl (NULL_TREE
);
822 gfc_start_block (&body
);
824 /* Generate the exit condition. */
825 end
= build (GT_EXPR
, boolean_type_node
, loopvar
, end
);
826 tmp
= build1_v (GOTO_EXPR
, exit_label
);
827 TREE_USED (exit_label
) = 1;
828 tmp
= build_v (COND_EXPR
, end
, tmp
, build_empty_stmt ());
829 gfc_add_expr_to_block (&body
, tmp
);
831 /* The main loop body. */
832 gfc_add_expr_to_block (&body
, loopbody
);
834 /* Increment the loop variable. */
835 tmp
= build (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
836 gfc_add_modify_expr (&body
, loopvar
, tmp
);
838 /* Finish the loop. */
839 tmp
= gfc_finish_block (&body
);
840 tmp
= build_v (LOOP_EXPR
, tmp
);
841 gfc_add_expr_to_block (pblock
, tmp
);
843 /* Add the exit label. */
844 tmp
= build1_v (LABEL_EXPR
, exit_label
);
845 gfc_add_expr_to_block (pblock
, tmp
);
849 /* Pass the code as is. */
850 tmp
= gfc_finish_block (&body
);
851 gfc_add_expr_to_block (pblock
, tmp
);
857 /* Get the size of an expression. Returns -1 if the size isn't constant.
858 Implied do loops with non-constant bounds are tricky because we must only
859 evaluate the bounds once. */
862 gfc_get_array_cons_size (mpz_t
* size
, gfc_constructor
* c
)
868 mpz_set_ui (*size
, 0);
872 for (; c
; c
= c
->next
)
874 if (c
->expr
->expr_type
== EXPR_ARRAY
)
876 /* A nested array constructor. */
877 gfc_get_array_cons_size (&len
, c
->expr
->value
.constructor
);
878 if (mpz_sgn (len
) < 0)
880 mpz_set (*size
, len
);
888 if (c
->expr
->rank
> 0)
890 mpz_set_si (*size
, -1);
902 if (i
->start
->expr_type
!= EXPR_CONSTANT
903 || i
->end
->expr_type
!= EXPR_CONSTANT
904 || i
->step
->expr_type
!= EXPR_CONSTANT
)
906 mpz_set_si (*size
, -1);
912 mpz_add (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
913 mpz_tdiv_q (val
, val
, i
->step
->value
.integer
);
914 mpz_add_ui (val
, val
, 1);
915 mpz_mul (len
, len
, val
);
917 mpz_add (*size
, *size
, len
);
924 /* Array constructors are handled by constructing a temporary, then using that
925 within the scalarization loop. This is not optimal, but seems by far the
929 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
937 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
938 gfc_todo_error ("Character string array constructors");
939 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
940 ss
->data
.info
.dimen
= loop
->dimen
;
942 gfc_trans_allocate_temp_array (loop
, &ss
->data
.info
, type
, NULL_TREE
);
944 desc
= ss
->data
.info
.descriptor
;
945 offset
= integer_zero_node
;
946 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
947 TREE_USED (offsetvar
) = 0;
948 gfc_trans_array_constructor_value (&loop
->pre
, type
,
950 ss
->expr
->value
.constructor
, &offset
,
953 if (TREE_USED (offsetvar
))
954 pushdecl (offsetvar
);
956 assert (INTEGER_CST_P (offset
));
958 /* Disable bound checking for now cos it's probably broken. */
959 if (flag_bounds_check
)
967 /* Add the pre and post chains for all the scalar expressions in a SS chain
968 to loop. This is called after the loop parameters have been calculated,
969 but before the actual scalarizing loops. */
973 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
980 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
987 /* Scalar expression. Evaluate this now. This includes elemental
988 dimension indices, but not array section bounds. */
989 gfc_init_se (&se
, NULL
);
990 gfc_conv_expr (&se
, ss
->expr
);
991 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
993 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
995 /* Move the evaluation of scalar expressions outside the
996 scalarization loop. */
998 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
999 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1000 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1003 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1005 ss
->data
.scalar
.expr
= se
.expr
;
1006 ss
->data
.scalar
.string_length
= se
.string_length
;
1009 case GFC_SS_REFERENCE
:
1010 /* Scalar reference. Evaluate this now. */
1011 gfc_init_se (&se
, NULL
);
1012 gfc_conv_expr_reference (&se
, ss
->expr
);
1013 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1014 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1016 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1017 ss
->data
.scalar
.string_length
= se
.string_length
;
1020 case GFC_SS_SECTION
:
1022 /* Scalarized expression. Evaluate any scalar subscripts. */
1023 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1025 /* Add the expressions for scalar subscripts. */
1026 if (ss
->data
.info
.subscript
[n
])
1027 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1031 case GFC_SS_INTRINSIC
:
1032 gfc_add_intrinsic_ss_code (loop
, ss
);
1035 case GFC_SS_FUNCTION
:
1036 /* Array function return value. We call the function and save its
1037 result in a temporary for use inside the loop. */
1038 gfc_init_se (&se
, NULL
);
1041 gfc_conv_expr (&se
, ss
->expr
);
1042 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1043 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1046 case GFC_SS_CONSTRUCTOR
:
1047 gfc_trans_array_constructor (loop
, ss
);
1057 /* Translate expressions for the descriptor and data pointer of a SS. */
1061 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1066 /* Get the descriptor for the array to be scalarized. */
1067 assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1068 gfc_init_se (&se
, NULL
);
1069 se
.descriptor_only
= 1;
1070 gfc_conv_expr_lhs (&se
, ss
->expr
);
1071 gfc_add_block_to_block (block
, &se
.pre
);
1072 ss
->data
.info
.descriptor
= se
.expr
;
1076 /* Also the data pointer. */
1077 tmp
= gfc_conv_array_data (se
.expr
);
1078 /* If this is a variable or address of a variable we use it directly.
1079 Otherwise we must evaluate it now to to avoid break dependency
1080 analysis by pulling the expressions for elemental array indices
1083 || (TREE_CODE (tmp
) == ADDR_EXPR
1084 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1085 tmp
= gfc_evaluate_now (tmp
, block
);
1086 ss
->data
.info
.data
= tmp
;
1088 tmp
= gfc_conv_array_offset (se
.expr
);
1089 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1094 /* Initialise a gfc_loopinfo structure. */
1097 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1101 memset (loop
, 0, sizeof (gfc_loopinfo
));
1102 gfc_init_block (&loop
->pre
);
1103 gfc_init_block (&loop
->post
);
1105 /* Initialy scalarize in order. */
1106 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1109 loop
->ss
= gfc_ss_terminator
;
1113 /* Copies the loop variable info to a gfc_se sructure. Does not copy the SS
1117 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1123 /* Return an expression for the data pointer of an array. */
1126 gfc_conv_array_data (tree descriptor
)
1130 type
= TREE_TYPE (descriptor
);
1131 if (GFC_ARRAY_TYPE_P (type
))
1133 if (TREE_CODE (type
) == POINTER_TYPE
)
1137 /* Descritporless arrays. */
1138 return gfc_build_addr_expr (NULL
, descriptor
);
1142 return gfc_conv_descriptor_data (descriptor
);
1146 /* Return an expression for the base offset of an array. */
1149 gfc_conv_array_offset (tree descriptor
)
1153 type
= TREE_TYPE (descriptor
);
1154 if (GFC_ARRAY_TYPE_P (type
))
1155 return GFC_TYPE_ARRAY_OFFSET (type
);
1157 return gfc_conv_descriptor_offset (descriptor
);
1161 /* Get an expression for the array stride. */
1164 gfc_conv_array_stride (tree descriptor
, int dim
)
1169 type
= TREE_TYPE (descriptor
);
1171 /* For descriptorless arrays use the array size. */
1172 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1173 if (tmp
!= NULL_TREE
)
1176 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1181 /* Like gfc_conv_array_stride, but for the lower bound. */
1184 gfc_conv_array_lbound (tree descriptor
, int dim
)
1189 type
= TREE_TYPE (descriptor
);
1191 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1192 if (tmp
!= NULL_TREE
)
1195 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1200 /* Like gfc_conv_array_stride, but for the upper bound. */
1203 gfc_conv_array_ubound (tree descriptor
, int dim
)
1208 type
= TREE_TYPE (descriptor
);
1210 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1211 if (tmp
!= NULL_TREE
)
1214 /* This should only ever happen when passing an assumed shape array
1215 as an actual parameter. The value will never be used. */
1216 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1217 return integer_zero_node
;
1219 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1224 /* Translate an array reference. The descriptor should be in se->expr.
1225 Do not use this function, it wil be removed soon. */
1229 gfc_conv_array_index_ref (gfc_se
* se
, tree pointer
, tree
* indices
,
1230 tree offset
, int dimen
)
1237 array
= gfc_build_indirect_ref (pointer
);
1240 for (n
= 0; n
< dimen
; n
++)
1242 /* index = index + stride[n]*indices[n] */
1243 tmp
= gfc_conv_array_stride (se
->expr
, n
);
1244 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, indices
[n
], tmp
));
1246 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1249 /* Result = data[index]. */
1250 tmp
= gfc_build_array_ref (array
, index
);
1252 /* Check we've used the correct number of dimensions. */
1253 assert (TREE_CODE (TREE_TYPE (tmp
)) != ARRAY_TYPE
);
1259 /* Generate code to perform an array index bound check. */
1262 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
)
1268 if (!flag_bounds_check
)
1271 index
= gfc_evaluate_now (index
, &se
->pre
);
1272 /* Check lower bound. */
1273 tmp
= gfc_conv_array_lbound (descriptor
, n
);
1274 fault
= fold (build (LT_EXPR
, boolean_type_node
, index
, tmp
));
1275 /* Check upper bound. */
1276 tmp
= gfc_conv_array_ubound (descriptor
, n
);
1277 cond
= fold (build (GT_EXPR
, boolean_type_node
, index
, tmp
));
1278 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1280 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1286 /* A reference to an array vector subscript. Uses recursion to handle nested
1287 vector subscripts. */
1290 gfc_conv_vector_array_index (gfc_se
* se
, tree index
, gfc_ss
* ss
)
1293 tree indices
[GFC_MAX_DIMENSIONS
];
1298 assert (ss
&& ss
->type
== GFC_SS_VECTOR
);
1300 /* Save the descriptor. */
1301 descsave
= se
->expr
;
1302 info
= &ss
->data
.info
;
1303 se
->expr
= info
->descriptor
;
1305 ar
= &info
->ref
->u
.ar
;
1306 for (n
= 0; n
< ar
->dimen
; n
++)
1308 switch (ar
->dimen_type
[n
])
1311 assert (info
->subscript
[n
] != gfc_ss_terminator
1312 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
1313 indices
[n
] = info
->subscript
[n
]->data
.scalar
.expr
;
1321 index
= gfc_conv_vector_array_index (se
, index
, info
->subscript
[n
]);
1324 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, n
);
1331 /* Get the index from the vector. */
1332 gfc_conv_array_index_ref (se
, info
->data
, indices
, info
->offset
, ar
->dimen
);
1334 /* Put the descriptor back. */
1335 se
->expr
= descsave
;
1341 /* Return the offset for an index. Performs bound checking for elemental
1342 dimensions. Single element references are processed seperately. */
1345 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
1346 gfc_array_ref
* ar
, tree stride
)
1350 /* Get the index into the array for this dimension. */
1353 assert (ar
->type
!= AR_ELEMENT
);
1354 if (ar
->dimen_type
[dim
] == DIMEN_ELEMENT
)
1357 /* Elemental dimension. */
1358 assert (info
->subscript
[dim
]
1359 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
1360 /* We've already translated this value outside the loop. */
1361 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
1364 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, dim
);
1368 /* Scalarized dimension. */
1369 assert (info
&& se
->loop
);
1371 /* Multiply the loop variable by the stride and dela. */
1372 index
= se
->loop
->loopvar
[i
];
1373 index
= fold (build (MULT_EXPR
, gfc_array_index_type
, index
,
1375 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
,
1378 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
1380 /* Handle vector subscripts. */
1381 index
= gfc_conv_vector_array_index (se
, index
,
1382 info
->subscript
[dim
]);
1384 gfc_trans_array_bound_check (se
, info
->descriptor
, index
,
1388 assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
);
1393 /* Temporary array. */
1395 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
1398 /* Multiply by the stride. */
1399 index
= fold (build (MULT_EXPR
, gfc_array_index_type
, index
, stride
));
1405 /* Build a scalarized reference to an array. */
1408 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1415 info
= &se
->ss
->data
.info
;
1417 n
= se
->loop
->order
[0];
1421 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
1423 /* Add the offset for this dimension to the stored offset for all other
1425 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
));
1427 tmp
= gfc_build_indirect_ref (info
->data
);
1428 se
->expr
= gfc_build_array_ref (tmp
, index
);
1432 /* Translate access of temporary array. */
1435 gfc_conv_tmp_array_ref (gfc_se
* se
)
1439 desc
= se
->ss
->data
.info
.descriptor
;
1440 /* TODO: We need the string length for string variables. */
1442 gfc_conv_scalarized_array_ref (se
, NULL
);
1446 /* Build an array reference. se->expr already holds the array descriptor.
1447 This should be either a variable, indirect variable reference or component
1448 reference. For arrays which do not have a descriptor, se->expr will be
1450 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1453 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1462 /* Handle scalarized references seperately. */
1463 if (ar
->type
!= AR_ELEMENT
)
1465 gfc_conv_scalarized_array_ref (se
, ar
);
1469 index
= integer_zero_node
;
1471 fault
= integer_zero_node
;
1473 /* Calculate the offsets from all the dimensions. */
1474 for (n
= 0; n
< ar
->dimen
; n
++)
1476 /* Calculate the index for this demension. */
1477 gfc_init_se (&indexse
, NULL
);
1478 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
1479 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
1481 if (flag_bounds_check
)
1483 /* Check array bounds. */
1486 indexse
.expr
= gfc_evaluate_now (indexse
.expr
, &se
->pre
);
1488 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
1489 cond
= fold (build (LT_EXPR
, boolean_type_node
, indexse
.expr
, tmp
));
1491 fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1493 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
1494 cond
= fold (build (GT_EXPR
, boolean_type_node
, indexse
.expr
, tmp
));
1496 fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
));
1499 /* Multiply the index by the stride. */
1500 stride
= gfc_conv_array_stride (se
->expr
, n
);
1501 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
1504 /* And add it to the total. */
1505 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1508 if (flag_bounds_check
)
1509 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1511 tmp
= gfc_conv_array_offset (se
->expr
);
1512 if (!integer_zerop (tmp
))
1513 index
= fold (build (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
));
1515 /* Access the calculated element. */
1516 tmp
= gfc_conv_array_data (se
->expr
);
1517 tmp
= gfc_build_indirect_ref (tmp
);
1518 se
->expr
= gfc_build_array_ref (tmp
, index
);
1522 /* Generate the code to be executed immediately before entering a
1523 scalarization loop. */
1526 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
1527 stmtblock_t
* pblock
)
1536 /* This code will be executed before entering the scalarization loop
1537 for this dimension. */
1538 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1540 if ((ss
->useflags
& flag
) == 0)
1543 if (ss
->type
!= GFC_SS_SECTION
1544 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
)
1547 info
= &ss
->data
.info
;
1549 if (dim
>= info
->dimen
)
1552 if (dim
== info
->dimen
- 1)
1554 /* For the outermost loop calculate the offset due to any
1555 elemental dimensions. It will have been initialized with the
1556 base offset of the array. */
1559 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
1561 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1564 gfc_init_se (&se
, NULL
);
1566 se
.expr
= info
->descriptor
;
1567 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
1568 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
1571 gfc_add_block_to_block (pblock
, &se
.pre
);
1573 info
->offset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
1574 info
->offset
, index
));
1575 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1579 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1582 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
1584 /* Calculate the stride of the innermost loop. Hopefully this will
1585 allow the backend optimizers to do their stuff more effectively.
1587 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
1591 /* Add the offset for the previous loop dimension. */
1596 ar
= &info
->ref
->u
.ar
;
1597 i
= loop
->order
[dim
+ 1];
1605 gfc_init_se (&se
, NULL
);
1607 se
.expr
= info
->descriptor
;
1608 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1609 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
1611 gfc_add_block_to_block (pblock
, &se
.pre
);
1612 info
->offset
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
1613 info
->offset
, index
));
1614 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1617 /* Remeber this offset for the second loop. */
1618 if (dim
== loop
->temp_dim
- 1)
1619 info
->saved_offset
= info
->offset
;
1624 /* Start a scalarized expression. Creates a scope and declares loop
1628 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
1634 assert (!loop
->array_parameter
);
1636 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
1638 n
= loop
->order
[dim
];
1640 gfc_start_block (&loop
->code
[n
]);
1642 /* Create the loop variable. */
1643 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
1645 if (dim
< loop
->temp_dim
)
1649 /* Calculate values that will be constant within this loop. */
1650 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
1652 gfc_start_block (pbody
);
1656 /* Generates the actual loop code for a scalarization loop. */
1659 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
1660 stmtblock_t
* pbody
)
1668 loopbody
= gfc_finish_block (pbody
);
1670 /* Initialize the loopvar. */
1671 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
1673 exit_label
= gfc_build_label_decl (NULL_TREE
);
1675 /* Generate the loop body. */
1676 gfc_init_block (&block
);
1678 /* The exit condition. */
1679 cond
= build (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
1680 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1681 TREE_USED (exit_label
) = 1;
1682 tmp
= build_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1683 gfc_add_expr_to_block (&block
, tmp
);
1685 /* The main body. */
1686 gfc_add_expr_to_block (&block
, loopbody
);
1688 /* Increment the loopvar. */
1689 tmp
= build (PLUS_EXPR
, gfc_array_index_type
,
1690 loop
->loopvar
[n
], integer_one_node
);
1691 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
1693 /* Build the loop. */
1694 tmp
= gfc_finish_block (&block
);
1695 tmp
= build_v (LOOP_EXPR
, tmp
);
1696 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1698 /* Add the exit label. */
1699 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1700 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1704 /* Finishes and generates the loops for a scalarized expression. */
1707 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1712 stmtblock_t
*pblock
;
1716 /* Generate the loops. */
1717 for (dim
= 0; dim
< loop
->dimen
; dim
++)
1719 n
= loop
->order
[dim
];
1720 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1721 loop
->loopvar
[n
] = NULL_TREE
;
1722 pblock
= &loop
->code
[n
];
1725 tmp
= gfc_finish_block (pblock
);
1726 gfc_add_expr_to_block (&loop
->pre
, tmp
);
1728 /* Clear all the used flags. */
1729 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
1734 /* Finish the main body of a scalarized expression, and start the secondary
1738 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1742 stmtblock_t
*pblock
;
1746 /* We finish as many loops as are used by the temporary. */
1747 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
1749 n
= loop
->order
[dim
];
1750 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1751 loop
->loopvar
[n
] = NULL_TREE
;
1752 pblock
= &loop
->code
[n
];
1755 /* We don't want to finish the outermost loop entirely. */
1756 n
= loop
->order
[loop
->temp_dim
- 1];
1757 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1759 /* Restore the initial offsets. */
1760 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1762 if ((ss
->useflags
& 2) == 0)
1765 if (ss
->type
!= GFC_SS_SECTION
1766 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
)
1769 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
1772 /* Restart all the inner loops we just finished. */
1773 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
1775 n
= loop
->order
[dim
];
1777 gfc_start_block (&loop
->code
[n
]);
1779 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
1781 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
1784 /* Start a block for the secondary copying code. */
1785 gfc_start_block (body
);
1789 /* Calculate the upper bound of an array section. */
1792 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
1801 assert (ss
->type
== GFC_SS_SECTION
);
1803 /* For vector array subscripts we want the size of the vector. */
1804 dim
= ss
->data
.info
.dim
[n
];
1806 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
1808 vecss
= vecss
->data
.info
.subscript
[dim
];
1809 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
1810 dim
= vecss
->data
.info
.dim
[0];
1813 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
1814 end
= vecss
->data
.info
.ref
->u
.ar
.end
[dim
];
1815 desc
= vecss
->data
.info
.descriptor
;
1819 /* The upper bound was specified. */
1820 gfc_init_se (&se
, NULL
);
1821 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
1822 gfc_add_block_to_block (pblock
, &se
.pre
);
1827 /* No upper bound was specified, so use the bound of the array. */
1828 bound
= gfc_conv_array_ubound (desc
, dim
);
1835 /* Calculate the lower bound of an array section. */
1838 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
1848 info
= &ss
->data
.info
;
1852 /* For vector array subscripts we want the size of the vector. */
1854 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
1856 vecss
= vecss
->data
.info
.subscript
[dim
];
1857 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
1858 /* Get the descriptors for the vector subscripts as well. */
1859 if (!vecss
->data
.info
.descriptor
)
1860 gfc_conv_ss_descriptor (&loop
->pre
, vecss
, !loop
->array_parameter
);
1861 dim
= vecss
->data
.info
.dim
[0];
1864 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
1865 start
= vecss
->data
.info
.ref
->u
.ar
.start
[dim
];
1866 stride
= vecss
->data
.info
.ref
->u
.ar
.stride
[dim
];
1867 desc
= vecss
->data
.info
.descriptor
;
1869 /* Calculate the start of the range. For vector subscripts this will
1870 be the range of the vector. */
1873 /* Specified section start. */
1874 gfc_init_se (&se
, NULL
);
1875 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
1876 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1877 info
->start
[n
] = se
.expr
;
1881 /* No lower bound specified so use the bound of the array. */
1882 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
1884 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
1886 /* Calculate the stride. */
1888 info
->stride
[n
] = integer_one_node
;
1891 gfc_init_se (&se
, NULL
);
1892 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
1893 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1894 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
1899 /* Calculates the range start and stride for a SS chain. Also gets the
1900 descriptor and data pointer. The range of vector subscripts is the size
1901 of the vector. Array bounds are also checked. */
1904 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
1913 /* Determine the rank of the loop. */
1915 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
1919 case GFC_SS_SECTION
:
1920 case GFC_SS_CONSTRUCTOR
:
1921 case GFC_SS_FUNCTION
:
1922 loop
->dimen
= ss
->data
.info
.dimen
;
1930 if (loop
->dimen
== 0)
1931 gfc_todo_error ("Unable to determine rank of expression");
1934 /* loop over all the SS in the chain. */
1935 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1939 case GFC_SS_SECTION
:
1940 /* Get the descriptor for the array. */
1941 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
1943 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
1944 gfc_conv_section_startstride (loop
, ss
, n
);
1947 case GFC_SS_CONSTRUCTOR
:
1948 case GFC_SS_FUNCTION
:
1949 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
1951 ss
->data
.info
.start
[n
] = integer_zero_node
;
1952 ss
->data
.info
.stride
[n
] = integer_one_node
;
1961 /* The rest is just runtime bound checking. */
1962 if (flag_bounds_check
)
1968 tree size
[GFC_MAX_DIMENSIONS
];
1972 gfc_start_block (&block
);
1974 fault
= integer_zero_node
;
1975 for (n
= 0; n
< loop
->dimen
; n
++)
1976 size
[n
] = NULL_TREE
;
1978 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1980 if (ss
->type
!= GFC_SS_SECTION
)
1983 /* TODO: range checking for mapped dimensions. */
1984 info
= &ss
->data
.info
;
1986 /* This only checks scalarized dimensions, elemental dimensions are
1988 for (n
= 0; n
< loop
->dimen
; n
++)
1992 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
1995 vecss
= vecss
->data
.info
.subscript
[dim
];
1996 assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
1997 dim
= vecss
->data
.info
.dim
[0];
1999 assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2001 desc
= vecss
->data
.info
.descriptor
;
2003 /* Check lower bound. */
2004 bound
= gfc_conv_array_lbound (desc
, dim
);
2005 tmp
= info
->start
[n
];
2006 tmp
= fold (build (LT_EXPR
, boolean_type_node
, tmp
, bound
));
2007 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2010 /* Check the upper bound. */
2011 bound
= gfc_conv_array_ubound (desc
, dim
);
2012 end
= gfc_conv_section_upper_bound (ss
, n
, &block
);
2013 tmp
= fold (build (GT_EXPR
, boolean_type_node
, end
, bound
));
2014 fault
= fold (build (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2017 /* Check the section sizes match. */
2018 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, end
,
2020 tmp
= fold (build (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2022 /* We remember the size of the first section, and check all the
2023 others against this. */
2027 fold (build (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]));
2029 build (TRUTH_OR_EXPR
, boolean_type_node
, fault
, tmp
);
2032 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2035 gfc_trans_runtime_check (fault
, gfc_strconst_bounds
, &block
);
2037 tmp
= gfc_finish_block (&block
);
2038 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2043 /* Return true if the two SS could be aliased, ie. both point to the same data
2045 /* TODO: resolve aliases based on frontend expressions. */
2048 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2055 lsym
= lss
->expr
->symtree
->n
.sym
;
2056 rsym
= rss
->expr
->symtree
->n
.sym
;
2057 if (gfc_symbols_could_alias (lsym
, rsym
))
2060 if (rsym
->ts
.type
!= BT_DERIVED
2061 && lsym
->ts
.type
!= BT_DERIVED
)
2064 /* For Derived types we must check all the component types. We can ignore
2065 array references as these will have the same base type as the previous
2067 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2069 if (lref
->type
!= REF_COMPONENT
)
2072 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2075 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2078 if (rref
->type
!= REF_COMPONENT
)
2081 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2086 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2088 if (rref
->type
!= REF_COMPONENT
)
2091 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2099 /* Resolve array data dependencies. Creates a temporary if required. */
2100 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2104 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2114 loop
->temp_ss
= NULL
;
2115 aref
= dest
->data
.info
.ref
;
2118 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2120 if (ss
->type
!= GFC_SS_SECTION
)
2123 if (gfc_could_be_alias (dest
, ss
))
2129 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
2131 lref
= dest
->expr
->ref
;
2132 rref
= ss
->expr
->ref
;
2134 nDepend
= gfc_dep_resolver (lref
, rref
);
2136 /* TODO : loop shifting. */
2139 /* Mark the dimensions for LOOP SHIFTING */
2140 for (n
= 0; n
< loop
->dimen
; n
++)
2142 int dim
= dest
->data
.info
.dim
[n
];
2144 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2146 else if (! gfc_is_same_range (&lref
->u
.ar
,
2147 &rref
->u
.ar
, dim
, 0))
2151 /* Put all the dimensions with dependancies in the
2154 for (n
= 0; n
< loop
->dimen
; n
++)
2156 assert (loop
->order
[n
] == n
);
2158 loop
->order
[dim
++] = n
;
2161 for (n
= 0; n
< loop
->dimen
; n
++)
2164 loop
->order
[dim
++] = n
;
2167 assert (dim
== loop
->dimen
);
2176 loop
->temp_ss
= gfc_get_ss ();
2177 loop
->temp_ss
->type
= GFC_SS_TEMP
;
2178 loop
->temp_ss
->data
.temp
.type
=
2179 gfc_get_element_type (TREE_TYPE (dest
->data
.info
.descriptor
));
2180 loop
->temp_ss
->data
.temp
.string_length
= NULL_TREE
;
2181 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
2182 loop
->temp_ss
->next
= gfc_ss_terminator
;
2183 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
2186 loop
->temp_ss
= NULL
;
2190 /* Initialise the scalarization loop. Creates the loop variables. Determines
2191 the range of the loop variables. Creates a temporary if required.
2192 Calculates how to transform from loop variables to array indices for each
2193 expression. Also generates code for scalar expressions which have been
2194 moved outside the loop. */
2197 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
2202 gfc_ss_info
*specinfo
;
2206 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
2211 for (n
= 0; n
< loop
->dimen
; n
++)
2214 /* We use one SS term, and use that to determine the bounds of the
2215 loop for this dimension. We try to pick the simplest term. */
2216 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2218 if (ss
->expr
&& ss
->expr
->shape
)
2220 /* The frontend has worked out the size for us. */
2225 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
2227 /* Try to figure out the size of the constructior. */
2228 /* TODO: avoid this by making the prontend set the shape. */
2229 gfc_get_array_cons_size (&i
, ss
->expr
->value
.constructor
);
2230 /* A negative value meens we failed. */
2231 if (mpz_sgn (i
) > 0)
2233 mpz_sub_ui (i
, i
, 1);
2235 gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2241 /* We don't know how to handle functions yet.
2242 This may not be possible in all cases. */
2243 if (ss
->type
!= GFC_SS_SECTION
)
2246 info
= &ss
->data
.info
;
2249 specinfo
= &loopspec
[n
]->data
.info
;
2252 info
= &ss
->data
.info
;
2254 /* Criteria for choosing a loop specifier (most important first):
2262 else if (loopspec
[n
]->type
!= GFC_SS_CONSTRUCTOR
)
2264 if (integer_onep (info
->stride
[n
])
2265 && !integer_onep (specinfo
->stride
[n
]))
2267 else if (INTEGER_CST_P (info
->stride
[n
])
2268 && !INTEGER_CST_P (specinfo
->stride
[n
]))
2270 else if (INTEGER_CST_P (info
->start
[n
])
2271 && !INTEGER_CST_P (specinfo
->start
[n
]))
2273 /* We don't work out the upper bound.
2274 else if (INTEGER_CST_P (info->finish[n])
2275 && ! INTEGER_CST_P (specinfo->finish[n]))
2276 loopspec[n] = ss; */
2281 gfc_todo_error ("Unable to find scalarization loop specifier");
2283 info
= &loopspec
[n
]->data
.info
;
2285 /* Set the extents of this range. */
2286 cshape
= loopspec
[n
]->expr
->shape
;
2287 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
2288 && INTEGER_CST_P (info
->stride
[n
]))
2290 loop
->from
[n
] = info
->start
[n
];
2291 mpz_set (i
, cshape
[n
]);
2292 mpz_sub_ui (i
, i
, 1);
2293 /* To = from + (size - 1) * stride. */
2294 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2295 if (!integer_onep (info
->stride
[n
]))
2297 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
,
2298 tmp
, info
->stride
[n
]));
2300 loop
->to
[n
] = fold (build (PLUS_EXPR
, gfc_array_index_type
,
2301 loop
->from
[n
], tmp
));
2305 loop
->from
[n
] = info
->start
[n
];
2306 switch (loopspec
[n
]->type
)
2308 case GFC_SS_CONSTRUCTOR
:
2309 assert (info
->dimen
== 1);
2310 assert (loop
->to
[n
]);
2313 case GFC_SS_SECTION
:
2314 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
2323 /* Transform everything so we have a simple incrementing variable. */
2324 if (integer_onep (info
->stride
[n
]))
2325 info
->delta
[n
] = integer_zero_node
;
2328 /* Set the delta for this section. */
2329 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
2330 /* Number of iterations is (end - start + step) / step.
2331 with start = 0, this simplifies to
2333 for (i = 0; i<=last; i++){...}; */
2334 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, loop
->to
[n
],
2336 tmp
= fold (build (TRUNC_DIV_EXPR
, gfc_array_index_type
, tmp
,
2338 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2339 /* Make the loop variable start at 0. */
2340 loop
->from
[n
] = integer_zero_node
;
2344 /* If we want a temporary then create it. */
2345 if (loop
->temp_ss
!= NULL
)
2347 assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
2348 tmp
= loop
->temp_ss
->data
.temp
.type
;
2349 len
= loop
->temp_ss
->data
.temp
.string_length
;
2350 n
= loop
->temp_ss
->data
.temp
.dimen
;
2351 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
2352 loop
->temp_ss
->type
= GFC_SS_SECTION
;
2353 loop
->temp_ss
->data
.info
.dimen
= n
;
2354 gfc_trans_allocate_temp_array (loop
, &loop
->temp_ss
->data
.info
,
2358 /* Add all the scalar code that can be taken out of the loops. */
2359 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
2361 for (n
= 0; n
< loop
->temp_dim
; n
++)
2362 loopspec
[loop
->order
[n
]] = NULL
;
2366 /* For array parameters we don't have loop variables, so don't calculate the
2368 if (loop
->array_parameter
)
2371 /* Calculate the translation from loop variables to array indices. */
2372 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2374 if (ss
->type
!= GFC_SS_SECTION
)
2377 info
= &ss
->data
.info
;
2379 for (n
= 0; n
< info
->dimen
; n
++)
2383 /* If we are specifying the range the delta may already be set. */
2384 if (loopspec
[n
] != ss
)
2386 /* Calculate the offset relative to the loop variable.
2387 First multiply by the stride. */
2388 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
,
2389 loop
->from
[n
], info
->stride
[n
]));
2391 /* Then subtract this from our starting value. */
2392 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
2393 info
->start
[n
], tmp
));
2395 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2402 /* Fills in an array descriptor, and returns the size of the array. The size
2403 will be a simple_val, ie a variable or a constant. Also calculates the
2404 offset of the base. Returns the size of the arrary.
2408 for (n = 0; n < rank; n++)
2410 a.lbound[n] = specified_lower_bound;
2411 offset = offset + a.lbond[n] * stride;
2413 a.ubound[n] = specified_upper_bound;
2414 a.stride[n] = stride;
2415 size = ubound + size; //size = ubound + 1 - lbound
2416 stride = stride * size;
2423 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
2424 gfc_expr
** lower
, gfc_expr
** upper
,
2425 stmtblock_t
* pblock
)
2436 type
= TREE_TYPE (descriptor
);
2438 stride
= integer_one_node
;
2439 offset
= integer_zero_node
;
2441 /* Set the dtype. */
2442 tmp
= gfc_conv_descriptor_dtype (descriptor
);
2443 gfc_add_modify_expr (pblock
, tmp
,
2444 GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (descriptor
)));
2446 for (n
= 0; n
< rank
; n
++)
2448 /* We have 3 possibilities for determining the size of the array:
2449 lower == NULL => lbound = 1, ubound = upper[n]
2450 upper[n] = NULL => lbound = 1, ubound = lower[n]
2451 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2454 /* Set lower bound. */
2455 gfc_init_se (&se
, NULL
);
2457 se
.expr
= integer_one_node
;
2463 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
2464 gfc_add_block_to_block (pblock
, &se
.pre
);
2468 se
.expr
= integer_one_node
;
2472 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
2473 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2475 /* Work out the offset for this component. */
2476 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
));
2477 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
2479 /* Start the calculation for the size of this dimension. */
2480 size
= build (MINUS_EXPR
, gfc_array_index_type
,
2481 integer_one_node
, se
.expr
);
2483 /* Set upper bound. */
2484 gfc_init_se (&se
, NULL
);
2486 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
2487 gfc_add_block_to_block (pblock
, &se
.pre
);
2489 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
2490 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2492 /* Store the stride. */
2493 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
2494 gfc_add_modify_expr (pblock
, tmp
, stride
);
2496 /* Calculate the size of this dimension. */
2497 size
= fold (build (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
));
2499 /* Multiply the stride by the number of elements in this dimension. */
2500 stride
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
, size
));
2501 stride
= gfc_evaluate_now (stride
, pblock
);
2504 /* The stride is the number of elements in the array, so multiply by the
2505 size of an element to get the total size. */
2506 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2507 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
));
2509 if (poffset
!= NULL
)
2511 offset
= gfc_evaluate_now (offset
, pblock
);
2515 size
= gfc_evaluate_now (size
, pblock
);
2520 /* Initialises the descriptor and generates a call to _gfor_allocate. Does
2521 the work for an ALLOCATE statement. */
2525 gfc_array_allocate (gfc_se
* se
, gfc_ref
* ref
, tree pstat
)
2535 /* Figure out the size of the array. */
2536 switch (ref
->u
.ar
.type
)
2540 upper
= ref
->u
.ar
.start
;
2544 assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
2546 lower
= ref
->u
.ar
.as
->lower
;
2547 upper
= ref
->u
.ar
.as
->upper
;
2551 lower
= ref
->u
.ar
.start
;
2552 upper
= ref
->u
.ar
.end
;
2560 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
2561 lower
, upper
, &se
->pre
);
2563 /* Allocate memory to store the data. */
2564 tmp
= gfc_conv_descriptor_data (se
->expr
);
2565 pointer
= gfc_build_addr_expr (NULL
, tmp
);
2566 pointer
= gfc_evaluate_now (pointer
, &se
->pre
);
2568 if (gfc_array_index_type
== gfc_int4_type_node
)
2569 allocate
= gfor_fndecl_allocate
;
2570 else if (gfc_array_index_type
== gfc_int8_type_node
)
2571 allocate
= gfor_fndecl_allocate64
;
2575 tmp
= gfc_chainon_list (NULL_TREE
, pointer
);
2576 tmp
= gfc_chainon_list (tmp
, size
);
2577 tmp
= gfc_chainon_list (tmp
, pstat
);
2578 tmp
= gfc_build_function_call (allocate
, tmp
);
2579 gfc_add_expr_to_block (&se
->pre
, tmp
);
2581 pointer
= gfc_conv_descriptor_data (se
->expr
);
2583 tmp
= gfc_conv_descriptor_offset (se
->expr
);
2584 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
2588 /* Deallocate an array variable. Also used when an allocated variable goes
2593 gfc_array_deallocate (tree descriptor
)
2599 gfc_start_block (&block
);
2600 /* Get a pointer to the data. */
2601 tmp
= gfc_conv_descriptor_data (descriptor
);
2602 tmp
= gfc_build_addr_expr (NULL
, tmp
);
2603 var
= gfc_create_var (TREE_TYPE (tmp
), "ptr");
2604 gfc_add_modify_expr (&block
, var
, tmp
);
2606 /* Parameter is the address of the data component. */
2607 tmp
= gfc_chainon_list (NULL_TREE
, var
);
2608 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
2609 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
2610 gfc_add_expr_to_block (&block
, tmp
);
2612 return gfc_finish_block (&block
);
2616 /* Create an array constructor from an initialization expression.
2617 We assume the frontend already did any expansions and conversions. */
2620 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
2628 unsigned HOST_WIDE_INT lo
;
2632 switch (expr
->expr_type
)
2635 case EXPR_STRUCTURE
:
2636 /* A single scalar or derived type value. Create an array with all
2637 elements equal to that value. */
2638 gfc_init_se (&se
, NULL
);
2639 gfc_conv_expr (&se
, expr
);
2641 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2642 assert (tmp
&& INTEGER_CST_P (tmp
));
2643 hi
= TREE_INT_CST_HIGH (tmp
);
2644 lo
= TREE_INT_CST_LOW (tmp
);
2648 /* This will probably eat buckets of memory for large arrays. */
2649 while (hi
!= 0 || lo
!= 0)
2651 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
2659 /* Create a list of all the elements. */
2660 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2664 /* Problems occur when we get something like
2665 integer :: a(lots) = (/(i, i=1,lots)/) */
2666 /* TODO: Unexpanded array initializers. */
2668 ("Possible frontend bug: array constructor not expanded");
2670 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2671 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2675 if (mpz_cmp_si (c
->repeat
, 0) != 0)
2679 mpz_set (maxval
, c
->repeat
);
2680 mpz_add (maxval
, c
->n
.offset
, maxval
);
2681 mpz_sub_ui (maxval
, maxval
, 1);
2682 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2683 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2685 mpz_add_ui (maxval
, c
->n
.offset
, 1);
2686 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2689 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2691 range
= build (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
2697 gfc_init_se (&se
, NULL
);
2698 switch (c
->expr
->expr_type
)
2701 gfc_conv_constant (&se
, c
->expr
);
2702 if (range
== NULL_TREE
)
2703 list
= tree_cons (index
, se
.expr
, list
);
2706 if (index
!= NULL_TREE
)
2707 list
= tree_cons (index
, se
.expr
, list
);
2708 list
= tree_cons (range
, se
.expr
, list
);
2712 case EXPR_STRUCTURE
:
2713 gfc_conv_structure (&se
, c
->expr
, 1);
2714 list
= tree_cons (index
, se
.expr
, list
);
2721 /* We created the list in reverse order. */
2722 list
= nreverse (list
);
2729 /* Create a constructor from the list of elements. */
2730 tmp
= build1 (CONSTRUCTOR
, type
, list
);
2731 TREE_CONSTANT (tmp
) = 1;
2732 TREE_INVARIANT (tmp
) = 1;
2737 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2738 returns the size (in elements) of the array. */
2741 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
2742 stmtblock_t
* pblock
)
2757 size
= integer_one_node
;
2758 offset
= integer_zero_node
;
2759 for (dim
= 0; dim
< as
->rank
; dim
++)
2761 /* Evaluate non-constant array bound expressions. */
2762 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2763 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
2765 gfc_init_se (&se
, NULL
);
2766 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
2767 gfc_add_block_to_block (pblock
, &se
.pre
);
2768 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
2770 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2771 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
2773 gfc_init_se (&se
, NULL
);
2774 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
2775 gfc_add_block_to_block (pblock
, &se
.pre
);
2776 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
2778 /* The offset of this dimension. offset = offset - lbound * stride. */
2779 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, lbound
, size
));
2780 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
2782 /* The size of this dimension, and the stride of the next. */
2783 if (dim
+ 1 < as
->rank
)
2784 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
2788 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
2790 /* Calculate stride = size * (ubound + 1 - lbound). */
2791 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
2792 integer_one_node
, lbound
));
2793 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
));
2794 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2796 gfc_add_modify_expr (pblock
, stride
, tmp
);
2798 stride
= gfc_evaluate_now (tmp
, pblock
);
2809 /* Generate code to initialize/allocate an array variable. */
2812 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
2823 assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
2825 /* Do nothing for USEd variables. */
2826 if (sym
->attr
.use_assoc
)
2829 type
= TREE_TYPE (decl
);
2830 assert (GFC_ARRAY_TYPE_P (type
));
2831 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
2833 /* We never generate initialization code of module variables. */
2834 if (fnbody
== NULL_TREE
)
2838 /* Generate static initializer. */
2841 DECL_INITIAL (decl
) =
2842 gfc_conv_array_initializer (TREE_TYPE (decl
), sym
->value
);
2847 gfc_start_block (&block
);
2849 /* Evaluate character string length. */
2850 if (sym
->ts
.type
== BT_CHARACTER
2851 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2853 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2855 DECL_DEFER_OUTPUT (decl
) = 1;
2857 /* Generate code to allocate the automatic variable. It will be
2858 freed automatically. */
2859 tmp
= gfc_build_addr_expr (NULL
, decl
);
2860 args
= gfc_chainon_list (NULL_TREE
, tmp
);
2861 args
= gfc_chainon_list (args
, sym
->ts
.cl
->backend_decl
);
2862 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_STACK_ALLOC
],
2864 gfc_add_expr_to_block (&block
, tmp
);
2871 DECL_INITIAL (decl
) =
2872 gfc_conv_array_initializer (TREE_TYPE (decl
), sym
->value
);
2875 gfc_add_expr_to_block (&block
, fnbody
);
2876 return gfc_finish_block (&block
);
2879 type
= TREE_TYPE (type
);
2881 assert (!sym
->attr
.use_assoc
);
2882 assert (!TREE_STATIC (decl
));
2883 assert (!sym
->module
[0]);
2885 if (sym
->ts
.type
== BT_CHARACTER
2886 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2887 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2889 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
2891 /* The size is the number of elements in the array, so multiply by the
2892 size of an element to get the total size. */
2893 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2894 size
= fold (build (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2896 /* Allocate memory to hold the data. */
2897 tmp
= gfc_chainon_list (NULL_TREE
, size
);
2899 if (gfc_index_integer_kind
== 4)
2900 fndecl
= gfor_fndecl_internal_malloc
;
2901 else if (gfc_index_integer_kind
== 8)
2902 fndecl
= gfor_fndecl_internal_malloc64
;
2905 tmp
= gfc_build_function_call (fndecl
, tmp
);
2906 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
2907 gfc_add_modify_expr (&block
, decl
, tmp
);
2909 /* Set offset of the array. */
2910 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
2911 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
2914 /* Automatic arrays should not have initializers. */
2915 assert (!sym
->value
);
2917 gfc_add_expr_to_block (&block
, fnbody
);
2919 /* Free the temporary. */
2920 tmp
= convert (pvoid_type_node
, decl
);
2921 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
2922 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2923 gfc_add_expr_to_block (&block
, tmp
);
2925 return gfc_finish_block (&block
);
2929 /* Generate entry and exit code for g77 calling convention arrays. */
2932 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
2941 gfc_get_backend_locus (&loc
);
2942 gfc_set_backend_locus (&sym
->declared_at
);
2944 /* Descriptor type. */
2945 parm
= sym
->backend_decl
;
2946 type
= TREE_TYPE (parm
);
2947 assert (GFC_ARRAY_TYPE_P (type
));
2949 gfc_start_block (&block
);
2951 if (sym
->ts
.type
== BT_CHARACTER
2952 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
2953 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
2955 /* Evaluate the bounds of the array. */
2956 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
2958 /* Set the offset. */
2959 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
2960 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
2962 /* Set the pointer itself if we aren't using the parameter dirtectly. */
2963 if (TREE_CODE (parm
) != PARM_DECL
)
2965 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
2966 gfc_add_modify_expr (&block
, parm
, tmp
);
2968 tmp
= gfc_finish_block (&block
);
2970 gfc_set_backend_locus (&loc
);
2972 gfc_start_block (&block
);
2973 /* Add the initialization code to the start of the function. */
2974 gfc_add_expr_to_block (&block
, tmp
);
2975 gfc_add_expr_to_block (&block
, body
);
2977 return gfc_finish_block (&block
);
2981 /* Modify the descriptor of an array parameter so that it has the
2982 correct lower bound. Also move the upper bound accordingly.
2983 If the array is not packed, it will be copied into a temporary.
2984 For each dimension we set the new lower and upper bounds. Then we copy the
2985 stride and calculate the offset for this dimension. We also work out
2986 what the stride of a packed array would be, and see it the two match.
2987 If the array need repacking, we set the stride to the values we just
2988 calculated, recalculate the offset and copy the array data.
2989 Code is also added to copy the data back at the end of the function.
2993 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3000 stmtblock_t cleanup
;
3017 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3018 return gfc_trans_g77_array (sym
, body
);
3020 gfc_get_backend_locus (&loc
);
3021 gfc_set_backend_locus (&sym
->declared_at
);
3023 /* Descriptor type. */
3024 type
= TREE_TYPE (tmpdesc
);
3025 assert (GFC_ARRAY_TYPE_P (type
));
3026 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3027 dumdesc
= gfc_build_indirect_ref (dumdesc
);
3028 gfc_start_block (&block
);
3030 if (sym
->ts
.type
== BT_CHARACTER
3031 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3032 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3034 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3036 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3037 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3039 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3041 /* For non-constant shape arrays we only check if the first dimension
3042 is contiguous. Repacking higher dimensions wouldn't gain us
3043 anything as we still don't know the array stride. */
3044 partial
= gfc_create_var (boolean_type_node
, "partial");
3045 TREE_USED (partial
) = 1;
3046 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3047 tmp
= fold (build (EQ_EXPR
, boolean_type_node
, tmp
, integer_one_node
));
3048 gfc_add_modify_expr (&block
, partial
, tmp
);
3052 partial
= NULL_TREE
;
3055 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3056 here, however I think it does the right thing. */
3059 /* Set the first stride. */
3060 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3061 stride
= gfc_evaluate_now (stride
, &block
);
3063 tmp
= build (EQ_EXPR
, boolean_type_node
, stride
, integer_zero_node
);
3064 tmp
= build (COND_EXPR
, gfc_array_index_type
, tmp
,
3065 integer_one_node
, stride
);
3066 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3067 gfc_add_modify_expr (&block
, stride
, tmp
);
3069 /* Allow the user to disable array repacking. */
3070 stmt_unpacked
= NULL_TREE
;
3074 assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3075 /* A library call to repack the array if neccessary. */
3076 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3077 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3078 stmt_unpacked
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3080 stride
= integer_one_node
;
3083 /* This is for the case where the array data is used directly without
3084 calling the repack function. */
3085 if (no_repack
|| partial
!= NULL_TREE
)
3086 stmt_packed
= gfc_conv_descriptor_data (dumdesc
);
3088 stmt_packed
= NULL_TREE
;
3090 /* Assign the data pointer. */
3091 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3093 /* Don't repack unknown shape arrays when the first stride is 1. */
3094 tmp
= build (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3095 stmt_packed
, stmt_unpacked
);
3098 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3099 gfc_add_modify_expr (&block
, tmpdesc
, tmp
);
3101 offset
= integer_zero_node
;
3102 size
= integer_one_node
;
3104 /* Evaluate the bounds of the array. */
3105 for (n
= 0; n
< sym
->as
->rank
; n
++)
3107 if (checkparm
|| !sym
->as
->upper
[n
])
3109 /* Get the bounds of the actual parameter. */
3110 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3111 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3115 dubound
= NULL_TREE
;
3116 dlbound
= NULL_TREE
;
3119 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3120 if (!INTEGER_CST_P (lbound
))
3122 gfc_init_se (&se
, NULL
);
3123 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3124 gfc_array_index_type
);
3125 gfc_add_block_to_block (&block
, &se
.pre
);
3126 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3129 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3130 /* Set the desired upper bound. */
3131 if (sym
->as
->upper
[n
])
3133 /* We know what we want the upper bound to be. */
3134 if (!INTEGER_CST_P (ubound
))
3136 gfc_init_se (&se
, NULL
);
3137 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3138 gfc_array_index_type
);
3139 gfc_add_block_to_block (&block
, &se
.pre
);
3140 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3143 /* Check the sizes match. */
3146 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3148 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
, ubound
,
3150 stride
= build (MINUS_EXPR
, gfc_array_index_type
, dubound
,
3152 tmp
= fold (build (NE_EXPR
, gfc_array_index_type
, tmp
, stride
));
3153 gfc_trans_runtime_check (tmp
, gfc_strconst_bounds
, &block
);
3158 /* For assumed shape arrays move the upper bound by the same amount
3159 as the lower bound. */
3160 tmp
= build (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3161 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
));
3162 gfc_add_modify_expr (&block
, ubound
, tmp
);
3164 /* The offset of this dimension. offset = offset - lbound * stride. */
3165 tmp
= fold (build (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
));
3166 offset
= fold (build (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
));
3168 /* The size of this dimension, and the stride of the next. */
3169 if (n
+ 1 < sym
->as
->rank
)
3171 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3173 if (no_repack
|| partial
!= NULL_TREE
)
3176 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
3179 /* Figure out the stride if not a known constant. */
3180 if (!INTEGER_CST_P (stride
))
3183 stmt_packed
= NULL_TREE
;
3186 /* Calculate stride = size * (ubound + 1 - lbound). */
3187 tmp
= fold (build (MINUS_EXPR
, gfc_array_index_type
,
3188 integer_one_node
, lbound
));
3189 tmp
= fold (build (PLUS_EXPR
, gfc_array_index_type
,
3191 size
= fold (build (MULT_EXPR
, gfc_array_index_type
,
3196 /* Assign the stride. */
3197 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3199 tmp
= build (COND_EXPR
, gfc_array_index_type
, partial
,
3200 stmt_unpacked
, stmt_packed
);
3203 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
3204 gfc_add_modify_expr (&block
, stride
, tmp
);
3209 /* Set the offset. */
3210 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3211 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3213 stmt
= gfc_finish_block (&block
);
3215 gfc_start_block (&block
);
3217 /* Only do the entry/initialization code if the arg is present. */
3218 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3219 if (sym
->attr
.optional
)
3221 tmp
= gfc_conv_expr_present (sym
);
3222 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3224 gfc_add_expr_to_block (&block
, stmt
);
3226 /* Add the main function body. */
3227 gfc_add_expr_to_block (&block
, body
);
3232 gfc_start_block (&cleanup
);
3234 if (sym
->attr
.intent
!= INTENT_IN
)
3236 /* Copy the data back. */
3237 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
3238 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
3239 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3240 gfc_add_expr_to_block (&cleanup
, tmp
);
3243 /* Free the temporary. */
3244 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
3245 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3246 gfc_add_expr_to_block (&cleanup
, tmp
);
3248 stmt
= gfc_finish_block (&cleanup
);
3250 /* Only do the cleanup if the array was repacked. */
3251 tmp
= gfc_build_indirect_ref (dumdesc
);
3252 tmp
= gfc_conv_descriptor_data (tmp
);
3253 tmp
= build (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
3254 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3256 if (sym
->attr
.optional
)
3258 tmp
= gfc_conv_expr_present (sym
);
3259 stmt
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3261 gfc_add_expr_to_block (&block
, stmt
);
3263 /* We don't need to free any memory allocated by internal_pack as it will
3264 be freed at the end of the function by pop_context. */
3265 return gfc_finish_block (&block
);
3269 /* Convert an array for passing as an actual parameter. Expressions
3270 and vector subscripts are evaluated and stored in a teporary, which is then
3271 passed. For whole arrays the descriptor is passed. For array sections
3272 a modified copy of the descriptor is passed, but using the original data.
3273 Also used for array pointer assignments by setting se->direct_byref. */
3276 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
3290 assert (ss
!= gfc_ss_terminator
);
3292 /* TODO: Pass constant array constructors without a temporary. */
3293 /* If we have a linear array section, we can pass it directly. Otherwise
3294 we need to copy it into a temporary. */
3295 if (expr
->expr_type
== EXPR_VARIABLE
)
3299 /* Find the SS for the array section. */
3301 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
3302 secss
= secss
->next
;
3304 assert (secss
!= gfc_ss_terminator
);
3307 for (n
= 0; n
< secss
->data
.info
.dimen
; n
++)
3309 vss
= secss
->data
.info
.subscript
[secss
->data
.info
.dim
[n
]];
3310 if (vss
&& vss
->type
== GFC_SS_VECTOR
)
3314 info
= &secss
->data
.info
;
3316 /* Get the descriptor for the array. */
3317 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
3318 desc
= info
->descriptor
;
3319 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
3321 /* Create a new descriptor if the array doesn't have one. */
3324 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
3326 else if (se
->direct_byref
)
3330 assert (info
->ref
->u
.ar
.type
== AR_SECTION
);
3333 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3335 /* Detect passing the full array as a section. This could do
3336 even more checking, but it doesn't seem worth it. */
3337 if (info
->ref
->u
.ar
.start
[n
]
3338 || info
->ref
->u
.ar
.end
[n
]
3339 || (info
->ref
->u
.ar
.stride
[n
]
3340 && !gfc_expr_is_one (info
->ref
->u
.ar
.stride
[n
], 0)))
3349 if (se
->direct_byref
)
3351 /* Copy the descriptor for pointer assignments. */
3352 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
3354 else if (se
->want_pointer
)
3356 /* We pass full arrays directly. This means that pointers and
3357 allocatable arrays should also work. */
3358 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3374 gfc_init_loopinfo (&loop
);
3376 /* Associate the SS with the loop. */
3377 gfc_add_ss_to_loop (&loop
, ss
);
3379 /* Tell the scalarizer not to bother creating loop varliables, etc. */
3381 loop
.array_parameter
= 1;
3383 assert (se
->want_pointer
&& !se
->direct_byref
);
3385 /* Setup the scalarizing loops and bounds. */
3386 gfc_conv_ss_startstride (&loop
);
3390 /* Tell the scalarizer to make a temporary. */
3391 loop
.temp_ss
= gfc_get_ss ();
3392 loop
.temp_ss
->type
= GFC_SS_TEMP
;
3393 loop
.temp_ss
->next
= gfc_ss_terminator
;
3394 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
3395 loop
.temp_ss
->data
.temp
.string_length
= NULL
;
3396 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
3397 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3400 gfc_conv_loop_setup (&loop
);
3404 /* Copy into a temporary and pass that. We don't need to copy the data
3405 back because expressions and vector subscripts must be INTENT_IN. */
3406 /* TODO: Optimize passing function return values. */
3410 /* Start the copying loops. */
3411 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3412 gfc_mark_ss_chain_used (ss
, 1);
3413 gfc_start_scalarized_body (&loop
, &block
);
3415 /* Copy each data element. */
3416 gfc_init_se (&lse
, NULL
);
3417 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3418 gfc_init_se (&rse
, NULL
);
3419 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3421 lse
.ss
= loop
.temp_ss
;
3424 gfc_conv_scalarized_array_ref (&lse
, NULL
);
3425 gfc_conv_expr_val (&rse
, expr
);
3427 gfc_add_block_to_block (&block
, &rse
.pre
);
3428 gfc_add_block_to_block (&block
, &lse
.pre
);
3430 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
3432 /* Finish the copying loops. */
3433 gfc_trans_scalarizing_loops (&loop
, &block
);
3435 /* Set the first stride component to zero to indicate a temporary. */
3436 desc
= loop
.temp_ss
->data
.info
.descriptor
;
3437 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[0]);
3438 gfc_add_modify_expr (&loop
.pre
, tmp
, integer_zero_node
);
3440 assert (is_gimple_lvalue (desc
));
3441 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3445 /* We pass sections without copying to a temporary. A function may
3446 decide to repack the array to speed up access, but we're not
3447 bothered about that here. */
3456 /* Otherwise make a new descriptor and point it at the section we
3457 want. The loop variable limits will be the limits of the section.
3459 desc
= info
->descriptor
;
3460 assert (secss
&& secss
!= gfc_ss_terminator
);
3461 if (se
->direct_byref
)
3463 /* For pointer assignments we fill in the destination. */
3465 parmtype
= TREE_TYPE (parm
);
3469 /* Otherwise make a new one. */
3470 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3471 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
3472 loop
.from
, loop
.to
, 0);
3473 parm
= gfc_create_var (parmtype
, "parm");
3476 offset
= integer_zero_node
;
3479 /* The following can be somewhat confusing. We have two
3480 descriptors, a new one and the original array.
3481 {parm, parmtype, dim} refer to the new one.
3482 {desc, type, n, secss, loop} refer to the original, which maybe
3483 a descriptorless array.
3484 The bounds of the scaralization are the bounds of the section.
3485 We don't have to worry about numeric overflows when calculating
3486 the offsets because all elements are within the array data. */
3488 /* Set the dtype. */
3489 tmp
= gfc_conv_descriptor_dtype (parm
);
3490 gfc_add_modify_expr (&loop
.pre
, tmp
, GFC_TYPE_ARRAY_DTYPE (parmtype
));
3492 if (se
->direct_byref
)
3493 base
= integer_zero_node
;
3497 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3499 stride
= gfc_conv_array_stride (desc
, n
);
3501 /* Work out the offset. */
3502 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3504 assert (info
->subscript
[n
]
3505 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
3506 start
= info
->subscript
[n
]->data
.scalar
.expr
;
3510 /* Check we haven't somehow got out of sync. */
3511 assert (info
->dim
[dim
] == n
);
3513 /* Evaluate and remember the start of the section. */
3514 start
= info
->start
[dim
];
3515 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
3518 tmp
= gfc_conv_array_lbound (desc
, n
);
3519 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
));
3521 tmp
= fold (build (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
));
3522 offset
= fold (build (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
));
3524 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3526 /* For elemental dimensions, we only need the offset. */
3530 /* Vector subscripts need copying and are handled elsewhere. */
3531 assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
3533 /* Set the new lower bound. */
3534 from
= loop
.from
[dim
];
3536 if (!integer_onep (from
))
3538 /* Make sure the new section starts at 1. */
3539 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (from
),
3540 integer_one_node
, from
));
3541 to
= fold (build (PLUS_EXPR
, TREE_TYPE (to
), to
, tmp
));
3542 from
= integer_one_node
;
3544 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
3545 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
3547 /* Set the new upper bound. */
3548 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
3549 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
3551 /* Multiply the stride by the section stride to get the
3553 stride
= fold (build (MULT_EXPR
, gfc_array_index_type
, stride
,
3554 info
->stride
[dim
]));
3556 if (se
->direct_byref
)
3558 base
= fold (build (MINUS_EXPR
, TREE_TYPE (base
),
3562 /* Store the new stride. */
3563 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
3564 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
3569 /* Point the data pointer at the first element in the section. */
3570 tmp
= gfc_conv_array_data (desc
);
3571 tmp
= gfc_build_indirect_ref (tmp
);
3572 tmp
= gfc_build_array_ref (tmp
, offset
);
3573 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
3575 tmp
= gfc_conv_descriptor_data (parm
);
3576 gfc_add_modify_expr (&loop
.pre
, tmp
, offset
);
3578 if (se
->direct_byref
)
3580 /* Set the offset. */
3581 tmp
= gfc_conv_descriptor_offset (parm
);
3582 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
3586 /* Only the callee knows what the correct offset it, so just set
3588 tmp
= gfc_conv_descriptor_offset (parm
);
3589 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3592 if (!se
->direct_byref
)
3594 /* Get a pointer to the new descriptor. */
3595 if (se
->want_pointer
)
3596 se
->expr
= gfc_build_addr_expr (NULL
, parm
);
3602 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3603 gfc_add_block_to_block (&se
->post
, &loop
.post
);
3605 /* Cleanup the scalarizer. */
3606 gfc_cleanup_loop (&loop
);
3610 /* Convert an array for passing as an actual parameter. */
3611 /* TODO: Optimize passing g77 arrays. */
3614 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
3623 /* Passing address of the array if it is not pointer or assumed-shape. */
3624 if (expr
->expr_type
== EXPR_VARIABLE
3625 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
3627 sym
= expr
->symtree
->n
.sym
;
3628 tmp
= gfc_get_symbol_decl (sym
);
3629 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
3630 && !sym
->attr
.allocatable
)
3632 if (!sym
->attr
.dummy
)
3633 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
3638 if (sym
->attr
.allocatable
)
3640 se
->expr
= gfc_conv_array_data (tmp
);
3645 se
->want_pointer
= 1;
3646 gfc_conv_expr_descriptor (se
, expr
, ss
);
3651 /* Repack the array. */
3652 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3653 ptr
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3654 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
3657 gfc_start_block (&block
);
3659 /* Copy the data back. */
3660 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3661 tmp
= gfc_chainon_list (tmp
, ptr
);
3662 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3663 gfc_add_expr_to_block (&block
, tmp
);
3665 /* Free the temporary. */
3666 tmp
= convert (pvoid_type_node
, ptr
);
3667 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3668 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3669 gfc_add_expr_to_block (&block
, tmp
);
3671 stmt
= gfc_finish_block (&block
);
3673 gfc_init_block (&block
);
3674 /* Only if it was repacked. This code needs to be executed before the
3675 loop cleanup code. */
3676 tmp
= gfc_build_indirect_ref (desc
);
3677 tmp
= gfc_conv_array_data (tmp
);
3678 tmp
= build (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
3679 tmp
= build_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3681 gfc_add_expr_to_block (&block
, tmp
);
3682 gfc_add_block_to_block (&block
, &se
->post
);
3684 gfc_init_block (&se
->post
);
3685 gfc_add_block_to_block (&se
->post
, &block
);
3690 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3693 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
3700 stmtblock_t fnblock
;
3703 /* Make sure the frontend gets these right. */
3704 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3706 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
3708 gfc_init_block (&fnblock
);
3710 assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
);
3711 if (sym
->ts
.type
== BT_CHARACTER
3712 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3713 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
3715 /* Parameter variables don't need anything special. */
3716 if (sym
->attr
.dummy
)
3718 gfc_add_expr_to_block (&fnblock
, body
);
3720 return gfc_finish_block (&fnblock
);
3723 gfc_get_backend_locus (&loc
);
3724 gfc_set_backend_locus (&sym
->declared_at
);
3725 descriptor
= sym
->backend_decl
;
3727 if (TREE_STATIC (descriptor
))
3729 /* SAVEd variables are not freed on exit. */
3730 gfc_trans_static_array_pointer (sym
);
3734 /* Get the descriptor type. */
3735 type
= TREE_TYPE (sym
->backend_decl
);
3736 assert (GFC_DESCRIPTOR_TYPE_P (type
));
3738 /* NULLIFY the data pointer. */
3739 tmp
= gfc_conv_descriptor_data (descriptor
);
3740 gfc_add_modify_expr (&fnblock
, 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 seperately. */
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
);