bound simplification refactoring
gcc/fortran/ * simplify.c (simplify_bound_dim): Don't check for emptyness in the case of cobound simplification. Factor lower/upper bound differenciation before the actual simplification. (simplify_bound): Remove assumed shape specific simplification. Don't give up early for the lbound of an assumed shape. gcc/testsuite/ * gfortran.dg/bound_simplification_5.f90: New. From-SVN: r222979
This commit is contained in:
Mikael Morin
parent
edff0c0662
commit
22fa926f19
@ -1,3 +1,11 @@
|
||||
2015-05-10 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
* simplify.c (simplify_bound_dim): Don't check for emptyness
|
||||
in the case of cobound simplification. Factor lower/upper
|
||||
bound differenciation before the actual simplification.
|
||||
(simplify_bound): Remove assumed shape specific simplification.
|
||||
Don't give up early for the lbound of an assumed shape.
|
||||
|
||||
2015-05-09 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/65894
|
||||
|
||||
@ -3340,29 +3340,43 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
|
||||
/* Then, we need to know the extent of the given dimension. */
|
||||
if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
|
||||
{
|
||||
gfc_expr *declared_bound;
|
||||
int empty_bound;
|
||||
bool constant_lbound, constant_ubound;
|
||||
|
||||
l = as->lower[d-1];
|
||||
u = as->upper[d-1];
|
||||
|
||||
if (l->expr_type != EXPR_CONSTANT || u == NULL
|
||||
|| u->expr_type != EXPR_CONSTANT)
|
||||
gcc_assert (l != NULL);
|
||||
|
||||
constant_lbound = l->expr_type == EXPR_CONSTANT;
|
||||
constant_ubound = u && u->expr_type == EXPR_CONSTANT;
|
||||
|
||||
empty_bound = upper ? 0 : 1;
|
||||
declared_bound = upper ? u : l;
|
||||
|
||||
if ((!upper && !constant_lbound)
|
||||
|| (upper && !constant_ubound))
|
||||
goto returnNull;
|
||||
|
||||
if (mpz_cmp (l->value.integer, u->value.integer) > 0)
|
||||
if (!coarray)
|
||||
{
|
||||
/* Zero extent. */
|
||||
if (upper)
|
||||
mpz_set_si (result->value.integer, 0);
|
||||
/* For {L,U}BOUND, the value depends on whether the array
|
||||
is empty. We can nevertheless simplify if the declared bound
|
||||
has the same value as that of an empty array, in which case
|
||||
the result isn't dependent on the array emptyness. */
|
||||
if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
|
||||
mpz_set_si (result->value.integer, empty_bound);
|
||||
else if (!constant_lbound || !constant_ubound)
|
||||
/* Array emptyness can't be determined, we can't simplify. */
|
||||
goto returnNull;
|
||||
else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
|
||||
mpz_set_si (result->value.integer, empty_bound);
|
||||
else
|
||||
mpz_set_si (result->value.integer, 1);
|
||||
mpz_set (result->value.integer, declared_bound->value.integer);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Nonzero extent. */
|
||||
if (upper)
|
||||
mpz_set (result->value.integer, u->value.integer);
|
||||
else
|
||||
mpz_set (result->value.integer, l->value.integer);
|
||||
}
|
||||
mpz_set (result->value.integer, declared_bound->value.integer);
|
||||
}
|
||||
else
|
||||
{
|
||||
@ -3442,43 +3456,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
|
||||
|
||||
done:
|
||||
|
||||
/* If the array shape is assumed shape or explicit, we can simplify lbound
|
||||
to 1 if the given lower bound is one because this matches what lbound
|
||||
should return for an empty array. */
|
||||
|
||||
if (!upper && as && dim && dim->expr_type == EXPR_CONSTANT
|
||||
&& (as->type == AS_ASSUMED_SHAPE || as->type == AS_EXPLICIT)
|
||||
&& ref->u.ar.type != AR_SECTION)
|
||||
{
|
||||
/* Watch out for allocatable or pointer dummy arrays, they can have
|
||||
lower bounds that are not equal to one. */
|
||||
if (!(array->symtree && array->symtree->n.sym
|
||||
&& (array->symtree->n.sym->attr.allocatable
|
||||
|| array->symtree->n.sym->attr.pointer)))
|
||||
{
|
||||
unsigned long int ndim;
|
||||
gfc_expr *lower, *res;
|
||||
|
||||
ndim = mpz_get_si (dim->value.integer) - 1;
|
||||
lower = as->lower[ndim];
|
||||
if (lower->expr_type == EXPR_CONSTANT
|
||||
&& mpz_cmp_si (lower->value.integer, 1) == 0)
|
||||
{
|
||||
res = gfc_copy_expr (lower);
|
||||
if (kind)
|
||||
{
|
||||
int nkind = mpz_get_si (kind->value.integer);
|
||||
res->ts.kind = nkind;
|
||||
}
|
||||
return res;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
|
||||
|| as->type == AS_ASSUMED_RANK))
|
||||
if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
|
||||
|| (as->type == AS_ASSUMED_SHAPE && upper)))
|
||||
return NULL;
|
||||
|
||||
gcc_assert (!as
|
||||
|| (as->type != AS_DEFERRED
|
||||
&& array->expr_type == EXPR_VARIABLE
|
||||
&& !array->symtree->n.sym->attr.allocatable
|
||||
&& !array->symtree->n.sym->attr.pointer));
|
||||
|
||||
if (dim == NULL)
|
||||
{
|
||||
/* Multi-dimensional bounds. */
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
2015-05-10 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/bound_simplification_5.f90: New.
|
||||
|
||||
2015-05-09 Jason Merrill <jason@redhat.com>
|
||||
|
||||
* lib/target-supports.exp (cxx_default): New global.
|
||||
|
||||
75
gcc/testsuite/gfortran.dg/bound_simplification_5.f90
Normal file
75
gcc/testsuite/gfortran.dg/bound_simplification_5.f90
Normal file
@ -0,0 +1,75 @@
|
||||
! { dg-do run }
|
||||
! { dg-additional-options "-fcoarray=single -fdump-tree-original" }
|
||||
!
|
||||
! Check that {L,U}{,CO}BOUND intrinsics are properly simplified.
|
||||
!
|
||||
implicit none
|
||||
|
||||
type :: t
|
||||
integer :: c
|
||||
end type t
|
||||
|
||||
type(t) :: d(3:8) = t(7)
|
||||
type(t) :: e[5:9,-1:*]
|
||||
type(t) :: h(3), j(4), k(0)
|
||||
|
||||
!Test full arrays vs subarrays
|
||||
if (lbound(d, 1) /= 3) call abort
|
||||
if (lbound(d(3:5), 1) /= 1) call abort
|
||||
if (lbound(d%c, 1) /= 1) call abort
|
||||
if (ubound(d, 1) /= 8) call abort
|
||||
if (ubound(d(3:5), 1) /= 3) call abort
|
||||
if (ubound(d%c, 1) /= 6) call abort
|
||||
|
||||
if (lcobound(e, 1) /= 5) call abort
|
||||
if (lcobound(e%c, 1) /= 5) call abort
|
||||
if (lcobound(e, 2) /= -1) call abort
|
||||
if (lcobound(e%c, 2) /= -1) call abort
|
||||
if (ucobound(e, 1) /= 9) call abort
|
||||
if (ucobound(e%c, 1) /= 9) call abort
|
||||
! no simplification for ucobound(e{,%c}, dim=2)
|
||||
|
||||
if (any(lbound(d ) /= [3])) call abort
|
||||
if (any(lbound(d(3:5)) /= [1])) call abort
|
||||
if (any(lbound(d%c ) /= [1])) call abort
|
||||
if (any(ubound(d ) /= [8])) call abort
|
||||
if (any(ubound(d(3:5)) /= [3])) call abort
|
||||
if (any(ubound(d%c ) /= [6])) call abort
|
||||
|
||||
if (any(lcobound(e ) /= [5, -1])) call abort
|
||||
if (any(lcobound(e%c) /= [5, -1])) call abort
|
||||
! no simplification for ucobound(e{,%c})
|
||||
|
||||
call test_empty_arrays(h, j, k)
|
||||
|
||||
contains
|
||||
subroutine test_empty_arrays(a, c, d)
|
||||
type(t) :: a(:), c(-3:0), d(3:1)
|
||||
type(t) :: f(4:2), g(0:6)
|
||||
|
||||
if (lbound(a, 1) /= 1) call abort
|
||||
if (lbound(c, 1) /= -3) call abort
|
||||
if (lbound(d, 1) /= 1) call abort
|
||||
if (lbound(f, 1) /= 1) call abort
|
||||
if (lbound(g, 1) /= 0) call abort
|
||||
|
||||
if (ubound(c, 1) /= 0) call abort
|
||||
if (ubound(d, 1) /= 0) call abort
|
||||
if (ubound(f, 1) /= 0) call abort
|
||||
if (ubound(g, 1) /= 6) call abort
|
||||
|
||||
if (any(lbound(a) /= [ 1])) call abort
|
||||
if (any(lbound(c) /= [-3])) call abort
|
||||
if (any(lbound(d) /= [ 1])) call abort
|
||||
if (any(lbound(f) /= [ 1])) call abort
|
||||
if (any(lbound(g) /= [ 0])) call abort
|
||||
|
||||
if (any(ubound(c) /= [0])) call abort
|
||||
if (any(ubound(d) /= [0])) call abort
|
||||
if (any(ubound(f) /= [0])) call abort
|
||||
if (any(ubound(g) /= [6])) call abort
|
||||
|
||||
end subroutine
|
||||
end
|
||||
! { dg-final { scan-tree-dump-not "abort" "original" } }
|
||||
! { dg-final { cleanup-tree-dump "original" } }
|
||||
Loading…
Reference in New Issue
Block a user