From 9f1dce5609ca54d2caa87d0ecfece64a7bb58c81 Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Thu, 16 Nov 2006 13:25:11 +0100 Subject: re PR fortran/29391 ([4.2/4.1 only] LBOUND and UBOUND are broken) PR fortran/29391 PR fortran/29489 * simplify.c (simplify_bound): Fix the simplification of LBOUND/UBOUND intrinsics. * trans-intrinsic.c (simplify_bound): Fix the logic, and remove an erroneous assert. * gcc/testsuite/gfortran.dg/bound_2.f90: Add more checks. * gcc/testsuite/gfortran.dg/bound_3.f90: New test. From-SVN: r118888 --- gcc/fortran/ChangeLog | 9 +++ gcc/fortran/simplify.c | 45 +++++++++-- gcc/fortran/trans-intrinsic.c | 32 +++++--- gcc/testsuite/ChangeLog | 7 ++ gcc/testsuite/gfortran.dg/bound_2.f90 | 146 ++++++++++++++++++++++++++++++++++ 5 files changed, 220 insertions(+), 19 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3141d72..c26bf0b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2006-11-16 Francois-Xavier Coudert + + PR fortran/29391 + PR fortran/29489 + * simplify.c (simplify_bound): Fix the simplification of + LBOUND/UBOUND intrinsics. + * trans-intrinsic.c (simplify_bound): Fix the logic, and + remove an erroneous assert. + 2006-11-16 Francois-Xavier Coudert * trans-decl.c (gfc_get_symbol_decl): Fix formatting. diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 75e4c3c..8ecabf0 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1913,12 +1913,9 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) { gfc_ref *ref; gfc_array_spec *as; - gfc_expr *e; + gfc_expr *l, *u, *result; int d; - if (array->expr_type != EXPR_VARIABLE) - return NULL; - if (dim == NULL) /* TODO: Simplify constant multi-dimensional bounds. */ return NULL; @@ -1926,6 +1923,9 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) if (dim->expr_type != EXPR_CONSTANT) return NULL; + if (array->expr_type != EXPR_VARIABLE) + return NULL; + /* Follow any component references. */ as = array->symtree->n.sym->as; for (ref = array->ref; ref; ref = ref->next) @@ -1975,12 +1975,43 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) return &gfc_bad_expr; } - e = upper ? as->upper[d-1] : as->lower[d-1]; + /* 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; + } - if (e->expr_type != EXPR_CONSTANT) + /* 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; - return gfc_copy_expr (e); + 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"); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index ec857a53..5facd5b 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -712,14 +712,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tree type; tree bound; tree tmp; - tree cond, cond1, cond2, cond3, size; + tree cond, cond1, cond2, cond3, cond4, size; tree ubound; tree lbound; gfc_se argse; gfc_ss *ss; gfc_array_spec * as; gfc_ref *ref; - int i; arg = expr->value.function.actual; arg2 = arg->next; @@ -761,9 +760,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (INTEGER_CST_P (bound)) { - gcc_assert (TREE_INT_CST_HIGH (bound) == 0); - i = TREE_INT_CST_LOW (bound); - gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))); + int hi, low; + + hi = TREE_INT_CST_HIGH (bound); + low = TREE_INT_CST_LOW (bound); + if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " + "dimension index", upper ? "UBOUND" : "LBOUND", + &expr->where); } else { @@ -842,15 +846,21 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (as) { tree stride = gfc_conv_descriptor_stride (desc, bound); + cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound); cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound); - cond3 = fold_build2 (GT_EXPR, boolean_type_node, stride, + + cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride, gfc_index_zero_node); + cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1); + + cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride, + gfc_index_zero_node); + cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2); if (upper) { - cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1); - cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond2); + cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, ubound, gfc_index_zero_node); @@ -860,13 +870,11 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (as->type == AS_ASSUMED_SIZE) cond = fold_build2 (EQ_EXPR, boolean_type_node, bound, build_int_cst (TREE_TYPE (bound), - arg->expr->rank)); + arg->expr->rank - 1)); else cond = boolean_false_node; - cond1 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1); - cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond1, cond2); - + cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1); se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3e2ee9b..efbbfe4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2006-11-16 Francois-Xavier Coudert + + PR fortran/29391 + PR fortran/29489 + * gcc/testsuite/gfortran.dg/bound_2.f90: Add more checks. + * gcc/testsuite/gfortran.dg/bound_3.f90: New test. + 2006-11-16 Maxim Kuvyrkov PR target/29201 diff --git a/gcc/testsuite/gfortran.dg/bound_2.f90 b/gcc/testsuite/gfortran.dg/bound_2.f90 index bd8cb4e..2fa0c4b 100644 --- a/gcc/testsuite/gfortran.dg/bound_2.f90 +++ b/gcc/testsuite/gfortran.dg/bound_2.f90 @@ -6,46 +6,146 @@ implicit none integer :: i(-1:1,-1:1) = 0 integer :: j(-1:2) = 0 + integer :: u(7,4,2,9) + + call foo(u,4) + call jackal(-1,-8) + call jackal(-1,8) if (any(lbound(i(-1:1,-1:1)) /= 1)) call abort + if (lbound(i(-1:1,-1:1), 1) /= 1) call abort + if (lbound(i(-1:1,-1:1), 2) /= 1) call abort + if (any(ubound(i(-1:1,-1:1)) /= 3)) call abort + if (ubound(i(-1:1,-1:1), 1) /= 3) call abort + if (ubound(i(-1:1,-1:1), 2) /= 3) call abort + if (any(lbound(i(:,:)) /= 1)) call abort + if (lbound(i(:,:), 1) /= 1) call abort + if (lbound(i(:,:), 2) /= 1) call abort + if (any(ubound(i(:,:)) /= 3)) call abort + if (ubound(i(:,:), 1) /= 3) call abort + if (ubound(i(:,:), 2) /= 3) call abort + if (any(lbound(i(0:,-1:)) /= 1)) call abort + if (lbound(i(0:,-1:), 1) /= 1) call abort + if (lbound(i(0:,-1:), 2) /= 1) call abort + if (any(ubound(i(0:,-1:)) /= [2,3])) call abort + if (ubound(i(0:,-1:), 1) /= 2) call abort + if (ubound(i(0:,-1:), 2) /= 3) call abort + if (any(lbound(i(:0,:0)) /= 1)) call abort + if (lbound(i(:0,:0), 1) /= 1) call abort + if (lbound(i(:0,:0), 2) /= 1) call abort + if (any(ubound(i(:0,:0)) /= 2)) call abort + if (ubound(i(:0,:0), 1) /= 2) call abort + if (ubound(i(:0,:0), 2) /= 2) call abort if (any(lbound(transpose(i)) /= 1)) call abort + if (lbound(transpose(i), 1) /= 1) call abort + if (lbound(transpose(i), 2) /= 1) call abort + if (any(ubound(transpose(i)) /= 3)) call abort + if (ubound(transpose(i), 1) /= 3) call abort + if (ubound(transpose(i), 2) /= 3) call abort + if (any(lbound(reshape(i,[2,2])) /= 1)) call abort + if (lbound(reshape(i,[2,2]), 1) /= 1) call abort + if (lbound(reshape(i,[2,2]), 2) /= 1) call abort + if (any(ubound(reshape(i,[2,2])) /= 2)) call abort + if (ubound(reshape(i,[2,2]), 1) /= 2) call abort + if (ubound(reshape(i,[2,2]), 2) /= 2) call abort + if (any(lbound(cshift(i,-1)) /= 1)) call abort + if (lbound(cshift(i,-1), 1) /= 1) call abort + if (lbound(cshift(i,-1), 2) /= 1) call abort + if (any(ubound(cshift(i,-1)) /= 3)) call abort + if (ubound(cshift(i,-1), 1) /= 3) call abort + if (ubound(cshift(i,-1), 2) /= 3) call abort + if (any(lbound(eoshift(i,-1)) /= 1)) call abort + if (lbound(eoshift(i,-1), 1) /= 1) call abort + if (lbound(eoshift(i,-1), 2) /= 1) call abort + if (any(ubound(eoshift(i,-1)) /= 3)) call abort + if (ubound(eoshift(i,-1), 1) /= 3) call abort + if (ubound(eoshift(i,-1), 2) /= 3) call abort + if (any(lbound(spread(i,1,2)) /= 1)) call abort + if (lbound(spread(i,1,2), 1) /= 1) call abort + if (lbound(spread(i,1,2), 2) /= 1) call abort + if (any(ubound(spread(i,1,2)) /= [2,3,3])) call abort + if (ubound(spread(i,1,2), 1) /= 2) call abort + if (ubound(spread(i,1,2), 2) /= 3) call abort + if (ubound(spread(i,1,2), 3) /= 3) call abort + if (any(lbound(maxloc(i)) /= 1)) call abort + if (lbound(maxloc(i), 1) /= 1) call abort + if (any(ubound(maxloc(i)) /= 2)) call abort + if (ubound(maxloc(i), 1) /= 2) call abort + if (any(lbound(minloc(i)) /= 1)) call abort + if (lbound(minloc(i), 1) /= 1) call abort + if (any(ubound(minloc(i)) /= 2)) call abort + if (ubound(minloc(i), 1) /= 2) call abort + if (any(lbound(maxval(i,2)) /= 1)) call abort + if (lbound(maxval(i,2), 1) /= 1) call abort + if (any(ubound(maxval(i,2)) /= 3)) call abort + if (ubound(maxval(i,2), 1) /= 3) call abort + if (any(lbound(minval(i,2)) /= 1)) call abort + if (lbound(minval(i,2), 1) /= 1) call abort + if (any(ubound(minval(i,2)) /= 3)) call abort + if (ubound(minval(i,2), 1) /= 3) call abort + if (any(lbound(any(i==1,2)) /= 1)) call abort + if (lbound(any(i==1,2), 1) /= 1) call abort + if (any(ubound(any(i==1,2)) /= 3)) call abort + if (ubound(any(i==1,2), 1) /= 3) call abort + if (any(lbound(count(i==1,2)) /= 1)) call abort + if (lbound(count(i==1,2), 1) /= 1) call abort + if (any(ubound(count(i==1,2)) /= 3)) call abort + if (ubound(count(i==1,2), 1) /= 3) call abort + if (any(lbound(merge(i,i,.true.)) /= 1)) call abort + if (lbound(merge(i,i,.true.), 1) /= 1) call abort + if (lbound(merge(i,i,.true.), 2) /= 1) call abort + if (any(ubound(merge(i,i,.true.)) /= 3)) call abort + if (ubound(merge(i,i,.true.), 1) /= 3) call abort + if (ubound(merge(i,i,.true.), 2) /= 3) call abort + if (any(lbound(lbound(i)) /= 1)) call abort + if (lbound(lbound(i), 1) /= 1) call abort + if (any(ubound(lbound(i)) /= 2)) call abort + if (ubound(lbound(i), 1) /= 2) call abort + if (any(lbound(ubound(i)) /= 1)) call abort + if (lbound(ubound(i), 1) /= 1) call abort + if (any(ubound(ubound(i)) /= 2)) call abort + if (ubound(ubound(i), 1) /= 2) call abort + if (any(lbound(shape(i)) /= 1)) call abort + if (lbound(shape(i), 1) /= 1) call abort + if (any(ubound(shape(i)) /= 2)) call abort + if (ubound(shape(i), 1) /= 2) call abort if (any(lbound(product(i,2)) /= 1)) call abort if (any(ubound(product(i,2)) /= 3)) call abort @@ -60,13 +160,59 @@ call sub1(i,3) call sub1(reshape([7,9,4,6,7,9],[3,2]),3) + call sub2 contains subroutine sub1(a,n) integer :: a(2:n+1,4:*), n + if (any([lbound(a,1), lbound(a,2)] /= [2, 4])) call abort if (any(lbound(a) /= [2, 4])) call abort end subroutine sub1 + subroutine sub2 + integer :: x(3:2, 1:2) + + if (size(x) /= 0) call abort + if (lbound (x, 1) /= 1 .or. lbound(x, 2) /= 1) call abort + if (any (lbound (x) /= [1, 1])) call abort + if (ubound (x, 1) /= 0 .or. ubound(x, 2) /= 2) call abort + if (any (ubound (x) /= [0, 2])) call abort + end subroutine sub2 + + subroutine sub3 + integer :: x(4:5, 1:2) + + if (size(x) /= 0) call abort + if (lbound (x, 1) /= 4 .or. lbound(x, 2) /= 1) call abort + if (any (lbound (x) /= [4, 1])) call abort + if (ubound (x, 1) /= 4 .or. ubound(x, 2) /= 2) call abort + if (any (ubound (x) /= [4, 2])) call abort + end subroutine sub3 + + subroutine foo (x,n) + integer :: x(7,n,2,*), n + + !if (ubound(x,1) /= 7 .or. ubound(x,2) /= 4 .or. ubound(x,3) /= 2) call abort + end subroutine foo + + subroutine jackal (b, c) + integer :: b, c + integer :: soda(b:c, 3:4) + + if (b > c) then + if (size(soda) /= 0) call abort + if (lbound (soda, 1) /= 1 .or. ubound (soda, 1) /= 0) call abort + else + if (size(soda) /= 2*(c-b+1)) call abort + if (lbound (soda, 1) /= b .or. ubound (soda, 1) /= c) call abort + end if + + if (lbound (soda, 2) /= 3 .or. ubound (soda, 2) /= 4) call abort + if (any (lbound (soda) /= [lbound(soda,1), lbound(soda,2)])) call abort + if (any (ubound (soda) /= [ubound(soda,1), ubound(soda,2)])) call abort + + end subroutine jackal + end -- cgit v1.1