re PR fortran/38914 ([4.3 only] ICE with array inquiry functions above contains in parameter expression)

2008-02-21  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/38914
	* array.c (ref_dimen_size):  Rename to gfc_ref_dimen_size,
	make global.  Change function name in error messages.
	(ref_size):  Change ref_dimen_size to gfc_ref_dimen_size.
	(gfc_array_ref_shape):  Likewise.
	* gfortran.h:  Add prototype for gfc_ref_dimen_size.
	* simplify.c (simplify_bound_dim):  Add ref argument.
	If the reference isn't a full array, return one for
	the lower bound and the extent for the upper bound.
	(simplify_bound):  For array sections, take as from the
	argument.  Add reference to all to simplify_bound_dim.

2008-02-21  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/38914
	* bound_simplification_2.f90:  New test case.
	* bound_7.f90:  New test case.

From-SVN: r144362

7 files changed, 299 insertions, 26 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 147891a..57ad11b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2008-02-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/38914
+	* array.c (ref_dimen_size):  Rename to gfc_ref_dimen_size,
+	make global.  Change function name in error messages.
+	(ref_size):  Change ref_dimen_size to gfc_ref_dimen_size.
+	(gfc_array_ref_shape):  Likewise.
+	* gfortran.h:  Add prototype for gfc_ref_dimen_size.
+	* simplify.c (simplify_bound_dim):  Add ref argument.
+	If the reference isn't a full array, return one for
+	the lower bound and the extent for the upper bound.
+	(simplify_bound):  For array sections, take as from the
+	argument.  Add reference to all to simplify_bound_dim.
+
 2009-02-19  Daniel Franke  <franke.daniel@gmail.com>
 
 	* scanner.c (load_line): At end of line, skip '\r' without setting
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index fe83ec6..46c7425 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1876,14 +1876,14 @@ spec_size (gfc_array_spec *as, mpz_t *result)
 
 /* Get the number of elements in an array section.  */
 
-static gfc_try
-ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
+gfc_try
+gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
 {
   mpz_t upper, lower, stride;
   gfc_try t;
 
   if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
-    gfc_internal_error ("ref_dimen_size(): Bad dimension");
+    gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
 
   switch (ar->dimen_type[dimen])
     {
@@ -1957,7 +1957,7 @@ ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
       return t;
 
     default:
-      gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
+      gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
     }
 
   return t;
@@ -1974,7 +1974,7 @@ ref_size (gfc_array_ref *ar, mpz_t *result)
 
   for (d = 0; d < ar->dimen; d++)
     {
-      if (ref_dimen_size (ar, d, &size) == FAILURE)
+      if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
 	{
 	  mpz_clear (*result);
 	  return FAILURE;
@@ -2020,7 +2020,7 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
 		if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
 		  dimen--;
 
-	      return ref_dimen_size (&ref->u.ar, i - 1, result);
+	      return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
 	    }
 	}
 
@@ -2148,7 +2148,7 @@ gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
 	{
 	  if (ar->dimen_type[i] != DIMEN_ELEMENT)
 	    {
-	      if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
+	      if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
 		goto cleanup;
 	      d++;
 	    }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 19faa06..8795bee 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2517,6 +2517,9 @@ gfc_try spec_size (gfc_array_spec *, mpz_t *);
 gfc_try spec_dimen_size (gfc_array_spec *, int, mpz_t *);
 int gfc_is_compile_time_shape (gfc_array_spec *);
 
+gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
+
+
 /* interface.c -- FIXME: some of these should be in symbol.c */
 void gfc_free_interface (gfc_interface *);
 int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index c460f31..6893a88 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2178,7 +2178,7 @@ gfc_simplify_kind (gfc_expr *e)
 
 static gfc_expr *
 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
-		    gfc_array_spec *as)
+		    gfc_array_spec *as, gfc_ref *ref)
 {
   gfc_expr *l, *u, *result;
   int k;
@@ -2192,13 +2192,6 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
 	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;
-
   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
 		gfc_default_integer_kind); 
   if (k == -1)
@@ -2206,21 +2199,43 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
 
   result = gfc_constant_result (BT_INTEGER, k, &array->where);
 
-  if (mpz_cmp (l->value.integer, u->value.integer) > 0)
+
+  /* Then, we need to know the extent of the given dimension.  */
+  if (ref->u.ar.type == AR_FULL)
     {
-      /* Zero extent.  */
-      if (upper)
-	mpz_set_si (result->value.integer, 0);
+      l = as->lower[d-1];
+      u = as->upper[d-1];
+
+      if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
+	return NULL;
+
+      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
-	mpz_set_si (result->value.integer, 1);
+	{
+	  /* Nonzero extent.  */
+	  if (upper)
+	    mpz_set (result->value.integer, u->value.integer);
+	  else
+	    mpz_set (result->value.integer, l->value.integer);
+	}
     }
   else
     {
-      /* Nonzero extent.  */
       if (upper)
-	mpz_set (result->value.integer, u->value.integer);
+	{
+	  if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer)
+	      != SUCCESS)
+	    return NULL;
+	}
       else
-	mpz_set (result->value.integer, l->value.integer);
+	mpz_set_si (result->value.integer, (long int) 1);
     }
 
   return range_check (result, upper ? "UBOUND" : "LBOUND");
@@ -2258,9 +2273,12 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 
 	    /* Fall through.  */
 
-	    case AR_SECTION:
 	    case AR_UNKNOWN:
 	      return NULL;
+
+	    case AR_SECTION:
+	      as = ref->u.ar.as;
+	      goto done;
 	    }
 
 	  gcc_unreachable ();
@@ -2300,7 +2318,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
       /* Simplify the bounds for each dimension.  */
       for (d = 0; d < array->rank; d++)
 	{
-	  bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
 	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
 	    {
 	      int j;
@@ -2366,7 +2384,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 	  return &gfc_bad_expr;
 	}
 
-      return simplify_bound_dim (array, kind, d, upper, as);
+      return simplify_bound_dim (array, kind, d, upper, as, ref);
     }
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1d2db2e..9c63dbf 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2008-02-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/38914
+	* bound_simplification_2.f90:  New test case.
+	* bound_7.f90:  New test case.
+
 2009-02-21  Joseph Myers  <joseph@codesourcery.com>
 
 	* gcc.dg/cpp/include4.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/bound_7.f90 b/gcc/testsuite/gfortran.dg/bound_7.f90
new file mode 100644
index 0000000..e422845
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bound_7.f90
@@ -0,0 +1,223 @@
+! { dg-do run }
+! { dg-options "-std=gnu" }
+! PR fortran/29391
+! This file is here to check that LBOUND and UBOUND return correct values
+!
+! Contributed by Francois-Xavier Coudert (coudert@clipper.ens.fr)
+  implicit none
+  integer, allocatable :: i(:,:), j(:), u(:,:,:,:)
+
+  allocate (i(-1:1,-1:1))
+  i = 0
+  allocate (j(-1:2))
+  j = 0
+  allocate (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
+  if (any(lbound(sum(i,2)) /= 1)) call abort
+  if (any(ubound(sum(i,2)) /= 3)) call abort
+  if (any(lbound(matmul(i,i)) /= 1)) call abort
+  if (any(ubound(matmul(i,i)) /= 3)) call abort
+  if (any(lbound(pack(i,.true.)) /= 1)) call abort
+  if (any(ubound(pack(i,.true.)) /= 9)) call abort
+  if (any(lbound(unpack(j,[.true.],[2])) /= 1)) call abort
+  if (any(ubound(unpack(j,[.true.],[2])) /= 1)) call abort
+
+  call sub1(i,3)
+  call sub1(reshape([7,9,4,6,7,9],[3,2]),3)
+  call sub2
+
+contains
+
+  subroutine sub1(a,n)
+    integer :: n, a(2:n+1,4:*)
+
+    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
diff --git a/gcc/testsuite/gfortran.dg/bound_simplification_2.f90 b/gcc/testsuite/gfortran.dg/bound_simplification_2.f90
new file mode 100644
index 0000000..0547777
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bound_simplification_2.f90
@@ -0,0 +1,9 @@
+! { dg-do compile }
+! PR 38914 - this used to give an ICE due to missing
+! simplification.
+module foo
+  INTEGER, PARAMETER, DIMENSION(0:20,4) :: IP_ARRAY2_4_S = 0
+  INTEGER, PARAMETER, DIMENSION(2) ::  IP_ARRAY1_32_S = &
+  & (/  LBOUND(IP_ARRAY2_4_S(5:10,2:3))/)
+END module foo
+! { dg-final { cleanup-modules "foo" } }