2005-09-09 Richard Sandiford <richard@codesourcery.com>
+ PR fortran/21104
+ * trans.h (gfc_interface_sym_mapping, gfc_interface_mapping): Moved
+ from trans-expr.c.
+ (gfc_init_interface_mapping, gfc_free_interface_mapping)
+ (gfc_add_interface_mapping, gfc_finish_interface_mapping)
+ (gfc_apply_interface_mapping): Declare.
+ * trans-array.h (gfc_set_loop_bounds_from_array_spec): Declare.
+ (gfc_trans_allocate_temp_array): Add pre and post block arguments.
+ * trans-array.c (gfc_set_loop_bounds_from_array_spec): New function.
+ (gfc_trans_allocate_array_storage): Replace loop argument with
+ separate pre and post blocks.
+ (gfc_trans_allocate_temp_array): Add pre and post block arguments.
+ Update call to gfc_trans_allocate_array_storage.
+ (gfc_trans_array_constructor, gfc_conv_loop_setup): Adjust for new
+ interface to gfc_trans_allocate_temp_array.
+ * trans-expr.c (gfc_interface_sym_mapping, gfc_interface_mapping):
+ Moved to trans.h.
+ (gfc_init_interface_mapping, gfc_free_interface_mapping)
+ (gfc_add_interface_mapping, gfc_finish_interface_mapping)
+ (gfc_apply_interface_mapping): Make extern.
+ (gfc_conv_function_call): Build an interface mapping for array
+ return values too. Call gfc_set_loop_bounds_from_array_spec.
+ Adjust call to gfc_trans_allocate_temp_array so that code is
+ added to SE rather than LOOP.
+
+2005-09-09 Richard Sandiford <richard@codesourcery.com>
+
PR fortran/12840
* trans.h (gfor_fndecl_internal_realloc): Declare.
(gfor_fndecl_internal_realloc64): Declare.
}
+/* If the bounds of SE's loop have not yet been set, see if they can be
+ determined from array spec AS, which is the array spec of a called
+ function. MAPPING maps the callee's dummy arguments to the values
+ that the caller is passing. Add any initialization and finalization
+ code to SE. */
+
+void
+gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
+ gfc_se * se, gfc_array_spec * as)
+{
+ int n, dim;
+ gfc_se tmpse;
+ tree lower;
+ tree upper;
+ tree tmp;
+
+ if (as && as->type == AS_EXPLICIT)
+ for (dim = 0; dim < se->loop->dimen; dim++)
+ {
+ n = se->loop->order[dim];
+ if (se->loop->to[n] == NULL_TREE)
+ {
+ /* Evaluate the lower bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ lower = tmpse.expr;
+
+ /* ...and the upper bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ upper = tmpse.expr;
+
+ /* Set the upper bound of the loop to UPPER - LOWER. */
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->loop->to[n] = tmp;
+ }
+ }
+}
+
+
/* Generate code to allocate an array temporary, or create a variable to
hold the data. If size is NULL zero the descriptor so that so that the
callee will allocate the array. Also generates code to free the array
afterwards.
+ Initialization code is added to PRE and finalization code to POST.
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
static void
-gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
- tree size, tree nelem, bool dynamic)
+gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
+ gfc_ss_info * info, tree size, tree nelem,
+ bool dynamic)
{
tree tmp;
tree args;
if (size == NULL_TREE || integer_zerop (size))
{
/* A callee allocated array. */
- gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
+ gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
onstack = FALSE;
}
else
tmp);
tmp = gfc_create_var (tmp, "A");
tmp = gfc_build_addr_expr (NULL, tmp);
- gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
+ gfc_conv_descriptor_data_set (pre, desc, tmp);
}
else
{
else
gcc_unreachable ();
tmp = gfc_build_function_call (tmp, args);
- tmp = gfc_evaluate_now (tmp, &loop->pre);
- gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
+ tmp = gfc_evaluate_now (tmp, pre);
+ gfc_conv_descriptor_data_set (pre, desc, tmp);
}
}
info->data = gfc_conv_descriptor_data_get (desc);
/* The offset is zero because we create temporaries with a zero
lower bound. */
tmp = gfc_conv_descriptor_offset (desc);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
+ gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
if (!onstack)
{
tmp = fold_convert (pvoid_type_node, tmp);
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
- gfc_add_expr_to_block (&loop->post, tmp);
+ gfc_add_expr_to_block (post, tmp);
}
}
Also fills in the descriptor, data and offset fields of info if known.
Returns the size of the array, or NULL for a callee allocated array.
- DYNAMIC is as for gfc_trans_allocate_array_storage. */
+ PRE, POST and DYNAMIC are as for gfc_trans_allocate_array_storage. */
tree
-gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
+gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
+ gfc_loopinfo * loop, gfc_ss_info * info,
tree eltype, bool dynamic)
{
tree type;
/* Fill in the array dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
/*
Fill in the bounds and stride. This is a packed array, so:
/* Store the stride and bound components in the descriptor. */
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, size);
+ gfc_add_modify_expr (pre, tmp, size);
tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
+ gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
+ gfc_add_modify_expr (pre, tmp, loop->to[n]);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
loop->to[n], gfc_index_one_node);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
- size = gfc_evaluate_now (size, &loop->pre);
+ size = gfc_evaluate_now (size, pre);
}
/* Get the size of the array. */
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- gfc_trans_allocate_array_storage (loop, info, size, nelem, dynamic);
+ gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic);
if (info->dimen > loop->temp_dim)
loop->temp_dim = info->dimen;
mpz_clear (size);
}
- gfc_trans_allocate_temp_array (loop, &ss->data.info, type, dynamic);
+ gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
+ &ss->data.info, type, dynamic);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
loop->temp_ss->type = GFC_SS_SECTION;
loop->temp_ss->data.info.dimen = n;
- gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info,
- tmp, false);
+ gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
+ &loop->temp_ss->data.info, tmp, false);
}
for (n = 0; n < loop->temp_dim; n++)
se, which should contain an expression for the array descriptor. */
void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
+/* Allow the bounds of a loop to be set from a callee's array spec. */
+void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
+ gfc_se *, gfc_array_spec *);
+
/* Generate code to allocate a temporary array. */
-tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree, bool);
+tree gfc_trans_allocate_temp_array (stmtblock_t *, stmtblock_t *,
+ gfc_loopinfo *, gfc_ss_info *, tree, bool);
/* Generate function entry code for allocation of compiler allocated array
variables. */
#include "trans-stmt.h"
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
+static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
+ gfc_expr *);
/* Copy the scalarization loop variables. */
}
-/* This group of functions allows a caller to evaluate an expression from
- the callee's interface. It establishes a mapping between the interface's
- dummy arguments and the caller's actual arguments, then applies that
- mapping to a given gfc_expr.
-
- You can initialize a mapping structure like so:
-
- gfc_interface_mapping mapping;
- ...
- gfc_init_interface_mapping (&mapping);
-
- You should then evaluate each actual argument into a temporary
- gfc_se structure, here called "se", and map the result to the
- dummy argument's symbol, here called "sym":
-
- gfc_add_interface_mapping (&mapping, sym, &se);
-
- After adding all mappings, you should call:
-
- gfc_finish_interface_mapping (&mapping, pre, post);
-
- where "pre" and "post" are statement blocks for initialization
- and finalization code respectively. You can then evaluate an
- interface expression "expr" as follows:
-
- gfc_apply_interface_mapping (&mapping, se, expr);
-
- Once you've evaluated all expressions, you should free
- the mapping structure with:
-
- gfc_free_interface_mapping (&mapping); */
-
-
-/* This structure represents a mapping from OLD to NEW, where OLD is a
- dummy argument symbol and NEW is a symbol that represents the value
- of an actual argument. Mappings are linked together using NEXT
- (in no particular order). */
-typedef struct gfc_interface_sym_mapping
-{
- struct gfc_interface_sym_mapping *next;
- gfc_symbol *old;
- gfc_symtree *new;
-}
-gfc_interface_sym_mapping;
-
-
-/* This structure is used by callers to evaluate an expression from
- a callee's interface. */
-typedef struct gfc_interface_mapping
-{
- /* Maps the interface's dummy arguments to the values that the caller
- is passing. The whole list is owned by this gfc_interface_mapping. */
- gfc_interface_sym_mapping *syms;
-
- /* A list of gfc_charlens that were needed when creating copies of
- expressions. The whole list is owned by this gfc_interface_mapping. */
- gfc_charlen *charlens;
-}
-gfc_interface_mapping;
-
-
-static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
- gfc_expr *);
-
/* Initialize MAPPING. */
-static void
+void
gfc_init_interface_mapping (gfc_interface_mapping * mapping)
{
mapping->syms = NULL;
/* Free all memory held by MAPPING (but not MAPPING itself). */
-static void
+void
gfc_free_interface_mapping (gfc_interface_mapping * mapping)
{
gfc_interface_sym_mapping *sym;
in SE. The caller may still use se->expr and se->string_length after
calling this function. */
-static void
+void
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
gfc_symbol * sym, gfc_se * se)
{
the length of each argument, adding any initialization code to PRE and
any finalization code to POST. */
-static void
+void
gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
stmtblock_t * pre, stmtblock_t * post)
{
/* Evaluate interface expression EXPR using MAPPING. Store the result
in SE. */
-static void
+void
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
gfc_se * se, gfc_expr * expr)
{
info = NULL;
gfc_init_interface_mapping (&mapping);
- need_interface_mapping = (sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length->expr_type != EXPR_CONSTANT);
+ need_interface_mapping = ((sym->ts.type == BT_CHARACTER
+ && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
+ || sym->attr.dimension);
formal = sym->formal;
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
len = cl.backend_decl;
}
- gfc_free_interface_mapping (&mapping);
byref = gfc_return_by_reference (sym);
if (byref)
tmp = gfc_typenode_for_spec (&ts);
info->dimen = se->loop->dimen;
+ /* Evaluate the bounds of the result, if known. */
+ gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
+
/* Allocate a temporary to store the result. */
- gfc_trans_allocate_temp_array (se->loop, info, tmp, false);
+ gfc_trans_allocate_temp_array (&se->pre, &se->post,
+ se->loop, info, tmp, false);
/* Zero the first stride to indicate a temporary. */
tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
if (ts.type == BT_CHARACTER)
retargs = gfc_chainon_list (retargs, len);
}
+ gfc_free_interface_mapping (&mapping);
/* Add the return arguments. */
arglist = chainon (retargs, arglist);
arg1, arg2)
#define build3_v(code, arg1, arg2, arg3) build3(code, void_type_node, \
arg1, arg2, arg3)
+
+/* This group of functions allows a caller to evaluate an expression from
+ the callee's interface. It establishes a mapping between the interface's
+ dummy arguments and the caller's actual arguments, then applies that
+ mapping to a given gfc_expr.
+
+ You can initialize a mapping structure like so:
+
+ gfc_interface_mapping mapping;
+ ...
+ gfc_init_interface_mapping (&mapping);
+
+ You should then evaluate each actual argument into a temporary
+ gfc_se structure, here called "se", and map the result to the
+ dummy argument's symbol, here called "sym":
+
+ gfc_add_interface_mapping (&mapping, sym, &se);
+
+ After adding all mappings, you should call:
+
+ gfc_finish_interface_mapping (&mapping, pre, post);
+
+ where "pre" and "post" are statement blocks for initialization
+ and finalization code respectively. You can then evaluate an
+ interface expression "expr" as follows:
+
+ gfc_apply_interface_mapping (&mapping, se, expr);
+
+ Once you've evaluated all expressions, you should free
+ the mapping structure with:
+
+ gfc_free_interface_mapping (&mapping); */
+
+
+/* This structure represents a mapping from OLD to NEW, where OLD is a
+ dummy argument symbol and NEW is a symbol that represents the value
+ of an actual argument. Mappings are linked together using NEXT
+ (in no particular order). */
+typedef struct gfc_interface_sym_mapping
+{
+ struct gfc_interface_sym_mapping *next;
+ gfc_symbol *old;
+ gfc_symtree *new;
+}
+gfc_interface_sym_mapping;
+
+
+/* This structure is used by callers to evaluate an expression from
+ a callee's interface. */
+typedef struct gfc_interface_mapping
+{
+ /* Maps the interface's dummy arguments to the values that the caller
+ is passing. The whole list is owned by this gfc_interface_mapping. */
+ gfc_interface_sym_mapping *syms;
+
+ /* A list of gfc_charlens that were needed when creating copies of
+ expressions. The whole list is owned by this gfc_interface_mapping. */
+ gfc_charlen *charlens;
+}
+gfc_interface_mapping;
+
+void gfc_init_interface_mapping (gfc_interface_mapping *);
+void gfc_free_interface_mapping (gfc_interface_mapping *);
+void gfc_add_interface_mapping (gfc_interface_mapping *,
+ gfc_symbol *, gfc_se *);
+void gfc_finish_interface_mapping (gfc_interface_mapping *,
+ stmtblock_t *, stmtblock_t *);
+void gfc_apply_interface_mapping (gfc_interface_mapping *,
+ gfc_se *, gfc_expr *);
+
#endif /* GFC_TRANS_H */
2005-09-09 Richard Sandiford <richard@codesourcery.com>
+ PR fortran/21104
+ * gfortran.dg/array_alloc_1.f90,
+ * gfortran.dg/array_alloc_2.f90,
+ * gfortran.dg/array_alloc_3.f90: New tests.
+
+2005-09-09 Richard Sandiford <richard@codesourcery.com>
+
PR fortran/12840
* gfortran.dg/array_constructor_6.f90
* gfortran.dg/array_constructor_7.f90
--- /dev/null
+! PR 21104. Make sure that either f() or its caller will allocate
+! the array data. We've decided to make the caller allocate it.
+! { dg-do run }
+program main
+ implicit none
+ call test (f ())
+contains
+ subroutine test (x)
+ integer, dimension (10) :: x
+ integer :: i
+ do i = 1, 10
+ if (x (i) .ne. i * 100) call abort
+ end do
+ end subroutine test
+
+ function f
+ integer, dimension (10) :: f
+ integer :: i
+ forall (i = 1:10) f (i) = i * 100
+ end function f
+end program main
--- /dev/null
+! Like array_alloc_1.f90, but check cases in which the array length is
+! not a literal constant.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n = 100
+ call test (n, f1 ())
+ call test (47, f2 (50))
+ call test (n, f3 (f1 ()))
+contains
+ subroutine test (expected, x)
+ integer, dimension (:) :: x
+ integer :: i, expected
+ if (size (x, 1) .ne. expected) call abort
+ do i = 1, expected
+ if (x (i) .ne. i * 100) call abort
+ end do
+ end subroutine test
+
+ function f1
+ integer, dimension (n) :: f1
+ integer :: i
+ forall (i = 1:n) f1 (i) = i * 100
+ end function f1
+
+ function f2 (howmuch)
+ integer :: i, howmuch
+ integer, dimension (4:howmuch) :: f2
+ forall (i = 4:howmuch) f2 (i) = i * 100 - 300
+ end function f2
+
+ function f3 (x)
+ integer, dimension (:) :: x
+ integer, dimension (size (x, 1)) :: f3
+ integer :: i
+ forall (i = 1:size(x)) f3 (i) = i * 100
+ end function f3
+end program main
--- /dev/null
+! Like array_alloc_1.f90, but check multi-dimensional arrays.
+! { dg-do run }
+program main
+ implicit none
+ call test ((/ 3, 4, 5 /), f ((/ 3, 4, 5 /)))
+contains
+ subroutine test (expected, x)
+ integer, dimension (:,:,:) :: x
+ integer, dimension (3) :: expected
+ integer :: i, i1, i2, i3
+ do i = 1, 3
+ if (size (x, i) .ne. expected (i)) call abort
+ end do
+ do i1 = 1, expected (1)
+ do i2 = 1, expected (2)
+ do i3 = 1, expected (3)
+ if (x (i1, i2, i3) .ne. i1 + i2 * 10 + i3 * 100) call abort
+ end do
+ end do
+ end do
+ end subroutine test
+
+ function f (x)
+ integer, dimension (3) :: x
+ integer, dimension (x(1), x(2), x(3)) :: f
+ integer :: i1, i2, i3
+ do i1 = 1, x(1)
+ do i2 = 1, x(2)
+ do i3 = 1, x(3)
+ f (i1, i2, i3) = i1 + i2 * 10 + i3 * 100
+ end do
+ end do
+ end do
+ end function f
+end program main
OSDN Git Service
