From dd94eecae95d20c4a5ebe54fd6ee956ea52ab854 Mon Sep 17 00:00:00 2001 From: fxcoudert Date: Mon, 5 Jun 2006 22:41:29 +0000 Subject: [PATCH] PR libfortran/27895 * resolve.c (compute_last_value_for_triplet): New function. (check_dimension): Correctly handle zero-sized array sections. Add checking on last element of array sections. * gfortran.dg/bounds_check_3.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@114414 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 7 ++ gcc/fortran/resolve.c | 112 +++++++++++++++++++++++++-- gcc/testsuite/ChangeLog | 13 +++- gcc/testsuite/gfortran.dg/bounds_check_3.f90 | 69 +++++++++++++++++ 4 files changed, 192 insertions(+), 9 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/bounds_check_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c0301da..776394e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2006-06-05 Francois-Xavier Coudert + + PR libfortran/27895 + * resolve.c (compute_last_value_for_triplet): New function. + (check_dimension): Correctly handle zero-sized array sections. + Add checking on last element of array sections. + 2006-06-05 Steven G. Kargl * data.c (gfc_assign_data_value): Fix comment typo. Remove diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fef969f..8e54d3c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2100,12 +2100,86 @@ compare_bound_int (gfc_expr * a, int b) } +/* Compare an integer expression with a mpz_t. */ + +static comparison +compare_bound_mpz_t (gfc_expr * a, mpz_t b) +{ + int i; + + if (a == NULL || a->expr_type != EXPR_CONSTANT) + return CMP_UNKNOWN; + + if (a->ts.type != BT_INTEGER) + gfc_internal_error ("compare_bound_int(): Bad expression"); + + i = mpz_cmp (a->value.integer, b); + + if (i < 0) + return CMP_LT; + if (i > 0) + return CMP_GT; + return CMP_EQ; +} + + +/* Compute the last value of a sequence given by a triplet. + Return 0 if it wasn't able to compute the last value, or if the + sequence if empty, and 1 otherwise. */ + +static int +compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end, + gfc_expr * stride, mpz_t last) +{ + mpz_t rem; + + if (start == NULL || start->expr_type != EXPR_CONSTANT + || end == NULL || end->expr_type != EXPR_CONSTANT + || (stride != NULL && stride->expr_type != EXPR_CONSTANT)) + return 0; + + if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER + || (stride != NULL && stride->ts.type != BT_INTEGER)) + return 0; + + if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ) + { + if (compare_bound (start, end) == CMP_GT) + return 0; + mpz_set (last, end->value.integer); + return 1; + } + + if (compare_bound_int (stride, 0) == CMP_GT) + { + /* Stride is positive */ + if (mpz_cmp (start->value.integer, end->value.integer) > 0) + return 0; + } + else + { + /* Stride is negative */ + if (mpz_cmp (start->value.integer, end->value.integer) < 0) + return 0; + } + + mpz_init (rem); + mpz_sub (rem, end->value.integer, start->value.integer); + mpz_tdiv_r (rem, rem, stride->value.integer); + mpz_sub (last, end->value.integer, rem); + mpz_clear (rem); + + return 1; +} + + /* Compare a single dimension of an array reference to the array specification. */ static try check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as) { + mpz_t last_value; /* Given start, end and stride values, calculate the minimum and maximum referenced indexes. */ @@ -2130,13 +2204,41 @@ check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as) return FAILURE; } - if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) - goto bound; - if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) +#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i]) +#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i]) + + if (compare_bound (AR_START, AR_END) == CMP_EQ + && (compare_bound (AR_START, as->lower[i]) == CMP_LT + || compare_bound (AR_START, as->upper[i]) == CMP_GT)) goto bound; - /* TODO: Possibly, we could warn about end[i] being out-of-bound although - it is legal (see 6.2.2.3.1). */ + if (((compare_bound_int (ar->stride[i], 0) == CMP_GT + || ar->stride[i] == NULL) + && compare_bound (AR_START, AR_END) != CMP_GT) + || (compare_bound_int (ar->stride[i], 0) == CMP_LT + && compare_bound (AR_START, AR_END) != CMP_LT)) + { + if (compare_bound (AR_START, as->lower[i]) == CMP_LT) + goto bound; + if (compare_bound (AR_START, as->upper[i]) == CMP_GT) + goto bound; + } + + mpz_init (last_value); + if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i], + last_value)) + { + if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT + || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT) + { + mpz_clear (last_value); + goto bound; + } + } + mpz_clear (last_value); + +#undef AR_START +#undef AR_END break; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e25cd59..2a597d4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2006-06-05 Francois-Xavier Coudert + + PR libfortran/27895 + * gfortran.dg/bounds_check_3.f90: New test. + 2006-06-05 Mike Stump * objc.dg/objc-fast-4.m: Skip for ppc64. @@ -10,10 +15,10 @@ 2006-06-05 Dorit Nuzman Victor Kaplansky - PR tree-optimizations/26360 - * gcc.dg/vect/vect.exp: Compile tests prefixed with "no-tree-dce" - with -fno-tree-dce. - * gcc.dg/vect/no-tree-dce-pr26360.c: New test. + PR tree-optimizations/26360 + * gcc.dg/vect/vect.exp: Compile tests prefixed with "no-tree-dce" + with -fno-tree-dce. + * gcc.dg/vect/no-tree-dce-pr26360.c: New test. 2006-06-05 Paul Thomas diff --git a/gcc/testsuite/gfortran.dg/bounds_check_3.f90 b/gcc/testsuite/gfortran.dg/bounds_check_3.f90 new file mode 100644 index 0000000..5fb96b8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bounds_check_3.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } + integer,parameter :: n = 5, m = 8 + integer a(10), i + + print *, a(15:14) ! don't warn + print *, a(14:15) ! { dg-warning "is out of bounds" } + print *, a(-5:-6) ! don't warn + print *, a(-6:-5) ! { dg-warning "is out of bounds" } + print *, a(15:14:1) ! don't warn + print *, a(14:15:1) ! { dg-warning "is out of bounds" } + print *, a(-5:-6:1) ! don't warn + print *, a(-6:-5:1) ! { dg-warning "is out of bounds" } + print *, a(15:14:-1) ! { dg-warning "is out of bounds" } + print *, a(14:15:-1) ! don't warn + print *, a(-5:-6:-1) ! { dg-warning "is out of bounds" } + print *, a(-6:-5:-1) ! don't warn + + print *, a(15:) ! don't warn + print *, a(15::-1) ! { dg-warning "is out of bounds" } + print *, a(-1:) ! { dg-warning "is out of bounds" } + print *, a(-1::-1) ! don't warn + print *, a(:-1) ! don't warn + print *, a(:-1:-1) ! { dg-warning "is out of bounds" } + print *, a(:11) ! { dg-warning "is out of bounds" } + print *, a(:11:-1) ! don't warn + + print *, a(1:20:10) ! { dg-warning "is out of bounds" } + print *, a(1:15:15) ! don't warn + print *, a(1:16:15) ! { dg-warning "is out of bounds" } + print *, a(10:15:6) ! don't warn + print *, a(11:15:6) ! { dg-warning "is out of bounds" } + print *, a(11:-5:6) ! don't warn + + print *, a(10:-8:-9) ! { dg-warning "is out of bounds" } + print *, a(10:-7:-9) ! don't warn + + print *, a(0:0:-1) ! { dg-warning "is out of bounds" } + print *, a(0:0:1) ! { dg-warning "is out of bounds" } + print *, a(0:0) ! { dg-warning "is out of bounds" } + + print *, a(1:15:i) ! don't warn + print *, a(1:15:n) ! { dg-warning "is out of bounds" } + print *, a(1:15:m) ! don't warn + + print *, a(1:-5:-m) ! don't warn + print *, a(1:-5:-n) ! { dg-warning "is out of bounds" } + print *, a(1:-5:-i) ! don't warn + + print *, a(-5:-5) ! { dg-warning "is out of bounds" } + print *, a(15:15) ! { dg-warning "is out of bounds" } + print *, a(-5:-5:1) ! { dg-warning "is out of bounds" } + print *, a(15:15:-1) ! { dg-warning "is out of bounds" } + print *, a(-5:-5:2) ! { dg-warning "is out of bounds" } + print *, a(15:15:-2) ! { dg-warning "is out of bounds" } + print *, a(-5:-5:n) ! { dg-warning "is out of bounds" } + print *, a(15:15:-n) ! { dg-warning "is out of bounds" } + print *, a(-5:-5:i) ! { dg-warning "is out of bounds" } + print *, a(15:15:-i) ! { dg-warning "is out of bounds" } + print *, a(5:5) ! don't warn + print *, a(5:5:1) ! don't warn + print *, a(5:5:-1) ! don't warn + print *, a(5:5:2) ! don't warn + print *, a(5:5:-2) ! don't warn + print *, a(5:5:n) ! don't warn + print *, a(5:5:-n) ! don't warn + print *, a(5:5:i) ! don't warn + print *, a(5:5:-i) ! don't warn + + end -- 2.7.4