This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
RFA: PR fortran/12840: Scalarisation of general array constructors
- 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: Wed, 24 Aug 2005 18:07:07 +0100
- Subject: RFA: PR fortran/12840: Scalarisation of general array constructors
[Sorry for the gcc-patches dup. Forgot to cc to fortran@]
At the moment, gfortran can only determine the bounds of a scalarisation
loop from a constructor if the constructor's size is constant. E.g.:
call sub ((/ i, i = 1, 1000 /))
is OK, but:
call sub ((/ i, i = 1, foo /))
isn't handled.
What makes the general case tricky is that we might only know the
size of a constructor once we've evaluated all its subexpressions.
One particularly contrived example is:
subroutine foo (order)
integer :: order, i
interface
function gen (order)
real, dimension (:, :), pointer :: gen
integer :: order
end function gen
end interface
call sub (order, (/ (gen (i), i = 1, order) /))
end subroutine foo
We'll only know the size of the array argument once we've evaluated
each gen (i).
I thought about two ways of handling this sort of situation. First,
we could cache the descriptors of each subarray before allocating the
temporary destination, using the bounds of the cached descriptors to
calculate the necessary size. Second, we could grow the temporary
array dynamically before adding a variable-sized element. The second
seemed by far the simplest.
A large part of this patch is therefore about allowing an array to
grow dynamically. The specific changes are:
- A new argument to gfc_trans_allocate_temp_array that says whether
the array might grow later. We can't allocate it on the stack if so.
- A new function, gfc_grow_array, for extending an array by a given
number of elements.
- A new pair of library functions, internal_relloc and internal_realloc64,
for reallocating an array's data.
As things stand, even an array of size zero will be internal_malloc()ed.
This gives us a memory block with a header but no data. However, a
dynamically-growing array will often start out with a size of zero,
and it seems daft to allocate the header, then immediately reallocate it.
So (perhaps controversially!) the patch allows null pointers to be used
for zero-length arrays. This led to the following changes:
- gfc_trans_allocate_array_storage will now use a null pointer if
the size is zero.
- internal_malloc will return a null pointer when given a null size.
- internal_free will treat freeing a null pointer as a no-op
(rather than a potential source of double-freeing, as it does now).
The rest of the patch deals with the constructors themselves. First,
the size of a constructor is now expressed as the sum of a compile-time
value and a run-time value. The new gfc_get_array_constructor_size
function determines the compile-time value and returns true if the
run-time value might be nonzero. (This function replaces
gfc_get_array_cons_size.)
Second, gfc_conv_loop_setup will now allow any constructor to be used
to determine the bounds of a scalarisation loop. It will prefer to
use constructors over other sources if the constructor's size is a
compile-time constant. However, because of the overheads involved in
dynamic reallocation, it will prefer to use other sources when the
size is not a compile-time constant.
If a constructor is used to determine the bound, the patch postpones
the calculation of that bound until gfc_trans_array_constructor.
This is very similar to the way we handle functions that return arrays.
If gfc_trans_array_constructor has to calculate the loop bounds, then:
(a) It will use gfc_get_array_constructor_size to calculate the
compile-time part of the size. Memory for this compile-time part
will be allocated by gfc_trans_allocate_temp_array in the normal way.
(b) It will remember whether there is a (possibly) nonzero run-time
size as well. If so, it will tell its subroutines that they must
allocate memory for these run-time parts themselves.
(c) The final loop bound is taken from the upper bound of the full-grown
temporary array.
The subroutines mentioned above are gfc_trans_array_constructor_subarray
and gfc_trans_array_constructor_value. The parts of a constructor that
are treated as having run-time size are:
(a) subarrays; and
(b) those controlled by iterators with non-constant bounds
The subroutines must use gfc_grow_array before writing to these parts
of the constructor.
I should note that the calls to gfc_grow_array appear in the prequel to
the subloops, so only one call is needed per component. For example:
call sub ((/ i, i = 1, foo /))
results in a single
tmp.ubound[0] += foo
tmp.data = internal_realloc (tmp.data, (tmp.ubound[0] + 1) * elemsize)
Combined with the zero-size optimisation above, we end up with:
tmp.ubound[0] = foo - 1
tmp.data = internal_realloc (NULL, foo * elemsize)
which is basically just as efficient as a malloc() would have been.
Of course, more complicated cases like the gen() example above will
use several reallocs to construct the temporary. In the "gen" case,
we'll call internal_realloc() once for each call to gen().
I've added various testcases for the new functionality, each testing
various combinations of compile-time and run-time values.
A few other points:
- The realloc functions ignore GFC_CLEAR_MEMORY because they don't
know how big the original memory was. I suppose it would be
possible to pass this as an extra parameter, but it hardly seems
worth it when we're going to overwrite the data anyhow. (I realise
that GFC_CLEAR_MEMORY is mainly a debugging aid though, so perhaps
that argument isn't too convincing.)
- Before the patch, all subarrays were treated as having a non-constant
size. This is still true after the patch. It would be good to take
advantage of cases where the subarray is known to have a particular
(constant) shape, but I think that's a separate issue, and could be
dealt with later if someone's sufficiently motivated. What the patch
does now should at least be correct, even if it's not optimal.
- The handling of characters seems a bit ad-hoc, and doesn't cope
very well with non-constant elements or array bounds. For example:
subroutine foo
character (len = 2) :: c
c = 'e'
call bar ((/ c /))
end subroutine foo
ICEs both before and after the patch with:
internal compiler error: in gfc_build_indirect_ref, at fortran/trans.c:291
and:
subroutine foo (order)
integer :: order, i
interface
subroutine bar (order, x)
integer :: order
character (len = 2), dimension (order) :: x
end subroutine bar
end interface
call bar (order, (/ ('e', i = 1, order) /))
end subroutine foo
similarly ICEs before and after with:
internal compiler error: in gfc_conv_expr_descriptor, at fortran/trans-array.c:3805
I haven't tried to tackle these issues here since they seem to
separate problems.
- I noticed that:
program main
integer, dimension (8) :: values
values = ((/ (abs ((/ i, -i /)), i = 1, 4) /))
print *, values
end program main
is not expanded properly. We convert the constructor into 4 copies
of the abs (...) expression, but don't replace 'i' within the copies.
I haven't tried to tackle that either; the transformation happens
before expanding into trees.
There might be bug reports about these things already. I haven't
checked yet. I just wanted to flag them as "things I know aren't
fixed by this patch".
Bootstrapped & regression tested on i686-pc-linux-gnu. OK to install?
Richard
gcc/fortran/
* trans.h (gfor_fndecl_internal_realloc): Declare.
(gfor_fndecl_internal_realloc64): Declare.
* trans-decl.c (gfor_fndecl_internal_realloc): New variable.
(gfor_fndecl_internal_realloc64): New variable.
(gfc_build_builtin_function_decls): Initialize them.
* trans-array.h (gfc_trans_allocate_temp_array): Add a fourth argument.
* trans-array.c (gfc_trans_allocate_array_storage): Add an argument
to say whether the array can grow later. Don't allocate the array
on the stack if so. Don't call malloc for zero-sized arrays.
(gfc_trans_allocate_temp_array): Add a similar argument here.
Pass it along to gfc_trans_allocate_array_storage.
(gfc_get_iteration_count, gfc_grow_array): New functions.
(gfc_iterator_has_dynamic_bounds): New function.
(gfc_get_array_constructor_element_size): New function.
(gfc_get_array_constructor_size): New function.
(gfc_trans_array_ctor_element): Replace pointer argument with
a descriptor tree.
(gfc_trans_array_constructor_subarray): Likewise. Take an extra
argument to say whether the variable-sized part of the constructor
must be allocated using realloc. Grow the array when this
argument is true.
(gfc_trans_array_constructor_value): Likewise.
(gfc_get_array_cons_size): Delete.
(gfc_trans_array_constructor): If the loop bound has not been set,
split the allocation into a static part and a dynamic part. Set
loop->to to the bounds for static part before allocating the
temporary. Adjust call to gfc_trans_array_constructor_value.
(gfc_conv_loop_setup): Allow any constructor to determine the
loop bounds. Check whether the constructor has a dynamic size
and prefer to use something else if so. Expect the loop bound
to be set later. Adjust call to gfc_trans_allocate_temp_array.
* trans-expr.c (gfc_conv_function_call): Adjust another call here.
libgfortran/
* runtime/memory.c (internal_malloc_size): Return a null pointer
if the size is zero.
(internal_free): Do nothing if the pointer is null.
(internal_realloc_size, internal_realloc, internal_realloc64): New.
gcc/testsuite/
* gfortran.fortran-torture/execute/pr12840-1.f90,
* gfortran.fortran-torture/execute/pr12840-2.f90,
* gfortran.fortran-torture/execute/pr12840-3.f90,
* gfortran.fortran-torture/execute/pr12840-4.f90,
* gfortran.fortran-torture/execute/pr12840-5.f90,
* gfortran.fortran-torture/execute/pr12840-6.f90: New tests.
Index: gcc/fortran/trans.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans.h,v
retrieving revision 1.32
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.32 trans.h
*** gcc/fortran/trans.h 11 Aug 2005 13:50:10 -0000 1.32
--- gcc/fortran/trans.h 24 Aug 2005 13:42:16 -0000
*************** tree builtin_function (const char *, tre
*** 443,448 ****
--- 443,450 ----
/* Runtime library function decls. */
extern GTY(()) tree gfor_fndecl_internal_malloc;
extern GTY(()) tree gfor_fndecl_internal_malloc64;
+ extern GTY(()) tree gfor_fndecl_internal_realloc;
+ extern GTY(()) tree gfor_fndecl_internal_realloc64;
extern GTY(()) tree gfor_fndecl_internal_free;
extern GTY(()) tree gfor_fndecl_allocate;
extern GTY(()) tree gfor_fndecl_allocate64;
Index: gcc/fortran/trans-decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.66
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.66 trans-decl.c
*** gcc/fortran/trans-decl.c 11 Aug 2005 13:50:09 -0000 1.66
--- gcc/fortran/trans-decl.c 24 Aug 2005 13:42:16 -0000
*************** tree gfc_static_ctors;
*** 73,78 ****
--- 73,80 ----
tree gfor_fndecl_internal_malloc;
tree gfor_fndecl_internal_malloc64;
+ tree gfor_fndecl_internal_realloc;
+ tree gfor_fndecl_internal_realloc64;
tree gfor_fndecl_internal_free;
tree gfor_fndecl_allocate;
tree gfor_fndecl_allocate64;
*************** gfc_build_builtin_function_decls (void)
*** 1887,1892 ****
--- 1889,1906 ----
pvoid_type_node, 1, gfc_int8_type_node);
DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
+ gfor_fndecl_internal_realloc =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("internal_realloc")),
+ pvoid_type_node, 2, pvoid_type_node,
+ gfc_int4_type_node);
+
+ gfor_fndecl_internal_realloc64 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("internal_realloc64")),
+ pvoid_type_node, 2, pvoid_type_node,
+ gfc_int8_type_node);
+
gfor_fndecl_internal_free =
gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
void_type_node, 1, pvoid_type_node);
Index: gcc/fortran/trans-array.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.h,v
retrieving revision 1.12
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.12 trans-array.h
*** gcc/fortran/trans-array.h 6 Aug 2005 12:56:18 -0000 1.12
--- gcc/fortran/trans-array.h 24 Aug 2005 13:42:16 -0000
*************** tree gfc_array_deallocate (tree, tree);
*** 27,33 ****
void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
/* Generate code to allocate a temporary array. */
! tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree);
/* Generate function entry code for allocation of compiler allocated array
variables. */
--- 27,33 ----
void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
/* Generate code to allocate a temporary array. */
! tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree, bool);
/* Generate function entry code for allocation of compiler allocated array
variables. */
Index: gcc/fortran/trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.54
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.54 trans-array.c
*** gcc/fortran/trans-array.c 6 Aug 2005 12:56:18 -0000 1.54
--- gcc/fortran/trans-array.c 24 Aug 2005 13:42:17 -0000
*************** 02110-1301, USA. */
*** 94,99 ****
--- 94,100 ----
#include "dependency.h"
static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
+ static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
/* The contents of this structure aren't actually used, just the address. */
static gfc_ss gfc_ss_terminator_var;
*************** gfc_trans_static_array_pointer (gfc_symb
*** 435,445 ****
/* 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. */
static void
gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
! tree size, tree nelem)
{
tree tmp;
tree args;
--- 436,449 ----
/* 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.
!
! 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)
{
tree tmp;
tree args;
*************** gfc_trans_allocate_array_storage (gfc_lo
*** 448,454 ****
desc = info->descriptor;
info->offset = gfc_index_zero_node;
! if (size == NULL_TREE)
{
/* A callee allocated array. */
gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
--- 452,458 ----
desc = info->descriptor;
info->offset = gfc_index_zero_node;
! if (size == NULL_TREE || integer_zerop (size))
{
/* A callee allocated array. */
gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
*************** gfc_trans_allocate_array_storage (gfc_lo
*** 457,463 ****
else
{
/* Allocate the temporary. */
! onstack = gfc_can_put_var_on_stack (size);
if (onstack)
{
--- 461,467 ----
else
{
/* Allocate the temporary. */
! onstack = !dynamic && gfc_can_put_var_on_stack (size);
if (onstack)
{
*************** gfc_trans_allocate_array_storage (gfc_lo
*** 512,522 ****
functions returning arrays. Adjusts the loop variables to be zero-based,
and calculates the loop bounds for callee allocated arrays.
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. */
tree
gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
! tree eltype)
{
tree type;
tree desc;
--- 516,528 ----
functions returning arrays. Adjusts the loop variables to be zero-based,
and calculates the loop bounds for callee allocated arrays.
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. */
tree
gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
! tree eltype, bool dynamic)
{
tree type;
tree desc;
*************** gfc_trans_allocate_temp_array (gfc_loopi
*** 611,617 ****
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);
if (info->dimen > loop->temp_dim)
loop->temp_dim = info->dimen;
--- 617,623 ----
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);
if (info->dimen > loop->temp_dim)
loop->temp_dim = info->dimen;
*************** gfc_trans_allocate_temp_array (gfc_loopi
*** 620,625 ****
--- 626,772 ----
}
+ /* Return the number of iterations in a loop that starts at START,
+ ends at END, and has step STEP. */
+
+ static tree
+ gfc_get_iteration_count (tree start, tree end, tree step)
+ {
+ tree tmp;
+
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, start);
+ tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp, step);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, gfc_index_one_node);
+ tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, gfc_index_zero_node);
+ return tmp;
+ }
+
+
+ /* Extend the data in array DESC by EXTRA elements. */
+
+ static void
+ gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
+ {
+ tree args;
+ tree tmp;
+ tree size;
+ tree ubound;
+
+ if (integer_zerop (extra))
+ return;
+
+ ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
+
+ /* Add EXTRA to the upper bound. */
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
+ gfc_add_modify_expr (pblock, ubound, tmp);
+
+ /* Get the value of the current data pointer. */
+ tmp = gfc_conv_descriptor_data_get (desc);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+
+ /* Calculate the new array size. */
+ size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
+ tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
+ args = gfc_chainon_list (args, tmp);
+
+ /* Pick the appropriate realloc function. */
+ if (gfc_index_integer_kind == 4)
+ tmp = gfor_fndecl_internal_realloc;
+ else if (gfc_index_integer_kind == 8)
+ tmp = gfor_fndecl_internal_realloc64;
+ else
+ gcc_unreachable ();
+
+ /* Set the new data pointer. */
+ tmp = gfc_build_function_call (tmp, args);
+ gfc_conv_descriptor_data_set (pblock, desc, tmp);
+ }
+
+
+ /* Return true if the bounds of iterator I can only be determined
+ at run time. */
+
+ static inline bool
+ gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
+ {
+ return (i->start->expr_type != EXPR_CONSTANT
+ || i->end->expr_type != EXPR_CONSTANT
+ || i->step->expr_type != EXPR_CONSTANT);
+ }
+
+
+ /* Split the size of constructor element EXPR into the sum of two terms,
+ one of which can be determined at compile time and one of which must
+ be calculated at run time. Set *SIZE to the former and return true
+ if the latter might be nonzero. */
+
+ static bool
+ gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
+ {
+ if (expr->expr_type == EXPR_ARRAY)
+ return gfc_get_array_constructor_size (size, expr->value.constructor);
+ else if (expr->rank > 0)
+ {
+ /* Calculate everything at run time. */
+ mpz_set_ui (*size, 0);
+ return true;
+ }
+ else
+ {
+ /* A single element. */
+ mpz_set_ui (*size, 1);
+ return false;
+ }
+ }
+
+
+ /* Like gfc_get_array_constructor_element_size, but applied to the whole
+ of array constructor C. */
+
+ static bool
+ gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
+ {
+ gfc_iterator *i;
+ mpz_t val;
+ mpz_t len;
+ bool dynamic;
+
+ mpz_set_ui (*size, 0);
+ mpz_init (len);
+ mpz_init (val);
+
+ dynamic = false;
+ for (; c; c = c->next)
+ {
+ i = c->iterator;
+ if (i && gfc_iterator_has_dynamic_bounds (i))
+ dynamic = true;
+ else
+ {
+ dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
+ if (i)
+ {
+ /* Multiply the static part of the element size by the
+ number of iterations. */
+ mpz_sub (val, i->end->value.integer, i->start->value.integer);
+ mpz_fdiv_q (val, val, i->step->value.integer);
+ mpz_add_ui (val, val, 1);
+ if (mpz_sgn (val) > 0)
+ mpz_mul (len, len, val);
+ else
+ mpz_set_ui (len, 0);
+ }
+ mpz_add (*size, *size, len);
+ }
+ }
+ mpz_clear (len);
+ mpz_clear (val);
+ return dynamic;
+ }
+
+
/* Make sure offset is a variable. */
static void
*************** gfc_put_offset_into_var (stmtblock_t * p
*** 638,644 ****
/* Assign an element of an array constructor. */
static void
! gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
--- 785,791 ----
/* Assign an element of an array constructor. */
static void
! gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
*************** gfc_trans_array_ctor_element (stmtblock_
*** 647,653 ****
gfc_conv_expr (se, expr);
/* Store the value. */
! tmp = gfc_build_indirect_ref (pointer);
tmp = gfc_build_array_ref (tmp, offset);
if (expr->ts.type == BT_CHARACTER)
{
--- 794,800 ----
gfc_conv_expr (se, expr);
/* Store the value. */
! tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
tmp = gfc_build_array_ref (tmp, offset);
if (expr->ts.type == BT_CHARACTER)
{
*************** gfc_trans_array_ctor_element (stmtblock_
*** 684,702 ****
}
! /* Add the contents of an array to the constructor. */
static void
gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
tree type ATTRIBUTE_UNUSED,
! tree pointer, gfc_expr * expr,
! tree * poffset, tree * offsetvar)
{
gfc_se se;
gfc_ss *ss;
gfc_loopinfo loop;
stmtblock_t body;
tree tmp;
/* We need this to be a variable so we can increment it. */
gfc_put_offset_into_var (pblock, poffset, offsetvar);
--- 831,853 ----
}
! /* Add the contents of an array to the constructor. DYNAMIC is as for
! gfc_trans_array_constructor_value. */
static void
gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
tree type ATTRIBUTE_UNUSED,
! tree desc, gfc_expr * expr,
! tree * poffset, tree * offsetvar,
! bool dynamic)
{
gfc_se se;
gfc_ss *ss;
gfc_loopinfo loop;
stmtblock_t body;
tree tmp;
+ tree size;
+ int n;
/* We need this to be a variable so we can increment it. */
gfc_put_offset_into_var (pblock, poffset, offsetvar);
*************** gfc_trans_array_constructor_subarray (st
*** 715,720 ****
--- 866,887 ----
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
+ /* Make sure the constructed array has room for the new data. */
+ if (dynamic)
+ {
+ /* Set SIZE to the total number of elements in the subarray. */
+ size = gfc_index_one_node;
+ for (n = 0; n < loop.dimen; n++)
+ {
+ tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
+ gfc_index_one_node);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ }
+
+ /* Grow the constructed array by SIZE elements. */
+ gfc_grow_array (&loop.pre, desc, size);
+ }
+
/* Make the loop body. */
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &body);
*************** gfc_trans_array_constructor_subarray (st
*** 724,730 ****
if (expr->ts.type == BT_CHARACTER)
gfc_todo_error ("character arrays in constructors");
! gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
gcc_assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
--- 891,897 ----
if (expr->ts.type == BT_CHARACTER)
gfc_todo_error ("character arrays in constructors");
! gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
gcc_assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
*************** gfc_trans_array_constructor_subarray (st
*** 741,757 ****
}
! /* Assign the values to the elements of an array constructor. */
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
! tree pointer, gfc_constructor * c,
! tree * poffset, tree * offsetvar)
{
tree tmp;
stmtblock_t body;
gfc_se se;
for (; c; c = c->next)
{
/* If this is an iterator or an array, the offset must be a variable. */
--- 908,930 ----
}
! /* Assign the values to the elements of an array constructor. DYNAMIC
! is true if descriptor DESC only contains enough data for the static
! size calculated by gfc_get_array_constructor_size. When true, memory
! for the dynamic parts must be allocated using realloc. */
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
! tree desc, gfc_constructor * c,
! tree * poffset, tree * offsetvar,
! bool dynamic)
{
tree tmp;
stmtblock_t body;
gfc_se se;
+ mpz_t size;
+ mpz_init (size);
for (; c; c = c->next)
{
/* If this is an iterator or an array, the offset must be a variable. */
*************** gfc_trans_array_constructor_value (stmtb
*** 763,776 ****
if (c->expr->expr_type == EXPR_ARRAY)
{
/* Array constructors can be nested. */
! gfc_trans_array_constructor_value (&body, type, pointer,
c->expr->value.constructor,
! poffset, offsetvar);
}
else if (c->expr->rank > 0)
{
! gfc_trans_array_constructor_subarray (&body, type, pointer,
! c->expr, poffset, offsetvar);
}
else
{
--- 936,949 ----
if (c->expr->expr_type == EXPR_ARRAY)
{
/* Array constructors can be nested. */
! gfc_trans_array_constructor_value (&body, type, desc,
c->expr->value.constructor,
! poffset, offsetvar, dynamic);
}
else if (c->expr->rank > 0)
{
! gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
! poffset, offsetvar, dynamic);
}
else
{
*************** gfc_trans_array_constructor_value (stmtb
*** 790,797 ****
{
/* Scalar values. */
gfc_init_se (&se, NULL);
! gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
! c->expr);
*poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
*poffset, gfc_index_one_node);
--- 963,970 ----
{
/* Scalar values. */
gfc_init_se (&se, NULL);
! gfc_trans_array_ctor_element (&body, desc, *poffset,
! &se, c->expr);
*poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
*poffset, gfc_index_one_node);
*************** gfc_trans_array_constructor_value (stmtb
*** 813,825 ****
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
if (p->expr->ts.type == BT_CHARACTER
! && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
! (TREE_TYPE (pointer)))))
{
/* For constant character array constructors we build
an array of pointers. */
se.expr = gfc_build_addr_expr (pchar_type_node,
! se.expr);
}
list = tree_cons (NULL_TREE, se.expr, list);
--- 986,997 ----
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
if (p->expr->ts.type == BT_CHARACTER
! && POINTER_TYPE_P (type))
{
/* For constant character array constructors we build
an array of pointers. */
se.expr = gfc_build_addr_expr (pchar_type_node,
! se.expr);
}
list = tree_cons (NULL_TREE, se.expr, list);
*************** gfc_trans_array_constructor_value (stmtb
*** 846,852 ****
init = tmp;
/* Use BUILTIN_MEMCPY to assign the values. */
! tmp = gfc_build_indirect_ref (pointer);
tmp = gfc_build_array_ref (tmp, *poffset);
tmp = gfc_build_addr_expr (NULL, tmp);
init = gfc_build_addr_expr (NULL, init);
--- 1018,1025 ----
init = tmp;
/* Use BUILTIN_MEMCPY to assign the values. */
! tmp = gfc_conv_descriptor_data_get (desc);
! tmp = gfc_build_indirect_ref (tmp);
tmp = gfc_build_array_ref (tmp, *poffset);
tmp = gfc_build_addr_expr (NULL, tmp);
init = gfc_build_addr_expr (NULL, init);
*************** gfc_trans_array_constructor_value (stmtb
*** 887,892 ****
--- 1060,1066 ----
tree loopvar;
tree exit_label;
tree loopbody;
+ tree tmp2;
loopbody = gfc_finish_block (&body);
*************** gfc_trans_array_constructor_value (stmtb
*** 911,916 ****
--- 1085,1107 ----
gfc_add_block_to_block (pblock, &se.pre);
step = gfc_evaluate_now (se.expr, pblock);
+ /* If this array expands dynamically, and the number of iterations
+ is not constant, we won't have allocated space for the static
+ part of C->EXPR's size. Do that now. */
+ if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
+ {
+ /* Get the number of iterations. */
+ tmp = gfc_get_iteration_count (loopvar, end, step);
+
+ /* Get the static part of C->EXPR's size. */
+ gfc_get_array_constructor_element_size (&size, c->expr);
+ tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
+
+ /* Grow the array by TMP * TMP2 elements. */
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
+ gfc_grow_array (pblock, desc, tmp);
+ }
+
/* Generate the loop body. */
exit_label = gfc_build_label_decl (NULL_TREE);
gfc_start_block (&body);
*************** gfc_trans_array_constructor_value (stmtb
*** 947,1019 ****
gfc_add_expr_to_block (pblock, tmp);
}
}
! }
!
!
! /* Get the size of an expression. Returns -1 if the size isn't constant.
! Implied do loops with non-constant bounds are tricky because we must only
! evaluate the bounds once. */
!
! static void
! gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c)
! {
! gfc_iterator *i;
! mpz_t val;
! mpz_t len;
!
! mpz_set_ui (*size, 0);
! mpz_init (len);
! mpz_init (val);
!
! for (; c; c = c->next)
! {
! if (c->expr->expr_type == EXPR_ARRAY)
! {
! /* A nested array constructor. */
! gfc_get_array_cons_size (&len, c->expr->value.constructor);
! if (mpz_sgn (len) < 0)
! {
! mpz_set (*size, len);
! mpz_clear (len);
! mpz_clear (val);
! return;
! }
! }
! else
! {
! if (c->expr->rank > 0)
! {
! mpz_set_si (*size, -1);
! mpz_clear (len);
! mpz_clear (val);
! return;
! }
! mpz_set_ui (len, 1);
! }
!
! if (c->iterator)
! {
! i = c->iterator;
!
! if (i->start->expr_type != EXPR_CONSTANT
! || i->end->expr_type != EXPR_CONSTANT
! || i->step->expr_type != EXPR_CONSTANT)
! {
! mpz_set_si (*size, -1);
! mpz_clear (len);
! mpz_clear (val);
! return;
! }
!
! mpz_add (val, i->end->value.integer, i->start->value.integer);
! mpz_tdiv_q (val, val, i->step->value.integer);
! mpz_add_ui (val, val, 1);
! mpz_mul (len, len, val);
! }
! mpz_add (*size, *size, len);
! }
! mpz_clear (len);
! mpz_clear (val);
}
--- 1138,1144 ----
gfc_add_expr_to_block (pblock, tmp);
}
}
! mpz_clear (size);
}
*************** get_array_ctor_strlen (gfc_constructor *
*** 1104,1122 ****
static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
{
tree offset;
tree offsetvar;
tree desc;
- tree size;
tree type;
bool const_string;
ss->data.info.dimen = loop->dimen;
if (ss->expr->ts.type == BT_CHARACTER)
{
! const_string = get_array_ctor_strlen (ss->expr->value.constructor,
! &ss->string_length);
if (!ss->string_length)
gfc_todo_error ("complex character array constructors");
--- 1229,1248 ----
static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
{
+ gfc_constructor *c;
tree offset;
tree offsetvar;
tree desc;
tree type;
bool const_string;
+ bool dynamic;
ss->data.info.dimen = loop->dimen;
+ c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
{
! const_string = get_array_ctor_strlen (c, &ss->string_length);
if (!ss->string_length)
gfc_todo_error ("complex character array constructors");
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1130,1145 ****
type = gfc_typenode_for_spec (&ss->expr->ts);
}
! size = gfc_trans_allocate_temp_array (loop, &ss->data.info, type);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
TREE_USED (offsetvar) = 0;
! gfc_trans_array_constructor_value (&loop->pre, type,
! ss->data.info.data,
! ss->expr->value.constructor, &offset,
! &offsetvar);
if (TREE_USED (offsetvar))
pushdecl (offsetvar);
--- 1256,1294 ----
type = gfc_typenode_for_spec (&ss->expr->ts);
}
! /* See if the constructor determines the loop bounds. */
! dynamic = false;
! if (loop->to[0] == NULL_TREE)
! {
! mpz_t size;
!
! /* We should have a 1-dimensional, zero-based loop. */
! gcc_assert (loop->dimen == 1);
! gcc_assert (integer_zerop (loop->from[0]));
!
! /* Split the constructor size into a static part and a dynamic part.
! Allocate the static size up-front and record whether the dynamic
! size might be nonzero. */
! mpz_init (size);
! dynamic = gfc_get_array_constructor_size (&size, c);
! mpz_sub_ui (size, size, 1);
! loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
! mpz_clear (size);
! }
!
! gfc_trans_allocate_temp_array (loop, &ss->data.info, type, dynamic);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
TREE_USED (offsetvar) = 0;
! gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
! &offset, &offsetvar, dynamic);
!
! /* If the array grows dynamically, the upper bound of the loop variable
! is determined by the array's final upper bound. */
! if (dynamic)
! loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
if (TREE_USED (offsetvar))
pushdecl (offsetvar);
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2409,2414 ****
--- 2558,2565 ----
tree tmp;
tree len;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
+ bool dynamic[GFC_MAX_DIMENSIONS];
+ gfc_constructor *c;
mpz_t *cshape;
mpz_t i;
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2416,2421 ****
--- 2567,2573 ----
for (n = 0; n < loop->dimen; n++)
{
loopspec[n] = NULL;
+ dynamic[n] = false;
/* We use one SS term, and use that to determine the bounds of the
loop for this dimension. We try to pick the simplest term. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2433,2449 ****
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
gcc_assert (loop->dimen == 1);
! /* Try to figure out the size of the constructor. */
! /* TODO: avoid this by making the frontend set the shape. */
! gfc_get_array_cons_size (&i, ss->expr->value.constructor);
! /* A negative value means we failed. */
! if (mpz_sgn (i) > 0)
! {
! mpz_sub_ui (i, i, 1);
! loop->to[n] =
! gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
! loopspec[n] = ss;
! }
continue;
}
--- 2585,2599 ----
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
gcc_assert (loop->dimen == 1);
!
! /* Always prefer to use the constructor bounds if the size
! can be determined at compile time. Prefer not to otherwise,
! since the general case involves realloc, and it's better to
! avoid that overhead if possible. */
! c = ss->expr->value.constructor;
! dynamic[n] = gfc_get_array_constructor_size (&i, c);
! if (!dynamic[n] || !loopspec[n])
! loopspec[n] = ss;
continue;
}
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2464,2494 ****
specinfo = NULL;
info = &ss->data.info;
/* Criteria for choosing a loop specifier (most important first):
stride of one
known stride
known lower bound
known upper bound
*/
! if (!specinfo)
loopspec[n] = ss;
! /* TODO: Is != constructor correct? */
! else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
! {
! if (integer_onep (info->stride[n])
! && !integer_onep (specinfo->stride[n]))
! loopspec[n] = ss;
! else if (INTEGER_CST_P (info->stride[n])
! && !INTEGER_CST_P (specinfo->stride[n]))
! loopspec[n] = ss;
! else if (INTEGER_CST_P (info->start[n])
! && !INTEGER_CST_P (specinfo->start[n]))
! loopspec[n] = ss;
! /* We don't work out the upper bound.
! else if (INTEGER_CST_P (info->finish[n])
! && ! INTEGER_CST_P (specinfo->finish[n]))
! loopspec[n] = ss; */
! }
}
if (!loopspec[n])
--- 2614,2643 ----
specinfo = NULL;
info = &ss->data.info;
+ if (!specinfo)
+ loopspec[n] = ss;
/* Criteria for choosing a loop specifier (most important first):
+ doesn't need realloc
stride of one
known stride
known lower bound
known upper bound
*/
! else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
loopspec[n] = ss;
! else if (integer_onep (info->stride[n])
! && !integer_onep (specinfo->stride[n]))
! loopspec[n] = ss;
! else if (INTEGER_CST_P (info->stride[n])
! && !INTEGER_CST_P (specinfo->stride[n]))
! loopspec[n] = ss;
! else if (INTEGER_CST_P (info->start[n])
! && !INTEGER_CST_P (specinfo->start[n]))
! loopspec[n] = ss;
! /* We don't work out the upper bound.
! else if (INTEGER_CST_P (info->finish[n])
! && ! INTEGER_CST_P (specinfo->finish[n]))
! loopspec[n] = ss; */
}
if (!loopspec[n])
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2518,2525 ****
switch (loopspec[n]->type)
{
case GFC_SS_CONSTRUCTOR:
! gcc_assert (info->dimen == 1);
! gcc_assert (loop->to[n]);
break;
case GFC_SS_SECTION:
--- 2667,2675 ----
switch (loopspec[n]->type)
{
case GFC_SS_CONSTRUCTOR:
! /* The upper bound is calculated when we expand the
! constructor. */
! gcc_assert (loop->to[n] == NULL_TREE);
break;
case GFC_SS_SECTION:
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2573,2579 ****
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);
}
for (n = 0; n < loop->temp_dim; n++)
--- 2723,2730 ----
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);
}
for (n = 0; n < loop->temp_dim; n++)
Index: gcc/fortran/trans-expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.57
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.57 trans-expr.c
*** gcc/fortran/trans-expr.c 16 Aug 2005 12:58:46 -0000 1.57
--- gcc/fortran/trans-expr.c 24 Aug 2005 13:42:18 -0000
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1158,1164 ****
info->dimen = se->loop->dimen;
/* Allocate a temporary to store the result. */
! gfc_trans_allocate_temp_array (se->loop, info, tmp);
/* Zero the first stride to indicate a temporary. */
tmp =
--- 1158,1164 ----
info->dimen = se->loop->dimen;
/* Allocate a temporary to store the result. */
! gfc_trans_allocate_temp_array (se->loop, info, tmp, false);
/* Zero the first stride to indicate a temporary. */
tmp =
Index: libgfortran/runtime/memory.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/runtime/memory.c,v
retrieving revision 1.8
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.8 memory.c
*** libgfortran/runtime/memory.c 17 Aug 2005 02:49:08 -0000 1.8
--- libgfortran/runtime/memory.c 24 Aug 2005 13:42:18 -0000
*************** internal_malloc_size (size_t size)
*** 141,146 ****
--- 141,149 ----
{
malloc_t *newmem;
+ if (size == 0)
+ return 0;
+
newmem = malloc_with_header (size);
if (!newmem)
*************** internal_free (void *mem)
*** 195,201 ****
malloc_t *m;
if (!mem)
! runtime_error ("Internal: Possible double free of temporary.");
m = DATA_HEADER (mem);
--- 198,204 ----
malloc_t *m;
if (!mem)
! return;
m = DATA_HEADER (mem);
*************** internal_free (void *mem)
*** 213,218 ****
--- 216,282 ----
}
iexport(internal_free);
+ /* Reallocate internal memory MEM so it has SIZE bytes of data.
+ Allocate a new block if MEM is zero, and free the block if
+ SIZE is 0. */
+
+ static void *
+ internal_realloc_size (void *mem, size_t size)
+ {
+ malloc_t *m;
+
+ if (size == 0)
+ {
+ if (mem)
+ internal_free (mem);
+ return 0;
+ }
+
+ if (mem == 0)
+ return internal_malloc (size);
+
+ m = DATA_HEADER (mem);
+ if (m->magic != GFC_MALLOC_MAGIC)
+ runtime_error ("Internal: No magic memblock marker. "
+ "Possible memory corruption");
+
+ m = realloc (m, size + HEADER_SIZE);
+ if (!m)
+ os_error ("Out of memory.");
+
+ m->prev->next = m;
+ m->next->prev = m;
+ return DATA_POINTER (m);
+ }
+
+ extern void *internal_realloc (void *, GFC_INTEGER_4);
+ export_proto(internal_realloc);
+
+ void *
+ internal_realloc (void *mem, GFC_INTEGER_4 size)
+ {
+ #ifdef GFC_CHECK_MEMORY
+ /* Under normal circumstances, this is _never_ going to happen! */
+ if (size < 0)
+ runtime_error ("Attempt to allocate a negative amount of memory.");
+ #endif
+ return internal_realloc_size (mem, (size_t) size);
+ }
+
+ extern void *internal_realloc64 (void *, GFC_INTEGER_8);
+ export_proto(internal_realloc64);
+
+ void *
+ internal_realloc64 (void *mem, GFC_INTEGER_8 size)
+ {
+ #ifdef GFC_CHECK_MEMORY
+ /* Under normal circumstances, this is _never_ going to happen! */
+ if (size < 0)
+ runtime_error ("Attempt to allocate a negative amount of memory.");
+ #endif
+ return internal_realloc_size (mem, (size_t) size);
+ }
+
/* User-allocate, one call for each member of the alloc-list of an
ALLOCATE statement. */
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr12840-1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr12840-1.f90 2005-08-24 10:10:12.000000000 +0100
***************
*** 0 ****
--- 1,22 ----
+ program main
+ implicit none
+ call build (11)
+ contains
+ subroutine build (order)
+ integer :: order, i
+
+ call test (order, (/ (i * 2, i = 1, order) /))
+ call test (17, (/ (i * 2, i = 1, 17) /))
+ call test (5, (/ 2, 4, 6, 8, 10 /))
+ end subroutine build
+
+ subroutine test (order, values)
+ integer, dimension (:) :: values
+ integer :: order, i
+
+ if (size (values, dim = 1) .ne. order) call abort
+ do i = 1, order
+ if (values (i) .ne. i * 2) call abort
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr12840-2.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr12840-2.f90 2005-08-24 10:02:33.000000000 +0100
***************
*** 0 ****
--- 1,24 ----
+ program main
+ implicit none
+ call build (17)
+ contains
+ subroutine build (order)
+ integer :: order, i, j
+
+ call test (order, (/ (((j + 100) * i, j = 1, i), i = 1, order) /))
+ call test (9, (/ (((j + 100) * i, j = 1, i), i = 1, 9) /))
+ call test (3, (/ 101, 202, 204, 303, 306, 309 /))
+ end subroutine build
+
+ subroutine test (order, values)
+ integer, dimension (:) :: values
+ integer :: order, i, j
+
+ if (size (values, dim = 1) .ne. order * (order + 1) / 2) call abort
+ do i = 1, order
+ do j = 1, i
+ if (values (i * (i - 1) / 2 + j) .ne. (j + 100) * i) call abort
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr12840-3.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr12840-3.f90 2005-08-24 10:27:03.000000000 +0100
***************
*** 0 ****
--- 1,43 ----
+ program main
+ implicit none
+ call build (42)
+ contains
+ subroutine build (order)
+ integer :: order, i
+
+ call test (order, 8, 5, (/ ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), i = 1, order), &
+ 100, 200, 300, 400, 500 /))
+
+ call test (order, 2, 3, (/ ((/ 1, 2 /), i = 1, order), &
+ 100, 200, 300 /))
+
+ call test (order, 3, 5, (/ ((/ 1, 2, 3 /), i = 1, order), &
+ 100, 200, 300, 400, 500 /))
+
+ call test (order, 6, 1, (/ ((/ 1, 2, 3, 4, 5, 6 /), i = 1, order), &
+ 100 /))
+
+ call test (order, 5, 0, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, order) /))
+
+ call test (order, 0, 4, (/ 100, 200, 300, 400 /))
+
+ call test (11, 5, 2, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, 11), &
+ 100, 200 /))
+
+ call test (6, 2, order, (/ ((/ 1, 2 /), i = 1, 6), &
+ (i * 100, i = 1, order) /))
+ end subroutine build
+
+ subroutine test (order, repeat, trail, values)
+ integer, dimension (:) :: values
+ integer :: order, repeat, trail, i
+
+ if (size (values, dim = 1) .ne. order * repeat + trail) call abort
+ do i = 1, order * repeat
+ if (values (i) .ne. mod (i - 1, repeat) + 1) call abort
+ end do
+ do i = 1, trail
+ if (values (i + order * repeat) .ne. i * 100) call abort
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr12840-4.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr12840-4.f90 2005-08-24 14:17:29.000000000 +0100
***************
*** 0 ****
--- 1,40 ----
+ program main
+ implicit none
+ call build (9)
+ contains
+ function gen (order)
+ real, dimension (:, :), pointer :: gen
+ integer :: order, i, j
+
+ allocate (gen (order, order + 1))
+ forall (i = 1 : order, j = 1 : order + 1) gen (i, j) = i * i + j
+ end function gen
+
+ ! Deliberately leaky!
+ subroutine build (order)
+ integer :: order, i
+
+ call test (order, 0, (/ (gen (i), i = 1, order) /))
+ call test (3, 2, (/ ((/ 1.5, 1.5, gen (i) /), i = 1, 3) /))
+ end subroutine build
+
+ subroutine test (order, prefix, values)
+ real, dimension (:) :: values
+ integer :: order, prefix, last, i, j, k
+
+ last = 0
+ do i = 1, order
+ do j = 1, prefix
+ last = last + 1
+ if (values (last) .ne. 1.5) call abort
+ end do
+ do j = 1, i + 1
+ do k = 1, i
+ last = last + 1
+ if (values (last) .ne. j + k * k) call abort
+ end do
+ end do
+ end do
+ if (size (values, dim = 1) .ne. last) call abort
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr12840-5.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr12840-5.f90 2005-08-24 11:04:47.000000000 +0100
***************
*** 0 ****
--- 1,24 ----
+ program main
+ implicit none
+ call build (200)
+ contains
+ subroutine build (order)
+ integer :: order, i
+
+ call test (order, (/ (abs ((/ i, -i, -i * 2 /)), i = 1, order) /))
+ call test (order, abs ((/ ((/ -i, -i, i * 2 /), i = 1, order) /)))
+ call test (order, (/ abs ((/ ((/ i, i, -i * 2 /), i = 1, order) /)) /))
+ end subroutine build
+
+ subroutine test (order, values)
+ integer, dimension (3:) :: values
+ integer :: order, i
+
+ if (size (values, dim = 1) .ne. order * 3) call abort
+ do i = 1, order
+ if (values (i * 3) .ne. i) call abort
+ if (values (i * 3 + 1) .ne. i) call abort
+ if (values (i * 3 + 2) .ne. i * 2) call abort
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr12840-6.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr12840-6.f90 2005-08-24 14:21:06.000000000 +0100
***************
*** 0 ****
--- 1,44 ----
+ program main
+ implicit none
+ call build (77)
+ contains
+ subroutine build (order)
+ integer :: order, i, j
+
+ call test (1, 11, 3, (/ (i, i = 1, 11, 3) /))
+ call test (3, 20, 2, (/ (i, i = 3, 20, 2) /))
+ call test (4, 0, 11, (/ (i, i = 4, 0, 11) /))
+
+ call test (110, 10, -3, (/ (i, i = 110, 10, -3) /))
+ call test (200, 20, -12, (/ (i, i = 200, 20, -12) /))
+ call test (29, 30, -6, (/ (i, i = 29, 30, -6) /))
+
+ call test (1, order, 3, (/ (i, i = 1, order, 3) /))
+ call test (order, 1, -3, (/ (i, i = order, 1, -3) /))
+
+ ! Triggers compile-time iterator calculations in trans-array.c
+ call test (1, 1000, 2, (/ (i, i = 1, 1000, 2), (i, i = order, 0, 1) /))
+ call test (1, 0, 3, (/ (i, i = 1, 0, 3), (i, i = order, 0, 1) /))
+ call test (1, 2000, -5, (/ (i, i = 1, 2000, -5), (i, i = order, 0, 1) /))
+ call test (3000, 99, 4, (/ (i, i = 3000, 99, 4), (i, i = order, 0, 1) /))
+ call test (400, 77, -39, (/ (i, i = 400, 77, -39), (i, i = order, 0, 1) /))
+
+ do j = -10, 10
+ call test (order + j, order, 5, (/ (i, i = order + j, order, 5) /))
+ call test (order + j, order, -5, (/ (i, i = order + j, order, -5) /))
+ end do
+
+ end subroutine build
+
+ subroutine test (from, to, step, values)
+ integer, dimension (:) :: values
+ integer :: from, to, step, last, i
+
+ last = 0
+ do i = from, to, step
+ last = last + 1
+ if (values (last) .ne. i) call abort
+ end do
+ if (size (values, dim = 1) .ne. last) call abort
+ end subroutine test
+ end program main