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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@124281 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 845e35e..208d784 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2007-04-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+       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  <franke.daniel@gmail.com>
 
        * gfortran.texi: Cleaned up keyword index.

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index ab3d3d2..b31597d 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1938,20 +1938,57 @@ gfc_simplify_kind (gfc_expr *e)
 
 
 static gfc_expr *
-simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
+simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as)
 {
-  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;
+  /* 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 (dim->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;
 
+  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;
+  int d;
+
   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;
+
+      /* 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;
+           }
 
-  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);
+         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 f7283ec..d9972b7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-04-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+       PR fortran/31591
+       * gfortran.dg/bound_simplification_1.f90: New test.
+
 2007-04-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        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 (file)
index 0000000..def5b70
--- /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