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

+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.

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);
+    }
 }
 
 

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/bound_simplification_1.f90

+! { 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