From fc9f54d5b517c077b32bc592e4b4b2cad8fd8c5d Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Sun, 29 Apr 2007 16:03:58 +0000 Subject: [PATCH] re PR fortran/31591 (UBOUND as initialization expression (lacking simplification)) 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 --- gcc/fortran/ChangeLog | 7 + gcc/fortran/simplify.c | 159 +++++++++++++----- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/bound_simplification_1.f90 | 27 +++ 4 files changed, 154 insertions(+), 44 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/bound_simplification_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 845e35e702b..208d7847148 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2007-04-29 Francois-Xavier Coudert + + 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 * gfortran.texi: Cleaned up keyword index. diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index ab3d3d2fe75..b31597d170b 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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); + } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f7283eccab4..d9972b7497f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-04-29 Francois-Xavier Coudert + + PR fortran/31591 + * gfortran.dg/bound_simplification_1.f90: New test. + 2007-04-29 Francois-Xavier Coudert PR fortran/31645 diff --git a/gcc/testsuite/gfortran.dg/bound_simplification_1.f90 b/gcc/testsuite/gfortran.dg/bound_simplification_1.f90 new file mode 100644 index 00000000000..def5b7005ef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bound_simplification_1.f90 @@ -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