bound simplification refactoring

gcc/fortran/
	* simplify.c (simplify_bound_dim): Don't check for emptyness
	in the case of cobound simplification.  Factor lower/upper
	bound differenciation before the actual simplification.
	(simplify_bound): Remove assumed shape specific simplification.
	Don't give up early for the lbound of an assumed shape.
gcc/testsuite/
	* gfortran.dg/bound_simplification_5.f90: New.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9c952a1..b91f503 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2015-05-10  Mikael Morin  <mikael@gcc.gnu.org>
+
+       * simplify.c (simplify_bound_dim): Don't check for emptyness
+       in the case of cobound simplification.  Factor lower/upper
+       bound differenciation before the actual simplification.
+       (simplify_bound): Remove assumed shape specific simplification.  
+       Don't give up early for the lbound of an assumed shape.
+
 2015-05-09  Mikael Morin  <mikael@gcc.gnu.org>
 
        PR fortran/65894

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 4ef9025..f8d55fd 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3340,29 +3340,43 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
   /* Then, we need to know the extent of the given dimension.  */
   if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
     {
+      gfc_expr *declared_bound;
+      int empty_bound;
+      bool constant_lbound, constant_ubound;
+
       l = as->lower[d-1];
       u = as->upper[d-1];
 
-      if (l->expr_type != EXPR_CONSTANT || u == NULL
-         || u->expr_type != EXPR_CONSTANT)
+      gcc_assert (l != NULL);
+
+      constant_lbound = l->expr_type == EXPR_CONSTANT;
+      constant_ubound = u && u->expr_type == EXPR_CONSTANT;
+
+      empty_bound = upper ? 0 : 1;
+      declared_bound = upper ? u : l;
+
+      if ((!upper && !constant_lbound)
+         || (upper && !constant_ubound))
        goto returnNull;
 
-      if (mpz_cmp (l->value.integer, u->value.integer) > 0)
+      if (!coarray)
        {
-         /* Zero extent.  */
-         if (upper)
-           mpz_set_si (result->value.integer, 0);
+         /* For {L,U}BOUND, the value depends on whether the array
+            is empty.  We can nevertheless simplify if the declared bound
+            has the same value as that of an empty array, in which case
+            the result isn't dependent on the array emptyness.  */
+         if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
+           mpz_set_si (result->value.integer, empty_bound);
+         else if (!constant_lbound || !constant_ubound)
+           /* Array emptyness can't be determined, we can't simplify.  */
+           goto returnNull;
+         else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
+           mpz_set_si (result->value.integer, empty_bound);
          else
-           mpz_set_si (result->value.integer, 1);
+           mpz_set (result->value.integer, declared_bound->value.integer);
        }
       else
-       {
-         /* Nonzero extent.  */
-         if (upper)
-           mpz_set (result->value.integer, u->value.integer);
-         else
-           mpz_set (result->value.integer, l->value.integer);
-       }
+       mpz_set (result->value.integer, declared_bound->value.integer);
     }
   else
     {
@@ -3442,43 +3456,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 
  done:
 
-  /* If the array shape is assumed shape or explicit, we can simplify lbound
-     to 1 if the given lower bound is one because this matches what lbound
-     should return for an empty array.  */
-
-  if (!upper && as && dim && dim->expr_type == EXPR_CONSTANT
-      && (as->type == AS_ASSUMED_SHAPE || as->type == AS_EXPLICIT) 
-      && ref->u.ar.type != AR_SECTION)
-    {
-      /* Watch out for allocatable or pointer dummy arrays, they can have
-        lower bounds that are not equal to one.  */
-      if (!(array->symtree && array->symtree->n.sym
-           && (array->symtree->n.sym->attr.allocatable
-               || array->symtree->n.sym->attr.pointer)))
-       {
-         unsigned long int ndim;
-         gfc_expr *lower, *res;
-
-         ndim = mpz_get_si (dim->value.integer) - 1;
-         lower = as->lower[ndim];
-         if (lower->expr_type == EXPR_CONSTANT
-             && mpz_cmp_si (lower->value.integer, 1) == 0)
-           {
-             res = gfc_copy_expr (lower);
-             if (kind)
-               {
-                 int nkind = mpz_get_si (kind->value.integer);
-                 res->ts.kind = nkind;
-               }
-             return res;
-           }
-       }
-    }
-
-  if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
-            || as->type == AS_ASSUMED_RANK))
+  if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
+            || (as->type == AS_ASSUMED_SHAPE && upper)))
     return NULL;
 
+  gcc_assert (!as
+             || (as->type != AS_DEFERRED
+                 && array->expr_type == EXPR_VARIABLE
+                 && !array->symtree->n.sym->attr.allocatable
+                 && !array->symtree->n.sym->attr.pointer));
+
   if (dim == NULL)
     {
       /* Multi-dimensional bounds.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 49b758e..63ee9cc 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2015-05-10  Mikael Morin  <mikael@gcc.gnu.org>
+
+       * gfortran.dg/bound_simplification_5.f90: New.
+
 2015-05-09  Jason Merrill  <jason@redhat.com>
 
        * lib/target-supports.exp (cxx_default): New global.

diff --git a/gcc/testsuite/gfortran.dg/bound_simplification_5.f90 b/gcc/testsuite/gfortran.dg/bound_simplification_5.f90
new file mode 100644 (file)
index 0000000..7c9f040
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bound_simplification_5.f90
@@ -0,0 +1,75 @@
+! { dg-do run }
+! { dg-additional-options "-fcoarray=single -fdump-tree-original" }
+!
+! Check that {L,U}{,CO}BOUND intrinsics are properly simplified.
+!
+  implicit none
+
+  type :: t
+    integer :: c
+  end type t
+
+  type(t) :: d(3:8) = t(7)
+  type(t) :: e[5:9,-1:*]
+  type(t) :: h(3), j(4), k(0)
+
+  !Test full arrays vs subarrays
+  if (lbound(d,      1) /= 3) call abort
+  if (lbound(d(3:5), 1) /= 1) call abort
+  if (lbound(d%c,    1) /= 1) call abort
+  if (ubound(d,      1) /= 8) call abort
+  if (ubound(d(3:5), 1) /= 3) call abort
+  if (ubound(d%c,    1) /= 6) call abort  
+
+  if (lcobound(e,   1) /=  5) call abort
+  if (lcobound(e%c, 1) /=  5) call abort
+  if (lcobound(e,   2) /= -1) call abort
+  if (lcobound(e%c, 2) /= -1) call abort
+  if (ucobound(e,   1) /=  9) call abort
+  if (ucobound(e%c, 1) /=  9) call abort
+  ! no simplification for ucobound(e{,%c}, dim=2)
+
+  if (any(lbound(d     ) /= [3])) call abort
+  if (any(lbound(d(3:5)) /= [1])) call abort
+  if (any(lbound(d%c   ) /= [1])) call abort
+  if (any(ubound(d     ) /= [8])) call abort
+  if (any(ubound(d(3:5)) /= [3])) call abort
+  if (any(ubound(d%c   ) /= [6])) call abort  
+
+  if (any(lcobound(e  ) /=  [5, -1])) call abort
+  if (any(lcobound(e%c) /=  [5, -1])) call abort
+  ! no simplification for ucobound(e{,%c})
+
+  call test_empty_arrays(h, j, k)
+
+contains
+  subroutine test_empty_arrays(a, c, d)
+    type(t) :: a(:), c(-3:0), d(3:1)
+    type(t) :: f(4:2), g(0:6)
+
+    if (lbound(a, 1) /=  1) call abort
+    if (lbound(c, 1) /= -3) call abort
+    if (lbound(d, 1) /=  1) call abort
+    if (lbound(f, 1) /=  1) call abort
+    if (lbound(g, 1) /=  0) call abort
+
+    if (ubound(c, 1) /=  0) call abort
+    if (ubound(d, 1) /=  0) call abort
+    if (ubound(f, 1) /=  0) call abort
+    if (ubound(g, 1) /=  6) call abort
+
+    if (any(lbound(a) /= [ 1])) call abort
+    if (any(lbound(c) /= [-3])) call abort
+    if (any(lbound(d) /= [ 1])) call abort
+    if (any(lbound(f) /= [ 1])) call abort
+    if (any(lbound(g) /= [ 0])) call abort
+
+    if (any(ubound(c) /= [0])) call abort
+    if (any(ubound(d) /= [0])) call abort
+    if (any(ubound(f) /= [0])) call abort
+    if (any(ubound(g) /= [6])) call abort
+
+  end subroutine
+end
+! { dg-final { scan-tree-dump-not "abort" "original" } }
+! { dg-final { cleanup-tree-dump "original" } }