procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/31591 (UBOUND as initialization expression (lacking simplification))

Browse source 
PR fortran/31591

	* simplify.c (simplify_bound_dim): New function.
	(simplify_bound): Use the above. Perform simplification of LBOUND
	and UBOUND when DIM argument is not present.

	* gfortran.dg/bound_simplification_1.f90: New test.

From-SVN: r124281
This commit is contained in:
Francois-Xavier Coudert 2007-04-29 16:03:58 +00:00 • committed by François-Xavier Coudert
parent 26c5953d27
commit fc9f54d5b5
4 changed files with 154 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View file

@ -1,3 +1,10 @@
2007-04-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31591
* simplify.c (simplify_bound_dim): New function.
(simplify_bound): Use the above. Perform simplification of LBOUND
and UBOUND when DIM argument is not present.
2007-04-29 Daniel Franke <franke.daniel@gmail.com>
* gfortran.texi: Cleaned up keyword index.

159
gcc/fortran/simplify.c
View file

@ -1937,21 +1937,58 @@ gfc_simplify_kind (gfc_expr *e)
}
static gfc_expr *
simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as)
{
gfc_expr *l, *u, *result;
/* The last dimension of an assumed-size array is special. */
if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
return gfc_copy_expr (as->lower[d-1]);
else
return NULL;
}
/* Then, we need to know the extent of the given dimension. */
l = as->lower[d-1];
u = as->upper[d-1];
if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&array->where);
if (mpz_cmp (l->value.integer, u->value.integer) > 0)
{
/* Zero extent. */
if (upper)
mpz_set_si (result->value.integer, 0);
else
mpz_set_si (result->value.integer, 1);
}
else
{
/* Nonzero extent. */
if (upper)
mpz_set (result->value.integer, u->value.integer);
else
mpz_set (result->value.integer, l->value.integer);
}
return range_check (result, upper ? "UBOUND" : "LBOUND");
}
static gfc_expr *
simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
{
gfc_ref *ref;
gfc_array_spec *as;
gfc_expr *l, *u, *result;
int d;
if (dim == NULL)
/* TODO: Simplify constant multi-dimensional bounds. */
return NULL;
if (dim->expr_type != EXPR_CONSTANT)
return NULL;
if (array->expr_type != EXPR_VARIABLE)
return NULL;
@ -1992,55 +2029,89 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
gcc_unreachable ();
done:
if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
return NULL;
d = mpz_get_si (dim->value.integer);
if (d < 1 || d > as->rank
|| (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
if (dim == NULL)
{
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
return &gfc_bad_expr;
}
/* Multi-dimensional bounds. */
gfc_expr *bounds[GFC_MAX_DIMENSIONS];
gfc_expr *e;
gfc_constructor *head, *tail;
/* The last dimension of an assumed-size array is special. */
if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
return gfc_copy_expr (as->lower[d-1]);
else
return NULL;
}
/* UBOUND(ARRAY) is not valid for an assumed-size array. */
if (upper && as->type == AS_ASSUMED_SIZE)
{
/* An error message will be emitted in
check_assumed_size_reference (resolve.c). */
return &gfc_bad_expr;
}
/* Then, we need to know the extent of the given dimension. */
l = as->lower[d-1];
u = as->upper[d-1];
/* Simplify the bounds for each dimension. */
for (d = 0; d < array->rank; d++)
{
bounds[d] = simplify_bound_dim (array, d + 1, upper, as);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
int j;
if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
return NULL;
for (j = 0; j < d; j++)
gfc_free_expr (bounds[j]);
return bounds[d];
}
}
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
&array->where);
/* Allocate the result expression. */
e = gfc_get_expr ();
e->where = array->where;
e->expr_type = EXPR_ARRAY;
e->ts.type = BT_INTEGER;
e->ts.kind = gfc_default_integer_kind;
if (mpz_cmp (l->value.integer, u->value.integer) > 0)
{
/* Zero extent. */
if (upper)
mpz_set_si (result->value.integer, 0);
else
mpz_set_si (result->value.integer, 1);
/* The result is a rank 1 array; its size is the rank of the first
argument to {L,U}BOUND. */
e->rank = 1;
e->shape = gfc_get_shape (1);
mpz_init_set_ui (e->shape[0], array->rank);
/* Create the constructor for this array. */
head = tail = NULL;
for (d = 0; d < array->rank; d++)
{
/* Get a new constructor element. */
if (head == NULL)
head = tail = gfc_get_constructor ();
else
{
tail->next = gfc_get_constructor ();
tail = tail->next;
}
tail->where = e->where;
tail->expr = bounds[d];
}
e->value.constructor = head;
return e;
}
else
{
/* Nonzero extent. */
if (upper)
mpz_set (result->value.integer, u->value.integer);
else
mpz_set (result->value.integer, l->value.integer);
}
/* A DIM argument is specified. */
if (dim->expr_type != EXPR_CONSTANT)
return NULL;
return range_check (result, upper ? "UBOUND" : "LBOUND");
d = mpz_get_si (dim->value.integer);
if (d < 1 || d > as->rank
|| (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
{
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
return &gfc_bad_expr;
}
return simplify_bound_dim (array, d, upper, as);
}
}

5
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
2007-04-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31591
* gfortran.dg/bound_simplification_1.f90: New test.
2007-04-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31645

27
gcc/testsuite/gfortran.dg/bound_simplification_1.f90 Normal file
View file

@ -0,0 +1,27 @@
! { dg-do run }
! { dg-options "" }
implicit none
real :: f(10,10,10,3,4)
integer, parameter :: upper(5) = ubound(f), lower(5) = lbound (f)
integer :: varu(5), varl(5)
varu(:) = ubound(f)
varl(:) = lbound(f)
if (any (varu /= upper)) call abort
if (any (varl /= lower)) call abort
call check (f, upper, lower)
call check (f, ubound(f), lbound(f))
contains
subroutine check (f, upper, lower)
implicit none
integer :: upper(5), lower(5)
real :: f(:,:,:,:,:)
if (any (ubound(f) /= upper)) call abort
if (any (lbound(f) /= lower)) call abort
end subroutine check
end