dependency.c (gfc_dep_compare_expr): Strip parentheses and unary plus operators when...

	* dependency.c (gfc_dep_compare_expr): Strip parentheses and unary
	plus operators when comparing expressions.  Handle comparisons of
	the form "X+C vs. X", "X vs. X+C", "X-C vs. X" and "X vs. X-C" where
	C is an integer constant.  Handle comparisons of the form "P+Q vs.
	R+S" and "P-Q vs. R-S".  Handle comparisons of integral extensions
	specially (increasing functions) so extend(A) > extend(B), when A>B.
	(gfc_check_element_vs_element): Move test later, so that we ignore
	the fact that "A < B" or "A > B" when A or B contains a forall index.

	* gfortran.dg/dependency_14.f90: New test case.
	* gfortran.dg/dependency_15.f90: Likewise.
	* gfortran.dg/dependency_16.f90: Likewise.

From-SVN: r112605

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a312507d01fa28e578dcb684c6dd04589c7b2751..c6bed7875ffa5546de11df53e0fdff7a2a4fe3fe 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2006-04-01  Roger Sayle  <roger@eyesopen.com>
+
+       * dependency.c (gfc_dep_compare_expr): Strip parentheses and unary
+       plus operators when comparing expressions.  Handle comparisons of
+       the form "X+C vs. X", "X vs. X+C", "X-C vs. X" and "X vs. X-C" where
+       C is an integer constant.  Handle comparisons of the form "P+Q vs.
+       R+S" and "P-Q vs. R-S".  Handle comparisons of integral extensions
+       specially (increasing functions) so extend(A) > extend(B), when A>B.
+       (gfc_check_element_vs_element): Move test later, so that we ignore
+       the fact that "A < B" or "A > B" when A or B contains a forall index.
+
 2006-03-31  Asher Langton  <langton2@llnl.gov>
 
        PR fortran/25358

diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index ca370b64bf60ff13c402291557cbfe1c0d86b7ff..c3762bdc4d8b8de0094d4f6a4b403fc82ec5fa3a 100644 (file)
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -72,8 +72,112 @@ gfc_expr_is_one (gfc_expr * expr, int def)
 int
 gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
 {
+  gfc_actual_arglist *args1;
+  gfc_actual_arglist *args2;
   int i;
 
+  if (e1->expr_type == EXPR_OP
+      && (e1->value.op.operator == INTRINSIC_UPLUS
+          || e1->value.op.operator == INTRINSIC_PARENTHESES))
+    return gfc_dep_compare_expr (e1->value.op.op1, e2);
+  if (e2->expr_type == EXPR_OP
+      && (e2->value.op.operator == INTRINSIC_UPLUS
+          || e2->value.op.operator == INTRINSIC_PARENTHESES))
+    return gfc_dep_compare_expr (e1, e2->value.op.op1);
+
+  if (e1->expr_type == EXPR_OP
+      && e1->value.op.operator == INTRINSIC_PLUS)
+    {
+      /* Compare X+C vs. X.  */
+      if (e1->value.op.op2->expr_type == EXPR_CONSTANT
+         && e1->value.op.op2->ts.type == BT_INTEGER
+         && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
+       return mpz_sgn (e1->value.op.op2->value.integer);
+
+      /* Compare P+Q vs. R+S.  */
+      if (e2->expr_type == EXPR_OP
+         && e2->value.op.operator == INTRINSIC_PLUS)
+       {
+         int l, r;
+
+         l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+         r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+         if (l == 0 && r == 0)
+           return 0;
+         if (l == 0 && r != -2)
+           return r;
+         if (l != -2 && r == 0)
+           return l;
+         if (l == 1 && r == 1)
+           return 1;
+         if (l == -1 && r == -1)
+           return -1;
+
+         l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
+         r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
+         if (l == 0 && r == 0)
+           return 0;
+         if (l == 0 && r != -2)
+           return r;
+         if (l != -2 && r == 0)
+           return l;
+         if (l == 1 && r == 1)
+           return 1;
+         if (l == -1 && r == -1)
+           return -1;
+       }
+    }
+
+  /* Compare X vs. X+C.  */
+  if (e2->expr_type == EXPR_OP
+      && e2->value.op.operator == INTRINSIC_PLUS)
+    {
+      if (e2->value.op.op2->expr_type == EXPR_CONSTANT
+         && e2->value.op.op2->ts.type == BT_INTEGER
+         && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
+       return -mpz_sgn (e2->value.op.op2->value.integer);
+    }
+
+  /* Compare X-C vs. X.  */
+  if (e1->expr_type == EXPR_OP
+      && e1->value.op.operator == INTRINSIC_MINUS)
+    {
+      if (e1->value.op.op2->expr_type == EXPR_CONSTANT
+         && e1->value.op.op2->ts.type == BT_INTEGER
+         && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
+       return -mpz_sgn (e1->value.op.op2->value.integer);
+
+      /* Compare P-Q vs. R-S.  */
+      if (e2->expr_type == EXPR_OP
+         && e2->value.op.operator == INTRINSIC_MINUS)
+       {
+         int l, r;
+
+         l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+         r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+         if (l == 0 && r == 0)
+           return 0;
+         if (l != -2 && r == 0)
+           return l;
+         if (l == 0 && r != -2)
+           return -r;
+         if (l == 1 && r == -1)
+           return 1;
+         if (l == -1 && r == 1)
+           return -1;
+       }
+    }
+
+  /* Compare X vs. X-C.  */
+  if (e2->expr_type == EXPR_OP
+      && e2->value.op.operator == INTRINSIC_MINUS)
+    {
+      if (e2->value.op.op2->expr_type == EXPR_CONSTANT
+         && e2->value.op.op2->ts.type == BT_INTEGER
+         && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
+       return mpz_sgn (e2->value.op.op2->value.integer);
+    }
+
   if (e1->expr_type != e2->expr_type)
     return -2;
 
@@ -119,12 +223,29 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
          || e1->value.function.isym != e2->value.function.isym)
        return -2;
 
+      args1 = e1->value.function.actual;
+      args2 = e2->value.function.actual;
+
       /* We should list the "constant" intrinsic functions.  Those
         without side-effects that provide equal results given equal
         argument lists.  */
       switch (e1->value.function.isym->generic_id)
        {
        case GFC_ISYM_CONVERSION:
+         /* Handle integer extensions specially, as __convert_i4_i8
+            is not only "constant" but also "unary" and "increasing".  */
+         if (args1 && !args1->next
+             && args2 && !args2->next
+             && e1->ts.type == BT_INTEGER
+             && args1->expr->ts.type == BT_INTEGER
+             && e1->ts.kind > args1->expr->ts.kind
+             && e2->ts.type == e1->ts.type
+             && e2->ts.kind == e1->ts.kind
+             && args2->expr->ts.type == args1->expr->ts.type
+             && args2->expr->ts.kind == args2->expr->ts.kind)
+           return gfc_dep_compare_expr (args1->expr, args2->expr);
+         break;
+
        case GFC_ISYM_REAL:
        case GFC_ISYM_LOGICAL:
        case GFC_ISYM_DBLE:
@@ -135,18 +256,14 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
        }
 
       /* Compare the argument lists for equality.  */
-      {
-       gfc_actual_arglist *args1 = e1->value.function.actual;
-       gfc_actual_arglist *args2 = e2->value.function.actual;
-       while (args1 && args2)
-         {
-           if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
-             return -2;
-           args1 = args1->next;
-           args2 = args2->next;
-         }
-       return (args1 || args2) ? -2 : 0;
-      }
+      while (args1 && args2)
+       {
+         if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
+           return -2;
+         args1 = args1->next;
+         args2 = args2->next;
+       }
+      return (args1 || args2) ? -2 : 0;
       
     default:
       return -2;
@@ -904,8 +1021,6 @@ gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
   i = gfc_dep_compare_expr (r_start, l_start);
   if (i == 0)
     return GFC_DEP_EQUAL;
-  if (i != -2)
-    return GFC_DEP_NODEP;
 
   /* Treat two scalar variables as potentially equal.  This allows
      us to prove that a(i,:) and a(j,:) have no dependency.  See
@@ -920,6 +1035,8 @@ gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
       || contains_forall_index_p (l_start))
     return GFC_DEP_OVERLAP;
 
+  if (i != -2)
+    return GFC_DEP_NODEP;
   return GFC_DEP_EQUAL;
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 80d1d7f6d84d3c6e4b9b254a311aec3ce950e0d0..6901373486866b79331675df2edcf3f1fe040df6 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2006-04-01  Roger Sayle  <roger@eyesopen.com>
+
+       * gfortran.dg/dependency_14.f90: New test case.
+       * gfortran.dg/dependency_15.f90: Likewise.
+       * gfortran.dg/dependency_16.f90: Likewise.
+
 2006-03-31  Asher Langton  <langton2@llnl.gov>
 
        PR fortran/25358

diff --git a/gcc/testsuite/gfortran.dg/dependency_14.f90 b/gcc/testsuite/gfortran.dg/dependency_14.f90
new file mode 100644 (file)
index 0000000..71e962c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependency_14.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-O2 -fdump-tree-original" }
+subroutine foo(a,i)
+  integer, dimension (4,4) :: a
+  integer :: i
+
+  where (a(i,1:3) .ne. 0)
+    a(i+1,2:4) = 1
+  endwhere
+end subroutine
+! { dg-final { scan-tree-dump-times "malloc" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

diff --git a/gcc/testsuite/gfortran.dg/dependency_15.f90 b/gcc/testsuite/gfortran.dg/dependency_15.f90
new file mode 100644 (file)
index 0000000..36eb3a4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependency_15.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-O2 -fdump-tree-original" }
+subroutine foo(a,i)
+  integer, dimension (4,4) :: a
+  integer :: i
+
+  where (a(i,1:3) .ne. 0)
+    a(i-1,2:4) = 1
+  endwhere
+end subroutine
+! { dg-final { scan-tree-dump-times "malloc" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

diff --git a/gcc/testsuite/gfortran.dg/dependency_16.f90 b/gcc/testsuite/gfortran.dg/dependency_16.f90
new file mode 100644 (file)
index 0000000..b669771
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependency_16.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-O2 -fdump-tree-original" }
+subroutine foo(a,i)
+  integer, dimension (4,4) :: a
+  integer :: i
+
+  where (a(i+1,1:3) .ne. 0)
+    a(i+2,2:4) = 1
+  endwhere
+end subroutine
+! { dg-final { scan-tree-dump-times "malloc" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }