This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
PR fortran/19239: Handle general vector subscripts
- 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: Tue, 06 Sep 2005 11:47:20 +0100
- Subject: PR fortran/19239: Handle general vector subscripts
At the moment, the only sort of vector subscripts we can handle
are variable references. For example:
integer, dimension (:) :: a, vec
a (vec) = 0
works, but:
integer, dimension (:) :: a, vec
a (vec + 1) = 0
doesn't. This patch generalises the vector subscript code to handle
all types of subscript. It also fixes a bug in which:
a (vec) = foo ()
wouldn't modify "a" at all.
Part of the problem is the way vector subscripts are represented in a
scalarised loop. GFC_SS_VECTOR nodes are tied to an EXPR_VARIABLE and
describe the parts of the variable that is being used as a subscript.
Thus, when gfc_walk_variable sees a DIMEN_VECTOR, it walks the vector
expression and expects to get back a GFC_SS_SECTION for a variable.
It then changes the code from GFC_SS_SECTION to GFC_SS_VECTOR.
I don't think it's really possible to generalise the code while keeping
this representation. I've therefore changed GFC_SS_VECTOR so that,
like GFC_SS_FUNCTION, it caches a descriptor that's created outside
of the loop.
This approach actually makes the code a lot simpler (IMO anyway),
so it's possible that I've missed a reason why it isn't valid.
It's also possible that the current code was written this way to
avoid the overhead of creating a descriptor. I don't think that's
really a problem in practice though. Almost all vectors that can
be handled by the current code can also be expressed directly
as a descriptor. For example, if we have:
a (vec (l1:b1:s1, l2:b2:s2)) = ...
then "vec (l1:b1:s1, l2:b2:s2)" can be represented as a descriptor
that points directly to vec's data. When optimisation is enabled,
SRA will eliminate this descriptor and we'll get more-or-less the
same code as we did under the current scheme. The only currently-
handled case I can think of where this isn't true is when the vector
subscript itself contains a vector subscript, as in:
a (vec1 (vec2)) = ...
If that case matters, I'd like to see it handled as a follow-on
optimisation.
One slightly tricky thing about handling general vector expressions
is that their bounds might not be known up-front. We then have the
same problem in determining loop bounds as we do with GFC_SS_FUNCTION,
and I've handled it in pretty much the same way. First of all, because
gfc_conv_loop_setup can't use GFC_SS_VECTORs to work out an upper bound,
it will simply set loop->to to NULL. gfc_add_loop_ss_code will then fill
in NULL loop->tos once the descriptor has been obtained. (Note that only
the GFC_SS_SECTION case knows which loop variable is being used to index
a vector, so the check is done there rather than in the GFC_SS_VECTOR
case itself.)
This means that we now have two cases (GFC_SS_FUNCTION and
GFC_SS_VECTOR) that set loop->to outside of gfc_conv_loop_setup.
I can see two potential problems here:
(1) If a loop dimension with a null loop->to has both a GFC_SS_VECTOR
and a GFC_SS_FUNCTION, we don't know which one gfc_conv_loop_setup
thought would be best. Both of them should give the same values,
so this is just an optimisation thing, not a correctness thing.
It also doesn't matter much at the moment because of the following
TODO in gfc_conv_loop_setup:
/* TODO: Pick the best bound if we have a choice between a
function and something else. */
if (ss->type == GFC_SS_FUNCTION)
{
loopspec[n] = ss;
continue;
}
If it ever becomes a concern, I think it could be handled as
a follow-on patch.
(2) At the moment, when a GFC_SS_FUNCTION allocates a temporary,
it adds the code directly to loop->pre. This might or might
not cause ordering problems if a GFC_SS_VECTOR sets a loop->to
that is later used by a GFC_SS_FUNCTION. I haven't checked
either way, because my patch for 21104 makes GFC_SS_FUNCTION
add the allocation code to the same block as the function
call itself, thus avoiding the problem.
Because GFC_SS_VECTOR uses gfc_conv_expr_descriptor to evaluate
the vector descriptor, it needs the gfc_conv_expr_descriptor
part of the transpose patch I posted recently:
http://gcc.gnu.org/ml/gcc-patches/2005-08/msg01472.html
The function currently has three cases:
- want_pointer && !se->direct_byref
EXPR is an actual argument. On exit, se->expr contains a
pointer to the array descriptor.
- !want_pointer && !se->direct_byref
EXPR is the left-hand side of a pointer assignment. On exit,
se->expr contains the descriptor for EXPR.
- !want_pointer && se->direct_byref
EXPR is the right-hand side of a pointer assignment and
se->expr is the descriptor for the previously-evaluated
left-hand side. The function creates an assignment from
EXPR to se->expr.
GFC_SS_VECTOR wants the same thing as the second case: a direct
reference to a descriptor. A few tweaks are needed to extend
that case to handle RHS as well as LHS values. Specifically:
(1) The following assert:
gcc_assert (se->want_pointer && !se->direct_byref);
needs to be relaxed to allow the second case to use a temporary.
(2) The handling of temporaries needs to check want_pointer.
I've done this by sinking:
if (!se->direct_byref)
{
/* Get a pointer to the new descriptor. */
if (se->want_pointer)
se->expr = gfc_build_addr_expr (NULL, desc);
else
se->expr = desc;
}
since it's general enough to handle all cases.
Finally (!), the bug I mentioned above. gfc_trans_arrayfunc_assign
doesn't check whether the target of the assignment needs a temporary
or not. Thus if we have:
a (vec) = foo ()
it will try to pass a descriptor of "a (vec)" to foo, even though
"a (vec)" needs a temporary.
We don't currently have a function that says "does this reference
need a temporary?", so I added one. The check is currently inlined
in two places: gfc_conv_expr_descriptor and gfc_check_fncall_dependency,
although the latter is slightly weaker in that doesn't handle substring
array references. I've made those two functions use the new one too.
I wondered about putting the new function in trans-array.c, but that
would introduce a dependency from dependency.c to trans-array.c,
which seemed a bit unclean. The function is also general enough
to handle non-array refs: it doesn't require the caller to
differentiate between array and non-array references up-front.
The patch is relative to the one I posted yesterday for 21104:
http://gcc.gnu.org/ml/gcc-patches/2005-09/msg00290.html
Bootstrapped & regression-tested on i686-pc-linux-gnu. OK to install?
Richard
gcc/fortran/
PR fortran/19239
* Makefile.in (fortran/trans-expr.o): Depend on dependency.h.
* dependency.h (gfc_ref_needs_temporary_p): Declare.
* dependency.c (gfc_ref_needs_temporary_p): New function.
(gfc_check_fncall_dependency): Use it instead of inlined check.
By so doing, take advantage of the fact that character substrings
within an array reference also need a temporary.
* trans.h (GFC_SS_VECTOR): Adjust comment.
* trans-array.c (gfc_free_ss): Remove GFC_SS_VECTOR case.
(gfc_set_vector_loop_bounds): New function.
(gfc_add_loop_ss_code): Call it after evaluating the subscripts of
a GFC_SS_SECTION. Deal with the GFC_SS_VECTOR case by evaluating
the vector expression and caching its descriptor for use within
the loop.
(gfc_conv_array_index_ref, gfc_conv_vector_array_index): Delete.
(gfc_conv_array_index_offset): Handle scalar, vector and range
dimensions as separate cases of a switch statement. In the vector
case, use the loop variable to calculate a vector index and use the
referenced element as the dimension's index. Perform bounds checking
on this final index.
(gfc_conv_section_upper_bound): Return null for vector indexes.
(gfc_conv_section_startstride): Give vector indexes a start value
of 0 and a stride of 1.
(gfc_conv_ss_startstride): Adjust for new GFC_SS_VECTOR representation.
(gfc_conv_expr_descriptor): Expand comments. Generalize the
handling of the !want_pointer && !direct_byref case. Use
gfc_ref_needs_temporary_p to decide whether the variable case
needs a temporary.
(gfc_walk_variable_expr): Handle DIMEN_VECTOR by creating a
GFC_SS_VECTOR index.
* trans-expr.c: Include dependency.h.
(gfc_trans_arrayfunc_assign): Fail if the target needs a temporary.
gcc/testsuite/
PR fortran/19239
* gfortran.fortran-torture/execute/pr19239-1.f90,
* gfortran.fortran-torture/execute/pr19239-2.f90: New tests
*** gcc/fortran/Make-lang.in 2005-09-05 08:51:23.000000000 +0100
--- gcc/fortran/Make-lang.in 2005-09-06 09:28:41.000000000 +0100
*************** fortran/trans-decl.o: $(GFORTRAN_TRANS_D
*** 289,295 ****
fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
real.h toplev.h $(TARGET_H)
fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
! fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h
fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)
--- 289,295 ----
fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
real.h toplev.h $(TARGET_H)
fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
! fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h
fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)
*** gcc/fortran/dependency.h 2005-09-05 08:51:23.000000000 +0100
--- gcc/fortran/dependency.h 2005-09-06 09:25:56.000000000 +0100
*************** Software Foundation, 51 Franklin Street,
*** 21,26 ****
--- 21,27 ----
+ bool gfc_ref_needs_temporary_p (gfc_ref *);
int gfc_check_fncall_dependency (gfc_expr *, gfc_expr *);
int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int);
*** gcc/fortran/dependency.c 2005-09-05 08:51:23.000000000 +0100
--- gcc/fortran/dependency.c 2005-09-06 09:58:49.000000000 +0100
*************** gfc_is_same_range (gfc_array_ref * ar1,
*** 175,180 ****
--- 175,219 ----
}
+ /* Return true if the result of reference REF can only be constructed
+ using a temporary array. */
+
+ bool
+ gfc_ref_needs_temporary_p (gfc_ref *ref)
+ {
+ int n;
+ bool subarray_p;
+
+ subarray_p = false;
+ for (; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ /* Vector dimensions are generally not monotonic and must be
+ handled using a temporary. */
+ if (ref->u.ar.type == AR_SECTION)
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+ return true;
+
+ subarray_p = true;
+ break;
+
+ case REF_SUBSTRING:
+ /* Within an array reference, character substrings generally
+ need a temporary. Character array strides are expressed as
+ multiples of the element size (consistent with other array
+ types), not in characters. */
+ return subarray_p;
+
+ case REF_COMPONENT:
+ break;
+ }
+
+ return false;
+ }
+
+
/* Dependency checking for direct function return by reference.
Returns true if the arguments of the function depend on the
destination. This is considerably less conservative than other
*************** int
*** 185,193 ****
gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall)
{
gfc_actual_arglist *actual;
- gfc_ref *ref;
gfc_expr *expr;
- int n;
gcc_assert (dest->expr_type == EXPR_VARIABLE
&& fncall->expr_type == EXPR_FUNCTION);
--- 224,230 ----
*************** gfc_check_fncall_dependency (gfc_expr *
*** 205,235 ****
switch (expr->expr_type)
{
case EXPR_VARIABLE:
! if (expr->rank > 1)
! {
! /* This is an array section. */
! for (ref = expr->ref; ref; ref = ref->next)
! {
! if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
! break;
! }
! gcc_assert (ref);
! /* AR_FULL can't contain vector subscripts. */
! if (ref->u.ar.type == AR_SECTION)
! {
! for (n = 0; n < ref->u.ar.dimen; n++)
! {
! if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
! break;
! }
! /* Vector subscript array sections will be copied to a
! temporary. */
! if (n != ref->u.ar.dimen)
! continue;
! }
! }
!
! if (gfc_check_dependency (dest, actual->expr, NULL, 0))
return 1;
break;
--- 242,249 ----
switch (expr->expr_type)
{
case EXPR_VARIABLE:
! if (!gfc_ref_needs_temporary_p (expr->ref)
! && gfc_check_dependency (dest, expr, NULL, 0))
return 1;
break;
*** gcc/fortran/trans.h 2005-09-05 13:44:40.000000000 +0100
--- gcc/fortran/trans.h 2005-09-06 07:37:02.000000000 +0100
*************** typedef enum
*** 138,145 ****
uses this temporary inside the scalarization loop. */
GFC_SS_CONSTRUCTOR,
! /* A vector subscript. Only used as the SS chain for a subscript.
! Similar int format to a GFC_SS_SECTION. */
GFC_SS_VECTOR,
/* A temporary array allocated by the scalarizer. Its rank can be less
--- 138,145 ----
uses this temporary inside the scalarization loop. */
GFC_SS_CONSTRUCTOR,
! /* A vector subscript. The vector's descriptor is cached in the
! "descriptor" field of the associated gfc_ss_info. */
GFC_SS_VECTOR,
/* A temporary array allocated by the scalarizer. Its rank can be less
*** gcc/fortran/trans-array.c 2005-09-05 15:03:56.000000000 +0100
--- gcc/fortran/trans-array.c 2005-09-06 11:45:48.000000000 +0100
*************** gfc_free_ss (gfc_ss * ss)
*** 361,367 ****
switch (ss->type)
{
case GFC_SS_SECTION:
- case GFC_SS_VECTOR:
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
{
if (ss->data.info.subscript[n])
--- 361,366 ----
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1353,1358 ****
--- 1352,1398 ----
}
+ /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
+ called after evaluating all of INFO's vector dimensions. Go through
+ each such vector dimension and see if we can now fill in any missing
+ loop bounds. */
+
+ static void
+ gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
+ {
+ gfc_se se;
+ tree tmp;
+ tree desc;
+ tree zero;
+ int n;
+ int dim;
+
+ for (n = 0; n < loop->dimen; n++)
+ {
+ dim = info->dim[n];
+ if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
+ && loop->to[n] == NULL)
+ {
+ /* Loop variable N indexes vector dimension DIM, and we don't
+ yet know the upper bound of loop variable N. Set it to the
+ difference between the vector's upper and lower bounds. */
+ gcc_assert (loop->from[n] == gfc_index_zero_node);
+ gcc_assert (info->subscript[dim]
+ && info->subscript[dim]->type == GFC_SS_VECTOR);
+
+ gfc_init_se (&se, NULL);
+ desc = info->subscript[dim]->data.info.descriptor;
+ zero = gfc_rank_cst[0];
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound (desc, zero),
+ gfc_conv_descriptor_lbound (desc, zero));
+ tmp = gfc_evaluate_now (tmp, &loop->pre);
+ loop->to[n] = tmp;
+ }
+ }
+ }
+
+
/* Add the pre and post chains for all the scalar expressions in a SS chain
to loop. This is called after the loop parameters have been calculated,
but before the actual scalarizing loops. */
*************** gfc_add_loop_ss_code (gfc_loopinfo * loo
*** 1408,1421 ****
break;
case GFC_SS_SECTION:
! case GFC_SS_VECTOR:
! /* Scalarized expression. Evaluate any scalar subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
! {
! /* Add the expressions for scalar subscripts. */
! if (ss->data.info.subscript[n])
! gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
! }
break;
case GFC_SS_INTRINSIC:
--- 1448,1468 ----
break;
case GFC_SS_SECTION:
! /* Add the expressions for scalar and vector subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
! if (ss->data.info.subscript[n])
! gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
!
! gfc_set_vector_loop_bounds (loop, &ss->data.info);
! break;
!
! case GFC_SS_VECTOR:
! /* Get the vector's descriptor and store it in SS. */
! gfc_init_se (&se, NULL);
! gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
! gfc_add_block_to_block (&loop->pre, &se.pre);
! gfc_add_block_to_block (&loop->post, &se.post);
! ss->data.info.descriptor = se.expr;
break;
case GFC_SS_INTRINSIC:
*************** gfc_conv_array_ubound (tree descriptor,
*** 1618,1658 ****
}
- /* Translate an array reference. The descriptor should be in se->expr.
- Do not use this function, it wil be removed soon. */
- /*GCC ARRAYS*/
-
- static void
- gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
- tree offset, int dimen)
- {
- tree array;
- tree tmp;
- tree index;
- int n;
-
- array = gfc_build_indirect_ref (pointer);
-
- index = offset;
- for (n = 0; n < dimen; n++)
- {
- /* index = index + stride[n]*indices[n] */
- tmp = gfc_conv_array_stride (se->expr, n);
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
-
- index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
- }
-
- /* Result = data[index]. */
- tmp = gfc_build_array_ref (array, index);
-
- /* Check we've used the correct number of dimensions. */
- gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
-
- se->expr = tmp;
- }
-
-
/* Generate code to perform an array index bound check. */
static tree
--- 1665,1670 ----
*************** gfc_trans_array_bound_check (gfc_se * se
*** 1680,1740 ****
}
- /* A reference to an array vector subscript. Uses recursion to handle nested
- vector subscripts. */
-
- static tree
- gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
- {
- tree descsave;
- tree indices[GFC_MAX_DIMENSIONS];
- gfc_array_ref *ar;
- gfc_ss_info *info;
- int n;
-
- gcc_assert (ss && ss->type == GFC_SS_VECTOR);
-
- /* Save the descriptor. */
- descsave = se->expr;
- info = &ss->data.info;
- se->expr = info->descriptor;
-
- ar = &info->ref->u.ar;
- for (n = 0; n < ar->dimen; n++)
- {
- switch (ar->dimen_type[n])
- {
- case DIMEN_ELEMENT:
- gcc_assert (info->subscript[n] != gfc_ss_terminator
- && info->subscript[n]->type == GFC_SS_SCALAR);
- indices[n] = info->subscript[n]->data.scalar.expr;
- break;
-
- case DIMEN_RANGE:
- indices[n] = index;
- break;
-
- case DIMEN_VECTOR:
- index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
-
- indices[n] =
- gfc_trans_array_bound_check (se, info->descriptor, index, n);
- break;
-
- default:
- gcc_unreachable ();
- }
- }
- /* Get the index from the vector. */
- gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
- index = se->expr;
- /* Put the descriptor back. */
- se->expr = descsave;
-
- return index;
- }
-
-
/* Return the offset for an index. Performs bound checking for elemental
dimensions. Single element references are processed separately. */
--- 1692,1697 ----
*************** gfc_conv_array_index_offset (gfc_se * se
*** 1743,1767 ****
gfc_array_ref * ar, tree stride)
{
tree index;
/* Get the index into the array for this dimension. */
if (ar)
{
gcc_assert (ar->type != AR_ELEMENT);
! if (ar->dimen_type[dim] == DIMEN_ELEMENT)
{
gcc_assert (i == -1);
/* Elemental dimension. */
gcc_assert (info->subscript[dim]
! && info->subscript[dim]->type == GFC_SS_SCALAR);
/* We've already translated this value outside the loop. */
index = info->subscript[dim]->data.scalar.expr;
index =
gfc_trans_array_bound_check (se, info->descriptor, index, dim);
! }
! else
! {
/* Scalarized dimension. */
gcc_assert (info && se->loop);
--- 1700,1751 ----
gfc_array_ref * ar, tree stride)
{
tree index;
+ tree desc;
+ tree data;
/* Get the index into the array for this dimension. */
if (ar)
{
gcc_assert (ar->type != AR_ELEMENT);
! switch (ar->dimen_type[dim])
{
+ case DIMEN_ELEMENT:
gcc_assert (i == -1);
/* Elemental dimension. */
gcc_assert (info->subscript[dim]
! && info->subscript[dim]->type == GFC_SS_SCALAR);
/* We've already translated this value outside the loop. */
index = info->subscript[dim]->data.scalar.expr;
index =
gfc_trans_array_bound_check (se, info->descriptor, index, dim);
! break;
!
! case DIMEN_VECTOR:
! gcc_assert (info && se->loop);
! gcc_assert (info->subscript[dim]
! && info->subscript[dim]->type == GFC_SS_VECTOR);
! desc = info->subscript[dim]->data.info.descriptor;
!
! /* Get a zero-based index into the vector. */
! index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
! se->loop->loopvar[i], se->loop->from[i]);
!
! /* Multiply the index by the stride. */
! index = fold_build2 (MULT_EXPR, gfc_array_index_type,
! index, gfc_conv_array_stride (desc, 0));
!
! /* Read the vector to get an index into info->descriptor. */
! data = gfc_build_indirect_ref (gfc_conv_array_data (desc));
! index = gfc_build_array_ref (data, index);
! index = gfc_evaluate_now (index, &se->pre);
!
! /* Do any bounds checking on the final info->descriptor index. */
! index = gfc_trans_array_bound_check (se, info->descriptor,
! index, dim);
! break;
!
! case DIMEN_RANGE:
/* Scalarized dimension. */
gcc_assert (info && se->loop);
*************** gfc_conv_array_index_offset (gfc_se * se
*** 1771,1788 ****
info->stride[i]);
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
info->delta[i]);
! if (ar->dimen_type[dim] == DIMEN_VECTOR)
! {
! /* Handle vector subscripts. */
! index = gfc_conv_vector_array_index (se, index,
! info->subscript[dim]);
! index =
! gfc_trans_array_bound_check (se, info->descriptor, index,
! dim);
! }
! else
! gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
}
}
else
--- 1755,1764 ----
info->stride[i]);
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
info->delta[i]);
+ break;
! default:
! gcc_unreachable ();
}
}
else
*************** static tree
*** 2193,2219 ****
gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
{
int dim;
- gfc_ss *vecss;
gfc_expr *end;
tree desc;
tree bound;
gfc_se se;
gcc_assert (ss->type == GFC_SS_SECTION);
! /* For vector array subscripts we want the size of the vector. */
! dim = ss->data.info.dim[n];
! vecss = ss;
! while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
! {
! vecss = vecss->data.info.subscript[dim];
! gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
! dim = vecss->data.info.dim[0];
! }
! gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
! end = vecss->data.info.ref->u.ar.end[dim];
! desc = vecss->data.info.descriptor;
if (end)
{
--- 2169,2193 ----
gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
{
int dim;
gfc_expr *end;
tree desc;
tree bound;
gfc_se se;
+ gfc_ss_info *info;
gcc_assert (ss->type == GFC_SS_SECTION);
! info = &ss->data.info;
! dim = info->dim[n];
! if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
! /* We'll calculate the upper bound once we have access to the
! vector's descriptor. */
! return NULL;
!
! gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
! desc = info->descriptor;
! end = info->ref->u.ar.end[dim];
if (end)
{
*************** gfc_conv_section_startstride (gfc_loopin
*** 2240,2271 ****
{
gfc_expr *start;
gfc_expr *stride;
- gfc_ss *vecss;
tree desc;
gfc_se se;
gfc_ss_info *info;
int dim;
! info = &ss->data.info;
dim = info->dim[n];
! /* For vector array subscripts we want the size of the vector. */
! vecss = ss;
! while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
! {
! vecss = vecss->data.info.subscript[dim];
! gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
! /* Get the descriptors for the vector subscripts as well. */
! if (!vecss->data.info.descriptor)
! gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
! dim = vecss->data.info.dim[0];
! }
!
! gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
! start = vecss->data.info.ref->u.ar.start[dim];
! stride = vecss->data.info.ref->u.ar.stride[dim];
! desc = vecss->data.info.descriptor;
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
--- 2214,2241 ----
{
gfc_expr *start;
gfc_expr *stride;
tree desc;
gfc_se se;
gfc_ss_info *info;
int dim;
! gcc_assert (ss->type == GFC_SS_SECTION);
+ info = &ss->data.info;
dim = info->dim[n];
! if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
! {
! /* We use a zero-based index to access the vector. */
! info->start[n] = gfc_index_zero_node;
! info->stride[n] = gfc_index_one_node;
! return;
! }
!
! gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
! desc = info->descriptor;
! start = info->ref->u.ar.start[dim];
! stride = info->ref->u.ar.stride[dim];
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
*************** gfc_conv_ss_startstride (gfc_loopinfo *
*** 2307,2313 ****
int n;
tree tmp;
gfc_ss *ss;
- gfc_ss *vecss;
tree desc;
loop->dimen = 0;
--- 2277,2282 ----
*************** gfc_conv_ss_startstride (gfc_loopinfo *
*** 2388,2409 ****
/* TODO: range checking for mapped dimensions. */
info = &ss->data.info;
! /* This only checks scalarized dimensions, elemental dimensions are
! checked later. */
for (n = 0; n < loop->dimen; n++)
{
dim = info->dim[n];
! vecss = ss;
! while (vecss->data.info.ref->u.ar.dimen_type[dim]
! == DIMEN_VECTOR)
! {
! vecss = vecss->data.info.subscript[dim];
! gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
! dim = vecss->data.info.dim[0];
! }
! gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
! == DIMEN_RANGE);
! desc = vecss->data.info.descriptor;
/* Check lower bound. */
bound = gfc_conv_array_lbound (desc, dim);
--- 2357,2371 ----
/* TODO: range checking for mapped dimensions. */
info = &ss->data.info;
! /* This code only checks ranges. Elemental and vector
! dimensions are checked later. */
for (n = 0; n < loop->dimen; n++)
{
dim = info->dim[n];
! if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
! continue;
!
! desc = ss->data.info.descriptor;
/* Check lower bound. */
bound = gfc_conv_array_lbound (desc, dim);
*************** gfc_trans_dummy_array_bias (gfc_symbol *
*** 3660,3670 ****
}
! /* Convert an array for passing as an actual parameter. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
a modified copy of the descriptor is passed, but using the original data.
! Also used for array pointer assignments by setting se->direct_byref. */
void
gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
--- 3622,3649 ----
}
! /* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
a modified copy of the descriptor is passed, but using the original data.
!
! This function is also used for array pointer assignments, and there
! are three cases:
!
! - want_pointer && !se->direct_byref
! EXPR is an actual argument. On exit, se->expr contains a
! pointer to the array descriptor.
!
! - !want_pointer && !se->direct_byref
! EXPR is an actual argument to an intrinsic function or the
! left-hand side of a pointer assignment. On exit, se->expr
! contains the descriptor for EXPR.
!
! - !want_pointer && se->direct_byref
! EXPR is the right-hand side of a pointer assignment and
! se->expr is the descriptor for the previously-evaluated
! left-hand side. The function creates an assignment from
! EXPR to se->expr. */
void
gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3680,3686 ****
tree start;
tree offset;
int full;
- gfc_ss *vss;
gfc_ref *ref;
gcc_assert (ss != gfc_ss_terminator);
--- 3659,3664 ----
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3699,3719 ****
secss = secss->next;
gcc_assert (secss != gfc_ss_terminator);
-
- need_tmp = 0;
- for (n = 0; n < secss->data.info.dimen; n++)
- {
- vss = secss->data.info.subscript[secss->data.info.dim[n]];
- if (vss && vss->type == GFC_SS_VECTOR)
- need_tmp = 1;
- }
-
info = &secss->data.info;
/* Get the descriptor for the array. */
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
! if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
/* Create a new descriptor if the array doesn't have one. */
full = 0;
--- 3677,3692 ----
secss = secss->next;
gcc_assert (secss != gfc_ss_terminator);
info = &secss->data.info;
/* Get the descriptor for the array. */
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
!
! need_tmp = gfc_ref_needs_temporary_p (expr->ref);
! if (need_tmp)
! full = 0;
! else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
/* Create a new descriptor if the array doesn't have one. */
full = 0;
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3743,3765 ****
}
}
- /* Check for substring references. */
- ref = expr->ref;
- if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
- {
- while (ref->next)
- ref = ref->next;
- if (ref->type == REF_SUBSTRING)
- {
- /* In general character substrings need a copy. Character
- array strides are expressed as multiples of the element
- size (consistent with other array types), not in
- characters. */
- full = 0;
- need_tmp = 1;
- }
- }
-
if (full)
{
if (se->direct_byref)
--- 3716,3721 ----
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3839,3845 ****
if (!need_tmp)
loop.array_parameter = 1;
else
! gcc_assert (se->want_pointer && !se->direct_byref);
/* Setup the scalarizing loops and bounds. */
gfc_conv_ss_startstride (&loop);
--- 3795,3802 ----
if (!need_tmp)
loop.array_parameter = 1;
else
! /* The right-hand side of a pointer assignment mustn't use a temporary. */
! gcc_assert (!se->direct_byref);
/* Setup the scalarizing loops and bounds. */
gfc_conv_ss_startstride (&loop);
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3920,3936 ****
gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
gcc_assert (is_gimple_lvalue (desc));
- se->expr = gfc_build_addr_expr (NULL, desc);
}
else if (expr->expr_type == EXPR_FUNCTION)
{
desc = info->descriptor;
- if (se->want_pointer)
- se->expr = gfc_build_addr_expr (NULL_TREE, desc);
- else
- se->expr = desc;
-
if (expr->ts.type == BT_CHARACTER)
se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
}
--- 3877,3887 ----
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4081,4095 ****
tmp = gfc_conv_descriptor_offset (parm);
gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
}
! if (!se->direct_byref)
! {
! /* Get a pointer to the new descriptor. */
! if (se->want_pointer)
! se->expr = gfc_build_addr_expr (NULL, parm);
! else
! se->expr = parm;
! }
}
gfc_add_block_to_block (&se->pre, &loop.pre);
--- 4032,4047 ----
tmp = gfc_conv_descriptor_offset (parm);
gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
}
+ desc = parm;
+ }
! if (!se->direct_byref)
! {
! /* Get a pointer to the new descriptor. */
! if (se->want_pointer)
! se->expr = gfc_build_addr_expr (NULL, desc);
! else
! se->expr = desc;
}
gfc_add_block_to_block (&se->pre, &loop.pre);
*************** gfc_walk_variable_expr (gfc_ss * ss, gfc
*** 4381,4404 ****
break;
case DIMEN_VECTOR:
! /* Get a SS for the vector. This will not be added to the
! chain directly. */
! indexss = gfc_walk_expr (ar->start[n]);
! if (indexss == gfc_ss_terminator)
! internal_error ("scalar vector subscript???");
!
! /* We currently only handle really simple vector
! subscripts. */
! if (indexss->next != gfc_ss_terminator)
! gfc_todo_error ("vector subscript expressions");
! indexss->loop_chain = gfc_ss_terminator;
!
! /* Mark this as a vector subscript. We don't add this
! directly into the chain, but as a subscript of the
! existing SS for this term. */
indexss->type = GFC_SS_VECTOR;
newss->data.info.subscript[n] = indexss;
- /* Also remember this dimension. */
newss->data.info.dim[newss->data.info.dimen] = n;
newss->data.info.dimen++;
break;
--- 4333,4346 ----
break;
case DIMEN_VECTOR:
! /* Create a GFC_SS_VECTOR index in which we can store
! the vector's descriptor. */
! indexss = gfc_get_ss ();
indexss->type = GFC_SS_VECTOR;
+ indexss->expr = ar->start[n];
+ indexss->next = gfc_ss_terminator;
+ indexss->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss;
newss->data.info.dim[newss->data.info.dimen] = n;
newss->data.info.dimen++;
break;
*** gcc/fortran/trans-expr.c 2005-09-05 14:01:49.000000000 +0100
--- gcc/fortran/trans-expr.c 2005-09-06 09:28:27.000000000 +0100
*************** Software Foundation, 51 Franklin Street,
*** 39,44 ****
--- 39,45 ----
#include "trans-array.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
#include "trans-stmt.h"
+ #include "dependency.h"
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 2556,2561 ****
--- 2557,2566 ----
if (expr2->symtree->n.sym->attr.elemental)
return NULL;
+ /* Fail if EXPR1 can't be expressed as a descriptor. */
+ if (gfc_ref_needs_temporary_p (expr1->ref))
+ return NULL;
+
/* Check for a dependency. */
if (gfc_check_fncall_dependency (expr1, expr2))
return NULL;
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr19239-1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr19239-1.f90 2005-09-06 11:22:12.000000000 +0100
***************
*** 0 ****
--- 1,171 ----
+ program main
+ implicit none
+ integer, parameter :: n = 10
+ integer :: i, j, calls
+ integer, dimension (n) :: a, b, idx, id
+
+ idx = (/ 3, 1, 5, 2, 4, 10, 8, 7, 6, 9 /)
+ id = (/ (i, i = 1, n) /)
+ b = (/ (i * 100, i = 1, n) /)
+
+ !------------------------------------------------------------------
+ ! Tests for a simple variable subscript
+ !------------------------------------------------------------------
+
+ a (idx) = b
+ call test (idx, id)
+
+ a = b (idx)
+ call test (id, idx)
+
+ a (idx) = b (idx)
+ call test (idx, idx)
+
+ !------------------------------------------------------------------
+ ! Tests for constant ranges with non-default stride
+ !------------------------------------------------------------------
+
+ a (idx (1:7:3)) = b (10:6:-2)
+ call test (idx (1:7:3), id (10:6:-2))
+
+ a (10:6:-2) = b (idx (1:7:3))
+ call test (id (10:6:-2), idx (1:7:3))
+
+ a (idx (1:7:3)) = b (idx (1:7:3))
+ call test (idx (1:7:3), idx (1:7:3))
+
+ a (idx (1:7:3)) = b (idx (10:6:-2))
+ call test (idx (1:7:3), idx (10:6:-2))
+
+ a (idx (10:6:-2)) = b (idx (10:6:-2))
+ call test (idx (10:6:-2), idx (10:6:-2))
+
+ a (idx (10:6:-2)) = b (idx (1:7:3))
+ call test (idx (10:6:-2), idx (1:7:3))
+
+ !------------------------------------------------------------------
+ ! Tests for subscripts of the form CONSTRANGE + CONST
+ !------------------------------------------------------------------
+
+ a (idx (1:5) + 1) = b (1:5)
+ call test (idx (1:5) + 1, id (1:5))
+
+ a (1:5) = b (idx (1:5) + 1)
+ call test (id (1:5), idx (1:5) + 1)
+
+ a (idx (6:10) - 1) = b (idx (1:5) + 1)
+ call test (idx (6:10) - 1, idx (1:5) + 1)
+
+ !------------------------------------------------------------------
+ ! Tests for variable subranges
+ !------------------------------------------------------------------
+
+ do j = 5, 10
+ a (idx (2:j:2)) = b (3:2+j/2)
+ call test (idx (2:j:2), id (3:2+j/2))
+
+ a (3:2+j/2) = b (idx (2:j:2))
+ call test (id (3:2+j/2), idx (2:j:2))
+
+ a (idx (2:j:2)) = b (idx (2:j:2))
+ call test (idx (2:j:2), idx (2:j:2))
+ end do
+
+ !------------------------------------------------------------------
+ ! Tests for function vectors
+ !------------------------------------------------------------------
+
+ calls = 0
+
+ a (foo (5, calls)) = b (2:10:2)
+ call test (foo (5, calls), id (2:10:2))
+
+ a (2:10:2) = b (foo (5, calls))
+ call test (id (2:10:2), foo (5, calls))
+
+ a (foo (5, calls)) = b (foo (5, calls))
+ call test (foo (5, calls), foo (5, calls))
+
+ if (calls .ne. 8) call abort
+
+ !------------------------------------------------------------------
+ ! Tests for constant vector constructors
+ !------------------------------------------------------------------
+
+ a ((/ 1, 5, 3, 9 /)) = b (1:4)
+ call test ((/ 1, 5, 3, 9 /), id (1:4))
+
+ a (1:4) = b ((/ 1, 5, 3, 9 /))
+ call test (id (1:4), (/ 1, 5, 3, 9 /))
+
+ a ((/ 1, 5, 3, 9 /)) = b ((/ 2, 5, 3, 7 /))
+ call test ((/ 1, 5, 3, 9 /), (/ 2, 5, 3, 7 /))
+
+ !------------------------------------------------------------------
+ ! Tests for variable vector constructors
+ !------------------------------------------------------------------
+
+ do j = 1, 5
+ a ((/ 1, (i + 3, i = 2, j) /)) = b (1:j)
+ call test ((/ 1, (i + 3, i = 2, j) /), id (1:j))
+
+ a (1:j) = b ((/ 1, (i + 3, i = 2, j) /))
+ call test (id (1:j), (/ 1, (i + 3, i = 2, j) /))
+
+ a ((/ 1, (i + 3, i = 2, j) /)) = b ((/ 8, (i + 2, i = 2, j) /))
+ call test ((/ 1, (i + 3, i = 2, j) /), (/ 8, (i + 2, i = 2, j) /))
+ end do
+
+ !------------------------------------------------------------------
+ ! Tests in which the vector dimension is partnered by a temporary
+ !------------------------------------------------------------------
+
+ calls = 0
+ a (idx (1:6)) = foo (6, calls)
+ if (calls .ne. 1) call abort
+ do i = 1, 6
+ if (a (idx (i)) .ne. i + 3) call abort
+ end do
+ a = 0
+
+ calls = 0
+ a (idx (1:6)) = foo (6, calls) * 100
+ if (calls .ne. 1) call abort
+ do i = 1, 6
+ if (a (idx (i)) .ne. (i + 3) * 100) call abort
+ end do
+ a = 0
+
+ a (idx) = id + 100
+ do i = 1, n
+ if (a (idx (i)) .ne. i + 100) call abort
+ end do
+ a = 0
+
+ a (idx (1:10:3)) = (/ 20, 10, 9, 11 /)
+ if (a (idx (1)) .ne. 20) call abort
+ if (a (idx (4)) .ne. 10) call abort
+ if (a (idx (7)) .ne. 9) call abort
+ if (a (idx (10)) .ne. 11) call abort
+ a = 0
+
+ contains
+ subroutine test (lhs, rhs)
+ integer, dimension (:) :: lhs, rhs
+ integer :: i
+
+ if (size (lhs, 1) .ne. size (rhs, 1)) call abort
+ do i = 1, size (lhs, 1)
+ if (a (lhs (i)) .ne. b (rhs (i))) call abort
+ end do
+ a = 0
+ end subroutine test
+
+ function foo (n, calls)
+ integer :: i, n, calls
+ integer, dimension (n) :: foo
+
+ calls = calls + 1
+ foo = (/ (i + 3, i = 1, n) /)
+ end function foo
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr19239-2.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr19239-2.f90 2005-09-05 18:40:09.000000000 +0100
***************
*** 0 ****
--- 1,36 ----
+ program main
+ implicit none
+ integer, parameter :: n = 5
+ integer :: i1, i2, i3
+ integer, dimension (n, n, n) :: a, b
+ integer, dimension (n) :: idx, id
+
+ idx = (/ 3, 1, 5, 2, 4 /)
+ id = (/ (i1, i1 = 1, n) /)
+ forall (i1 = 1:n, i2 = 1:n, i3 = 1:n)
+ b (i1, i2, i3) = i1 + i2 * 10 + i3 * 100
+ end forall
+
+ i1 = 5
+ a (foo (i1), 1, :) = b (2, :, foo (i1))
+ do i1 = 1, 5
+ do i2 = 1, 5
+ if (a (idx (i1), 1, i2) .ne. b (2, i1, idx (i2))) call abort
+ end do
+ end do
+ a = 0
+
+ a (1, idx (1:4), 2:4) = b (2:5, idx (3:5), 2)
+ do i1 = 1, 4
+ do i2 = 1, 3
+ if (a (1, idx (i1), 1 + i2) .ne. b (1 + i1, idx (i2 + 2), 2)) call abort
+ end do
+ end do
+ a = 0
+ contains
+ function foo (n)
+ integer :: n
+ integer, dimension (n) :: foo
+ foo = idx (1:n)
+ end function foo
+ end program main