re PR fortran/29391 ([4.2/4.1 only] LBOUND and UBOUND are broken)

	PR fortran/29391
	PR fortran/29489

	* simplify.c (simplify_bound): Fix the simplification of
	LBOUND/UBOUND intrinsics.
	* trans-intrinsic.c (simplify_bound): Fix the logic, and
	remove an erroneous assert.

	* gcc/testsuite/gfortran.dg/bound_2.f90: Add more checks.
	* gcc/testsuite/gfortran.dg/bound_3.f90: New test.

From-SVN: r118888

gcc/fortran/ChangeLog

+2006-11-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29391
+	PR fortran/29489
+	* simplify.c (simplify_bound): Fix the simplification of
+	LBOUND/UBOUND intrinsics.
+	* trans-intrinsic.c (simplify_bound): Fix the logic, and
+	remove an erroneous assert.
+
 2006-11-16  Francois-Xavier Coudert  <fxcoudert@gcc.gnu,org>
 
 	* trans-decl.c (gfc_get_symbol_decl): Fix formatting.

gcc/fortran/simplify.c

@@ -1913,12 +1913,9 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
 {
   gfc_ref *ref;
   gfc_array_spec *as;
-  gfc_expr *e;
+  gfc_expr *l, *u, *result;
   int d;
 
-  if (array->expr_type != EXPR_VARIABLE)
-    return NULL;
-
   if (dim == NULL)
     /* TODO: Simplify constant multi-dimensional bounds.  */
     return NULL;
@@ -1926,6 +1923,9 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
   if (dim->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  if (array->expr_type != EXPR_VARIABLE)
+    return NULL;
+
   /* Follow any component references.  */
   as = array->symtree->n.sym->as;
   for (ref = array->ref; ref; ref = ref->next)
@@ -1975,12 +1975,43 @@ simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
       return &gfc_bad_expr;
     }
 
-  e = upper ? as->upper[d-1] : as->lower[d-1];
+  /* 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 (e->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;
 
-  return gfc_copy_expr (e);
+  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");
 }
 
 

gcc/fortran/trans-intrinsic.c

@@ -712,14 +712,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   tree type;
   tree bound;
   tree tmp;
-  tree cond, cond1, cond2, cond3, size;
+  tree cond, cond1, cond2, cond3, cond4, size;
   tree ubound;
   tree lbound;
   gfc_se argse;
   gfc_ss *ss;
   gfc_array_spec * as;
   gfc_ref *ref;
-  int i;
 
   arg = expr->value.function.actual;
   arg2 = arg->next;
@@ -761,9 +760,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   if (INTEGER_CST_P (bound))
     {
-      gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
-      i = TREE_INT_CST_LOW (bound);
-      gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
+      int hi, low;
+
+      hi = TREE_INT_CST_HIGH (bound);
+      low = TREE_INT_CST_LOW (bound);
+      if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+	gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+		   "dimension index", upper ? "UBOUND" : "LBOUND",
+		   &expr->where);
     }
   else
     {
@@ -842,15 +846,21 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   if (as)
     {
       tree stride = gfc_conv_descriptor_stride (desc, bound);
+
       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
       cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
-      cond3 = fold_build2 (GT_EXPR, boolean_type_node, stride,
+
+      cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 			   gfc_index_zero_node);
+      cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+
+      cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
+			   gfc_index_zero_node);
+      cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
 
       if (upper)
 	{
-	  cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
-	  cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond2);
+	  cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 
 	  se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 				  ubound, gfc_index_zero_node);
@@ -860,13 +870,11 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 	  if (as->type == AS_ASSUMED_SIZE)
 	    cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 				build_int_cst (TREE_TYPE (bound),
-					       arg->expr->rank));
+					       arg->expr->rank - 1));
 	  else
 	    cond = boolean_false_node;
 
-	  cond1 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
-	  cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond1, cond2);
-
+	  cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 	  cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
 
 	  se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,

gcc/testsuite/ChangeLog

+2006-11-16  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29391
+	PR fortran/29489
+	* gcc/testsuite/gfortran.dg/bound_2.f90: Add more checks.
+	* gcc/testsuite/gfortran.dg/bound_3.f90: New test.
+
 2006-11-16  Maxim Kuvyrkov  <mkuvyrkov@ispras.ru>
 
 	PR target/29201

gcc/testsuite/gfortran.dg/bound_2.f90

@@ -6,46 +6,146 @@
   implicit none
   integer :: i(-1:1,-1:1) = 0
   integer :: j(-1:2) = 0
+  integer :: u(7,4,2,9)
+
+  call foo(u,4)
+  call jackal(-1,-8)
+  call jackal(-1,8)
 
   if (any(lbound(i(-1:1,-1:1)) /= 1)) call abort
+  if (lbound(i(-1:1,-1:1), 1) /= 1) call abort
+  if (lbound(i(-1:1,-1:1), 2) /= 1) call abort
+
   if (any(ubound(i(-1:1,-1:1)) /= 3)) call abort
+  if (ubound(i(-1:1,-1:1), 1) /= 3) call abort
+  if (ubound(i(-1:1,-1:1), 2) /= 3) call abort
+
   if (any(lbound(i(:,:)) /= 1)) call abort
+  if (lbound(i(:,:), 1) /= 1) call abort
+  if (lbound(i(:,:), 2) /= 1) call abort
+
   if (any(ubound(i(:,:)) /= 3)) call abort
+  if (ubound(i(:,:), 1) /= 3) call abort
+  if (ubound(i(:,:), 2) /= 3) call abort
+
   if (any(lbound(i(0:,-1:)) /= 1)) call abort
+  if (lbound(i(0:,-1:), 1) /= 1) call abort
+  if (lbound(i(0:,-1:), 2) /= 1) call abort
+
   if (any(ubound(i(0:,-1:)) /= [2,3])) call abort
+  if (ubound(i(0:,-1:), 1) /= 2) call abort
+  if (ubound(i(0:,-1:), 2) /= 3) call abort
+
   if (any(lbound(i(:0,:0)) /= 1)) call abort
+  if (lbound(i(:0,:0), 1) /= 1) call abort
+  if (lbound(i(:0,:0), 2) /= 1) call abort
+
   if (any(ubound(i(:0,:0)) /= 2)) call abort
+  if (ubound(i(:0,:0), 1) /= 2) call abort
+  if (ubound(i(:0,:0), 2) /= 2) call abort
 
   if (any(lbound(transpose(i)) /= 1)) call abort
+  if (lbound(transpose(i), 1) /= 1) call abort
+  if (lbound(transpose(i), 2) /= 1) call abort
+
   if (any(ubound(transpose(i)) /= 3)) call abort
+  if (ubound(transpose(i), 1) /= 3) call abort
+  if (ubound(transpose(i), 2) /= 3) call abort
+
   if (any(lbound(reshape(i,[2,2])) /= 1)) call abort
+  if (lbound(reshape(i,[2,2]), 1) /= 1) call abort
+  if (lbound(reshape(i,[2,2]), 2) /= 1) call abort
+
   if (any(ubound(reshape(i,[2,2])) /= 2)) call abort
+  if (ubound(reshape(i,[2,2]), 1) /= 2) call abort
+  if (ubound(reshape(i,[2,2]), 2) /= 2) call abort
+
   if (any(lbound(cshift(i,-1)) /= 1)) call abort
+  if (lbound(cshift(i,-1), 1) /= 1) call abort
+  if (lbound(cshift(i,-1), 2) /= 1) call abort
+
   if (any(ubound(cshift(i,-1)) /= 3)) call abort
+  if (ubound(cshift(i,-1), 1) /= 3) call abort
+  if (ubound(cshift(i,-1), 2) /= 3) call abort
+
   if (any(lbound(eoshift(i,-1)) /= 1)) call abort
+  if (lbound(eoshift(i,-1), 1) /= 1) call abort
+  if (lbound(eoshift(i,-1), 2) /= 1) call abort
+
   if (any(ubound(eoshift(i,-1)) /= 3)) call abort
+  if (ubound(eoshift(i,-1), 1) /= 3) call abort
+  if (ubound(eoshift(i,-1), 2) /= 3) call abort
+
   if (any(lbound(spread(i,1,2)) /= 1)) call abort
+  if (lbound(spread(i,1,2), 1) /= 1) call abort
+  if (lbound(spread(i,1,2), 2) /= 1) call abort
+
   if (any(ubound(spread(i,1,2)) /= [2,3,3])) call abort
+  if (ubound(spread(i,1,2), 1) /= 2) call abort
+  if (ubound(spread(i,1,2), 2) /= 3) call abort
+  if (ubound(spread(i,1,2), 3) /= 3) call abort
+
   if (any(lbound(maxloc(i)) /= 1)) call abort
+  if (lbound(maxloc(i), 1) /= 1) call abort
+
   if (any(ubound(maxloc(i)) /= 2)) call abort
+  if (ubound(maxloc(i), 1) /= 2) call abort
+
   if (any(lbound(minloc(i)) /= 1)) call abort
+  if (lbound(minloc(i), 1) /= 1) call abort
+
   if (any(ubound(minloc(i)) /= 2)) call abort
+  if (ubound(minloc(i), 1) /= 2) call abort
+
   if (any(lbound(maxval(i,2)) /= 1)) call abort
+  if (lbound(maxval(i,2), 1) /= 1) call abort
+
   if (any(ubound(maxval(i,2)) /= 3)) call abort
+  if (ubound(maxval(i,2), 1) /= 3) call abort
+
   if (any(lbound(minval(i,2)) /= 1)) call abort
+  if (lbound(minval(i,2), 1) /= 1) call abort
+
   if (any(ubound(minval(i,2)) /= 3)) call abort
+  if (ubound(minval(i,2), 1) /= 3) call abort
+
   if (any(lbound(any(i==1,2)) /= 1)) call abort
+  if (lbound(any(i==1,2), 1) /= 1) call abort
+
   if (any(ubound(any(i==1,2)) /= 3)) call abort
+  if (ubound(any(i==1,2), 1) /= 3) call abort
+
   if (any(lbound(count(i==1,2)) /= 1)) call abort
+  if (lbound(count(i==1,2), 1) /= 1) call abort
+
   if (any(ubound(count(i==1,2)) /= 3)) call abort
+  if (ubound(count(i==1,2), 1) /= 3) call abort
+
   if (any(lbound(merge(i,i,.true.)) /= 1)) call abort
+  if (lbound(merge(i,i,.true.), 1) /= 1) call abort
+  if (lbound(merge(i,i,.true.), 2) /= 1) call abort
+
   if (any(ubound(merge(i,i,.true.)) /= 3)) call abort
+  if (ubound(merge(i,i,.true.), 1) /= 3) call abort
+  if (ubound(merge(i,i,.true.), 2) /= 3) call abort
+
   if (any(lbound(lbound(i)) /= 1)) call abort
+  if (lbound(lbound(i), 1) /= 1) call abort
+
   if (any(ubound(lbound(i)) /= 2)) call abort
+  if (ubound(lbound(i), 1) /= 2) call abort
+
   if (any(lbound(ubound(i)) /= 1)) call abort
+  if (lbound(ubound(i), 1) /= 1) call abort
+
   if (any(ubound(ubound(i)) /= 2)) call abort
+  if (ubound(ubound(i), 1) /= 2) call abort
+
   if (any(lbound(shape(i)) /= 1)) call abort
+  if (lbound(shape(i), 1) /= 1) call abort
+
   if (any(ubound(shape(i)) /= 2)) call abort
+  if (ubound(shape(i), 1) /= 2) call abort
 
   if (any(lbound(product(i,2)) /= 1)) call abort
   if (any(ubound(product(i,2)) /= 3)) call abort
@@ -60,13 +160,59 @@
 
   call sub1(i,3)
   call sub1(reshape([7,9,4,6,7,9],[3,2]),3)
+  call sub2
 
 contains
 
   subroutine sub1(a,n)
     integer :: a(2:n+1,4:*), n
+
     if (any([lbound(a,1), lbound(a,2)] /= [2, 4])) call abort
     if (any(lbound(a) /= [2, 4])) call abort
   end subroutine sub1
 
+  subroutine sub2
+    integer :: x(3:2, 1:2)
+
+    if (size(x) /= 0) call abort
+    if (lbound (x, 1) /= 1 .or. lbound(x, 2) /= 1) call abort
+    if (any (lbound (x) /= [1, 1])) call abort
+    if (ubound (x, 1) /= 0 .or. ubound(x, 2) /= 2) call abort
+    if (any (ubound (x) /= [0, 2])) call abort
+  end subroutine sub2
+
+  subroutine sub3
+    integer :: x(4:5, 1:2)
+
+    if (size(x) /= 0) call abort
+    if (lbound (x, 1) /= 4 .or. lbound(x, 2) /= 1) call abort
+    if (any (lbound (x) /= [4, 1])) call abort
+    if (ubound (x, 1) /= 4 .or. ubound(x, 2) /= 2) call abort
+    if (any (ubound (x) /= [4, 2])) call abort
+  end subroutine sub3
+
+  subroutine foo (x,n)
+    integer :: x(7,n,2,*), n
+
+    !if (ubound(x,1) /= 7 .or. ubound(x,2) /= 4 .or. ubound(x,3) /= 2) call abort
+  end subroutine foo
+
+  subroutine jackal (b, c)
+    integer :: b, c
+    integer :: soda(b:c, 3:4)
+
+    if (b > c) then
+      if (size(soda) /= 0) call abort
+      if (lbound (soda, 1) /= 1 .or. ubound (soda, 1) /= 0) call abort
+    else
+      if (size(soda) /= 2*(c-b+1)) call abort
+      if (lbound (soda, 1) /= b .or. ubound (soda, 1) /= c) call abort
+    end if
+
+    if (lbound (soda, 2) /= 3 .or. ubound (soda, 2) /= 4) call abort
+    if (any (lbound (soda) /= [lbound(soda,1), lbound(soda,2)])) call abort
+    if (any (ubound (soda) /= [ubound(soda,1), ubound(soda,2)])) call abort
+
+  end subroutine jackal
+
 end