This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
PR fortran/21104: Failure to allocate returned arrays
- From: Richard Sandiford <richard at codesourcery dot com>
- To: gcc-patches at gcc dot gnu dot org
- Cc: fortran at gcc dot gnu dot org
- Date: Mon, 05 Sep 2005 17:36:32 +0100
- Subject: PR fortran/21104: Failure to allocate returned arrays
Here's a patch for PR 21104, which keeps tripping me up when writing
testcases. The problem is basically the same as one I mentioned in:
http://gcc.gnu.org/ml/gcc-patches/2005-09/msg00098.html
namely that, for a program like:
program main
print *, f ()
contains
function f
integer, dimension (2) :: f
f = 1
end function f
end program main
neither the caller nor callee allocate data for the returned array.
The caller is setting up a descriptor with a null pointer and leaving
the callee to (a) calculate the bounds and (b) allocate the data.
Unfortunately, while intrinsic callees are prepared to do that,
non-intrinsic callees aren't.
As for the fix... well, when a non-intrinsic function returns an array,
we should always have access to its gfc_array_spec. I think we should
therefore be able to fix the non-intrinsic case using either caller or
callee allocation (in other words, I think we have a free choice).
It's just a question of deciding which is better.
I prefer caller allocation for several reasons:
(1) It leads to less run-time decision logic. When calling a
non-intrinsic function, the caller will allocate the array
unconditionally. The callee will use the provided data
unconditionally.
(2) For simple cases like the one above, the caller has the option
of using stack allocation.
(3) It keeps the callee side of the interface stable (rather than
the caller side). When we have situations like this, in which a
calling convention doesn't always work, it seems better to change
the caller where possible, since the callee is more likely to be
part of a library, and could therefore be harder to recompile.
Also, after the patch linked above, caller allocation is pretty easy to do.
I suspect it's easier than callee allocation.
I suppose one argument in favour of callee allocation is that it makes
the non-intrinsic case consistent with the intrinsic one. However, with
our current data structures, I think intrinsics are always going to be
something of a special case. This is because non-intrinsic functions
that return an array must always have an interface, whereas (AIUI) we
never provide compiler-generated interfaces for intrinsic functions.
So, on to the patch...
At the moment, when a caller defers allocation to the callee,
gfc_trans_allocate_temp_array sets any null loop bounds to the
difference between the returned array bounds. The idea with this patch
is that, if a caller is calling a non-intrinsic function, and some of
the loop bounds are null, we will set those loop bounds _before_ calling
gfc_trans_allocate_temp_array. g_t_a_t_a will then use them to calculate
the size of the required temporary.
With the interface_mapping stuff, this is pretty easy to do. We just
need to evaluate the lower and upper bounds of the callee's gfc_array_spec
and store the difference in loop->to. In the patch below, this step is
done by gfc_set_loop_bounds_from_array_spec.
A couple of other things make the patch a bit bigger:
- In the original charlen patch (linked above) all the interface_mapping
stuff was local to trans-expr.c, and was therefore declared static.
However, gfc_set_loop_bounds_from_array_spec seemed more like a
trans-array.c function than a trans-expr.c function, so I've now
exported the top-level interface_mapping functions.
- The array should only be allocated after the new loop->to values
have been calculated. This means that the allocation code should
be added to the function call's se->pre, not directly to loop->pre.
I've therefore changed gfc_trans_allocate_temp_array so that it takes
separate pre and post block arguments.
I haven't tried to test all sorts of weird dimension specifications
because that sort of thing is already covered by the 15326 tests.
The patch applies on top of those for 15326 and 12840:
http://gcc.gnu.org/ml/gcc-patches/2005-09/msg00098.html
http://gcc.gnu.org/ml/gcc-patches/2005-08/msg01404.html
(which must be applied in that order)[1]. 15326 is needed because of the
interface_mapping stuff; 12840 isn't needed to make the patch work, but,
like this patch, it included a change to the gfc_trans_allocate_temp_array
interface. I wanted a series of patches that would apply on top of one
another.
Bootstrapped & regression tested on i686-pc-linux-gnu. OK to install?
Richard
[1] Note that one of the 12840 hunks is fuzz 1 because of code
reordering done by 15326. The fuzzed part applies correctly though.
gcc/fortran/
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.
gcc/testsuite/
* gfortran.fortran-torture/execute/pr21104-1.c,
* gfortran.fortran-torture/execute/pr21104-2.c,
* gfortran.fortran-torture/execute/pr21104-3.c: New tests.
--- gcc/fortran/trans.h 2005-09-02 16:30:53.000000000 +0100
+++ gcc/fortran/trans.h 2005-09-05 13:44:40.000000000 +0100
@@ -572,4 +572,74 @@ struct lang_decl GTY(())
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 */
--- gcc/fortran/trans-array.h 2005-09-02 16:30:53.000000000 +0100
+++ gcc/fortran/trans-array.h 2005-09-05 14:00:30.000000000 +0100
@@ -26,8 +26,13 @@ tree gfc_array_deallocate (tree, tree);
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. */
--- gcc/fortran/trans-array.c 2005-09-02 16:31:08.000000000 +0100
+++ gcc/fortran/trans-array.c 2005-09-05 15:03:56.000000000 +0100
@@ -433,17 +433,64 @@ gfc_trans_static_array_pointer (gfc_symb
}
+/* 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;
@@ -455,7 +502,7 @@ gfc_trans_allocate_array_storage (gfc_lo
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
@@ -474,7 +521,7 @@ gfc_trans_allocate_array_storage (gfc_lo
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
{
@@ -488,8 +535,8 @@ gfc_trans_allocate_array_storage (gfc_lo
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);
@@ -497,7 +544,7 @@ gfc_trans_allocate_array_storage (gfc_lo
/* 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)
{
@@ -506,7 +553,7 @@ gfc_trans_allocate_array_storage (gfc_lo
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);
}
}
@@ -518,10 +565,11 @@ gfc_trans_allocate_array_storage (gfc_lo
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;
@@ -565,7 +613,7 @@ gfc_trans_allocate_temp_array (gfc_loopi
/* 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:
@@ -596,19 +644,19 @@ gfc_trans_allocate_temp_array (gfc_loopi
/* 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. */
@@ -617,7 +665,7 @@ gfc_trans_allocate_temp_array (gfc_loopi
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;
@@ -1276,7 +1324,8 @@ gfc_trans_array_constructor (gfc_loopinf
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;
@@ -2725,8 +2774,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop
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++)
--- gcc/fortran/trans-expr.c 2005-09-02 16:31:08.000000000 +0100
+++ gcc/fortran/trans-expr.c 2005-09-05 14:01:49.000000000 +0100
@@ -41,6 +41,8 @@ Software Foundation, 51 Franklin Street,
#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. */
@@ -1075,73 +1077,9 @@ gfc_conv_function_val (gfc_se * se, gfc_
}
-/* 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;
@@ -1151,7 +1089,7 @@ gfc_init_interface_mapping (gfc_interfac
/* 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;
@@ -1258,7 +1196,7 @@ gfc_set_interface_mapping_bounds (stmtbl
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)
{
@@ -1359,7 +1297,7 @@ gfc_add_interface_mapping (gfc_interface
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)
{
@@ -1503,7 +1441,7 @@ gfc_apply_interface_mapping_to_expr (gfc
/* 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)
{
@@ -1571,8 +1509,9 @@ gfc_conv_function_call (gfc_se * se, gfc
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)
@@ -1678,7 +1617,6 @@ gfc_conv_function_call (gfc_se * se, gfc
len = cl.backend_decl;
}
- gfc_free_interface_mapping (&mapping);
byref = gfc_return_by_reference (sym);
if (byref)
@@ -1693,8 +1631,12 @@ gfc_conv_function_call (gfc_se * se, gfc
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]);
@@ -1745,6 +1687,7 @@ gfc_conv_function_call (gfc_se * se, gfc
if (ts.type == BT_CHARACTER)
retargs = gfc_chainon_list (retargs, len);
}
+ gfc_free_interface_mapping (&mapping);
/* Add the return arguments. */
arglist = chainon (retargs, arglist);
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr21104-1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr21104-1.f90 2005-09-05 14:52:31.000000000 +0100
***************
*** 0 ****
--- 1,18 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr21104-2.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr21104-2.f90 2005-09-05 14:44:35.000000000 +0100
***************
*** 0 ****
--- 1,35 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr21104-3.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr21104-3.f90 2005-09-05 14:52:47.000000000 +0100
***************
*** 0 ****
--- 1,33 ----
+ 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