From 2a4a78303029ec0f3765450a918e5677370d1106 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Tobias=20Schl=C3=BCter?= Date: Tue, 1 Mar 2005 01:41:41 +0100 Subject: [PATCH] re PR fortran/19479 (UBOUND causes ICE) fortran/ PR fortran/19479 * simplify.c (gfc_simplify_bound): Rename to ... (simplify_bound): ... this and overhaul. testsuite/ PR fortran/19479 * gfortran.dg/bound_1.f90: New test. From-SVN: r95713 --- gcc/fortran/ChangeLog | 7 +++ gcc/fortran/simplify.c | 71 +++++++++++++++++++++------ gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/bound_1.f90 | 20 ++++++++ 4 files changed, 87 insertions(+), 16 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/bound_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0ddf41ca5c0..6df6301bd4e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2005-02-28 Tobias Schl"uter + (port from g95) + + PR fortran/19479 + * simplify.c (gfc_simplify_bound): Rename to ... + (simplify_bound): ... this and overhaul. + 2005-02-28 Steven G. Kargl * trans-intrinsic.c (gfc_conv_intrinsic_iargc): remove boolean argument. diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 81bc0159909..c2117148839 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1766,16 +1766,18 @@ gfc_simplify_kind (gfc_expr * e) static gfc_expr * -gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) +simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) { gfc_ref *ref; gfc_array_spec *as; - int i; + gfc_expr *e; + int d; if (array->expr_type != EXPR_VARIABLE) return NULL; if (dim == NULL) + /* TODO: Simplify constant multi-dimensional bounds. */ return NULL; if (dim->expr_type != EXPR_CONSTANT) @@ -1783,29 +1785,66 @@ gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) /* Follow any component references. */ as = array->symtree->n.sym->as; - ref = array->ref; - while (ref->next != NULL) + for (ref = array->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + goto done; + + case AR_SECTION: + case AR_UNKNOWN: + return NULL; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + } + } + + 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 (ref->type == REF_COMPONENT) - as = ref->u.c.sym->as; - ref = ref->next; + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; } - if (ref->type != REF_ARRAY || ref->u.ar.type != AR_FULL) + e = upper ? as->upper[d-1] : as->lower[d-1]; + + if (e->expr_type != EXPR_CONSTANT) return NULL; - - i = mpz_get_si (dim->value.integer); - if (upper) - return gfc_copy_expr (as->upper[i-1]); - else - return gfc_copy_expr (as->lower[i-1]); + + return gfc_copy_expr (e); } gfc_expr * gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim) { - return gfc_simplify_bound (array, dim, 0); + return simplify_bound (array, dim, 0); } @@ -3578,7 +3617,7 @@ gfc_simplify_trim (gfc_expr * e) gfc_expr * gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim) { - return gfc_simplify_bound (array, dim, 1); + return simplify_bound (array, dim, 1); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a58496be594..26fa08c5ce8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2005-02-28 Tobias Schl"uter + + PR fortran/19479 + * gfortran.dg/bound_1.f90: New test. + 2005-02-28 Janis Johnson * gcc.test-framework/dg-error-exp-P.c: Update message for new C parser. diff --git a/gcc/testsuite/gfortran.dg/bound_1.f90 b/gcc/testsuite/gfortran.dg/bound_1.f90 new file mode 100644 index 00000000000..ce872bb0af5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bound_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } + implicit none + + type test_type + integer, dimension(5) :: a + end type test_type + + type (test_type), target :: tt(2) + integer i + + i = ubound(tt(1)%a, 1) + if (i/=5) call abort() + i = lbound(tt(1)%a, 1) + if (i/=1) call abort() + + i = ubound(tt, 1) + if (i/=2) call abort() + i = lbound(tt, 1) + if (i/=1) call abort() +end -- 2.30.2