1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
83 #include "tree-gimple.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss
*gfc_walk_subexpr (gfc_ss
*, gfc_expr
*);
98 /* The contents of this structure aren't actually used, just the address. */
99 static gfc_ss gfc_ss_terminator_var
;
100 gfc_ss
* const gfc_ss_terminator
= &gfc_ss_terminator_var
;
104 gfc_array_dataptr_type (tree desc
)
106 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
)));
110 /* Build expressions to access the members of an array descriptor.
111 It's surprisingly easy to mess up here, so never access
112 an array descriptor by "brute force", always use these
113 functions. This also avoids problems if we change the format
114 of an array descriptor.
116 To understand these magic numbers, look at the comments
117 before gfc_build_array_type() in trans-types.c.
119 The code within these defines should be the only code which knows the format
120 of an array descriptor.
122 Any code just needing to read obtain the bounds of an array should use
123 gfc_conv_array_* rather than the following functions as these will return
124 know constant values, and work with arrays which do not have descriptors.
126 Don't forget to #undef these! */
129 #define OFFSET_FIELD 1
130 #define DTYPE_FIELD 2
131 #define DIMENSION_FIELD 3
133 #define STRIDE_SUBFIELD 0
134 #define LBOUND_SUBFIELD 1
135 #define UBOUND_SUBFIELD 2
137 /* This provides READ-ONLY access to the data field. The field itself
138 doesn't have the proper type. */
141 gfc_conv_descriptor_data_get (tree desc
)
145 type
= TREE_TYPE (desc
);
146 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
148 field
= TYPE_FIELDS (type
);
149 gcc_assert (DATA_FIELD
== 0);
151 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
152 t
= fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
), t
);
157 /* This provides WRITE access to the data field. */
160 gfc_conv_descriptor_data_set (stmtblock_t
*block
, tree desc
, tree value
)
164 type
= TREE_TYPE (desc
);
165 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
167 field
= TYPE_FIELDS (type
);
168 gcc_assert (DATA_FIELD
== 0);
170 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
171 gfc_add_modify_expr (block
, t
, fold_convert (TREE_TYPE (field
), value
));
175 /* This provides address access to the data field. This should only be
176 used by array allocation, passing this on to the runtime. */
179 gfc_conv_descriptor_data_addr (tree desc
)
183 type
= TREE_TYPE (desc
);
184 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
186 field
= TYPE_FIELDS (type
);
187 gcc_assert (DATA_FIELD
== 0);
189 t
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
190 return gfc_build_addr_expr (NULL
, t
);
194 gfc_conv_descriptor_offset (tree desc
)
199 type
= TREE_TYPE (desc
);
200 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
202 field
= gfc_advance_chain (TYPE_FIELDS (type
), OFFSET_FIELD
);
203 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
205 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
209 gfc_conv_descriptor_dtype (tree desc
)
214 type
= TREE_TYPE (desc
);
215 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
217 field
= gfc_advance_chain (TYPE_FIELDS (type
), DTYPE_FIELD
);
218 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
220 return build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
224 gfc_conv_descriptor_dimension (tree desc
, tree dim
)
230 type
= TREE_TYPE (desc
);
231 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
233 field
= gfc_advance_chain (TYPE_FIELDS (type
), DIMENSION_FIELD
);
234 gcc_assert (field
!= NULL_TREE
235 && TREE_CODE (TREE_TYPE (field
)) == ARRAY_TYPE
236 && TREE_CODE (TREE_TYPE (TREE_TYPE (field
))) == RECORD_TYPE
);
238 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), desc
, field
, NULL_TREE
);
239 tmp
= gfc_build_array_ref (tmp
, dim
);
244 gfc_conv_descriptor_stride (tree desc
, tree dim
)
249 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
250 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
251 field
= gfc_advance_chain (field
, STRIDE_SUBFIELD
);
252 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
254 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
259 gfc_conv_descriptor_lbound (tree desc
, tree dim
)
264 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
265 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
266 field
= gfc_advance_chain (field
, LBOUND_SUBFIELD
);
267 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
269 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
274 gfc_conv_descriptor_ubound (tree desc
, tree dim
)
279 tmp
= gfc_conv_descriptor_dimension (desc
, dim
);
280 field
= TYPE_FIELDS (TREE_TYPE (tmp
));
281 field
= gfc_advance_chain (field
, UBOUND_SUBFIELD
);
282 gcc_assert (field
!= NULL_TREE
&& TREE_TYPE (field
) == gfc_array_index_type
);
284 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), tmp
, field
, NULL_TREE
);
289 /* Build an null array descriptor constructor. */
292 gfc_build_null_descriptor (tree type
)
297 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
298 gcc_assert (DATA_FIELD
== 0);
299 field
= TYPE_FIELDS (type
);
301 /* Set a NULL data pointer. */
302 tmp
= tree_cons (field
, null_pointer_node
, NULL_TREE
);
303 tmp
= build1 (CONSTRUCTOR
, type
, tmp
);
304 TREE_CONSTANT (tmp
) = 1;
305 TREE_INVARIANT (tmp
) = 1;
306 /* All other fields are ignored. */
312 /* Cleanup those #defines. */
317 #undef DIMENSION_FIELD
318 #undef STRIDE_SUBFIELD
319 #undef LBOUND_SUBFIELD
320 #undef UBOUND_SUBFIELD
323 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
324 flags & 1 = Main loop body.
325 flags & 2 = temp copy loop. */
328 gfc_mark_ss_chain_used (gfc_ss
* ss
, unsigned flags
)
330 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
331 ss
->useflags
= flags
;
334 static void gfc_free_ss (gfc_ss
*);
337 /* Free a gfc_ss chain. */
340 gfc_free_ss_chain (gfc_ss
* ss
)
344 while (ss
!= gfc_ss_terminator
)
346 gcc_assert (ss
!= NULL
);
357 gfc_free_ss (gfc_ss
* ss
)
365 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
367 if (ss
->data
.info
.subscript
[n
])
368 gfc_free_ss_chain (ss
->data
.info
.subscript
[n
]);
380 /* Free all the SS associated with a loop. */
383 gfc_cleanup_loop (gfc_loopinfo
* loop
)
389 while (ss
!= gfc_ss_terminator
)
391 gcc_assert (ss
!= NULL
);
392 next
= ss
->loop_chain
;
399 /* Associate a SS chain with a loop. */
402 gfc_add_ss_to_loop (gfc_loopinfo
* loop
, gfc_ss
* head
)
406 if (head
== gfc_ss_terminator
)
410 for (; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
412 if (ss
->next
== gfc_ss_terminator
)
413 ss
->loop_chain
= loop
->ss
;
415 ss
->loop_chain
= ss
->next
;
417 gcc_assert (ss
== gfc_ss_terminator
);
422 /* Generate an initializer for a static pointer or allocatable array. */
425 gfc_trans_static_array_pointer (gfc_symbol
* sym
)
429 gcc_assert (TREE_STATIC (sym
->backend_decl
));
430 /* Just zero the data member. */
431 type
= TREE_TYPE (sym
->backend_decl
);
432 DECL_INITIAL (sym
->backend_decl
) = gfc_build_null_descriptor (type
);
436 /* Generate code to allocate an array temporary, or create a variable to
437 hold the data. If size is NULL zero the descriptor so that so that the
438 callee will allocate the array. Also generates code to free the array
442 gfc_trans_allocate_array_storage (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
443 tree size
, tree nelem
)
450 desc
= info
->descriptor
;
451 info
->offset
= gfc_index_zero_node
;
452 if (size
== NULL_TREE
)
454 /* A callee allocated array. */
455 gfc_conv_descriptor_data_set (&loop
->pre
, desc
, null_pointer_node
);
460 /* Allocate the temporary. */
461 onstack
= gfc_can_put_var_on_stack (size
);
465 /* Make a temporary variable to hold the data. */
466 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (nelem
), nelem
,
468 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
470 tmp
= build_array_type (gfc_get_element_type (TREE_TYPE (desc
)),
472 tmp
= gfc_create_var (tmp
, "A");
473 tmp
= gfc_build_addr_expr (NULL
, tmp
);
474 gfc_conv_descriptor_data_set (&loop
->pre
, desc
, tmp
);
478 /* Allocate memory to hold the data. */
479 args
= gfc_chainon_list (NULL_TREE
, size
);
481 if (gfc_index_integer_kind
== 4)
482 tmp
= gfor_fndecl_internal_malloc
;
483 else if (gfc_index_integer_kind
== 8)
484 tmp
= gfor_fndecl_internal_malloc64
;
487 tmp
= gfc_build_function_call (tmp
, args
);
488 tmp
= gfc_evaluate_now (tmp
, &loop
->pre
);
489 gfc_conv_descriptor_data_set (&loop
->pre
, desc
, tmp
);
492 info
->data
= gfc_conv_descriptor_data_get (desc
);
494 /* The offset is zero because we create temporaries with a zero
496 tmp
= gfc_conv_descriptor_offset (desc
);
497 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
501 /* Free the temporary. */
502 tmp
= gfc_conv_descriptor_data_get (desc
);
503 tmp
= fold_convert (pvoid_type_node
, tmp
);
504 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
505 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
506 gfc_add_expr_to_block (&loop
->post
, tmp
);
511 /* Generate code to allocate and initialize the descriptor for a temporary
512 array. This is used for both temporaries needed by the scalarizer, and
513 functions returning arrays. Adjusts the loop variables to be zero-based,
514 and calculates the loop bounds for callee allocated arrays.
515 Also fills in the descriptor, data and offset fields of info if known.
516 Returns the size of the array, or NULL for a callee allocated array. */
519 gfc_trans_allocate_temp_array (gfc_loopinfo
* loop
, gfc_ss_info
* info
,
530 gcc_assert (info
->dimen
> 0);
531 /* Set the lower bound to zero. */
532 for (dim
= 0; dim
< info
->dimen
; dim
++)
534 n
= loop
->order
[dim
];
535 if (n
< loop
->temp_dim
)
536 gcc_assert (integer_zerop (loop
->from
[n
]));
539 /* Callee allocated arrays may not have a known bound yet. */
541 loop
->to
[n
] = fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
542 loop
->to
[n
], loop
->from
[n
]);
543 loop
->from
[n
] = gfc_index_zero_node
;
546 info
->delta
[dim
] = gfc_index_zero_node
;
547 info
->start
[dim
] = gfc_index_zero_node
;
548 info
->stride
[dim
] = gfc_index_one_node
;
549 info
->dim
[dim
] = dim
;
552 /* Initialize the descriptor. */
554 gfc_get_array_type_bounds (eltype
, info
->dimen
, loop
->from
, loop
->to
, 1);
555 desc
= gfc_create_var (type
, "atmp");
556 GFC_DECL_PACKED_ARRAY (desc
) = 1;
558 info
->descriptor
= desc
;
559 size
= gfc_index_one_node
;
561 /* Fill in the array dtype. */
562 tmp
= gfc_conv_descriptor_dtype (desc
);
563 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
566 Fill in the bounds and stride. This is a packed array, so:
569 for (n = 0; n < rank; n++)
572 delta = ubound[n] + 1 - lbound[n];
575 size = size * sizeof(element);
578 for (n
= 0; n
< info
->dimen
; n
++)
580 if (loop
->to
[n
] == NULL_TREE
)
582 /* For a callee allocated array express the loop bounds in terms
583 of the descriptor fields. */
584 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
,
585 gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]),
586 gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]));
592 /* Store the stride and bound components in the descriptor. */
593 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[n
]);
594 gfc_add_modify_expr (&loop
->pre
, tmp
, size
);
596 tmp
= gfc_conv_descriptor_lbound (desc
, gfc_rank_cst
[n
]);
597 gfc_add_modify_expr (&loop
->pre
, tmp
, gfc_index_zero_node
);
599 tmp
= gfc_conv_descriptor_ubound (desc
, gfc_rank_cst
[n
]);
600 gfc_add_modify_expr (&loop
->pre
, tmp
, loop
->to
[n
]);
602 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
603 loop
->to
[n
], gfc_index_one_node
);
605 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
606 size
= gfc_evaluate_now (size
, &loop
->pre
);
609 /* Get the size of the array. */
612 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
613 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
615 gfc_trans_allocate_array_storage (loop
, info
, size
, nelem
);
617 if (info
->dimen
> loop
->temp_dim
)
618 loop
->temp_dim
= info
->dimen
;
624 /* Make sure offset is a variable. */
627 gfc_put_offset_into_var (stmtblock_t
* pblock
, tree
* poffset
,
630 /* We should have already created the offset variable. We cannot
631 create it here because we may be in an inner scope. */
632 gcc_assert (*offsetvar
!= NULL_TREE
);
633 gfc_add_modify_expr (pblock
, *offsetvar
, *poffset
);
634 *poffset
= *offsetvar
;
635 TREE_USED (*offsetvar
) = 1;
639 /* Assign an element of an array constructor. */
642 gfc_trans_array_ctor_element (stmtblock_t
* pblock
, tree pointer
,
643 tree offset
, gfc_se
* se
, gfc_expr
* expr
)
648 gfc_conv_expr (se
, expr
);
650 /* Store the value. */
651 tmp
= gfc_build_indirect_ref (pointer
);
652 tmp
= gfc_build_array_ref (tmp
, offset
);
653 if (expr
->ts
.type
== BT_CHARACTER
)
655 gfc_conv_string_parameter (se
);
656 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
658 /* The temporary is an array of pointers. */
659 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
660 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
664 /* The temporary is an array of string values. */
665 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
666 /* We know the temporary and the value will be the same length,
667 so can use memcpy. */
668 args
= gfc_chainon_list (NULL_TREE
, tmp
);
669 args
= gfc_chainon_list (args
, se
->expr
);
670 args
= gfc_chainon_list (args
, se
->string_length
);
671 tmp
= built_in_decls
[BUILT_IN_MEMCPY
];
672 tmp
= gfc_build_function_call (tmp
, args
);
673 gfc_add_expr_to_block (&se
->pre
, tmp
);
678 /* TODO: Should the frontend already have done this conversion? */
679 se
->expr
= fold_convert (TREE_TYPE (tmp
), se
->expr
);
680 gfc_add_modify_expr (&se
->pre
, tmp
, se
->expr
);
683 gfc_add_block_to_block (pblock
, &se
->pre
);
684 gfc_add_block_to_block (pblock
, &se
->post
);
688 /* Add the contents of an array to the constructor. */
691 gfc_trans_array_constructor_subarray (stmtblock_t
* pblock
,
692 tree type ATTRIBUTE_UNUSED
,
693 tree pointer
, gfc_expr
* expr
,
694 tree
* poffset
, tree
* offsetvar
)
702 /* We need this to be a variable so we can increment it. */
703 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
705 gfc_init_se (&se
, NULL
);
707 /* Walk the array expression. */
708 ss
= gfc_walk_expr (expr
);
709 gcc_assert (ss
!= gfc_ss_terminator
);
711 /* Initialize the scalarizer. */
712 gfc_init_loopinfo (&loop
);
713 gfc_add_ss_to_loop (&loop
, ss
);
715 /* Initialize the loop. */
716 gfc_conv_ss_startstride (&loop
);
717 gfc_conv_loop_setup (&loop
);
719 /* Make the loop body. */
720 gfc_mark_ss_chain_used (ss
, 1);
721 gfc_start_scalarized_body (&loop
, &body
);
722 gfc_copy_loopinfo_to_se (&se
, &loop
);
725 if (expr
->ts
.type
== BT_CHARACTER
)
726 gfc_todo_error ("character arrays in constructors");
728 gfc_trans_array_ctor_element (&body
, pointer
, *poffset
, &se
, expr
);
729 gcc_assert (se
.ss
== gfc_ss_terminator
);
731 /* Increment the offset. */
732 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, *poffset
, gfc_index_one_node
);
733 gfc_add_modify_expr (&body
, *poffset
, tmp
);
735 /* Finish the loop. */
736 gfc_trans_scalarizing_loops (&loop
, &body
);
737 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
738 tmp
= gfc_finish_block (&loop
.pre
);
739 gfc_add_expr_to_block (pblock
, tmp
);
741 gfc_cleanup_loop (&loop
);
745 /* Assign the values to the elements of an array constructor. */
748 gfc_trans_array_constructor_value (stmtblock_t
* pblock
, tree type
,
749 tree pointer
, gfc_constructor
* c
,
750 tree
* poffset
, tree
* offsetvar
)
756 for (; c
; c
= c
->next
)
758 /* If this is an iterator or an array, the offset must be a variable. */
759 if ((c
->iterator
|| c
->expr
->rank
> 0) && INTEGER_CST_P (*poffset
))
760 gfc_put_offset_into_var (pblock
, poffset
, offsetvar
);
762 gfc_start_block (&body
);
764 if (c
->expr
->expr_type
== EXPR_ARRAY
)
766 /* Array constructors can be nested. */
767 gfc_trans_array_constructor_value (&body
, type
, pointer
,
768 c
->expr
->value
.constructor
,
771 else if (c
->expr
->rank
> 0)
773 gfc_trans_array_constructor_subarray (&body
, type
, pointer
,
774 c
->expr
, poffset
, offsetvar
);
778 /* This code really upsets the gimplifier so don't bother for now. */
785 while (p
&& !(p
->iterator
|| p
->expr
->expr_type
!= EXPR_CONSTANT
))
793 gfc_init_se (&se
, NULL
);
794 gfc_trans_array_ctor_element (&body
, pointer
, *poffset
, &se
,
797 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
798 *poffset
, gfc_index_one_node
);
802 /* Collect multiple scalar constants into a constructor. */
810 /* Count the number of consecutive scalar constants. */
811 while (p
&& !(p
->iterator
812 || p
->expr
->expr_type
!= EXPR_CONSTANT
))
814 gfc_init_se (&se
, NULL
);
815 gfc_conv_constant (&se
, p
->expr
);
816 if (p
->expr
->ts
.type
== BT_CHARACTER
817 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
818 (TREE_TYPE (pointer
)))))
820 /* For constant character array constructors we build
821 an array of pointers. */
822 se
.expr
= gfc_build_addr_expr (pchar_type_node
,
826 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
831 bound
= build_int_cst (NULL_TREE
, n
- 1);
832 /* Create an array type to hold them. */
833 tmptype
= build_range_type (gfc_array_index_type
,
834 gfc_index_zero_node
, bound
);
835 tmptype
= build_array_type (type
, tmptype
);
837 init
= build1 (CONSTRUCTOR
, tmptype
, nreverse (list
));
838 TREE_CONSTANT (init
) = 1;
839 TREE_INVARIANT (init
) = 1;
840 TREE_STATIC (init
) = 1;
841 /* Create a static variable to hold the data. */
842 tmp
= gfc_create_var (tmptype
, "data");
843 TREE_STATIC (tmp
) = 1;
844 TREE_CONSTANT (tmp
) = 1;
845 TREE_INVARIANT (tmp
) = 1;
846 DECL_INITIAL (tmp
) = init
;
849 /* Use BUILTIN_MEMCPY to assign the values. */
850 tmp
= gfc_build_indirect_ref (pointer
);
851 tmp
= gfc_build_array_ref (tmp
, *poffset
);
852 tmp
= gfc_build_addr_expr (NULL
, tmp
);
853 init
= gfc_build_addr_expr (NULL
, init
);
855 size
= TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type
));
856 bound
= build_int_cst (NULL_TREE
, n
* size
);
857 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
858 tmp
= gfc_chainon_list (tmp
, init
);
859 tmp
= gfc_chainon_list (tmp
, bound
);
860 tmp
= gfc_build_function_call (built_in_decls
[BUILT_IN_MEMCPY
],
862 gfc_add_expr_to_block (&body
, tmp
);
864 *poffset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
867 if (!INTEGER_CST_P (*poffset
))
869 gfc_add_modify_expr (&body
, *offsetvar
, *poffset
);
870 *poffset
= *offsetvar
;
874 /* The frontend should already have done any expansions possible
878 /* Pass the code as is. */
879 tmp
= gfc_finish_block (&body
);
880 gfc_add_expr_to_block (pblock
, tmp
);
884 /* Build the implied do-loop. */
892 loopbody
= gfc_finish_block (&body
);
894 gfc_init_se (&se
, NULL
);
895 gfc_conv_expr (&se
, c
->iterator
->var
);
896 gfc_add_block_to_block (pblock
, &se
.pre
);
899 /* Initialize the loop. */
900 gfc_init_se (&se
, NULL
);
901 gfc_conv_expr_val (&se
, c
->iterator
->start
);
902 gfc_add_block_to_block (pblock
, &se
.pre
);
903 gfc_add_modify_expr (pblock
, loopvar
, se
.expr
);
905 gfc_init_se (&se
, NULL
);
906 gfc_conv_expr_val (&se
, c
->iterator
->end
);
907 gfc_add_block_to_block (pblock
, &se
.pre
);
908 end
= gfc_evaluate_now (se
.expr
, pblock
);
910 gfc_init_se (&se
, NULL
);
911 gfc_conv_expr_val (&se
, c
->iterator
->step
);
912 gfc_add_block_to_block (pblock
, &se
.pre
);
913 step
= gfc_evaluate_now (se
.expr
, pblock
);
915 /* Generate the loop body. */
916 exit_label
= gfc_build_label_decl (NULL_TREE
);
917 gfc_start_block (&body
);
919 /* Generate the exit condition. Depending on the sign of
920 the step variable we have to generate the correct
922 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, step
,
923 build_int_cst (TREE_TYPE (step
), 0));
924 cond
= fold_build3 (COND_EXPR
, boolean_type_node
, tmp
,
925 build2 (GT_EXPR
, boolean_type_node
,
927 build2 (LT_EXPR
, boolean_type_node
,
929 tmp
= build1_v (GOTO_EXPR
, exit_label
);
930 TREE_USED (exit_label
) = 1;
931 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
932 gfc_add_expr_to_block (&body
, tmp
);
934 /* The main loop body. */
935 gfc_add_expr_to_block (&body
, loopbody
);
937 /* Increase loop variable by step. */
938 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (loopvar
), loopvar
, step
);
939 gfc_add_modify_expr (&body
, loopvar
, tmp
);
941 /* Finish the loop. */
942 tmp
= gfc_finish_block (&body
);
943 tmp
= build1_v (LOOP_EXPR
, tmp
);
944 gfc_add_expr_to_block (pblock
, tmp
);
946 /* Add the exit label. */
947 tmp
= build1_v (LABEL_EXPR
, exit_label
);
948 gfc_add_expr_to_block (pblock
, tmp
);
954 /* Get the size of an expression. Returns -1 if the size isn't constant.
955 Implied do loops with non-constant bounds are tricky because we must only
956 evaluate the bounds once. */
959 gfc_get_array_cons_size (mpz_t
* size
, gfc_constructor
* c
)
965 mpz_set_ui (*size
, 0);
969 for (; c
; c
= c
->next
)
971 if (c
->expr
->expr_type
== EXPR_ARRAY
)
973 /* A nested array constructor. */
974 gfc_get_array_cons_size (&len
, c
->expr
->value
.constructor
);
975 if (mpz_sgn (len
) < 0)
977 mpz_set (*size
, len
);
985 if (c
->expr
->rank
> 0)
987 mpz_set_si (*size
, -1);
999 if (i
->start
->expr_type
!= EXPR_CONSTANT
1000 || i
->end
->expr_type
!= EXPR_CONSTANT
1001 || i
->step
->expr_type
!= EXPR_CONSTANT
)
1003 mpz_set_si (*size
, -1);
1009 mpz_add (val
, i
->end
->value
.integer
, i
->start
->value
.integer
);
1010 mpz_tdiv_q (val
, val
, i
->step
->value
.integer
);
1011 mpz_add_ui (val
, val
, 1);
1012 mpz_mul (len
, len
, val
);
1014 mpz_add (*size
, *size
, len
);
1021 /* Figure out the string length of a variable reference expression.
1022 Used by get_array_ctor_strlen. */
1025 get_array_ctor_var_strlen (gfc_expr
* expr
, tree
* len
)
1030 /* Don't bother if we already know the length is a constant. */
1031 if (*len
&& INTEGER_CST_P (*len
))
1034 ts
= &expr
->symtree
->n
.sym
->ts
;
1035 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1040 /* Array references don't change the string length. */
1044 /* Use the length of the component. */
1045 ts
= &ref
->u
.c
.component
->ts
;
1049 /* TODO: Substrings are tricky because we can't evaluate the
1050 expression more than once. For now we just give up, and hope
1051 we can figure it out elsewhere. */
1056 *len
= ts
->cl
->backend_decl
;
1060 /* Figure out the string length of a character array constructor.
1061 Returns TRUE if all elements are character constants. */
1064 get_array_ctor_strlen (gfc_constructor
* c
, tree
* len
)
1069 for (; c
; c
= c
->next
)
1071 switch (c
->expr
->expr_type
)
1074 if (!(*len
&& INTEGER_CST_P (*len
)))
1075 *len
= build_int_cstu (gfc_charlen_type_node
,
1076 c
->expr
->value
.character
.length
);
1080 if (!get_array_ctor_strlen (c
->expr
->value
.constructor
, len
))
1086 get_array_ctor_var_strlen (c
->expr
, len
);
1091 /* TODO: For now we just ignore anything we don't know how to
1092 handle, and hope we can figure it out a different way. */
1101 /* Array constructors are handled by constructing a temporary, then using that
1102 within the scalarization loop. This is not optimal, but seems by far the
1106 gfc_trans_array_constructor (gfc_loopinfo
* loop
, gfc_ss
* ss
)
1115 ss
->data
.info
.dimen
= loop
->dimen
;
1117 if (ss
->expr
->ts
.type
== BT_CHARACTER
)
1119 const_string
= get_array_ctor_strlen (ss
->expr
->value
.constructor
,
1120 &ss
->string_length
);
1121 if (!ss
->string_length
)
1122 gfc_todo_error ("complex character array constructors");
1124 type
= gfc_get_character_type_len (ss
->expr
->ts
.kind
, ss
->string_length
);
1126 type
= build_pointer_type (type
);
1130 const_string
= TRUE
;
1131 type
= gfc_typenode_for_spec (&ss
->expr
->ts
);
1134 size
= gfc_trans_allocate_temp_array (loop
, &ss
->data
.info
, type
);
1136 desc
= ss
->data
.info
.descriptor
;
1137 offset
= gfc_index_zero_node
;
1138 offsetvar
= gfc_create_var_np (gfc_array_index_type
, "offset");
1139 TREE_USED (offsetvar
) = 0;
1140 gfc_trans_array_constructor_value (&loop
->pre
, type
,
1142 ss
->expr
->value
.constructor
, &offset
,
1145 if (TREE_USED (offsetvar
))
1146 pushdecl (offsetvar
);
1148 gcc_assert (INTEGER_CST_P (offset
));
1150 /* Disable bound checking for now because it's probably broken. */
1151 if (flag_bounds_check
)
1159 /* Add the pre and post chains for all the scalar expressions in a SS chain
1160 to loop. This is called after the loop parameters have been calculated,
1161 but before the actual scalarizing loops. */
1164 gfc_add_loop_ss_code (gfc_loopinfo
* loop
, gfc_ss
* ss
, bool subscript
)
1169 /* TODO: This can generate bad code if there are ordering dependencies.
1170 eg. a callee allocated function and an unknown size constructor. */
1171 gcc_assert (ss
!= NULL
);
1173 for (; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1180 /* Scalar expression. Evaluate this now. This includes elemental
1181 dimension indices, but not array section bounds. */
1182 gfc_init_se (&se
, NULL
);
1183 gfc_conv_expr (&se
, ss
->expr
);
1184 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1186 if (ss
->expr
->ts
.type
!= BT_CHARACTER
)
1188 /* Move the evaluation of scalar expressions outside the
1189 scalarization loop. */
1191 se
.expr
= convert(gfc_array_index_type
, se
.expr
);
1192 se
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1193 gfc_add_block_to_block (&loop
->pre
, &se
.post
);
1196 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1198 ss
->data
.scalar
.expr
= se
.expr
;
1199 ss
->string_length
= se
.string_length
;
1202 case GFC_SS_REFERENCE
:
1203 /* Scalar reference. Evaluate this now. */
1204 gfc_init_se (&se
, NULL
);
1205 gfc_conv_expr_reference (&se
, ss
->expr
);
1206 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1207 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1209 ss
->data
.scalar
.expr
= gfc_evaluate_now (se
.expr
, &loop
->pre
);
1210 ss
->string_length
= se
.string_length
;
1213 case GFC_SS_SECTION
:
1215 /* Scalarized expression. Evaluate any scalar subscripts. */
1216 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1218 /* Add the expressions for scalar subscripts. */
1219 if (ss
->data
.info
.subscript
[n
])
1220 gfc_add_loop_ss_code (loop
, ss
->data
.info
.subscript
[n
], true);
1224 case GFC_SS_INTRINSIC
:
1225 gfc_add_intrinsic_ss_code (loop
, ss
);
1228 case GFC_SS_FUNCTION
:
1229 /* Array function return value. We call the function and save its
1230 result in a temporary for use inside the loop. */
1231 gfc_init_se (&se
, NULL
);
1234 gfc_conv_expr (&se
, ss
->expr
);
1235 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
1236 gfc_add_block_to_block (&loop
->post
, &se
.post
);
1239 case GFC_SS_CONSTRUCTOR
:
1240 gfc_trans_array_constructor (loop
, ss
);
1244 case GFC_SS_COMPONENT
:
1245 /* Do nothing. These are handled elsewhere. */
1255 /* Translate expressions for the descriptor and data pointer of a SS. */
1259 gfc_conv_ss_descriptor (stmtblock_t
* block
, gfc_ss
* ss
, int base
)
1264 /* Get the descriptor for the array to be scalarized. */
1265 gcc_assert (ss
->expr
->expr_type
== EXPR_VARIABLE
);
1266 gfc_init_se (&se
, NULL
);
1267 se
.descriptor_only
= 1;
1268 gfc_conv_expr_lhs (&se
, ss
->expr
);
1269 gfc_add_block_to_block (block
, &se
.pre
);
1270 ss
->data
.info
.descriptor
= se
.expr
;
1271 ss
->string_length
= se
.string_length
;
1275 /* Also the data pointer. */
1276 tmp
= gfc_conv_array_data (se
.expr
);
1277 /* If this is a variable or address of a variable we use it directly.
1278 Otherwise we must evaluate it now to avoid breaking dependency
1279 analysis by pulling the expressions for elemental array indices
1282 || (TREE_CODE (tmp
) == ADDR_EXPR
1283 && DECL_P (TREE_OPERAND (tmp
, 0)))))
1284 tmp
= gfc_evaluate_now (tmp
, block
);
1285 ss
->data
.info
.data
= tmp
;
1287 tmp
= gfc_conv_array_offset (se
.expr
);
1288 ss
->data
.info
.offset
= gfc_evaluate_now (tmp
, block
);
1293 /* Initialize a gfc_loopinfo structure. */
1296 gfc_init_loopinfo (gfc_loopinfo
* loop
)
1300 memset (loop
, 0, sizeof (gfc_loopinfo
));
1301 gfc_init_block (&loop
->pre
);
1302 gfc_init_block (&loop
->post
);
1304 /* Initially scalarize in order. */
1305 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1308 loop
->ss
= gfc_ss_terminator
;
1312 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1316 gfc_copy_loopinfo_to_se (gfc_se
* se
, gfc_loopinfo
* loop
)
1322 /* Return an expression for the data pointer of an array. */
1325 gfc_conv_array_data (tree descriptor
)
1329 type
= TREE_TYPE (descriptor
);
1330 if (GFC_ARRAY_TYPE_P (type
))
1332 if (TREE_CODE (type
) == POINTER_TYPE
)
1336 /* Descriptorless arrays. */
1337 return gfc_build_addr_expr (NULL
, descriptor
);
1341 return gfc_conv_descriptor_data_get (descriptor
);
1345 /* Return an expression for the base offset of an array. */
1348 gfc_conv_array_offset (tree descriptor
)
1352 type
= TREE_TYPE (descriptor
);
1353 if (GFC_ARRAY_TYPE_P (type
))
1354 return GFC_TYPE_ARRAY_OFFSET (type
);
1356 return gfc_conv_descriptor_offset (descriptor
);
1360 /* Get an expression for the array stride. */
1363 gfc_conv_array_stride (tree descriptor
, int dim
)
1368 type
= TREE_TYPE (descriptor
);
1370 /* For descriptorless arrays use the array size. */
1371 tmp
= GFC_TYPE_ARRAY_STRIDE (type
, dim
);
1372 if (tmp
!= NULL_TREE
)
1375 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[dim
]);
1380 /* Like gfc_conv_array_stride, but for the lower bound. */
1383 gfc_conv_array_lbound (tree descriptor
, int dim
)
1388 type
= TREE_TYPE (descriptor
);
1390 tmp
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1391 if (tmp
!= NULL_TREE
)
1394 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[dim
]);
1399 /* Like gfc_conv_array_stride, but for the upper bound. */
1402 gfc_conv_array_ubound (tree descriptor
, int dim
)
1407 type
= TREE_TYPE (descriptor
);
1409 tmp
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1410 if (tmp
!= NULL_TREE
)
1413 /* This should only ever happen when passing an assumed shape array
1414 as an actual parameter. The value will never be used. */
1415 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor
)))
1416 return gfc_index_zero_node
;
1418 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[dim
]);
1423 /* Translate an array reference. The descriptor should be in se->expr.
1424 Do not use this function, it wil be removed soon. */
1428 gfc_conv_array_index_ref (gfc_se
* se
, tree pointer
, tree
* indices
,
1429 tree offset
, int dimen
)
1436 array
= gfc_build_indirect_ref (pointer
);
1439 for (n
= 0; n
< dimen
; n
++)
1441 /* index = index + stride[n]*indices[n] */
1442 tmp
= gfc_conv_array_stride (se
->expr
, n
);
1443 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indices
[n
], tmp
);
1445 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
1448 /* Result = data[index]. */
1449 tmp
= gfc_build_array_ref (array
, index
);
1451 /* Check we've used the correct number of dimensions. */
1452 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) != ARRAY_TYPE
);
1458 /* Generate code to perform an array index bound check. */
1461 gfc_trans_array_bound_check (gfc_se
* se
, tree descriptor
, tree index
, int n
)
1467 if (!flag_bounds_check
)
1470 index
= gfc_evaluate_now (index
, &se
->pre
);
1471 /* Check lower bound. */
1472 tmp
= gfc_conv_array_lbound (descriptor
, n
);
1473 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, index
, tmp
);
1474 /* Check upper bound. */
1475 tmp
= gfc_conv_array_ubound (descriptor
, n
);
1476 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, index
, tmp
);
1477 fault
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
);
1479 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1485 /* A reference to an array vector subscript. Uses recursion to handle nested
1486 vector subscripts. */
1489 gfc_conv_vector_array_index (gfc_se
* se
, tree index
, gfc_ss
* ss
)
1492 tree indices
[GFC_MAX_DIMENSIONS
];
1497 gcc_assert (ss
&& ss
->type
== GFC_SS_VECTOR
);
1499 /* Save the descriptor. */
1500 descsave
= se
->expr
;
1501 info
= &ss
->data
.info
;
1502 se
->expr
= info
->descriptor
;
1504 ar
= &info
->ref
->u
.ar
;
1505 for (n
= 0; n
< ar
->dimen
; n
++)
1507 switch (ar
->dimen_type
[n
])
1510 gcc_assert (info
->subscript
[n
] != gfc_ss_terminator
1511 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
1512 indices
[n
] = info
->subscript
[n
]->data
.scalar
.expr
;
1520 index
= gfc_conv_vector_array_index (se
, index
, info
->subscript
[n
]);
1523 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, n
);
1530 /* Get the index from the vector. */
1531 gfc_conv_array_index_ref (se
, info
->data
, indices
, info
->offset
, ar
->dimen
);
1533 /* Put the descriptor back. */
1534 se
->expr
= descsave
;
1540 /* Return the offset for an index. Performs bound checking for elemental
1541 dimensions. Single element references are processed separately. */
1544 gfc_conv_array_index_offset (gfc_se
* se
, gfc_ss_info
* info
, int dim
, int i
,
1545 gfc_array_ref
* ar
, tree stride
)
1549 /* Get the index into the array for this dimension. */
1552 gcc_assert (ar
->type
!= AR_ELEMENT
);
1553 if (ar
->dimen_type
[dim
] == DIMEN_ELEMENT
)
1555 gcc_assert (i
== -1);
1556 /* Elemental dimension. */
1557 gcc_assert (info
->subscript
[dim
]
1558 && info
->subscript
[dim
]->type
== GFC_SS_SCALAR
);
1559 /* We've already translated this value outside the loop. */
1560 index
= info
->subscript
[dim
]->data
.scalar
.expr
;
1563 gfc_trans_array_bound_check (se
, info
->descriptor
, index
, dim
);
1567 /* Scalarized dimension. */
1568 gcc_assert (info
&& se
->loop
);
1570 /* Multiply the loop variable by the stride and delta. */
1571 index
= se
->loop
->loopvar
[i
];
1572 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
,
1574 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
,
1577 if (ar
->dimen_type
[dim
] == DIMEN_VECTOR
)
1579 /* Handle vector subscripts. */
1580 index
= gfc_conv_vector_array_index (se
, index
,
1581 info
->subscript
[dim
]);
1583 gfc_trans_array_bound_check (se
, info
->descriptor
, index
,
1587 gcc_assert (ar
->dimen_type
[dim
] == DIMEN_RANGE
);
1592 /* Temporary array or derived type component. */
1593 gcc_assert (se
->loop
);
1594 index
= se
->loop
->loopvar
[se
->loop
->order
[i
]];
1595 if (!integer_zerop (info
->delta
[i
]))
1596 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1597 index
, info
->delta
[i
]);
1600 /* Multiply by the stride. */
1601 index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, index
, stride
);
1607 /* Build a scalarized reference to an array. */
1610 gfc_conv_scalarized_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1617 info
= &se
->ss
->data
.info
;
1619 n
= se
->loop
->order
[0];
1623 index
= gfc_conv_array_index_offset (se
, info
, info
->dim
[n
], n
, ar
,
1625 /* Add the offset for this dimension to the stored offset for all other
1627 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, info
->offset
);
1629 tmp
= gfc_build_indirect_ref (info
->data
);
1630 se
->expr
= gfc_build_array_ref (tmp
, index
);
1634 /* Translate access of temporary array. */
1637 gfc_conv_tmp_array_ref (gfc_se
* se
)
1639 se
->string_length
= se
->ss
->string_length
;
1640 gfc_conv_scalarized_array_ref (se
, NULL
);
1644 /* Build an array reference. se->expr already holds the array descriptor.
1645 This should be either a variable, indirect variable reference or component
1646 reference. For arrays which do not have a descriptor, se->expr will be
1648 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1651 gfc_conv_array_ref (gfc_se
* se
, gfc_array_ref
* ar
)
1660 /* Handle scalarized references separately. */
1661 if (ar
->type
!= AR_ELEMENT
)
1663 gfc_conv_scalarized_array_ref (se
, ar
);
1667 index
= gfc_index_zero_node
;
1669 fault
= gfc_index_zero_node
;
1671 /* Calculate the offsets from all the dimensions. */
1672 for (n
= 0; n
< ar
->dimen
; n
++)
1674 /* Calculate the index for this dimension. */
1675 gfc_init_se (&indexse
, NULL
);
1676 gfc_conv_expr_type (&indexse
, ar
->start
[n
], gfc_array_index_type
);
1677 gfc_add_block_to_block (&se
->pre
, &indexse
.pre
);
1679 if (flag_bounds_check
)
1681 /* Check array bounds. */
1684 indexse
.expr
= gfc_evaluate_now (indexse
.expr
, &se
->pre
);
1686 tmp
= gfc_conv_array_lbound (se
->expr
, n
);
1687 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
1690 fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
);
1692 tmp
= gfc_conv_array_ubound (se
->expr
, n
);
1693 cond
= fold_build2 (GT_EXPR
, boolean_type_node
,
1696 fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, cond
);
1699 /* Multiply the index by the stride. */
1700 stride
= gfc_conv_array_stride (se
->expr
, n
);
1701 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, indexse
.expr
,
1704 /* And add it to the total. */
1705 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
1708 if (flag_bounds_check
)
1709 gfc_trans_runtime_check (fault
, gfc_strconst_fault
, &se
->pre
);
1711 tmp
= gfc_conv_array_offset (se
->expr
);
1712 if (!integer_zerop (tmp
))
1713 index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, index
, tmp
);
1715 /* Access the calculated element. */
1716 tmp
= gfc_conv_array_data (se
->expr
);
1717 tmp
= gfc_build_indirect_ref (tmp
);
1718 se
->expr
= gfc_build_array_ref (tmp
, index
);
1722 /* Generate the code to be executed immediately before entering a
1723 scalarization loop. */
1726 gfc_trans_preloop_setup (gfc_loopinfo
* loop
, int dim
, int flag
,
1727 stmtblock_t
* pblock
)
1736 /* This code will be executed before entering the scalarization loop
1737 for this dimension. */
1738 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1740 if ((ss
->useflags
& flag
) == 0)
1743 if (ss
->type
!= GFC_SS_SECTION
1744 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1745 && ss
->type
!= GFC_SS_COMPONENT
)
1748 info
= &ss
->data
.info
;
1750 if (dim
>= info
->dimen
)
1753 if (dim
== info
->dimen
- 1)
1755 /* For the outermost loop calculate the offset due to any
1756 elemental dimensions. It will have been initialized with the
1757 base offset of the array. */
1760 for (i
= 0; i
< info
->ref
->u
.ar
.dimen
; i
++)
1762 if (info
->ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1765 gfc_init_se (&se
, NULL
);
1767 se
.expr
= info
->descriptor
;
1768 stride
= gfc_conv_array_stride (info
->descriptor
, i
);
1769 index
= gfc_conv_array_index_offset (&se
, info
, i
, -1,
1772 gfc_add_block_to_block (pblock
, &se
.pre
);
1774 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1775 info
->offset
, index
);
1776 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1780 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1783 stride
= gfc_conv_array_stride (info
->descriptor
, 0);
1785 /* Calculate the stride of the innermost loop. Hopefully this will
1786 allow the backend optimizers to do their stuff more effectively.
1788 info
->stride0
= gfc_evaluate_now (stride
, pblock
);
1792 /* Add the offset for the previous loop dimension. */
1797 ar
= &info
->ref
->u
.ar
;
1798 i
= loop
->order
[dim
+ 1];
1806 gfc_init_se (&se
, NULL
);
1808 se
.expr
= info
->descriptor
;
1809 stride
= gfc_conv_array_stride (info
->descriptor
, info
->dim
[i
]);
1810 index
= gfc_conv_array_index_offset (&se
, info
, info
->dim
[i
], i
,
1812 gfc_add_block_to_block (pblock
, &se
.pre
);
1813 info
->offset
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1814 info
->offset
, index
);
1815 info
->offset
= gfc_evaluate_now (info
->offset
, pblock
);
1818 /* Remember this offset for the second loop. */
1819 if (dim
== loop
->temp_dim
- 1)
1820 info
->saved_offset
= info
->offset
;
1825 /* Start a scalarized expression. Creates a scope and declares loop
1829 gfc_start_scalarized_body (gfc_loopinfo
* loop
, stmtblock_t
* pbody
)
1835 gcc_assert (!loop
->array_parameter
);
1837 for (dim
= loop
->dimen
- 1; dim
>= 0; dim
--)
1839 n
= loop
->order
[dim
];
1841 gfc_start_block (&loop
->code
[n
]);
1843 /* Create the loop variable. */
1844 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "S");
1846 if (dim
< loop
->temp_dim
)
1850 /* Calculate values that will be constant within this loop. */
1851 gfc_trans_preloop_setup (loop
, dim
, flags
, &loop
->code
[n
]);
1853 gfc_start_block (pbody
);
1857 /* Generates the actual loop code for a scalarization loop. */
1860 gfc_trans_scalarized_loop_end (gfc_loopinfo
* loop
, int n
,
1861 stmtblock_t
* pbody
)
1869 loopbody
= gfc_finish_block (pbody
);
1871 /* Initialize the loopvar. */
1872 gfc_add_modify_expr (&loop
->code
[n
], loop
->loopvar
[n
], loop
->from
[n
]);
1874 exit_label
= gfc_build_label_decl (NULL_TREE
);
1876 /* Generate the loop body. */
1877 gfc_init_block (&block
);
1879 /* The exit condition. */
1880 cond
= build2 (GT_EXPR
, boolean_type_node
, loop
->loopvar
[n
], loop
->to
[n
]);
1881 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1882 TREE_USED (exit_label
) = 1;
1883 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1884 gfc_add_expr_to_block (&block
, tmp
);
1886 /* The main body. */
1887 gfc_add_expr_to_block (&block
, loopbody
);
1889 /* Increment the loopvar. */
1890 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1891 loop
->loopvar
[n
], gfc_index_one_node
);
1892 gfc_add_modify_expr (&block
, loop
->loopvar
[n
], tmp
);
1894 /* Build the loop. */
1895 tmp
= gfc_finish_block (&block
);
1896 tmp
= build1_v (LOOP_EXPR
, tmp
);
1897 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1899 /* Add the exit label. */
1900 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1901 gfc_add_expr_to_block (&loop
->code
[n
], tmp
);
1905 /* Finishes and generates the loops for a scalarized expression. */
1908 gfc_trans_scalarizing_loops (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1913 stmtblock_t
*pblock
;
1917 /* Generate the loops. */
1918 for (dim
= 0; dim
< loop
->dimen
; dim
++)
1920 n
= loop
->order
[dim
];
1921 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1922 loop
->loopvar
[n
] = NULL_TREE
;
1923 pblock
= &loop
->code
[n
];
1926 tmp
= gfc_finish_block (pblock
);
1927 gfc_add_expr_to_block (&loop
->pre
, tmp
);
1929 /* Clear all the used flags. */
1930 for (ss
= loop
->ss
; ss
; ss
= ss
->loop_chain
)
1935 /* Finish the main body of a scalarized expression, and start the secondary
1939 gfc_trans_scalarized_loop_boundary (gfc_loopinfo
* loop
, stmtblock_t
* body
)
1943 stmtblock_t
*pblock
;
1947 /* We finish as many loops as are used by the temporary. */
1948 for (dim
= 0; dim
< loop
->temp_dim
- 1; dim
++)
1950 n
= loop
->order
[dim
];
1951 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1952 loop
->loopvar
[n
] = NULL_TREE
;
1953 pblock
= &loop
->code
[n
];
1956 /* We don't want to finish the outermost loop entirely. */
1957 n
= loop
->order
[loop
->temp_dim
- 1];
1958 gfc_trans_scalarized_loop_end (loop
, n
, pblock
);
1960 /* Restore the initial offsets. */
1961 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
1963 if ((ss
->useflags
& 2) == 0)
1966 if (ss
->type
!= GFC_SS_SECTION
1967 && ss
->type
!= GFC_SS_FUNCTION
&& ss
->type
!= GFC_SS_CONSTRUCTOR
1968 && ss
->type
!= GFC_SS_COMPONENT
)
1971 ss
->data
.info
.offset
= ss
->data
.info
.saved_offset
;
1974 /* Restart all the inner loops we just finished. */
1975 for (dim
= loop
->temp_dim
- 2; dim
>= 0; dim
--)
1977 n
= loop
->order
[dim
];
1979 gfc_start_block (&loop
->code
[n
]);
1981 loop
->loopvar
[n
] = gfc_create_var (gfc_array_index_type
, "Q");
1983 gfc_trans_preloop_setup (loop
, dim
, 2, &loop
->code
[n
]);
1986 /* Start a block for the secondary copying code. */
1987 gfc_start_block (body
);
1991 /* Calculate the upper bound of an array section. */
1994 gfc_conv_section_upper_bound (gfc_ss
* ss
, int n
, stmtblock_t
* pblock
)
2003 gcc_assert (ss
->type
== GFC_SS_SECTION
);
2005 /* For vector array subscripts we want the size of the vector. */
2006 dim
= ss
->data
.info
.dim
[n
];
2008 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2010 vecss
= vecss
->data
.info
.subscript
[dim
];
2011 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2012 dim
= vecss
->data
.info
.dim
[0];
2015 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2016 end
= vecss
->data
.info
.ref
->u
.ar
.end
[dim
];
2017 desc
= vecss
->data
.info
.descriptor
;
2021 /* The upper bound was specified. */
2022 gfc_init_se (&se
, NULL
);
2023 gfc_conv_expr_type (&se
, end
, gfc_array_index_type
);
2024 gfc_add_block_to_block (pblock
, &se
.pre
);
2029 /* No upper bound was specified, so use the bound of the array. */
2030 bound
= gfc_conv_array_ubound (desc
, dim
);
2037 /* Calculate the lower bound of an array section. */
2040 gfc_conv_section_startstride (gfc_loopinfo
* loop
, gfc_ss
* ss
, int n
)
2050 info
= &ss
->data
.info
;
2054 /* For vector array subscripts we want the size of the vector. */
2056 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2058 vecss
= vecss
->data
.info
.subscript
[dim
];
2059 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2060 /* Get the descriptors for the vector subscripts as well. */
2061 if (!vecss
->data
.info
.descriptor
)
2062 gfc_conv_ss_descriptor (&loop
->pre
, vecss
, !loop
->array_parameter
);
2063 dim
= vecss
->data
.info
.dim
[0];
2066 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
] == DIMEN_RANGE
);
2067 start
= vecss
->data
.info
.ref
->u
.ar
.start
[dim
];
2068 stride
= vecss
->data
.info
.ref
->u
.ar
.stride
[dim
];
2069 desc
= vecss
->data
.info
.descriptor
;
2071 /* Calculate the start of the range. For vector subscripts this will
2072 be the range of the vector. */
2075 /* Specified section start. */
2076 gfc_init_se (&se
, NULL
);
2077 gfc_conv_expr_type (&se
, start
, gfc_array_index_type
);
2078 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2079 info
->start
[n
] = se
.expr
;
2083 /* No lower bound specified so use the bound of the array. */
2084 info
->start
[n
] = gfc_conv_array_lbound (desc
, dim
);
2086 info
->start
[n
] = gfc_evaluate_now (info
->start
[n
], &loop
->pre
);
2088 /* Calculate the stride. */
2090 info
->stride
[n
] = gfc_index_one_node
;
2093 gfc_init_se (&se
, NULL
);
2094 gfc_conv_expr_type (&se
, stride
, gfc_array_index_type
);
2095 gfc_add_block_to_block (&loop
->pre
, &se
.pre
);
2096 info
->stride
[n
] = gfc_evaluate_now (se
.expr
, &loop
->pre
);
2101 /* Calculates the range start and stride for a SS chain. Also gets the
2102 descriptor and data pointer. The range of vector subscripts is the size
2103 of the vector. Array bounds are also checked. */
2106 gfc_conv_ss_startstride (gfc_loopinfo
* loop
)
2115 /* Determine the rank of the loop. */
2117 ss
!= gfc_ss_terminator
&& loop
->dimen
== 0; ss
= ss
->loop_chain
)
2121 case GFC_SS_SECTION
:
2122 case GFC_SS_CONSTRUCTOR
:
2123 case GFC_SS_FUNCTION
:
2124 case GFC_SS_COMPONENT
:
2125 loop
->dimen
= ss
->data
.info
.dimen
;
2133 if (loop
->dimen
== 0)
2134 gfc_todo_error ("Unable to determine rank of expression");
2137 /* Loop over all the SS in the chain. */
2138 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2140 if (ss
->expr
&& ss
->expr
->shape
&& !ss
->shape
)
2141 ss
->shape
= ss
->expr
->shape
;
2145 case GFC_SS_SECTION
:
2146 /* Get the descriptor for the array. */
2147 gfc_conv_ss_descriptor (&loop
->pre
, ss
, !loop
->array_parameter
);
2149 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2150 gfc_conv_section_startstride (loop
, ss
, n
);
2153 case GFC_SS_CONSTRUCTOR
:
2154 case GFC_SS_FUNCTION
:
2155 for (n
= 0; n
< ss
->data
.info
.dimen
; n
++)
2157 ss
->data
.info
.start
[n
] = gfc_index_zero_node
;
2158 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2167 /* The rest is just runtime bound checking. */
2168 if (flag_bounds_check
)
2174 tree size
[GFC_MAX_DIMENSIONS
];
2178 gfc_start_block (&block
);
2180 fault
= integer_zero_node
;
2181 for (n
= 0; n
< loop
->dimen
; n
++)
2182 size
[n
] = NULL_TREE
;
2184 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2186 if (ss
->type
!= GFC_SS_SECTION
)
2189 /* TODO: range checking for mapped dimensions. */
2190 info
= &ss
->data
.info
;
2192 /* This only checks scalarized dimensions, elemental dimensions are
2194 for (n
= 0; n
< loop
->dimen
; n
++)
2198 while (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2201 vecss
= vecss
->data
.info
.subscript
[dim
];
2202 gcc_assert (vecss
&& vecss
->type
== GFC_SS_VECTOR
);
2203 dim
= vecss
->data
.info
.dim
[0];
2205 gcc_assert (vecss
->data
.info
.ref
->u
.ar
.dimen_type
[dim
]
2207 desc
= vecss
->data
.info
.descriptor
;
2209 /* Check lower bound. */
2210 bound
= gfc_conv_array_lbound (desc
, dim
);
2211 tmp
= info
->start
[n
];
2212 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, tmp
, bound
);
2213 fault
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2216 /* Check the upper bound. */
2217 bound
= gfc_conv_array_ubound (desc
, dim
);
2218 end
= gfc_conv_section_upper_bound (ss
, n
, &block
);
2219 tmp
= fold_build2 (GT_EXPR
, boolean_type_node
, end
, bound
);
2220 fault
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
,
2223 /* Check the section sizes match. */
2224 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, end
,
2226 tmp
= fold_build2 (FLOOR_DIV_EXPR
, gfc_array_index_type
, tmp
,
2228 /* We remember the size of the first section, and check all the
2229 others against this. */
2233 fold_build2 (NE_EXPR
, boolean_type_node
, tmp
, size
[n
]);
2235 build2 (TRUTH_OR_EXPR
, boolean_type_node
, fault
, tmp
);
2238 size
[n
] = gfc_evaluate_now (tmp
, &block
);
2241 gfc_trans_runtime_check (fault
, gfc_strconst_bounds
, &block
);
2243 tmp
= gfc_finish_block (&block
);
2244 gfc_add_expr_to_block (&loop
->pre
, tmp
);
2249 /* Return true if the two SS could be aliased, i.e. both point to the same data
2251 /* TODO: resolve aliases based on frontend expressions. */
2254 gfc_could_be_alias (gfc_ss
* lss
, gfc_ss
* rss
)
2261 lsym
= lss
->expr
->symtree
->n
.sym
;
2262 rsym
= rss
->expr
->symtree
->n
.sym
;
2263 if (gfc_symbols_could_alias (lsym
, rsym
))
2266 if (rsym
->ts
.type
!= BT_DERIVED
2267 && lsym
->ts
.type
!= BT_DERIVED
)
2270 /* For derived types we must check all the component types. We can ignore
2271 array references as these will have the same base type as the previous
2273 for (lref
= lss
->expr
->ref
; lref
!= lss
->data
.info
.ref
; lref
= lref
->next
)
2275 if (lref
->type
!= REF_COMPONENT
)
2278 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rsym
))
2281 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
;
2284 if (rref
->type
!= REF_COMPONENT
)
2287 if (gfc_symbols_could_alias (lref
->u
.c
.sym
, rref
->u
.c
.sym
))
2292 for (rref
= rss
->expr
->ref
; rref
!= rss
->data
.info
.ref
; rref
= rref
->next
)
2294 if (rref
->type
!= REF_COMPONENT
)
2297 if (gfc_symbols_could_alias (rref
->u
.c
.sym
, lsym
))
2305 /* Resolve array data dependencies. Creates a temporary if required. */
2306 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2310 gfc_conv_resolve_dependencies (gfc_loopinfo
* loop
, gfc_ss
* dest
,
2320 loop
->temp_ss
= NULL
;
2321 aref
= dest
->data
.info
.ref
;
2324 for (ss
= rss
; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
2326 if (ss
->type
!= GFC_SS_SECTION
)
2329 if (gfc_could_be_alias (dest
, ss
))
2335 if (dest
->expr
->symtree
->n
.sym
== ss
->expr
->symtree
->n
.sym
)
2337 lref
= dest
->expr
->ref
;
2338 rref
= ss
->expr
->ref
;
2340 nDepend
= gfc_dep_resolver (lref
, rref
);
2342 /* TODO : loop shifting. */
2345 /* Mark the dimensions for LOOP SHIFTING */
2346 for (n
= 0; n
< loop
->dimen
; n
++)
2348 int dim
= dest
->data
.info
.dim
[n
];
2350 if (lref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
2352 else if (! gfc_is_same_range (&lref
->u
.ar
,
2353 &rref
->u
.ar
, dim
, 0))
2357 /* Put all the dimensions with dependencies in the
2360 for (n
= 0; n
< loop
->dimen
; n
++)
2362 gcc_assert (loop
->order
[n
] == n
);
2364 loop
->order
[dim
++] = n
;
2367 for (n
= 0; n
< loop
->dimen
; n
++)
2370 loop
->order
[dim
++] = n
;
2373 gcc_assert (dim
== loop
->dimen
);
2382 loop
->temp_ss
= gfc_get_ss ();
2383 loop
->temp_ss
->type
= GFC_SS_TEMP
;
2384 loop
->temp_ss
->data
.temp
.type
=
2385 gfc_get_element_type (TREE_TYPE (dest
->data
.info
.descriptor
));
2386 loop
->temp_ss
->string_length
= dest
->string_length
;
2387 loop
->temp_ss
->data
.temp
.dimen
= loop
->dimen
;
2388 loop
->temp_ss
->next
= gfc_ss_terminator
;
2389 gfc_add_ss_to_loop (loop
, loop
->temp_ss
);
2392 loop
->temp_ss
= NULL
;
2396 /* Initialize the scalarization loop. Creates the loop variables. Determines
2397 the range of the loop variables. Creates a temporary if required.
2398 Calculates how to transform from loop variables to array indices for each
2399 expression. Also generates code for scalar expressions which have been
2400 moved outside the loop. */
2403 gfc_conv_loop_setup (gfc_loopinfo
* loop
)
2408 gfc_ss_info
*specinfo
;
2412 gfc_ss
*loopspec
[GFC_MAX_DIMENSIONS
];
2417 for (n
= 0; n
< loop
->dimen
; n
++)
2420 /* We use one SS term, and use that to determine the bounds of the
2421 loop for this dimension. We try to pick the simplest term. */
2422 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2426 /* The frontend has worked out the size for us. */
2431 if (ss
->type
== GFC_SS_CONSTRUCTOR
)
2433 /* An unknown size constructor will always be rank one.
2434 Higher rank constructors will either have known shape,
2435 or still be wrapped in a call to reshape. */
2436 gcc_assert (loop
->dimen
== 1);
2437 /* Try to figure out the size of the constructor. */
2438 /* TODO: avoid this by making the frontend set the shape. */
2439 gfc_get_array_cons_size (&i
, ss
->expr
->value
.constructor
);
2440 /* A negative value means we failed. */
2441 if (mpz_sgn (i
) > 0)
2443 mpz_sub_ui (i
, i
, 1);
2445 gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2451 /* TODO: Pick the best bound if we have a choice between a
2452 function and something else. */
2453 if (ss
->type
== GFC_SS_FUNCTION
)
2459 if (ss
->type
!= GFC_SS_SECTION
)
2463 specinfo
= &loopspec
[n
]->data
.info
;
2466 info
= &ss
->data
.info
;
2468 /* Criteria for choosing a loop specifier (most important first):
2476 /* TODO: Is != constructor correct? */
2477 else if (loopspec
[n
]->type
!= GFC_SS_CONSTRUCTOR
)
2479 if (integer_onep (info
->stride
[n
])
2480 && !integer_onep (specinfo
->stride
[n
]))
2482 else if (INTEGER_CST_P (info
->stride
[n
])
2483 && !INTEGER_CST_P (specinfo
->stride
[n
]))
2485 else if (INTEGER_CST_P (info
->start
[n
])
2486 && !INTEGER_CST_P (specinfo
->start
[n
]))
2488 /* We don't work out the upper bound.
2489 else if (INTEGER_CST_P (info->finish[n])
2490 && ! INTEGER_CST_P (specinfo->finish[n]))
2491 loopspec[n] = ss; */
2496 gfc_todo_error ("Unable to find scalarization loop specifier");
2498 info
= &loopspec
[n
]->data
.info
;
2500 /* Set the extents of this range. */
2501 cshape
= loopspec
[n
]->shape
;
2502 if (cshape
&& INTEGER_CST_P (info
->start
[n
])
2503 && INTEGER_CST_P (info
->stride
[n
]))
2505 loop
->from
[n
] = info
->start
[n
];
2506 mpz_set (i
, cshape
[n
]);
2507 mpz_sub_ui (i
, i
, 1);
2508 /* To = from + (size - 1) * stride. */
2509 tmp
= gfc_conv_mpz_to_tree (i
, gfc_index_integer_kind
);
2510 if (!integer_onep (info
->stride
[n
]))
2511 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2512 tmp
, info
->stride
[n
]);
2513 loop
->to
[n
] = fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2514 loop
->from
[n
], tmp
);
2518 loop
->from
[n
] = info
->start
[n
];
2519 switch (loopspec
[n
]->type
)
2521 case GFC_SS_CONSTRUCTOR
:
2522 gcc_assert (info
->dimen
== 1);
2523 gcc_assert (loop
->to
[n
]);
2526 case GFC_SS_SECTION
:
2527 loop
->to
[n
] = gfc_conv_section_upper_bound (loopspec
[n
], n
,
2531 case GFC_SS_FUNCTION
:
2532 /* The loop bound will be set when we generate the call. */
2533 gcc_assert (loop
->to
[n
] == NULL_TREE
);
2541 /* Transform everything so we have a simple incrementing variable. */
2542 if (integer_onep (info
->stride
[n
]))
2543 info
->delta
[n
] = gfc_index_zero_node
;
2546 /* Set the delta for this section. */
2547 info
->delta
[n
] = gfc_evaluate_now (loop
->from
[n
], &loop
->pre
);
2548 /* Number of iterations is (end - start + step) / step.
2549 with start = 0, this simplifies to
2551 for (i = 0; i<=last; i++){...}; */
2552 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2553 loop
->to
[n
], loop
->from
[n
]);
2554 tmp
= fold_build2 (TRUNC_DIV_EXPR
, gfc_array_index_type
,
2555 tmp
, info
->stride
[n
]);
2556 loop
->to
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2557 /* Make the loop variable start at 0. */
2558 loop
->from
[n
] = gfc_index_zero_node
;
2562 /* Add all the scalar code that can be taken out of the loops.
2563 This may include calculating the loop bounds, so do it before
2564 allocating the temporary. */
2565 gfc_add_loop_ss_code (loop
, loop
->ss
, false);
2567 /* If we want a temporary then create it. */
2568 if (loop
->temp_ss
!= NULL
)
2570 gcc_assert (loop
->temp_ss
->type
== GFC_SS_TEMP
);
2571 tmp
= loop
->temp_ss
->data
.temp
.type
;
2572 len
= loop
->temp_ss
->string_length
;
2573 n
= loop
->temp_ss
->data
.temp
.dimen
;
2574 memset (&loop
->temp_ss
->data
.info
, 0, sizeof (gfc_ss_info
));
2575 loop
->temp_ss
->type
= GFC_SS_SECTION
;
2576 loop
->temp_ss
->data
.info
.dimen
= n
;
2577 gfc_trans_allocate_temp_array (loop
, &loop
->temp_ss
->data
.info
, tmp
);
2580 for (n
= 0; n
< loop
->temp_dim
; n
++)
2581 loopspec
[loop
->order
[n
]] = NULL
;
2585 /* For array parameters we don't have loop variables, so don't calculate the
2587 if (loop
->array_parameter
)
2590 /* Calculate the translation from loop variables to array indices. */
2591 for (ss
= loop
->ss
; ss
!= gfc_ss_terminator
; ss
= ss
->loop_chain
)
2593 if (ss
->type
!= GFC_SS_SECTION
&& ss
->type
!= GFC_SS_COMPONENT
)
2596 info
= &ss
->data
.info
;
2598 for (n
= 0; n
< info
->dimen
; n
++)
2602 /* If we are specifying the range the delta is already set. */
2603 if (loopspec
[n
] != ss
)
2605 /* Calculate the offset relative to the loop variable.
2606 First multiply by the stride. */
2607 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2608 loop
->from
[n
], info
->stride
[n
]);
2610 /* Then subtract this from our starting value. */
2611 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2612 info
->start
[n
], tmp
);
2614 info
->delta
[n
] = gfc_evaluate_now (tmp
, &loop
->pre
);
2621 /* Fills in an array descriptor, and returns the size of the array. The size
2622 will be a simple_val, ie a variable or a constant. Also calculates the
2623 offset of the base. Returns the size of the array.
2627 for (n = 0; n < rank; n++)
2629 a.lbound[n] = specified_lower_bound;
2630 offset = offset + a.lbond[n] * stride;
2632 a.ubound[n] = specified_upper_bound;
2633 a.stride[n] = stride;
2634 size = ubound + size; //size = ubound + 1 - lbound
2635 stride = stride * size;
2642 gfc_array_init_size (tree descriptor
, int rank
, tree
* poffset
,
2643 gfc_expr
** lower
, gfc_expr
** upper
,
2644 stmtblock_t
* pblock
)
2655 type
= TREE_TYPE (descriptor
);
2657 stride
= gfc_index_one_node
;
2658 offset
= gfc_index_zero_node
;
2660 /* Set the dtype. */
2661 tmp
= gfc_conv_descriptor_dtype (descriptor
);
2662 gfc_add_modify_expr (pblock
, tmp
, gfc_get_dtype (TREE_TYPE (descriptor
)));
2664 for (n
= 0; n
< rank
; n
++)
2666 /* We have 3 possibilities for determining the size of the array:
2667 lower == NULL => lbound = 1, ubound = upper[n]
2668 upper[n] = NULL => lbound = 1, ubound = lower[n]
2669 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2672 /* Set lower bound. */
2673 gfc_init_se (&se
, NULL
);
2675 se
.expr
= gfc_index_one_node
;
2678 gcc_assert (lower
[n
]);
2681 gfc_conv_expr_type (&se
, lower
[n
], gfc_array_index_type
);
2682 gfc_add_block_to_block (pblock
, &se
.pre
);
2686 se
.expr
= gfc_index_one_node
;
2690 tmp
= gfc_conv_descriptor_lbound (descriptor
, gfc_rank_cst
[n
]);
2691 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2693 /* Work out the offset for this component. */
2694 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, se
.expr
, stride
);
2695 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
2697 /* Start the calculation for the size of this dimension. */
2698 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
2699 gfc_index_one_node
, se
.expr
);
2701 /* Set upper bound. */
2702 gfc_init_se (&se
, NULL
);
2703 gcc_assert (ubound
);
2704 gfc_conv_expr_type (&se
, ubound
, gfc_array_index_type
);
2705 gfc_add_block_to_block (pblock
, &se
.pre
);
2707 tmp
= gfc_conv_descriptor_ubound (descriptor
, gfc_rank_cst
[n
]);
2708 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
2710 /* Store the stride. */
2711 tmp
= gfc_conv_descriptor_stride (descriptor
, gfc_rank_cst
[n
]);
2712 gfc_add_modify_expr (pblock
, tmp
, stride
);
2714 /* Calculate the size of this dimension. */
2715 size
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, se
.expr
, size
);
2717 /* Multiply the stride by the number of elements in this dimension. */
2718 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, size
);
2719 stride
= gfc_evaluate_now (stride
, pblock
);
2722 /* The stride is the number of elements in the array, so multiply by the
2723 size of an element to get the total size. */
2724 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2725 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, stride
, tmp
);
2727 if (poffset
!= NULL
)
2729 offset
= gfc_evaluate_now (offset
, pblock
);
2733 size
= gfc_evaluate_now (size
, pblock
);
2738 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
2739 the work for an ALLOCATE statement. */
2743 gfc_array_allocate (gfc_se
* se
, gfc_ref
* ref
, tree pstat
)
2753 /* Figure out the size of the array. */
2754 switch (ref
->u
.ar
.type
)
2758 upper
= ref
->u
.ar
.start
;
2762 gcc_assert (ref
->u
.ar
.as
->type
== AS_EXPLICIT
);
2764 lower
= ref
->u
.ar
.as
->lower
;
2765 upper
= ref
->u
.ar
.as
->upper
;
2769 lower
= ref
->u
.ar
.start
;
2770 upper
= ref
->u
.ar
.end
;
2778 size
= gfc_array_init_size (se
->expr
, ref
->u
.ar
.as
->rank
, &offset
,
2779 lower
, upper
, &se
->pre
);
2781 /* Allocate memory to store the data. */
2782 tmp
= gfc_conv_descriptor_data_addr (se
->expr
);
2783 pointer
= gfc_evaluate_now (tmp
, &se
->pre
);
2785 if (TYPE_PRECISION (gfc_array_index_type
) == 32)
2786 allocate
= gfor_fndecl_allocate
;
2787 else if (TYPE_PRECISION (gfc_array_index_type
) == 64)
2788 allocate
= gfor_fndecl_allocate64
;
2792 tmp
= gfc_chainon_list (NULL_TREE
, pointer
);
2793 tmp
= gfc_chainon_list (tmp
, size
);
2794 tmp
= gfc_chainon_list (tmp
, pstat
);
2795 tmp
= gfc_build_function_call (allocate
, tmp
);
2796 gfc_add_expr_to_block (&se
->pre
, tmp
);
2798 tmp
= gfc_conv_descriptor_offset (se
->expr
);
2799 gfc_add_modify_expr (&se
->pre
, tmp
, offset
);
2803 /* Deallocate an array variable. Also used when an allocated variable goes
2808 gfc_array_deallocate (tree descriptor
, tree pstat
)
2814 gfc_start_block (&block
);
2815 /* Get a pointer to the data. */
2816 tmp
= gfc_conv_descriptor_data_addr (descriptor
);
2817 var
= gfc_evaluate_now (tmp
, &block
);
2819 /* Parameter is the address of the data component. */
2820 tmp
= gfc_chainon_list (NULL_TREE
, var
);
2821 tmp
= gfc_chainon_list (tmp
, pstat
);
2822 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
2823 gfc_add_expr_to_block (&block
, tmp
);
2825 return gfc_finish_block (&block
);
2829 /* Create an array constructor from an initialization expression.
2830 We assume the frontend already did any expansions and conversions. */
2833 gfc_conv_array_initializer (tree type
, gfc_expr
* expr
)
2841 unsigned HOST_WIDE_INT lo
;
2845 switch (expr
->expr_type
)
2848 case EXPR_STRUCTURE
:
2849 /* A single scalar or derived type value. Create an array with all
2850 elements equal to that value. */
2851 gfc_init_se (&se
, NULL
);
2853 if (expr
->expr_type
== EXPR_CONSTANT
)
2854 gfc_conv_constant (&se
, expr
);
2856 gfc_conv_structure (&se
, expr
, 1);
2858 tmp
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2859 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2860 hi
= TREE_INT_CST_HIGH (tmp
);
2861 lo
= TREE_INT_CST_LOW (tmp
);
2865 /* This will probably eat buckets of memory for large arrays. */
2866 while (hi
!= 0 || lo
!= 0)
2868 list
= tree_cons (NULL_TREE
, se
.expr
, list
);
2876 /* Create a list of all the elements. */
2877 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2881 /* Problems occur when we get something like
2882 integer :: a(lots) = (/(i, i=1,lots)/) */
2883 /* TODO: Unexpanded array initializers. */
2885 ("Possible frontend bug: array constructor not expanded");
2887 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2888 index
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2892 if (mpz_cmp_si (c
->repeat
, 0) != 0)
2896 mpz_set (maxval
, c
->repeat
);
2897 mpz_add (maxval
, c
->n
.offset
, maxval
);
2898 mpz_sub_ui (maxval
, maxval
, 1);
2899 tmp2
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2900 if (mpz_cmp_si (c
->n
.offset
, 0) != 0)
2902 mpz_add_ui (maxval
, c
->n
.offset
, 1);
2903 tmp1
= gfc_conv_mpz_to_tree (maxval
, gfc_index_integer_kind
);
2906 tmp1
= gfc_conv_mpz_to_tree (c
->n
.offset
, gfc_index_integer_kind
);
2908 range
= build2 (RANGE_EXPR
, integer_type_node
, tmp1
, tmp2
);
2914 gfc_init_se (&se
, NULL
);
2915 switch (c
->expr
->expr_type
)
2918 gfc_conv_constant (&se
, c
->expr
);
2919 if (range
== NULL_TREE
)
2920 list
= tree_cons (index
, se
.expr
, list
);
2923 if (index
!= NULL_TREE
)
2924 list
= tree_cons (index
, se
.expr
, list
);
2925 list
= tree_cons (range
, se
.expr
, list
);
2929 case EXPR_STRUCTURE
:
2930 gfc_conv_structure (&se
, c
->expr
, 1);
2931 list
= tree_cons (index
, se
.expr
, list
);
2938 /* We created the list in reverse order. */
2939 list
= nreverse (list
);
2946 /* Create a constructor from the list of elements. */
2947 tmp
= build1 (CONSTRUCTOR
, type
, list
);
2948 TREE_CONSTANT (tmp
) = 1;
2949 TREE_INVARIANT (tmp
) = 1;
2954 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
2955 returns the size (in elements) of the array. */
2958 gfc_trans_array_bounds (tree type
, gfc_symbol
* sym
, tree
* poffset
,
2959 stmtblock_t
* pblock
)
2974 size
= gfc_index_one_node
;
2975 offset
= gfc_index_zero_node
;
2976 for (dim
= 0; dim
< as
->rank
; dim
++)
2978 /* Evaluate non-constant array bound expressions. */
2979 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
2980 if (as
->lower
[dim
] && !INTEGER_CST_P (lbound
))
2982 gfc_init_se (&se
, NULL
);
2983 gfc_conv_expr_type (&se
, as
->lower
[dim
], gfc_array_index_type
);
2984 gfc_add_block_to_block (pblock
, &se
.pre
);
2985 gfc_add_modify_expr (pblock
, lbound
, se
.expr
);
2987 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
2988 if (as
->upper
[dim
] && !INTEGER_CST_P (ubound
))
2990 gfc_init_se (&se
, NULL
);
2991 gfc_conv_expr_type (&se
, as
->upper
[dim
], gfc_array_index_type
);
2992 gfc_add_block_to_block (pblock
, &se
.pre
);
2993 gfc_add_modify_expr (pblock
, ubound
, se
.expr
);
2995 /* The offset of this dimension. offset = offset - lbound * stride. */
2996 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, size
);
2997 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
2999 /* The size of this dimension, and the stride of the next. */
3000 if (dim
+ 1 < as
->rank
)
3001 stride
= GFC_TYPE_ARRAY_STRIDE (type
, dim
+ 1);
3005 if (ubound
!= NULL_TREE
&& !(stride
&& INTEGER_CST_P (stride
)))
3007 /* Calculate stride = size * (ubound + 1 - lbound). */
3008 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3009 gfc_index_one_node
, lbound
);
3010 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, ubound
, tmp
);
3011 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3013 gfc_add_modify_expr (pblock
, stride
, tmp
);
3015 stride
= gfc_evaluate_now (tmp
, pblock
);
3026 /* Generate code to initialize/allocate an array variable. */
3029 gfc_trans_auto_array_allocation (tree decl
, gfc_symbol
* sym
, tree fnbody
)
3039 gcc_assert (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
));
3041 /* Do nothing for USEd variables. */
3042 if (sym
->attr
.use_assoc
)
3045 type
= TREE_TYPE (decl
);
3046 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3047 onstack
= TREE_CODE (type
) != POINTER_TYPE
;
3049 gfc_start_block (&block
);
3051 /* Evaluate character string length. */
3052 if (sym
->ts
.type
== BT_CHARACTER
3053 && onstack
&& !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3055 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3057 /* Emit a DECL_EXPR for this variable, which will cause the
3058 gimplifier to allocate storage, and all that good stuff. */
3059 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
3060 gfc_add_expr_to_block (&block
, tmp
);
3065 gfc_add_expr_to_block (&block
, fnbody
);
3066 return gfc_finish_block (&block
);
3069 type
= TREE_TYPE (type
);
3071 gcc_assert (!sym
->attr
.use_assoc
);
3072 gcc_assert (!TREE_STATIC (decl
));
3073 gcc_assert (!sym
->module
);
3075 if (sym
->ts
.type
== BT_CHARACTER
3076 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
3077 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3079 size
= gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3081 /* The size is the number of elements in the array, so multiply by the
3082 size of an element to get the total size. */
3083 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3084 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
3086 /* Allocate memory to hold the data. */
3087 tmp
= gfc_chainon_list (NULL_TREE
, size
);
3089 if (gfc_index_integer_kind
== 4)
3090 fndecl
= gfor_fndecl_internal_malloc
;
3091 else if (gfc_index_integer_kind
== 8)
3092 fndecl
= gfor_fndecl_internal_malloc64
;
3095 tmp
= gfc_build_function_call (fndecl
, tmp
);
3096 tmp
= fold (convert (TREE_TYPE (decl
), tmp
));
3097 gfc_add_modify_expr (&block
, decl
, tmp
);
3099 /* Set offset of the array. */
3100 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3101 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3104 /* Automatic arrays should not have initializers. */
3105 gcc_assert (!sym
->value
);
3107 gfc_add_expr_to_block (&block
, fnbody
);
3109 /* Free the temporary. */
3110 tmp
= convert (pvoid_type_node
, decl
);
3111 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3112 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3113 gfc_add_expr_to_block (&block
, tmp
);
3115 return gfc_finish_block (&block
);
3119 /* Generate entry and exit code for g77 calling convention arrays. */
3122 gfc_trans_g77_array (gfc_symbol
* sym
, tree body
)
3131 gfc_get_backend_locus (&loc
);
3132 gfc_set_backend_locus (&sym
->declared_at
);
3134 /* Descriptor type. */
3135 parm
= sym
->backend_decl
;
3136 type
= TREE_TYPE (parm
);
3137 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3139 gfc_start_block (&block
);
3141 if (sym
->ts
.type
== BT_CHARACTER
3142 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3143 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3145 /* Evaluate the bounds of the array. */
3146 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
3148 /* Set the offset. */
3149 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3150 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3152 /* Set the pointer itself if we aren't using the parameter directly. */
3153 if (TREE_CODE (parm
) != PARM_DECL
)
3155 tmp
= convert (TREE_TYPE (parm
), GFC_DECL_SAVED_DESCRIPTOR (parm
));
3156 gfc_add_modify_expr (&block
, parm
, tmp
);
3158 tmp
= gfc_finish_block (&block
);
3160 gfc_set_backend_locus (&loc
);
3162 gfc_start_block (&block
);
3163 /* Add the initialization code to the start of the function. */
3164 gfc_add_expr_to_block (&block
, tmp
);
3165 gfc_add_expr_to_block (&block
, body
);
3167 return gfc_finish_block (&block
);
3171 /* Modify the descriptor of an array parameter so that it has the
3172 correct lower bound. Also move the upper bound accordingly.
3173 If the array is not packed, it will be copied into a temporary.
3174 For each dimension we set the new lower and upper bounds. Then we copy the
3175 stride and calculate the offset for this dimension. We also work out
3176 what the stride of a packed array would be, and see it the two match.
3177 If the array need repacking, we set the stride to the values we just
3178 calculated, recalculate the offset and copy the array data.
3179 Code is also added to copy the data back at the end of the function.
3183 gfc_trans_dummy_array_bias (gfc_symbol
* sym
, tree tmpdesc
, tree body
)
3190 stmtblock_t cleanup
;
3208 /* Do nothing for pointer and allocatable arrays. */
3209 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3212 if (sym
->attr
.dummy
&& gfc_is_nodesc_array (sym
))
3213 return gfc_trans_g77_array (sym
, body
);
3215 gfc_get_backend_locus (&loc
);
3216 gfc_set_backend_locus (&sym
->declared_at
);
3218 /* Descriptor type. */
3219 type
= TREE_TYPE (tmpdesc
);
3220 gcc_assert (GFC_ARRAY_TYPE_P (type
));
3221 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3222 dumdesc
= gfc_build_indirect_ref (dumdesc
);
3223 gfc_start_block (&block
);
3225 if (sym
->ts
.type
== BT_CHARACTER
3226 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
3227 gfc_trans_init_string_length (sym
->ts
.cl
, &block
);
3229 checkparm
= (sym
->as
->type
== AS_EXPLICIT
&& flag_bounds_check
);
3231 no_repack
= !(GFC_DECL_PACKED_ARRAY (tmpdesc
)
3232 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
));
3234 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc
))
3236 /* For non-constant shape arrays we only check if the first dimension
3237 is contiguous. Repacking higher dimensions wouldn't gain us
3238 anything as we still don't know the array stride. */
3239 partial
= gfc_create_var (boolean_type_node
, "partial");
3240 TREE_USED (partial
) = 1;
3241 tmp
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3242 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, tmp
, integer_one_node
);
3243 gfc_add_modify_expr (&block
, partial
, tmp
);
3247 partial
= NULL_TREE
;
3250 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3251 here, however I think it does the right thing. */
3254 /* Set the first stride. */
3255 stride
= gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[0]);
3256 stride
= gfc_evaluate_now (stride
, &block
);
3258 tmp
= build2 (EQ_EXPR
, boolean_type_node
, stride
, integer_zero_node
);
3259 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, tmp
,
3260 gfc_index_one_node
, stride
);
3261 stride
= GFC_TYPE_ARRAY_STRIDE (type
, 0);
3262 gfc_add_modify_expr (&block
, stride
, tmp
);
3264 /* Allow the user to disable array repacking. */
3265 stmt_unpacked
= NULL_TREE
;
3269 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type
, 0)));
3270 /* A library call to repack the array if necessary. */
3271 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3272 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3273 stmt_unpacked
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3275 stride
= gfc_index_one_node
;
3278 /* This is for the case where the array data is used directly without
3279 calling the repack function. */
3280 if (no_repack
|| partial
!= NULL_TREE
)
3281 stmt_packed
= gfc_conv_descriptor_data_get (dumdesc
);
3283 stmt_packed
= NULL_TREE
;
3285 /* Assign the data pointer. */
3286 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3288 /* Don't repack unknown shape arrays when the first stride is 1. */
3289 tmp
= build3 (COND_EXPR
, TREE_TYPE (stmt_packed
), partial
,
3290 stmt_packed
, stmt_unpacked
);
3293 tmp
= stmt_packed
!= NULL_TREE
? stmt_packed
: stmt_unpacked
;
3294 gfc_add_modify_expr (&block
, tmpdesc
, fold_convert (type
, tmp
));
3296 offset
= gfc_index_zero_node
;
3297 size
= gfc_index_one_node
;
3299 /* Evaluate the bounds of the array. */
3300 for (n
= 0; n
< sym
->as
->rank
; n
++)
3302 if (checkparm
|| !sym
->as
->upper
[n
])
3304 /* Get the bounds of the actual parameter. */
3305 dubound
= gfc_conv_descriptor_ubound (dumdesc
, gfc_rank_cst
[n
]);
3306 dlbound
= gfc_conv_descriptor_lbound (dumdesc
, gfc_rank_cst
[n
]);
3310 dubound
= NULL_TREE
;
3311 dlbound
= NULL_TREE
;
3314 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, n
);
3315 if (!INTEGER_CST_P (lbound
))
3317 gfc_init_se (&se
, NULL
);
3318 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3319 gfc_array_index_type
);
3320 gfc_add_block_to_block (&block
, &se
.pre
);
3321 gfc_add_modify_expr (&block
, lbound
, se
.expr
);
3324 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, n
);
3325 /* Set the desired upper bound. */
3326 if (sym
->as
->upper
[n
])
3328 /* We know what we want the upper bound to be. */
3329 if (!INTEGER_CST_P (ubound
))
3331 gfc_init_se (&se
, NULL
);
3332 gfc_conv_expr_type (&se
, sym
->as
->upper
[n
],
3333 gfc_array_index_type
);
3334 gfc_add_block_to_block (&block
, &se
.pre
);
3335 gfc_add_modify_expr (&block
, ubound
, se
.expr
);
3338 /* Check the sizes match. */
3341 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3343 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3345 stride
= build2 (MINUS_EXPR
, gfc_array_index_type
,
3347 tmp
= fold_build2 (NE_EXPR
, gfc_array_index_type
, tmp
, stride
);
3348 gfc_trans_runtime_check (tmp
, gfc_strconst_bounds
, &block
);
3353 /* For assumed shape arrays move the upper bound by the same amount
3354 as the lower bound. */
3355 tmp
= build2 (MINUS_EXPR
, gfc_array_index_type
, dubound
, dlbound
);
3356 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, lbound
);
3357 gfc_add_modify_expr (&block
, ubound
, tmp
);
3359 /* The offset of this dimension. offset = offset - lbound * stride. */
3360 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, lbound
, stride
);
3361 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
3363 /* The size of this dimension, and the stride of the next. */
3364 if (n
+ 1 < sym
->as
->rank
)
3366 stride
= GFC_TYPE_ARRAY_STRIDE (type
, n
+ 1);
3368 if (no_repack
|| partial
!= NULL_TREE
)
3371 gfc_conv_descriptor_stride (dumdesc
, gfc_rank_cst
[n
+1]);
3374 /* Figure out the stride if not a known constant. */
3375 if (!INTEGER_CST_P (stride
))
3378 stmt_packed
= NULL_TREE
;
3381 /* Calculate stride = size * (ubound + 1 - lbound). */
3382 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3383 gfc_index_one_node
, lbound
);
3384 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3386 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3391 /* Assign the stride. */
3392 if (stmt_packed
!= NULL_TREE
&& stmt_unpacked
!= NULL_TREE
)
3393 tmp
= build3 (COND_EXPR
, gfc_array_index_type
, partial
,
3394 stmt_unpacked
, stmt_packed
);
3396 tmp
= (stmt_packed
!= NULL_TREE
) ? stmt_packed
: stmt_unpacked
;
3397 gfc_add_modify_expr (&block
, stride
, tmp
);
3402 /* Set the offset. */
3403 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type
)) == VAR_DECL
)
3404 gfc_add_modify_expr (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
3406 stmt
= gfc_finish_block (&block
);
3408 gfc_start_block (&block
);
3410 /* Only do the entry/initialization code if the arg is present. */
3411 dumdesc
= GFC_DECL_SAVED_DESCRIPTOR (tmpdesc
);
3412 optional_arg
= (sym
->attr
.optional
3413 || (sym
->ns
->proc_name
->attr
.entry_master
3414 && sym
->attr
.dummy
));
3417 tmp
= gfc_conv_expr_present (sym
);
3418 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3420 gfc_add_expr_to_block (&block
, stmt
);
3422 /* Add the main function body. */
3423 gfc_add_expr_to_block (&block
, body
);
3428 gfc_start_block (&cleanup
);
3430 if (sym
->attr
.intent
!= INTENT_IN
)
3432 /* Copy the data back. */
3433 tmp
= gfc_chainon_list (NULL_TREE
, dumdesc
);
3434 tmp
= gfc_chainon_list (tmp
, tmpdesc
);
3435 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3436 gfc_add_expr_to_block (&cleanup
, tmp
);
3439 /* Free the temporary. */
3440 tmp
= gfc_chainon_list (NULL_TREE
, tmpdesc
);
3441 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3442 gfc_add_expr_to_block (&cleanup
, tmp
);
3444 stmt
= gfc_finish_block (&cleanup
);
3446 /* Only do the cleanup if the array was repacked. */
3447 tmp
= gfc_build_indirect_ref (dumdesc
);
3448 tmp
= gfc_conv_descriptor_data_get (tmp
);
3449 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, tmpdesc
);
3450 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3454 tmp
= gfc_conv_expr_present (sym
);
3455 stmt
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3457 gfc_add_expr_to_block (&block
, stmt
);
3459 /* We don't need to free any memory allocated by internal_pack as it will
3460 be freed at the end of the function by pop_context. */
3461 return gfc_finish_block (&block
);
3465 /* Convert an array for passing as an actual parameter. Expressions and
3466 vector subscripts are evaluated and stored in a temporary, which is then
3467 passed. For whole arrays the descriptor is passed. For array sections
3468 a modified copy of the descriptor is passed, but using the original data.
3469 Also used for array pointer assignments by setting se->direct_byref. */
3472 gfc_conv_expr_descriptor (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
)
3488 gcc_assert (ss
!= gfc_ss_terminator
);
3490 /* TODO: Pass constant array constructors without a temporary. */
3491 /* Special case things we know we can pass easily. */
3492 switch (expr
->expr_type
)
3495 /* If we have a linear array section, we can pass it directly.
3496 Otherwise we need to copy it into a temporary. */
3498 /* Find the SS for the array section. */
3500 while (secss
!= gfc_ss_terminator
&& secss
->type
!= GFC_SS_SECTION
)
3501 secss
= secss
->next
;
3503 gcc_assert (secss
!= gfc_ss_terminator
);
3506 for (n
= 0; n
< secss
->data
.info
.dimen
; n
++)
3508 vss
= secss
->data
.info
.subscript
[secss
->data
.info
.dim
[n
]];
3509 if (vss
&& vss
->type
== GFC_SS_VECTOR
)
3513 info
= &secss
->data
.info
;
3515 /* Get the descriptor for the array. */
3516 gfc_conv_ss_descriptor (&se
->pre
, secss
, 0);
3517 desc
= info
->descriptor
;
3518 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc
)))
3520 /* Create a new descriptor if the array doesn't have one. */
3523 else if (info
->ref
->u
.ar
.type
== AR_FULL
)
3525 else if (se
->direct_byref
)
3530 gcc_assert (ref
->u
.ar
.type
== AR_SECTION
);
3533 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3535 /* Detect passing the full array as a section. This could do
3536 even more checking, but it doesn't seem worth it. */
3537 if (ref
->u
.ar
.start
[n
]
3539 || (ref
->u
.ar
.stride
[n
]
3540 && !gfc_expr_is_one (ref
->u
.ar
.stride
[n
], 0)))
3548 /* Check for substring references. */
3550 if (!need_tmp
&& ref
&& expr
->ts
.type
== BT_CHARACTER
)
3554 if (ref
->type
== REF_SUBSTRING
)
3556 /* In general character substrings need a copy. Character
3557 array strides are expressed as multiples of the element
3558 size (consistent with other array types), not in
3567 if (se
->direct_byref
)
3569 /* Copy the descriptor for pointer assignments. */
3570 gfc_add_modify_expr (&se
->pre
, se
->expr
, desc
);
3572 else if (se
->want_pointer
)
3574 /* We pass full arrays directly. This means that pointers and
3575 allocatable arrays should also work. */
3576 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3583 if (expr
->ts
.type
== BT_CHARACTER
)
3584 se
->string_length
= gfc_get_expr_charlen (expr
);
3591 /* A transformational function return value will be a temporary
3592 array descriptor. We still need to go through the scalarizer
3593 to create the descriptor. Elemental functions ar handled as
3594 arbitrary expressions, i.e. copy to a temporary. */
3596 /* Look for the SS for this function. */
3597 while (secss
!= gfc_ss_terminator
3598 && (secss
->type
!= GFC_SS_FUNCTION
|| secss
->expr
!= expr
))
3599 secss
= secss
->next
;
3601 if (se
->direct_byref
)
3603 gcc_assert (secss
!= gfc_ss_terminator
);
3605 /* For pointer assignments pass the descriptor directly. */
3607 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3608 gfc_conv_expr (se
, expr
);
3612 if (secss
== gfc_ss_terminator
)
3614 /* Elemental function. */
3620 /* Transformational function. */
3621 info
= &secss
->data
.info
;
3627 /* Something complicated. Copy it into a temporary. */
3635 gfc_init_loopinfo (&loop
);
3637 /* Associate the SS with the loop. */
3638 gfc_add_ss_to_loop (&loop
, ss
);
3640 /* Tell the scalarizer not to bother creating loop variables, etc. */
3642 loop
.array_parameter
= 1;
3644 gcc_assert (se
->want_pointer
&& !se
->direct_byref
);
3646 /* Setup the scalarizing loops and bounds. */
3647 gfc_conv_ss_startstride (&loop
);
3651 /* Tell the scalarizer to make a temporary. */
3652 loop
.temp_ss
= gfc_get_ss ();
3653 loop
.temp_ss
->type
= GFC_SS_TEMP
;
3654 loop
.temp_ss
->next
= gfc_ss_terminator
;
3655 if (expr
->ts
.type
== BT_CHARACTER
)
3657 gcc_assert (expr
->ts
.cl
&& expr
->ts
.cl
->length
3658 && expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3659 loop
.temp_ss
->string_length
= gfc_conv_mpz_to_tree
3660 (expr
->ts
.cl
->length
->value
.integer
,
3661 expr
->ts
.cl
->length
->ts
.kind
);
3662 expr
->ts
.cl
->backend_decl
= loop
.temp_ss
->string_length
;
3664 loop
.temp_ss
->data
.temp
.type
= gfc_typenode_for_spec (&expr
->ts
);
3666 /* ... which can hold our string, if present. */
3667 if (expr
->ts
.type
== BT_CHARACTER
)
3669 loop
.temp_ss
->string_length
= TYPE_SIZE_UNIT (loop
.temp_ss
->data
.temp
.type
);
3670 se
->string_length
= loop
.temp_ss
->string_length
;
3673 loop
.temp_ss
->string_length
= NULL
;
3674 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
3675 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3678 gfc_conv_loop_setup (&loop
);
3682 /* Copy into a temporary and pass that. We don't need to copy the data
3683 back because expressions and vector subscripts must be INTENT_IN. */
3684 /* TODO: Optimize passing function return values. */
3688 /* Start the copying loops. */
3689 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3690 gfc_mark_ss_chain_used (ss
, 1);
3691 gfc_start_scalarized_body (&loop
, &block
);
3693 /* Copy each data element. */
3694 gfc_init_se (&lse
, NULL
);
3695 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3696 gfc_init_se (&rse
, NULL
);
3697 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3699 lse
.ss
= loop
.temp_ss
;
3702 gfc_conv_scalarized_array_ref (&lse
, NULL
);
3703 if (expr
->ts
.type
== BT_CHARACTER
)
3705 gfc_conv_expr (&rse
, expr
);
3706 rse
.expr
= gfc_build_indirect_ref (rse
.expr
);
3709 gfc_conv_expr_val (&rse
, expr
);
3711 gfc_add_block_to_block (&block
, &rse
.pre
);
3712 gfc_add_block_to_block (&block
, &lse
.pre
);
3714 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
3716 /* Finish the copying loops. */
3717 gfc_trans_scalarizing_loops (&loop
, &block
);
3719 /* Set the first stride component to zero to indicate a temporary. */
3720 desc
= loop
.temp_ss
->data
.info
.descriptor
;
3721 tmp
= gfc_conv_descriptor_stride (desc
, gfc_rank_cst
[0]);
3722 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3724 gcc_assert (is_gimple_lvalue (desc
));
3725 se
->expr
= gfc_build_addr_expr (NULL
, desc
);
3727 else if (expr
->expr_type
== EXPR_FUNCTION
)
3729 desc
= info
->descriptor
;
3731 if (se
->want_pointer
)
3732 se
->expr
= gfc_build_addr_expr (NULL_TREE
, desc
);
3736 if (expr
->ts
.type
== BT_CHARACTER
)
3737 se
->string_length
= expr
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
3741 /* We pass sections without copying to a temporary. Make a new
3742 descriptor and point it at the section we want. The loop variable
3743 limits will be the limits of the section.
3744 A function may decide to repack the array to speed up access, but
3745 we're not bothered about that here. */
3754 /* Set the string_length for a character array. */
3755 if (expr
->ts
.type
== BT_CHARACTER
)
3756 se
->string_length
= gfc_get_expr_charlen (expr
);
3758 desc
= info
->descriptor
;
3759 gcc_assert (secss
&& secss
!= gfc_ss_terminator
);
3760 if (se
->direct_byref
)
3762 /* For pointer assignments we fill in the destination. */
3764 parmtype
= TREE_TYPE (parm
);
3768 /* Otherwise make a new one. */
3769 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3770 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
3771 loop
.from
, loop
.to
, 0);
3772 parm
= gfc_create_var (parmtype
, "parm");
3775 offset
= gfc_index_zero_node
;
3778 /* The following can be somewhat confusing. We have two
3779 descriptors, a new one and the original array.
3780 {parm, parmtype, dim} refer to the new one.
3781 {desc, type, n, secss, loop} refer to the original, which maybe
3782 a descriptorless array.
3783 The bounds of the scalarization are the bounds of the section.
3784 We don't have to worry about numeric overflows when calculating
3785 the offsets because all elements are within the array data. */
3787 /* Set the dtype. */
3788 tmp
= gfc_conv_descriptor_dtype (parm
);
3789 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_get_dtype (parmtype
));
3791 if (se
->direct_byref
)
3792 base
= gfc_index_zero_node
;
3796 for (n
= 0; n
< info
->ref
->u
.ar
.dimen
; n
++)
3798 stride
= gfc_conv_array_stride (desc
, n
);
3800 /* Work out the offset. */
3801 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3803 gcc_assert (info
->subscript
[n
]
3804 && info
->subscript
[n
]->type
== GFC_SS_SCALAR
);
3805 start
= info
->subscript
[n
]->data
.scalar
.expr
;
3809 /* Check we haven't somehow got out of sync. */
3810 gcc_assert (info
->dim
[dim
] == n
);
3812 /* Evaluate and remember the start of the section. */
3813 start
= info
->start
[dim
];
3814 stride
= gfc_evaluate_now (stride
, &loop
.pre
);
3817 tmp
= gfc_conv_array_lbound (desc
, n
);
3818 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (tmp
), start
, tmp
);
3820 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (tmp
), tmp
, stride
);
3821 offset
= fold_build2 (PLUS_EXPR
, TREE_TYPE (tmp
), offset
, tmp
);
3823 if (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
)
3825 /* For elemental dimensions, we only need the offset. */
3829 /* Vector subscripts need copying and are handled elsewhere. */
3830 gcc_assert (info
->ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
);
3832 /* Set the new lower bound. */
3833 from
= loop
.from
[dim
];
3835 if (!integer_onep (from
))
3837 /* Make sure the new section starts at 1. */
3838 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
3839 gfc_index_one_node
, from
);
3840 to
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, to
, tmp
);
3841 from
= gfc_index_one_node
;
3843 tmp
= gfc_conv_descriptor_lbound (parm
, gfc_rank_cst
[dim
]);
3844 gfc_add_modify_expr (&loop
.pre
, tmp
, from
);
3846 /* Set the new upper bound. */
3847 tmp
= gfc_conv_descriptor_ubound (parm
, gfc_rank_cst
[dim
]);
3848 gfc_add_modify_expr (&loop
.pre
, tmp
, to
);
3850 /* Multiply the stride by the section stride to get the
3852 stride
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3853 stride
, info
->stride
[dim
]);
3855 if (se
->direct_byref
)
3856 base
= fold_build2 (MINUS_EXPR
, TREE_TYPE (base
),
3859 /* Store the new stride. */
3860 tmp
= gfc_conv_descriptor_stride (parm
, gfc_rank_cst
[dim
]);
3861 gfc_add_modify_expr (&loop
.pre
, tmp
, stride
);
3866 /* Point the data pointer at the first element in the section. */
3867 tmp
= gfc_conv_array_data (desc
);
3868 tmp
= gfc_build_indirect_ref (tmp
);
3869 tmp
= gfc_build_array_ref (tmp
, offset
);
3870 offset
= gfc_build_addr_expr (gfc_array_dataptr_type (desc
), tmp
);
3871 gfc_conv_descriptor_data_set (&loop
.pre
, parm
, offset
);
3873 if (se
->direct_byref
)
3875 /* Set the offset. */
3876 tmp
= gfc_conv_descriptor_offset (parm
);
3877 gfc_add_modify_expr (&loop
.pre
, tmp
, base
);
3881 /* Only the callee knows what the correct offset it, so just set
3883 tmp
= gfc_conv_descriptor_offset (parm
);
3884 gfc_add_modify_expr (&loop
.pre
, tmp
, gfc_index_zero_node
);
3887 if (!se
->direct_byref
)
3889 /* Get a pointer to the new descriptor. */
3890 if (se
->want_pointer
)
3891 se
->expr
= gfc_build_addr_expr (NULL
, parm
);
3897 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3898 gfc_add_block_to_block (&se
->post
, &loop
.post
);
3900 /* Cleanup the scalarizer. */
3901 gfc_cleanup_loop (&loop
);
3905 /* Convert an array for passing as an actual parameter. */
3906 /* TODO: Optimize passing g77 arrays. */
3909 gfc_conv_array_parameter (gfc_se
* se
, gfc_expr
* expr
, gfc_ss
* ss
, int g77
)
3918 /* Passing address of the array if it is not pointer or assumed-shape. */
3919 if (expr
->expr_type
== EXPR_VARIABLE
3920 && expr
->ref
->u
.ar
.type
== AR_FULL
&& g77
)
3922 sym
= expr
->symtree
->n
.sym
;
3923 tmp
= gfc_get_symbol_decl (sym
);
3924 if (sym
->ts
.type
== BT_CHARACTER
)
3925 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3926 if (!sym
->attr
.pointer
&& sym
->as
->type
!= AS_ASSUMED_SHAPE
3927 && !sym
->attr
.allocatable
)
3929 /* Some variables are declared directly, others are declared as
3930 pointers and allocated on the heap. */
3931 if (sym
->attr
.dummy
|| POINTER_TYPE_P (TREE_TYPE (tmp
)))
3934 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
3937 if (sym
->attr
.allocatable
)
3939 se
->expr
= gfc_conv_array_data (tmp
);
3944 se
->want_pointer
= 1;
3945 gfc_conv_expr_descriptor (se
, expr
, ss
);
3950 /* Repack the array. */
3951 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3952 ptr
= gfc_build_function_call (gfor_fndecl_in_pack
, tmp
);
3953 ptr
= gfc_evaluate_now (ptr
, &se
->pre
);
3956 gfc_start_block (&block
);
3958 /* Copy the data back. */
3959 tmp
= gfc_chainon_list (NULL_TREE
, desc
);
3960 tmp
= gfc_chainon_list (tmp
, ptr
);
3961 tmp
= gfc_build_function_call (gfor_fndecl_in_unpack
, tmp
);
3962 gfc_add_expr_to_block (&block
, tmp
);
3964 /* Free the temporary. */
3965 tmp
= convert (pvoid_type_node
, ptr
);
3966 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
3967 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
3968 gfc_add_expr_to_block (&block
, tmp
);
3970 stmt
= gfc_finish_block (&block
);
3972 gfc_init_block (&block
);
3973 /* Only if it was repacked. This code needs to be executed before the
3974 loop cleanup code. */
3975 tmp
= gfc_build_indirect_ref (desc
);
3976 tmp
= gfc_conv_array_data (tmp
);
3977 tmp
= build2 (NE_EXPR
, boolean_type_node
, ptr
, tmp
);
3978 tmp
= build3_v (COND_EXPR
, tmp
, stmt
, build_empty_stmt ());
3980 gfc_add_expr_to_block (&block
, tmp
);
3981 gfc_add_block_to_block (&block
, &se
->post
);
3983 gfc_init_block (&se
->post
);
3984 gfc_add_block_to_block (&se
->post
, &block
);
3989 /* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3992 gfc_trans_deferred_array (gfc_symbol
* sym
, tree body
)
3999 stmtblock_t fnblock
;
4002 /* Make sure the frontend gets these right. */
4003 if (!(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4005 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4007 gfc_init_block (&fnblock
);
4009 gcc_assert (TREE_CODE (sym
->backend_decl
) == VAR_DECL
);
4010 if (sym
->ts
.type
== BT_CHARACTER
4011 && !INTEGER_CST_P (sym
->ts
.cl
->backend_decl
))
4012 gfc_trans_init_string_length (sym
->ts
.cl
, &fnblock
);
4014 /* Parameter and use associated variables don't need anything special. */
4015 if (sym
->attr
.dummy
|| sym
->attr
.use_assoc
)
4017 gfc_add_expr_to_block (&fnblock
, body
);
4019 return gfc_finish_block (&fnblock
);
4022 gfc_get_backend_locus (&loc
);
4023 gfc_set_backend_locus (&sym
->declared_at
);
4024 descriptor
= sym
->backend_decl
;
4026 if (TREE_STATIC (descriptor
))
4028 /* SAVEd variables are not freed on exit. */
4029 gfc_trans_static_array_pointer (sym
);
4033 /* Get the descriptor type. */
4034 type
= TREE_TYPE (sym
->backend_decl
);
4035 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
4037 /* NULLIFY the data pointer. */
4038 gfc_conv_descriptor_data_set (&fnblock
, descriptor
, null_pointer_node
);
4040 gfc_add_expr_to_block (&fnblock
, body
);
4042 gfc_set_backend_locus (&loc
);
4043 /* Allocatable arrays need to be freed when they go out of scope. */
4044 if (sym
->attr
.allocatable
)
4046 gfc_start_block (&block
);
4048 /* Deallocate if still allocated at the end of the procedure. */
4049 deallocate
= gfc_array_deallocate (descriptor
, null_pointer_node
);
4051 tmp
= gfc_conv_descriptor_data_get (descriptor
);
4052 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
,
4053 build_int_cst (TREE_TYPE (tmp
), 0));
4054 tmp
= build3_v (COND_EXPR
, tmp
, deallocate
, build_empty_stmt ());
4055 gfc_add_expr_to_block (&block
, tmp
);
4057 tmp
= gfc_finish_block (&block
);
4058 gfc_add_expr_to_block (&fnblock
, tmp
);
4061 return gfc_finish_block (&fnblock
);
4064 /************ Expression Walking Functions ******************/
4066 /* Walk a variable reference.
4068 Possible extension - multiple component subscripts.
4069 x(:,:) = foo%a(:)%b(:)
4071 forall (i=..., j=...)
4072 x(i,j) = foo%a(j)%b(i)
4074 This adds a fair amout of complexity because you need to deal with more
4075 than one ref. Maybe handle in a similar manner to vector subscripts.
4076 Maybe not worth the effort. */
4080 gfc_walk_variable_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4088 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4090 /* We're only interested in array sections. */
4091 if (ref
->type
!= REF_ARRAY
)
4098 /* TODO: Take elemental array references out of scalarization
4103 newss
= gfc_get_ss ();
4104 newss
->type
= GFC_SS_SECTION
;
4107 newss
->data
.info
.dimen
= ar
->as
->rank
;
4108 newss
->data
.info
.ref
= ref
;
4110 /* Make sure array is the same as array(:,:), this way
4111 we don't need to special case all the time. */
4112 ar
->dimen
= ar
->as
->rank
;
4113 for (n
= 0; n
< ar
->dimen
; n
++)
4115 newss
->data
.info
.dim
[n
] = n
;
4116 ar
->dimen_type
[n
] = DIMEN_RANGE
;
4118 gcc_assert (ar
->start
[n
] == NULL
);
4119 gcc_assert (ar
->end
[n
] == NULL
);
4120 gcc_assert (ar
->stride
[n
] == NULL
);
4125 newss
= gfc_get_ss ();
4126 newss
->type
= GFC_SS_SECTION
;
4129 newss
->data
.info
.dimen
= 0;
4130 newss
->data
.info
.ref
= ref
;
4134 /* We add SS chains for all the subscripts in the section. */
4135 for (n
= 0; n
< ar
->dimen
; n
++)
4139 switch (ar
->dimen_type
[n
])
4142 /* Add SS for elemental (scalar) subscripts. */
4143 gcc_assert (ar
->start
[n
]);
4144 indexss
= gfc_get_ss ();
4145 indexss
->type
= GFC_SS_SCALAR
;
4146 indexss
->expr
= ar
->start
[n
];
4147 indexss
->next
= gfc_ss_terminator
;
4148 indexss
->loop_chain
= gfc_ss_terminator
;
4149 newss
->data
.info
.subscript
[n
] = indexss
;
4153 /* We don't add anything for sections, just remember this
4154 dimension for later. */
4155 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4156 newss
->data
.info
.dimen
++;
4160 /* Get a SS for the vector. This will not be added to the
4162 indexss
= gfc_walk_expr (ar
->start
[n
]);
4163 if (indexss
== gfc_ss_terminator
)
4164 internal_error ("scalar vector subscript???");
4166 /* We currently only handle really simple vector
4168 if (indexss
->next
!= gfc_ss_terminator
)
4169 gfc_todo_error ("vector subscript expressions");
4170 indexss
->loop_chain
= gfc_ss_terminator
;
4172 /* Mark this as a vector subscript. We don't add this
4173 directly into the chain, but as a subscript of the
4174 existing SS for this term. */
4175 indexss
->type
= GFC_SS_VECTOR
;
4176 newss
->data
.info
.subscript
[n
] = indexss
;
4177 /* Also remember this dimension. */
4178 newss
->data
.info
.dim
[newss
->data
.info
.dimen
] = n
;
4179 newss
->data
.info
.dimen
++;
4183 /* We should know what sort of section it is by now. */
4187 /* We should have at least one non-elemental dimension. */
4188 gcc_assert (newss
->data
.info
.dimen
> 0);
4193 /* We should know what sort of section it is by now. */
4202 /* Walk an expression operator. If only one operand of a binary expression is
4203 scalar, we must also add the scalar term to the SS chain. */
4206 gfc_walk_op_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4212 head
= gfc_walk_subexpr (ss
, expr
->value
.op
.op1
);
4213 if (expr
->value
.op
.op2
== NULL
)
4216 head2
= gfc_walk_subexpr (head
, expr
->value
.op
.op2
);
4218 /* All operands are scalar. Pass back and let the caller deal with it. */
4222 /* All operands require scalarization. */
4223 if (head
!= ss
&& (expr
->value
.op
.op2
== NULL
|| head2
!= head
))
4226 /* One of the operands needs scalarization, the other is scalar.
4227 Create a gfc_ss for the scalar expression. */
4228 newss
= gfc_get_ss ();
4229 newss
->type
= GFC_SS_SCALAR
;
4232 /* First operand is scalar. We build the chain in reverse order, so
4233 add the scarar SS after the second operand. */
4235 while (head
&& head
->next
!= ss
)
4237 /* Check we haven't somehow broken the chain. */
4241 newss
->expr
= expr
->value
.op
.op1
;
4243 else /* head2 == head */
4245 gcc_assert (head2
== head
);
4246 /* Second operand is scalar. */
4247 newss
->next
= head2
;
4249 newss
->expr
= expr
->value
.op
.op2
;
4256 /* Reverse a SS chain. */
4259 gfc_reverse_ss (gfc_ss
* ss
)
4264 gcc_assert (ss
!= NULL
);
4266 head
= gfc_ss_terminator
;
4267 while (ss
!= gfc_ss_terminator
)
4270 /* Check we didn't somehow break the chain. */
4271 gcc_assert (next
!= NULL
);
4281 /* Walk the arguments of an elemental function. */
4284 gfc_walk_elemental_function_args (gfc_ss
* ss
, gfc_expr
* expr
,
4287 gfc_actual_arglist
*arg
;
4293 head
= gfc_ss_terminator
;
4296 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4301 newss
= gfc_walk_subexpr (head
, arg
->expr
);
4304 /* Scalar argument. */
4305 newss
= gfc_get_ss ();
4307 newss
->expr
= arg
->expr
;
4317 while (tail
->next
!= gfc_ss_terminator
)
4324 /* If all the arguments are scalar we don't need the argument SS. */
4325 gfc_free_ss_chain (head
);
4330 /* Add it onto the existing chain. */
4336 /* Walk a function call. Scalar functions are passed back, and taken out of
4337 scalarization loops. For elemental functions we walk their arguments.
4338 The result of functions returning arrays is stored in a temporary outside
4339 the loop, so that the function is only called once. Hence we do not need
4340 to walk their arguments. */
4343 gfc_walk_function_expr (gfc_ss
* ss
, gfc_expr
* expr
)
4346 gfc_intrinsic_sym
*isym
;
4349 isym
= expr
->value
.function
.isym
;
4351 /* Handle intrinsic functions separately. */
4353 return gfc_walk_intrinsic_function (ss
, expr
, isym
);
4355 sym
= expr
->value
.function
.esym
;
4357 sym
= expr
->symtree
->n
.sym
;
4359 /* A function that returns arrays. */
4360 if (gfc_return_by_reference (sym
) && sym
->result
->attr
.dimension
)
4362 newss
= gfc_get_ss ();
4363 newss
->type
= GFC_SS_FUNCTION
;
4366 newss
->data
.info
.dimen
= expr
->rank
;
4370 /* Walk the parameters of an elemental function. For now we always pass
4372 if (sym
->attr
.elemental
)
4373 return gfc_walk_elemental_function_args (ss
, expr
, GFC_SS_REFERENCE
);
4375 /* Scalar functions are OK as these are evaluated outside the scalarization
4376 loop. Pass back and let the caller deal with it. */
4381 /* An array temporary is constructed for array constructors. */
4384 gfc_walk_array_constructor (gfc_ss
* ss
, gfc_expr
* expr
)
4389 newss
= gfc_get_ss ();
4390 newss
->type
= GFC_SS_CONSTRUCTOR
;
4393 newss
->data
.info
.dimen
= expr
->rank
;
4394 for (n
= 0; n
< expr
->rank
; n
++)
4395 newss
->data
.info
.dim
[n
] = n
;
4401 /* Walk an expression. Add walked expressions to the head of the SS chain.
4402 A wholly scalar expression will not be added. */
4405 gfc_walk_subexpr (gfc_ss
* ss
, gfc_expr
* expr
)
4409 switch (expr
->expr_type
)
4412 head
= gfc_walk_variable_expr (ss
, expr
);
4416 head
= gfc_walk_op_expr (ss
, expr
);
4420 head
= gfc_walk_function_expr (ss
, expr
);
4425 case EXPR_STRUCTURE
:
4426 /* Pass back and let the caller deal with it. */
4430 head
= gfc_walk_array_constructor (ss
, expr
);
4433 case EXPR_SUBSTRING
:
4434 /* Pass back and let the caller deal with it. */
4438 internal_error ("bad expression type during walk (%d)",
4445 /* Entry point for expression walking.
4446 A return value equal to the passed chain means this is
4447 a scalar expression. It is up to the caller to take whatever action is
4448 necessary to translate these. */
4451 gfc_walk_expr (gfc_expr
* expr
)
4455 res
= gfc_walk_subexpr (gfc_ss_terminator
, expr
);
4456 return gfc_reverse_ss (res
);