OSDN Git Service

(root) / pf3gnuchains / gcc-fork.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
gcc/fortran/
[pf3gnuchains/gcc-fork.git] / gcc / fortran / dependency.c
diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index df6609b..cb5d10c 100644 (file)
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -1,12 +1,13 @@
 /* Dependency analysis
 /* Dependency analysis
-   Copyright (C) 2000, 2001, 2002, 2005 Free Software Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
 
 This file is part of GCC.
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free
    Contributed by Paul Brook <paul@nowt.org>
 
 This file is part of GCC.
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
@@ -15,19 +16,20 @@ FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 for more details.
 
 You should have received a copy of the GNU General Public License
 for more details.
 
 You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING.  If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA.  */
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
 
 /* dependency.c -- Expression dependency analysis code.  */
 /* There's probably quite a bit of duplication in this file.  We currently
    have different dependency checking functions for different types
    if dependencies.  Ideally these would probably be merged.  */
    
 
 /* dependency.c -- Expression dependency analysis code.  */
 /* There's probably quite a bit of duplication in this file.  We currently
    have different dependency checking functions for different types
    if dependencies.  Ideally these would probably be merged.  */
    
-
 #include "config.h"
 #include "config.h"
+#include "system.h"
 #include "gfortran.h"
 #include "dependency.h"
 #include "gfortran.h"
 #include "dependency.h"
+#include "constructor.h"
+#include "arith.h"
 
 /* static declarations */
 /* Enums  */
 
 /* static declarations */
 /* Enums  */
@@ -38,7 +40,8 @@ typedef enum
 {
   GFC_DEP_ERROR,
   GFC_DEP_EQUAL,       /* Identical Ranges.  */
 {
   GFC_DEP_ERROR,
   GFC_DEP_EQUAL,       /* Identical Ranges.  */
-  GFC_DEP_FORWARD,     /* eg. a(1:3), a(2:4).  */
+  GFC_DEP_FORWARD,     /* e.g., a(1:3) = a(2:4).  */
+  GFC_DEP_BACKWARD,    /* e.g. a(2:4) = a(1:3).  */
   GFC_DEP_OVERLAP,     /* May overlap in some other way.  */
   GFC_DEP_NODEP                /* Distinct ranges.  */
 }
   GFC_DEP_OVERLAP,     /* May overlap in some other way.  */
   GFC_DEP_NODEP                /* Distinct ranges.  */
 }
@@ -47,12 +50,16 @@ gfc_dependency;
 /* Macros */
 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
 
 /* Macros */
 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
 
+/* Forward declarations */
+
+static gfc_dependency check_section_vs_section (gfc_array_ref *,
+                                               gfc_array_ref *, int);
 
 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
    def if the value could not be determined.  */
 
 int
 
 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
    def if the value could not be determined.  */
 
 int
-gfc_expr_is_one (gfc_expr * expr, int def)
+gfc_expr_is_one (gfc_expr *expr, int def)
 {
   gcc_assert (expr != NULL);
 
 {
   gcc_assert (expr != NULL);
 
@@ -65,14 +72,333 @@ gfc_expr_is_one (gfc_expr * expr, int def)
   return mpz_cmp_si (expr->value.integer, 1) == 0;
 }
 
   return mpz_cmp_si (expr->value.integer, 1) == 0;
 }
 
+/* Check if two array references are known to be identical.  Calls
+   gfc_dep_compare_expr if necessary for comparing array indices.  */
+
+static bool
+identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
+{
+  int i;
+
+  if (a1->type == AR_FULL && a2->type == AR_FULL)
+    return true;
+
+  if (a1->type == AR_SECTION && a2->type == AR_SECTION)
+    {
+      gcc_assert (a1->dimen == a2->dimen);
+
+      for ( i = 0; i < a1->dimen; i++)
+       {
+         /* TODO: Currently, we punt on an integer array as an index.  */
+         if (a1->dimen_type[i] != DIMEN_RANGE
+             || a2->dimen_type[i] != DIMEN_RANGE)
+           return false;
+
+         if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
+           return false;
+       }
+      return true;
+    }
+
+  if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
+    {
+      gcc_assert (a1->dimen == a2->dimen);
+      for (i = 0; i < a1->dimen; i++)
+       {
+         if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
+           return false;
+       }
+      return true;
+    }
+  return false;
+}
+
+
+
+/* Return true for identical variables, checking for references if
+   necessary.  Calls identical_array_ref for checking array sections.  */
+
+bool
+gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
+{
+  gfc_ref *r1, *r2;
+
+  if (e1->symtree->n.sym != e2->symtree->n.sym)
+    return false;
+
+  /* Volatile variables should never compare equal to themselves.  */
+
+  if (e1->symtree->n.sym->attr.volatile_)
+    return false;
+
+  r1 = e1->ref;
+  r2 = e2->ref;
+
+  while (r1 != NULL || r2 != NULL)
+    {
+
+      /* Assume the variables are not equal if one has a reference and the
+        other doesn't.
+        TODO: Handle full references like comparing a(:) to a.
+      */
+
+      if (r1 == NULL || r2 == NULL)
+       return false;
+
+      if (r1->type != r2->type)
+       return false;
+
+      switch (r1->type)
+       {
+
+       case REF_ARRAY:
+         if (!identical_array_ref (&r1->u.ar,  &r2->u.ar))
+           return false;
+
+         break;
+
+       case REF_COMPONENT:
+         if (r1->u.c.component != r2->u.c.component)
+           return false;
+         break;
+
+       case REF_SUBSTRING:
+         if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0
+             || gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
+           return false;
+         break;
+
+       default:
+         gfc_internal_error ("gfc_are_identical_variables: Bad type");
+       }
+      r1 = r1->next;
+      r2 = r2->next;
+    }
+  return true;
+}
+
+/* Compare two functions for equality.  Returns 0 if e1==e2, -2 otherwise.  If
+   impure_ok is false, only return 0 for pure functions.  */
+
+int
+gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
+{
+
+  gfc_actual_arglist *args1;
+  gfc_actual_arglist *args2;
+  
+  if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
+    return -2;
+
+  if ((e1->value.function.esym && e2->value.function.esym
+       && e1->value.function.esym == e2->value.function.esym
+       && (e1->value.function.esym->result->attr.pure || impure_ok))
+       || (e1->value.function.isym && e2->value.function.isym
+          && e1->value.function.isym == e2->value.function.isym
+          && (e1->value.function.isym->pure || impure_ok)))
+    {
+      args1 = e1->value.function.actual;
+      args2 = e2->value.function.actual;
+
+      /* Compare the argument lists for equality.  */
+      while (args1 && args2)
+       {
+         /*  Bitwise xor, since C has no non-bitwise xor operator.  */
+         if ((args1->expr == NULL) ^ (args2->expr == NULL))
+           return -2;
+         
+         if (args1->expr != NULL && args2->expr != NULL
+             && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
+           return -2;
+         
+         args1 = args1->next;
+         args2 = args2->next;
+       }
+      return (args1 || args2) ? -2 : 0;
+    }
+      else
+       return -2;      
+}
 
 /* Compare two values.  Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
    and -2 if the relationship could not be determined.  */
 
 int
 
 /* Compare two values.  Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
    and -2 if the relationship could not be determined.  */
 
 int
-gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
+gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
 {
 {
+  gfc_actual_arglist *args1;
+  gfc_actual_arglist *args2;
   int i;
   int i;
+  gfc_expr *n1, *n2;
+
+  n1 = NULL;
+  n2 = NULL;
+
+  /* Remove any integer conversion functions to larger types.  */
+  if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym
+      && e1->value.function.isym->id == GFC_ISYM_CONVERSION
+      && e1->ts.type == BT_INTEGER)
+    {
+      args1 = e1->value.function.actual;
+      if (args1->expr->ts.type == BT_INTEGER
+         && e1->ts.kind > args1->expr->ts.kind)
+       n1 = args1->expr;
+    }
+
+  if (e2->expr_type == EXPR_FUNCTION && e2->value.function.isym
+      && e2->value.function.isym->id == GFC_ISYM_CONVERSION
+      && e2->ts.type == BT_INTEGER)
+    {
+      args2 = e2->value.function.actual;
+      if (args2->expr->ts.type == BT_INTEGER
+         && e2->ts.kind > args2->expr->ts.kind)
+       n2 = args2->expr;
+    }
+
+  if (n1 != NULL)
+    {
+      if (n2 != NULL)
+       return gfc_dep_compare_expr (n1, n2);
+      else
+       return gfc_dep_compare_expr (n1, e2);
+    }
+  else
+    {
+      if (n2 != NULL)
+       return gfc_dep_compare_expr (e1, n2);
+    }
+  
+  if (e1->expr_type == EXPR_OP
+      && (e1->value.op.op == INTRINSIC_UPLUS
+         || e1->value.op.op == INTRINSIC_PARENTHESES))
+    return gfc_dep_compare_expr (e1->value.op.op1, e2);
+  if (e2->expr_type == EXPR_OP
+      && (e2->value.op.op == INTRINSIC_UPLUS
+         || e2->value.op.op == INTRINSIC_PARENTHESES))
+    return gfc_dep_compare_expr (e1, e2->value.op.op1);
+
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == 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.op == 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.op == 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.op == 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.op == 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 A // B vs. C // D.  */
+
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
+      && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
+    {
+      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 == -2)
+       return -2;
+
+      if (l == 0)
+       {
+         /* Watch out for 'A ' // x vs. 'A' // x.  */
+         gfc_expr *e1_left = e1->value.op.op1;
+         gfc_expr *e2_left = e2->value.op.op1;
+
+         if (e1_left->expr_type == EXPR_CONSTANT
+             && e2_left->expr_type == EXPR_CONSTANT
+             && e1_left->value.character.length
+               != e2_left->value.character.length)
+           return -2;
+         else
+           return r;
+       }
+      else
+       {
+         if (l != 0)
+           return l;
+         else
+           return r;
+       }
+    }
+
+  /* Compare X vs. X-C.  */
+  if (e2->expr_type == EXPR_OP && e2->value.op.op == 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;
 
   if (e1->expr_type != e2->expr_type)
     return -2;
@@ -80,6 +406,10 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
   switch (e1->expr_type)
     {
     case EXPR_CONSTANT:
   switch (e1->expr_type)
     {
     case EXPR_CONSTANT:
+      /* Compare strings for equality.  */
+      if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
+       return gfc_compare_string (e1, e2);
+
       if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
        return -2;
 
       if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
        return -2;
 
@@ -91,12 +421,30 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
       return 1;
 
     case EXPR_VARIABLE:
       return 1;
 
     case EXPR_VARIABLE:
-      if (e1->ref || e2->ref)
+      if (gfc_are_identical_variables (e1, e2))
+       return 0;
+      else
+       return -2;
+
+    case EXPR_OP:
+      /* Intrinsic operators are the same if their operands are the same.  */
+      if (e1->value.op.op != e2->value.op.op)
        return -2;
        return -2;
-      if (e1->symtree->n.sym == e2->symtree->n.sym)
+      if (e1->value.op.op2 == 0)
+       {
+         i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+         return i == 0 ? 0 : -2;
+       }
+      if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
+         && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
        return 0;
        return 0;
+      /* TODO Handle commutative binary operators here?  */
       return -2;
 
       return -2;
 
+    case EXPR_FUNCTION:
+      return gfc_dep_compare_functions (e1, e2, false);
+      break;
+
     default:
       return -2;
     }
     default:
       return -2;
     }
@@ -107,7 +455,7 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
    if the results are indeterminate.  N is the dimension to compare.  */
 
 int
    if the results are indeterminate.  N is the dimension to compare.  */
 
 int
-gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
+gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
 {
   gfc_expr *e1;
   gfc_expr *e2;
 {
   gfc_expr *e1;
   gfc_expr *e2;
@@ -150,28 +498,50 @@ gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
   /* Check the range start.  */
   e1 = ar1->start[n];
   e2 = ar2->start[n];
   /* Check the range start.  */
   e1 = ar1->start[n];
   e2 = ar2->start[n];
+  if (e1 || e2)
+    {
+      /* Use the bound of the array if no bound is specified.  */
+      if (ar1->as && !e1)
+       e1 = ar1->as->lower[n];
 
 
-  if (!(e1 || e2))
-    return 1;
+      if (ar2->as && !e2)
+       e2 = ar2->as->lower[n];
 
 
-  /* Use the bound of the array if no bound is specified.  */
-  if (ar1->as && !e1)
-    e1 = ar1->as->lower[n];
+      /* Check we have values for both.  */
+      if (!(e1 && e2))
+       return def;
 
 
-  if (ar2->as && !e2)
-    e2 = ar2->as->lower[n];
+      i = gfc_dep_compare_expr (e1, e2);
+      if (i == -2)
+       return def;
+      else if (i != 0)
+       return 0;
+    }
 
 
-  /* Check we have values for both.  */
-  if (!(e1 && e2))
-    return def;
+  /* Check the range end.  */
+  e1 = ar1->end[n];
+  e2 = ar2->end[n];
+  if (e1 || e2)
+    {
+      /* Use the bound of the array if no bound is specified.  */
+      if (ar1->as && !e1)
+       e1 = ar1->as->upper[n];
 
 
-  i = gfc_dep_compare_expr (e1, e2);
+      if (ar2->as && !e2)
+       e2 = ar2->as->upper[n];
 
 
-  if (i == -2)
-    return def;
-  else if (i == 0)
-    return 1;
-  return 0;
+      /* Check we have values for both.  */
+      if (!(e1 && e2))
+       return def;
+
+      i = gfc_dep_compare_expr (e1, e2);
+      if (i == -2)
+       return def;
+      else if (i != 0)
+       return 0;
+    }
+
+  return 1;
 }
 
 
 }
 
 
@@ -185,12 +555,12 @@ gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
    whose data can be reused, otherwise return NULL.  */
 
 gfc_expr *
    whose data can be reused, otherwise return NULL.  */
 
 gfc_expr *
-gfc_get_noncopying_intrinsic_argument (gfc_expr * expr)
+gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
 {
   if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
     return NULL;
 
 {
   if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
     return NULL;
 
-  switch (expr->value.function.isym->generic_id)
+  switch (expr->value.function.isym->id)
     {
     case GFC_ISYM_TRANSPOSE:
       return expr->value.function.actual->expr;
     {
     case GFC_ISYM_TRANSPOSE:
       return expr->value.function.actual->expr;
@@ -240,6 +610,28 @@ gfc_ref_needs_temporary_p (gfc_ref *ref)
 }
 
 
 }
 
 
+static int
+gfc_is_data_pointer (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
+    return 0;
+
+  /* No subreference if it is a function  */
+  gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
+
+  if (e->symtree->n.sym->attr.pointer)
+    return 1;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+      return 1;
+
+  return 0;
+}
+
+
 /* Return true if array variable VAR could be passed to the same function
    as argument EXPR without interfering with EXPR.  INTENT is the intent
    of VAR.
 /* Return true if array variable VAR could be passed to the same function
    as argument EXPR without interfering with EXPR.  INTENT is the intent
    of VAR.
@@ -249,26 +641,90 @@ gfc_ref_needs_temporary_p (gfc_ref *ref)
    temporary.  */
 
 static int
    temporary.  */
 
 static int
-gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
-                                  gfc_expr * expr)
+gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
+                                  gfc_expr *expr, gfc_dep_check elemental)
 {
 {
+  gfc_expr *arg;
+
   gcc_assert (var->expr_type == EXPR_VARIABLE);
   gcc_assert (var->rank > 0);
 
   switch (expr->expr_type)
     {
     case EXPR_VARIABLE:
   gcc_assert (var->expr_type == EXPR_VARIABLE);
   gcc_assert (var->rank > 0);
 
   switch (expr->expr_type)
     {
     case EXPR_VARIABLE:
-      return (gfc_ref_needs_temporary_p (expr->ref)
-             || gfc_check_dependency (var, expr, 1));
+      /* In case of elemental subroutines, there is no dependency 
+         between two same-range array references.  */
+      if (gfc_ref_needs_temporary_p (expr->ref)
+         || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
+       {
+         if (elemental == ELEM_DONT_CHECK_VARIABLE)
+           {
+             /* Too many false positive with pointers.  */
+             if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
+               {
+                 /* Elemental procedures forbid unspecified intents, 
+                    and we don't check dependencies for INTENT_IN args.  */
+                 gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
+
+                 /* We are told not to check dependencies. 
+                    We do it, however, and issue a warning in case we find one.
+                    If a dependency is found in the case 
+                    elemental == ELEM_CHECK_VARIABLE, we will generate
+                    a temporary, so we don't need to bother the user.  */
+                 gfc_warning ("INTENT(%s) actual argument at %L might "
+                              "interfere with actual argument at %L.", 
+                              intent == INTENT_OUT ? "OUT" : "INOUT", 
+                              &var->where, &expr->where);
+               }
+             return 0;
+           }
+         else
+           return 1; 
+       }
+      return 0;
 
     case EXPR_ARRAY:
       return gfc_check_dependency (var, expr, 1);
 
     case EXPR_FUNCTION:
 
     case EXPR_ARRAY:
       return gfc_check_dependency (var, expr, 1);
 
     case EXPR_FUNCTION:
-      if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
+      if (intent != INTENT_IN)
+       {
+         arg = gfc_get_noncopying_intrinsic_argument (expr);
+         if (arg != NULL)
+           return gfc_check_argument_var_dependency (var, intent, arg,
+                                                     NOT_ELEMENTAL);
+       }
+
+      if (elemental != NOT_ELEMENTAL)
+       {
+         if ((expr->value.function.esym
+              && expr->value.function.esym->attr.elemental)
+             || (expr->value.function.isym
+                 && expr->value.function.isym->elemental))
+           return gfc_check_fncall_dependency (var, intent, NULL,
+                                               expr->value.function.actual,
+                                               ELEM_CHECK_VARIABLE);
+       }
+      return 0;
+
+    case EXPR_OP:
+      /* In case of non-elemental procedures, there is no need to catch
+        dependencies, as we will make a temporary anyway.  */
+      if (elemental)
        {
        {
-         expr = gfc_get_noncopying_intrinsic_argument (expr);
-         return gfc_check_argument_var_dependency (var, intent, expr);
+         /* If the actual arg EXPR is an expression, we need to catch 
+            a dependency between variables in EXPR and VAR, 
+            an intent((IN)OUT) variable.  */
+         if (expr->value.op.op1
+             && gfc_check_argument_var_dependency (var, intent, 
+                                                   expr->value.op.op1, 
+                                                   ELEM_CHECK_VARIABLE))
+           return 1;
+         else if (expr->value.op.op2
+                  && gfc_check_argument_var_dependency (var, intent, 
+                                                        expr->value.op.op2, 
+                                                        ELEM_CHECK_VARIABLE))
+           return 1;
        }
       return 0;
 
        }
       return 0;
 
@@ -282,20 +738,20 @@ gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
    array expression OTHER, not just variables.  */
 
 static int
    array expression OTHER, not just variables.  */
 
 static int
-gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
-                              gfc_expr * expr)
+gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
+                              gfc_expr *expr, gfc_dep_check elemental)
 {
   switch (other->expr_type)
     {
     case EXPR_VARIABLE:
 {
   switch (other->expr_type)
     {
     case EXPR_VARIABLE:
-      return gfc_check_argument_var_dependency (other, intent, expr);
+      return gfc_check_argument_var_dependency (other, intent, expr, elemental);
 
     case EXPR_FUNCTION:
 
     case EXPR_FUNCTION:
-      if (other->inline_noncopying_intrinsic)
-       {
-         other = gfc_get_noncopying_intrinsic_argument (other);
-         return gfc_check_argument_dependency (other, INTENT_IN, expr);
-       }
+      other = gfc_get_noncopying_intrinsic_argument (other);
+      if (other != NULL)
+       return gfc_check_argument_dependency (other, INTENT_IN, expr,
+                                             NOT_ELEMENTAL);
+
       return 0;
 
     default:
       return 0;
 
     default:
@@ -308,8 +764,9 @@ gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
    FNSYM is the function being called, or NULL if not known.  */
 
 int
    FNSYM is the function being called, or NULL if not known.  */
 
 int
-gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
-                            gfc_symbol * fnsym, gfc_actual_arglist * actual)
+gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
+                            gfc_symbol *fnsym, gfc_actual_arglist *actual,
+                            gfc_dep_check elemental)
 {
   gfc_formal_arglist *formal;
   gfc_expr *expr;
 {
   gfc_formal_arglist *formal;
   gfc_expr *expr;
@@ -323,13 +780,16 @@ gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
       if (!expr)
        continue;
 
       if (!expr)
        continue;
 
+      /* Skip other itself.  */
+      if (expr == other)
+       continue;
+
       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
-      if (formal
-         && intent == INTENT_IN
+      if (formal && intent == INTENT_IN
          && formal->sym->attr.intent == INTENT_IN)
        continue;
 
          && formal->sym->attr.intent == INTENT_IN)
        continue;
 
-      if (gfc_check_argument_dependency (other, intent, expr))
+      if (gfc_check_argument_dependency (other, intent, expr, elemental))
        return 1;
     }
 
        return 1;
     }
 
@@ -337,6 +797,149 @@ gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
 }
 
 
 }
 
 
+/* Return 1 if e1 and e2 are equivalenced arrays, either
+   directly or indirectly; i.e., equivalence (a,b) for a and b
+   or equivalence (a,c),(b,c).  This function uses the equiv_
+   lists, generated in trans-common(add_equivalences), that are
+   guaranteed to pick up indirect equivalences.  We explicitly
+   check for overlap using the offset and length of the equivalence.
+   This function is symmetric.
+   TODO: This function only checks whether the full top-level
+   symbols overlap.  An improved implementation could inspect
+   e1->ref and e2->ref to determine whether the actually accessed
+   portions of these variables/arrays potentially overlap.  */
+
+int
+gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+  gfc_equiv_list *l;
+  gfc_equiv_info *s, *fl1, *fl2;
+
+  gcc_assert (e1->expr_type == EXPR_VARIABLE
+             && e2->expr_type == EXPR_VARIABLE);
+
+  if (!e1->symtree->n.sym->attr.in_equivalence
+      || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
+    return 0;
+
+  if (e1->symtree->n.sym->ns
+       && e1->symtree->n.sym->ns != gfc_current_ns)
+    l = e1->symtree->n.sym->ns->equiv_lists;
+  else
+    l = gfc_current_ns->equiv_lists;
+
+  /* Go through the equiv_lists and return 1 if the variables
+     e1 and e2 are members of the same group and satisfy the
+     requirement on their relative offsets.  */
+  for (; l; l = l->next)
+    {
+      fl1 = NULL;
+      fl2 = NULL;
+      for (s = l->equiv; s; s = s->next)
+       {
+         if (s->sym == e1->symtree->n.sym)
+           {
+             fl1 = s;
+             if (fl2)
+               break;
+           }
+         if (s->sym == e2->symtree->n.sym)
+           {
+             fl2 = s;
+             if (fl1)
+               break;
+           }
+       }
+
+      if (s)
+       {
+         /* Can these lengths be zero?  */
+         if (fl1->length <= 0 || fl2->length <= 0)
+           return 1;
+         /* These can't overlap if [f11,fl1+length] is before 
+            [fl2,fl2+length], or [fl2,fl2+length] is before
+            [fl1,fl1+length], otherwise they do overlap.  */
+         if (fl1->offset + fl1->length > fl2->offset
+             && fl2->offset + fl2->length > fl1->offset)
+           return 1;
+       }
+    }
+  return 0;
+}
+
+
+/* Return true if there is no possibility of aliasing because of a type
+   mismatch between all the possible pointer references and the
+   potential target.  Note that this function is asymmetric in the
+   arguments and so must be called twice with the arguments exchanged.  */
+
+static bool
+check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
+{
+  gfc_component *cm1;
+  gfc_symbol *sym1;
+  gfc_symbol *sym2;
+  gfc_ref *ref1;
+  bool seen_component_ref;
+
+  if (expr1->expr_type != EXPR_VARIABLE
+       || expr1->expr_type != EXPR_VARIABLE)
+    return false;
+
+  sym1 = expr1->symtree->n.sym;
+  sym2 = expr2->symtree->n.sym;
+
+  /* Keep it simple for now.  */
+  if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
+    return false;
+
+  if (sym1->attr.pointer)
+    {
+      if (gfc_compare_types (&sym1->ts, &sym2->ts))
+       return false;
+    }
+
+  /* This is a conservative check on the components of the derived type
+     if no component references have been seen.  Since we will not dig
+     into the components of derived type components, we play it safe by
+     returning false.  First we check the reference chain and then, if
+     no component references have been seen, the components.  */
+  seen_component_ref = false;
+  if (sym1->ts.type == BT_DERIVED)
+    {
+      for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
+       {
+         if (ref1->type != REF_COMPONENT)
+           continue;
+
+         if (ref1->u.c.component->ts.type == BT_DERIVED)
+           return false;
+
+         if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
+               && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
+           return false;
+
+         seen_component_ref = true;
+       }
+    }
+
+  if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
+    {
+      for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
+       {
+         if (cm1->ts.type == BT_DERIVED)
+           return false;
+
+         if ((sym2->attr.pointer || cm1->attr.pointer)
+               && gfc_compare_types (&cm1->ts, &sym2->ts))
+           return false;
+       }
+    }
+
+  return true;
+}
+
+
 /* Return true if the statement body redefines the condition.  Returns
    true if expr2 depends on expr1.  expr1 should be a single term
    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 /* Return true if the statement body redefines the condition.  Returns
    true if expr2 depends on expr1.  expr1 should be a single term
    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
@@ -346,23 +949,14 @@ gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
    temporary.  */
 
 int
    temporary.  */
 
 int
-gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
+gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
 {
 {
-  gfc_ref *ref;
-  int n;
   gfc_actual_arglist *actual;
   gfc_actual_arglist *actual;
+  gfc_constructor *c;
+  int n;
 
   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 
 
   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 
-  /* TODO: -fassume-no-pointer-aliasing */
-  if (expr1->symtree->n.sym->attr.pointer)
-    return 1;
-  for (ref = expr1->ref; ref; ref = ref->next)
-    {
-      if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
-       return 1;
-    }
-
   switch (expr2->expr_type)
     {
     case EXPR_OP:
   switch (expr2->expr_type)
     {
     case EXPR_OP:
@@ -374,40 +968,69 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
       return 0;
 
     case EXPR_VARIABLE:
       return 0;
 
     case EXPR_VARIABLE:
-      if (expr2->symtree->n.sym->attr.pointer)
-       return 1;
-
-      for (ref = expr2->ref; ref; ref = ref->next)
+      /* The interesting cases are when the symbols don't match.  */
+      if (expr1->symtree->n.sym != expr2->symtree->n.sym)
        {
        {
-         if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+         gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
+         gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
+
+         /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
+         if (gfc_are_equivalenced_arrays (expr1, expr2))
            return 1;
            return 1;
-       }
 
 
-      if (expr1->symtree->n.sym != expr2->symtree->n.sym)
-       return 0;
+         /* Symbols can only alias if they have the same type.  */
+         if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
+             && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
+           {
+             if (ts1->type != ts2->type || ts1->kind != ts2->kind)
+               return 0;
+           }
+
+         /* If either variable is a pointer, assume the worst.  */
+         /* TODO: -fassume-no-pointer-aliasing */
+         if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
+           {
+             if (check_data_pointer_types (expr1, expr2)
+                   && check_data_pointer_types (expr2, expr1))
+               return 0;
+
+             return 1;
+           }
+         else
+           {
+             gfc_symbol *sym1 = expr1->symtree->n.sym;
+             gfc_symbol *sym2 = expr2->symtree->n.sym;
+             if (sym1->attr.target && sym2->attr.target
+                 && ((sym1->attr.dummy && !sym1->attr.contiguous
+                      && (!sym1->attr.dimension
+                          || sym2->as->type == AS_ASSUMED_SHAPE))
+                     || (sym2->attr.dummy && !sym2->attr.contiguous
+                         && (!sym2->attr.dimension
+                             || sym2->as->type == AS_ASSUMED_SHAPE))))
+               return 1;
+           }
+
+         /* Otherwise distinct symbols have no dependencies.  */
+         return 0;
+       }
 
       if (identical)
        return 1;
 
 
       if (identical)
        return 1;
 
-      /* Identical ranges return 0, overlapping ranges return 1.  */
-
-      /* Return zero if we refer to the same full arrays.  */
-      if (expr1->ref->type == REF_ARRAY
-         && expr2->ref->type == REF_ARRAY
-         && expr1->ref->u.ar.type == AR_FULL
-         && expr2->ref->u.ar.type == AR_FULL
-         && !expr1->ref->next
-         && !expr2->ref->next)
-       return 0;
+      /* Identical and disjoint ranges return 0,
+        overlapping ranges return 1.  */
+      if (expr1->ref && expr2->ref)
+       return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
 
       return 1;
 
     case EXPR_FUNCTION:
 
       return 1;
 
     case EXPR_FUNCTION:
-      if (expr2->inline_noncopying_intrinsic)
+      if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
        identical = 1;
        identical = 1;
+
       /* Remember possible differences between elemental and
       /* Remember possible differences between elemental and
-         transformational functions.  All functions inside a FORALL
-         will be pure.  */
+        transformational functions.  All functions inside a FORALL
+        will be pure.  */
       for (actual = expr2->value.function.actual;
           actual; actual = actual->next)
        {
       for (actual = expr2->value.function.actual;
           actual; actual = actual->next)
        {
@@ -420,11 +1043,24 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
       return 0;
 
     case EXPR_CONSTANT:
       return 0;
 
     case EXPR_CONSTANT:
+    case EXPR_NULL:
       return 0;
 
     case EXPR_ARRAY:
       return 0;
 
     case EXPR_ARRAY:
-      /* Probably ok in the majority of (constant) cases.  */
-      return 1;
+      /* Loop through the array constructor's elements.  */
+      for (c = gfc_constructor_first (expr2->value.constructor);
+          c; c = gfc_constructor_next (c))
+       {
+         /* If this is an iterator, assume the worst.  */
+         if (c->iterator)
+           return 1;
+         /* Avoid recursion in the common case.  */
+         if (c->expr->expr_type == EXPR_CONSTANT)
+           continue;
+         if (gfc_check_dependency (expr1, c->expr, 1))
+           return 1;
+       }
+      return 0;
 
     default:
       return 1;
 
     default:
       return 1;
@@ -432,271 +1068,670 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
 }
 
 
 }
 
 
-/* Calculates size of the array reference using lower bound, upper bound
-   and stride.  */
+/* Determines overlapping for two array sections.  */
 
 
-static void
-get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1)
+static gfc_dependency
+check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
 {
 {
-  /* nNoOfEle = (u1-l1)/s1  */
-
-  mpz_sub (ele, u1->value.integer, l1->value.integer);
+  gfc_expr *l_start;
+  gfc_expr *l_end;
+  gfc_expr *l_stride;
+  gfc_expr *l_lower;
+  gfc_expr *l_upper;
+  int l_dir;
 
 
-  if (s1 != NULL)
-    mpz_tdiv_q (ele, ele, s1->value.integer);
-}
+  gfc_expr *r_start;
+  gfc_expr *r_end;
+  gfc_expr *r_stride;
+  gfc_expr *r_lower;
+  gfc_expr *r_upper;
+  gfc_expr *one_expr;
+  int r_dir;
+  int stride_comparison;
+  int start_comparison;
 
 
+  /* If they are the same range, return without more ado.  */
+  if (gfc_is_same_range (l_ar, r_ar, n, 0))
+    return GFC_DEP_EQUAL;
 
 
-/* Returns if the ranges ((0..Y), (X1..X2))  overlap.  */
+  l_start = l_ar->start[n];
+  l_end = l_ar->end[n];
+  l_stride = l_ar->stride[n];
+
+  r_start = r_ar->start[n];
+  r_end = r_ar->end[n];
+  r_stride = r_ar->stride[n];
+
+  /* If l_start is NULL take it from array specifier.  */
+  if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as))
+    l_start = l_ar->as->lower[n];
+  /* If l_end is NULL take it from array specifier.  */
+  if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as))
+    l_end = l_ar->as->upper[n];
+
+  /* If r_start is NULL take it from array specifier.  */
+  if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as))
+    r_start = r_ar->as->lower[n];
+  /* If r_end is NULL take it from array specifier.  */
+  if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
+    r_end = r_ar->as->upper[n];
+
+  /* Determine whether the l_stride is positive or negative.  */
+  if (!l_stride)
+    l_dir = 1;
+  else if (l_stride->expr_type == EXPR_CONSTANT
+          && l_stride->ts.type == BT_INTEGER)
+    l_dir = mpz_sgn (l_stride->value.integer);
+  else if (l_start && l_end)
+    l_dir = gfc_dep_compare_expr (l_end, l_start);
+  else
+    l_dir = -2;
+
+  /* Determine whether the r_stride is positive or negative.  */
+  if (!r_stride)
+    r_dir = 1;
+  else if (r_stride->expr_type == EXPR_CONSTANT
+          && r_stride->ts.type == BT_INTEGER)
+    r_dir = mpz_sgn (r_stride->value.integer);
+  else if (r_start && r_end)
+    r_dir = gfc_dep_compare_expr (r_end, r_start);
+  else
+    r_dir = -2;
 
 
-static gfc_dependency
-get_deps (mpz_t x1, mpz_t x2, mpz_t y)
-{
-  int start;
-  int end;
+  /* The strides should never be zero.  */
+  if (l_dir == 0 || r_dir == 0)
+    return GFC_DEP_OVERLAP;
 
 
-  start = mpz_cmp_ui (x1, 0);
-  end = mpz_cmp (x2, y);
-  
-  /* Both ranges the same.  */
-  if (start == 0 && end == 0)
-    return GFC_DEP_EQUAL;
+  /* Determine the relationship between the strides.  Set stride_comparison to
+     -2 if the dependency cannot be determined
+     -1 if l_stride < r_stride
+      0 if l_stride == r_stride
+      1 if l_stride > r_stride
+     as determined by gfc_dep_compare_expr.  */
 
 
-  /* Distinct ranges.  */
-  if ((start < 0 && mpz_cmp_ui (x2, 0) < 0)
-      || (mpz_cmp (x1, y) > 0 && end > 0))
-    return GFC_DEP_NODEP;
+  one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
 
 
-  /* Overlapping, but with corresponding elements of the second range
-     greater than the first.  */
-  if (start > 0 && end > 0)
-    return GFC_DEP_FORWARD;
+  stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
+                                           r_stride ? r_stride : one_expr);
 
 
-  /* Overlapping in some other way.  */
-  return GFC_DEP_OVERLAP;
-}
+  if (l_start && r_start)
+    start_comparison = gfc_dep_compare_expr (l_start, r_start);
+  else
+    start_comparison = -2;
+      
+  free (one_expr);
 
 
+  /* Determine LHS upper and lower bounds.  */
+  if (l_dir == 1)
+    {
+      l_lower = l_start;
+      l_upper = l_end;
+    }
+  else if (l_dir == -1)
+    {
+      l_lower = l_end;
+      l_upper = l_start;
+    }
+  else
+    {
+      l_lower = NULL;
+      l_upper = NULL;
+    }
 
 
-/* Perform the same linear transformation on sections l and r such that 
-   (l_start:l_end:l_stride) -> (0:no_of_elements)
-   (r_start:r_end:r_stride) -> (X1:X2)
-   Where r_end is implicit as both sections must have the same number of
-   elements.
-   Returns 0 on success, 1 of the transformation failed.  */
-/* TODO: Should this be (0:no_of_elements-1) */
+  /* Determine RHS upper and lower bounds.  */
+  if (r_dir == 1)
+    {
+      r_lower = r_start;
+      r_upper = r_end;
+    }
+  else if (r_dir == -1)
+    {
+      r_lower = r_end;
+      r_upper = r_start;
+    }
+  else
+    {
+      r_lower = NULL;
+      r_upper = NULL;
+    }
 
 
-static int
-transform_sections (mpz_t X1, mpz_t X2, mpz_t no_of_elements,
-                   gfc_expr * l_start, gfc_expr * l_end, gfc_expr * l_stride,
-                   gfc_expr * r_start, gfc_expr * r_stride)
-{
-  if (NULL == l_start || NULL == l_end || NULL == r_start)
-    return 1;
+  /* Check whether the ranges are disjoint.  */
+  if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
+    return GFC_DEP_NODEP;
+  if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
+    return GFC_DEP_NODEP;
 
 
-  /* TODO : Currently we check the dependency only when start, end and stride
-    are constant.  We could also check for equal (variable) values, and
-    common subexpressions, eg. x vs. x+1.  */
+  /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
+  if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
+    {
+      if (l_dir == 1 && r_dir == -1)
+       return GFC_DEP_EQUAL;
+      if (l_dir == -1 && r_dir == 1)
+       return GFC_DEP_EQUAL;
+    }
 
 
-  if (l_end->expr_type != EXPR_CONSTANT
-      || l_start->expr_type != EXPR_CONSTANT
-      || r_start->expr_type != EXPR_CONSTANT
-      || ((NULL != l_stride) && (l_stride->expr_type != EXPR_CONSTANT))
-      || ((NULL != r_stride) && (r_stride->expr_type != EXPR_CONSTANT)))
+  /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
+  if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
     {
     {
-       return 1;
+      if (l_dir == 1 && r_dir == -1)
+       return GFC_DEP_EQUAL;
+      if (l_dir == -1 && r_dir == 1)
+       return GFC_DEP_EQUAL;
     }
 
     }
 
+  /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
+     There is no dependency if the remainder of
+     (l_start - r_start) / gcd(l_stride, r_stride) is
+     nonzero.
+     TODO:
+       - Handle cases where x is an expression.
+       - Cases like a(1:4:2) = a(2:3) are still not handled.
+  */
 
 
-  get_no_of_elements (no_of_elements, l_end, l_start, l_stride);
+#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
+                             && (a)->ts.type == BT_INTEGER)
 
 
-  mpz_sub (X1, r_start->value.integer, l_start->value.integer);
-  if (l_stride != NULL)
-    mpz_cdiv_q (X1, X1, l_stride->value.integer);
-  
-  if (r_stride == NULL)
-    mpz_set (X2, no_of_elements);
-  else
-    mpz_mul (X2, no_of_elements, r_stride->value.integer);
+  if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
+      && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
+    {
+      mpz_t gcd, tmp;
+      int result;
 
 
-  if (l_stride != NULL)
-    mpz_cdiv_q (X2, X2, l_stride->value.integer);
-  mpz_add (X2, X2, X1);
+      mpz_init (gcd);
+      mpz_init (tmp);
 
 
-  return 0;
-}
-  
+      mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
+      mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
 
 
-/* Determines overlapping for two array sections.  */
+      mpz_fdiv_r (tmp, tmp, gcd);
+      result = mpz_cmp_si (tmp, 0L);
 
 
-static gfc_dependency
-gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
-{
-  gfc_expr *l_start;
-  gfc_expr *l_end;
-  gfc_expr *l_stride;
+      mpz_clear (gcd);
+      mpz_clear (tmp);
 
 
-  gfc_expr *r_start;
-  gfc_expr *r_stride;
+      if (result != 0)
+       return GFC_DEP_NODEP;
+    }
 
 
-  gfc_array_ref l_ar;
-  gfc_array_ref r_ar;
+#undef IS_CONSTANT_INTEGER
 
 
-  mpz_t no_of_elements;
-  mpz_t X1, X2;
-  gfc_dependency dep;
+  /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
 
 
-  l_ar = lref->u.ar;
-  r_ar = rref->u.ar;
-  
-  /* If they are the same range, return without more ado.  */
-  if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
-    return GFC_DEP_EQUAL;
+  if (l_dir == 1 && r_dir == 1 &&
+      (start_comparison == 0 || start_comparison == -1)
+      && (stride_comparison == 0 || stride_comparison == -1))
+         return GFC_DEP_FORWARD;
 
 
-  l_start = l_ar.start[n];
-  l_end = l_ar.end[n];
-  l_stride = l_ar.stride[n];
-  r_start = r_ar.start[n];
-  r_stride = r_ar.stride[n];
+  /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
+     x:y:-1 vs. x:y:-2.  */
+  if (l_dir == -1 && r_dir == -1 && 
+      (start_comparison == 0 || start_comparison == 1)
+      && (stride_comparison == 0 || stride_comparison == 1))
+    return GFC_DEP_FORWARD;
 
 
-  /* if l_start is NULL take it from array specifier  */
-  if (NULL == l_start && IS_ARRAY_EXPLICIT(l_ar.as))
-    l_start = l_ar.as->lower[n];
+  if (stride_comparison == 0 || stride_comparison == -1)
+    {
+      if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
+       {
 
 
-  /* if l_end is NULL take it from array specifier  */
-  if (NULL == l_end && IS_ARRAY_EXPLICIT(l_ar.as))
-    l_end = l_ar.as->upper[n];
+         /* Check for a(low:y:s) vs. a(z:x:s) or
+            a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
+            of low, which is always at least a forward dependence.  */
 
 
-  /* if r_start is NULL take it from array specifier  */
-  if (NULL == r_start && IS_ARRAY_EXPLICIT(r_ar.as))
-    r_start = r_ar.as->lower[n];
+         if (r_dir == 1
+             && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
+           return GFC_DEP_FORWARD;
+       }
+    }
 
 
-  mpz_init (X1);
-  mpz_init (X2);
-  mpz_init (no_of_elements);
+  if (stride_comparison == 0 || stride_comparison == 1)
+    {
+      if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
+       {
+      
+         /* Check for a(high:y:-s) vs. a(z:x:-s) or
+            a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
+            of high, which is always at least a forward dependence.  */
+
+         if (r_dir == -1
+             && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
+           return GFC_DEP_FORWARD;
+       }
+    }
 
 
-  if (transform_sections (X1, X2, no_of_elements,
-                         l_start, l_end, l_stride,
-                         r_start, r_stride))
-    dep = GFC_DEP_OVERLAP;
-  else
-    dep =  get_deps (X1, X2, no_of_elements);
 
 
-  mpz_clear (no_of_elements);
-  mpz_clear (X1);
-  mpz_clear (X2);
-  return dep;
+  if (stride_comparison == 0)
+    {
+      /* From here, check for backwards dependencies.  */
+      /* x+1:y vs. x:z.  */
+      if (l_dir == 1 && r_dir == 1  && start_comparison == 1)
+       return GFC_DEP_BACKWARD;
+
+      /* x-1:y:-1 vs. x:z:-1.  */
+      if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
+       return GFC_DEP_BACKWARD;
+    }
+
+  return GFC_DEP_OVERLAP;
 }
 
 
 }
 
 
-/* Checks if the expr chk is inside the range left-right.
-   Returns  GFC_DEP_NODEP if chk is outside the range,
-   GFC_DEP_OVERLAP otherwise.
-   Assumes left<=right.  */
+/* Determines overlapping for a single element and a section.  */
 
 static gfc_dependency
 
 static gfc_dependency
-gfc_is_inside_range (gfc_expr * chk, gfc_expr * left, gfc_expr * right)
+gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
 {
 {
-  int l;
-  int r;
+  gfc_array_ref *ref;
+  gfc_expr *elem;
+  gfc_expr *start;
+  gfc_expr *end;
+  gfc_expr *stride;
   int s;
 
   int s;
 
-  s = gfc_dep_compare_expr (left, right);
-  if (s == -2)
+  elem = lref->u.ar.start[n];
+  if (!elem)
     return GFC_DEP_OVERLAP;
 
     return GFC_DEP_OVERLAP;
 
-  l = gfc_dep_compare_expr (chk, left);
-  r = gfc_dep_compare_expr (chk, right);
+  ref = &rref->u.ar;
+  start = ref->start[n] ;
+  end = ref->end[n] ;
+  stride = ref->stride[n];
+
+  if (!start && IS_ARRAY_EXPLICIT (ref->as))
+    start = ref->as->lower[n];
+  if (!end && IS_ARRAY_EXPLICIT (ref->as))
+    end = ref->as->upper[n];
+
+  /* Determine whether the stride is positive or negative.  */
+  if (!stride)
+    s = 1;
+  else if (stride->expr_type == EXPR_CONSTANT
+          && stride->ts.type == BT_INTEGER)
+    s = mpz_sgn (stride->value.integer);
+  else
+    s = -2;
 
 
-  /* Check for indeterminate relationships.  */
-  if (l == -2 || r == -2 || s == -2)
+  /* Stride should never be zero.  */
+  if (s == 0)
     return GFC_DEP_OVERLAP;
 
     return GFC_DEP_OVERLAP;
 
+  /* Positive strides.  */
   if (s == 1)
     {
   if (s == 1)
     {
-      /* When left>right we want to check for right <= chk <= left.  */
-      if (l <= 0 || r >= 0)
-       return GFC_DEP_OVERLAP;
+      /* Check for elem < lower.  */
+      if (start && gfc_dep_compare_expr (elem, start) == -1)
+       return GFC_DEP_NODEP;
+      /* Check for elem > upper.  */
+      if (end && gfc_dep_compare_expr (elem, end) == 1)
+       return GFC_DEP_NODEP;
+
+      if (start && end)
+       {
+         s = gfc_dep_compare_expr (start, end);
+         /* Check for an empty range.  */
+         if (s == 1)
+           return GFC_DEP_NODEP;
+         if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
+           return GFC_DEP_EQUAL;
+       }
+    }
+  /* Negative strides.  */
+  else if (s == -1)
+    {
+      /* Check for elem > upper.  */
+      if (end && gfc_dep_compare_expr (elem, start) == 1)
+       return GFC_DEP_NODEP;
+      /* Check for elem < lower.  */
+      if (start && gfc_dep_compare_expr (elem, end) == -1)
+       return GFC_DEP_NODEP;
+
+      if (start && end)
+       {
+         s = gfc_dep_compare_expr (start, end);
+         /* Check for an empty range.  */
+         if (s == -1)
+           return GFC_DEP_NODEP;
+         if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
+           return GFC_DEP_EQUAL;
+       }
     }
     }
+  /* Unknown strides.  */
   else
     {
   else
     {
-      /* Otherwise check for left <= chk <= right.  */
-      if (l >= 0 || r <= 0)
+      if (!start || !end)
        return GFC_DEP_OVERLAP;
        return GFC_DEP_OVERLAP;
+      s = gfc_dep_compare_expr (start, end);
+      if (s == -2)
+       return GFC_DEP_OVERLAP;
+      /* Assume positive stride.  */
+      if (s == -1)
+       {
+         /* Check for elem < lower.  */
+         if (gfc_dep_compare_expr (elem, start) == -1)
+           return GFC_DEP_NODEP;
+         /* Check for elem > upper.  */
+         if (gfc_dep_compare_expr (elem, end) == 1)
+           return GFC_DEP_NODEP;
+       }
+      /* Assume negative stride.  */
+      else if (s == 1)
+       {
+         /* Check for elem > upper.  */
+         if (gfc_dep_compare_expr (elem, start) == 1)
+           return GFC_DEP_NODEP;
+         /* Check for elem < lower.  */
+         if (gfc_dep_compare_expr (elem, end) == -1)
+           return GFC_DEP_NODEP;
+       }
+      /* Equal bounds.  */
+      else if (s == 0)
+       {
+         s = gfc_dep_compare_expr (elem, start);
+         if (s == 0)
+           return GFC_DEP_EQUAL;
+         if (s == 1 || s == -1)
+           return GFC_DEP_NODEP;
+       }
     }
     }
-  
-  return GFC_DEP_NODEP;
+
+  return GFC_DEP_OVERLAP;
 }
 
 
 }
 
 
-/* Determines overlapping for a single element and a section.  */
+/* Traverse expr, checking all EXPR_VARIABLE symbols for their
+   forall_index attribute.  Return true if any variable may be
+   being used as a FORALL index.  Its safe to pessimistically
+   return true, and assume a dependency.  */
+
+static bool
+contains_forall_index_p (gfc_expr *expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_constructor *c;
+  gfc_ref *ref;
+  int i;
+
+  if (!expr)
+    return false;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+      if (expr->symtree->n.sym->forall_index)
+       return true;
+      break;
+
+    case EXPR_OP:
+      if (contains_forall_index_p (expr->value.op.op1)
+         || contains_forall_index_p (expr->value.op.op2))
+       return true;
+      break;
+
+    case EXPR_FUNCTION:
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+       if (contains_forall_index_p (arg->expr))
+         return true;
+      break;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_SUBSTRING:
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      for (c = gfc_constructor_first (expr->value.constructor);
+          c; gfc_constructor_next (c))
+       if (contains_forall_index_p (c->expr))
+         return true;
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+       for (i = 0; i < ref->u.ar.dimen; i++)
+         if (contains_forall_index_p (ref->u.ar.start[i])
+             || contains_forall_index_p (ref->u.ar.end[i])
+             || contains_forall_index_p (ref->u.ar.stride[i]))
+           return true;
+       break;
+
+      case REF_COMPONENT:
+       break;
+
+      case REF_SUBSTRING:
+       if (contains_forall_index_p (ref->u.ss.start)
+           || contains_forall_index_p (ref->u.ss.end))
+         return true;
+       break;
+
+      default:
+       gcc_unreachable ();
+      }
+
+  return false;
+}
+
+/* Determines overlapping for two single element array references.  */
 
 static gfc_dependency
 
 static gfc_dependency
-gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
+gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
 {
   gfc_array_ref l_ar;
   gfc_array_ref r_ar;
   gfc_expr *l_start;
   gfc_expr *r_start;
 {
   gfc_array_ref l_ar;
   gfc_array_ref r_ar;
   gfc_expr *l_start;
   gfc_expr *r_start;
-  gfc_expr *r_end;
+  int i;
 
   l_ar = lref->u.ar;
   r_ar = rref->u.ar;
   l_start = l_ar.start[n] ;
   r_start = r_ar.start[n] ;
 
   l_ar = lref->u.ar;
   r_ar = rref->u.ar;
   l_start = l_ar.start[n] ;
   r_start = r_ar.start[n] ;
-  r_end = r_ar.end[n] ;
-  if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
-    r_start = r_ar.as->lower[n];
-  if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
-    r_end = r_ar.as->upper[n];
-  if (NULL == r_start || NULL == r_end || l_start == NULL)
+  i = gfc_dep_compare_expr (r_start, l_start);
+  if (i == 0)
+    return GFC_DEP_EQUAL;
+
+  /* Treat two scalar variables as potentially equal.  This allows
+     us to prove that a(i,:) and a(j,:) have no dependency.  See
+     Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
+     Proceedings of the International Conference on Parallel and
+     Distributed Processing Techniques and Applications (PDPTA2001),
+     Las Vegas, Nevada, June 2001.  */
+  /* However, we need to be careful when either scalar expression
+     contains a FORALL index, as these can potentially change value
+     during the scalarization/traversal of this array reference.  */
+  if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
     return GFC_DEP_OVERLAP;
 
     return GFC_DEP_OVERLAP;
 
-  return gfc_is_inside_range (l_start, r_end, r_start);
+  if (i != -2)
+    return GFC_DEP_NODEP;
+  return GFC_DEP_EQUAL;
 }
 
 
 }
 
 
-/* Determines overlapping for two single element array references.  */
+/* Determine if an array ref, usually an array section specifies the
+   entire array.  In addition, if the second, pointer argument is
+   provided, the function will return true if the reference is
+   contiguous; eg. (:, 1) gives true but (1,:) gives false.  */
 
 
-static gfc_dependency
-gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
+bool
+gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
 {
 {
-  gfc_array_ref l_ar;
-  gfc_array_ref r_ar;
-  gfc_expr *l_start;
-  gfc_expr *r_start;
-  gfc_dependency nIsDep;
+  int i;
+  int n;
+  bool lbound_OK = true;
+  bool ubound_OK = true;
+
+  if (contiguous)
+    *contiguous = false;
+
+  if (ref->type != REF_ARRAY)
+    return false;
 
 
-  if (lref->type == REF_ARRAY && rref->type == REF_ARRAY)
+  if (ref->u.ar.type == AR_FULL)
     {
     {
-      l_ar = lref->u.ar;
-      r_ar = rref->u.ar;
-      l_start = l_ar.start[n] ;
-      r_start = r_ar.start[n] ;
-      if (gfc_dep_compare_expr (r_start, l_start) == 0)
-        nIsDep = GFC_DEP_EQUAL;
-      else
-       nIsDep = GFC_DEP_NODEP;
-  }
-  else
-    nIsDep = GFC_DEP_NODEP;
+      if (contiguous)
+       *contiguous = true;
+      return true;
+    }
+
+  if (ref->u.ar.type != AR_SECTION)
+    return false;
+  if (ref->next)
+    return false;
 
 
-  return nIsDep;
+  for (i = 0; i < ref->u.ar.dimen; i++)
+    {
+      /* If we have a single element in the reference, for the reference
+        to be full, we need to ascertain that the array has a single
+        element in this dimension and that we actually reference the
+        correct element.  */
+      if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
+       {
+         /* This is unconditionally a contiguous reference if all the
+            remaining dimensions are elements.  */
+         if (contiguous)
+           {
+             *contiguous = true;
+             for (n = i + 1; n < ref->u.ar.dimen; n++)
+               if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+                 *contiguous = false;
+           }
+
+         if (!ref->u.ar.as
+             || !ref->u.ar.as->lower[i]
+             || !ref->u.ar.as->upper[i]
+             || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
+                                      ref->u.ar.as->upper[i])
+             || !ref->u.ar.start[i]
+             || gfc_dep_compare_expr (ref->u.ar.start[i],
+                                      ref->u.ar.as->lower[i]))
+           return false;
+         else
+           continue;
+       }
+
+      /* Check the lower bound.  */
+      if (ref->u.ar.start[i]
+         && (!ref->u.ar.as
+             || !ref->u.ar.as->lower[i]
+             || gfc_dep_compare_expr (ref->u.ar.start[i],
+                                      ref->u.ar.as->lower[i])))
+       lbound_OK = false;
+      /* Check the upper bound.  */
+      if (ref->u.ar.end[i]
+         && (!ref->u.ar.as
+             || !ref->u.ar.as->upper[i]
+             || gfc_dep_compare_expr (ref->u.ar.end[i],
+                                      ref->u.ar.as->upper[i])))
+       ubound_OK = false;
+      /* Check the stride.  */
+      if (ref->u.ar.stride[i]
+           && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
+       return false;
+
+      /* This is unconditionally a contiguous reference as long as all
+        the subsequent dimensions are elements.  */
+      if (contiguous)
+       {
+         *contiguous = true;
+         for (n = i + 1; n < ref->u.ar.dimen; n++)
+           if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+             *contiguous = false;
+       }
+
+      if (!lbound_OK || !ubound_OK)
+       return false;
+    }
+  return true;
+}
+
+
+/* Determine if a full array is the same as an array section with one
+   variable limit.  For this to be so, the strides must both be unity
+   and one of either start == lower or end == upper must be true.  */
+
+static bool
+ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
+{
+  int i;
+  bool upper_or_lower;
+
+  if (full_ref->type != REF_ARRAY)
+    return false;
+  if (full_ref->u.ar.type != AR_FULL)
+    return false;
+  if (ref->type != REF_ARRAY)
+    return false;
+  if (ref->u.ar.type != AR_SECTION)
+    return false;
+
+  for (i = 0; i < ref->u.ar.dimen; i++)
+    {
+      /* If we have a single element in the reference, we need to check
+        that the array has a single element and that we actually reference
+        the correct element.  */
+      if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
+       {
+         if (!full_ref->u.ar.as
+             || !full_ref->u.ar.as->lower[i]
+             || !full_ref->u.ar.as->upper[i]
+             || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
+                                      full_ref->u.ar.as->upper[i])
+             || !ref->u.ar.start[i]
+             || gfc_dep_compare_expr (ref->u.ar.start[i],
+                                      full_ref->u.ar.as->lower[i]))
+           return false;
+       }
+
+      /* Check the strides.  */
+      if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
+       return false;
+      if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
+       return false;
+
+      upper_or_lower = false;
+      /* Check the lower bound.  */
+      if (ref->u.ar.start[i]
+         && (ref->u.ar.as
+               && full_ref->u.ar.as->lower[i]
+               && gfc_dep_compare_expr (ref->u.ar.start[i],
+                                        full_ref->u.ar.as->lower[i]) == 0))
+       upper_or_lower =  true;
+      /* Check the upper bound.  */
+      if (ref->u.ar.end[i]
+         && (ref->u.ar.as
+               && full_ref->u.ar.as->upper[i]
+               && gfc_dep_compare_expr (ref->u.ar.end[i],
+                                        full_ref->u.ar.as->upper[i]) == 0))
+       upper_or_lower =  true;
+      if (!upper_or_lower)
+       return false;
+    }
+  return true;
 }
 
 
 /* Finds if two array references are overlapping or not.
    Return value
 }
 
 
 /* Finds if two array references are overlapping or not.
    Return value
+       2 : array references are overlapping but reversal of one or
+           more dimensions will clear the dependency.
        1 : array references are overlapping.
        1 : array references are overlapping.
-       0 : array references are not overlapping.  */
+       0 : array references are identical or not overlapping.  */
 
 int
 
 int
-gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
+gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
 {
   int n;
   gfc_dependency fin_dep;
   gfc_dependency this_dep;
 
 {
   int n;
   gfc_dependency fin_dep;
   gfc_dependency this_dep;
 
-
+  this_dep = GFC_DEP_ERROR;
   fin_dep = GFC_DEP_ERROR;
   /* Dependencies due to pointers should already have been identified.
      We only need to check for overlapping array references.  */
   fin_dep = GFC_DEP_ERROR;
   /* Dependencies due to pointers should already have been identified.
      We only need to check for overlapping array references.  */
@@ -704,7 +1739,7 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
   while (lref && rref)
     {
       /* We're resolving from the same base symbol, so both refs should be
   while (lref && rref)
     {
       /* We're resolving from the same base symbol, so both refs should be
-         the same type.  We traverse the reference chain intil we find ranges
+        the same type.  We traverse the reference chain until we find ranges
         that are not equal.  */
       gcc_assert (lref->type == rref->type);
       switch (lref->type)
         that are not equal.  */
       gcc_assert (lref->type == rref->type);
       switch (lref->type)
@@ -717,21 +1752,42 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
          break;
          
        case REF_SUBSTRING:
          break;
          
        case REF_SUBSTRING:
-         /* Substring overlaps are handled by the string assignment code.  */
-         return 0;
+         /* Substring overlaps are handled by the string assignment code
+            if there is not an underlying dependency.  */
+         return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
        
        case REF_ARRAY:
        
        case REF_ARRAY:
-         
+
+         if (ref_same_as_full_array (lref, rref))
+           return 0;
+
+         if (ref_same_as_full_array (rref, lref))
+           return 0;
+
+         if (lref->u.ar.dimen != rref->u.ar.dimen)
+           {
+             if (lref->u.ar.type == AR_FULL)
+               fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
+                                                           : GFC_DEP_OVERLAP;
+             else if (rref->u.ar.type == AR_FULL)
+               fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
+                                                           : GFC_DEP_OVERLAP;
+             else
+               return 1;
+             break;
+           }
+
          for (n=0; n < lref->u.ar.dimen; n++)
            {
              /* Assume dependency when either of array reference is vector
          for (n=0; n < lref->u.ar.dimen; n++)
            {
              /* Assume dependency when either of array reference is vector
-                subscript.  */
+                subscript.  */
              if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
                  || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
                return 1;
              if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
                  || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
                return 1;
+
              if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
                  && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
              if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
                  && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
-               this_dep = gfc_check_section_vs_section (lref, rref, n);
+               this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
              else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
                       && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
                this_dep = gfc_check_element_vs_section (lref, rref, n);
              else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
                       && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
                this_dep = gfc_check_element_vs_section (lref, rref, n);
@@ -741,7 +1797,7 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
              else 
                {
                  gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
              else 
                {
                  gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
-                         && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
+                             && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
                  this_dep = gfc_check_element_vs_element (rref, lref, n);
                }
 
                  this_dep = gfc_check_element_vs_element (rref, lref, n);
                }
 
@@ -749,14 +1805,63 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
              if (this_dep == GFC_DEP_NODEP)
                return 0;
 
              if (this_dep == GFC_DEP_NODEP)
                return 0;
 
+             /* Now deal with the loop reversal logic:  This only works on
+                ranges and is activated by setting
+                               reverse[n] == GFC_ENABLE_REVERSE
+                The ability to reverse or not is set by previous conditions
+                in this dimension.  If reversal is not activated, the
+                value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP.  */
+             if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
+                   && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
+               {
+                 /* Set reverse if backward dependence and not inhibited.  */
+                 if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
+                   reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
+                                GFC_REVERSE_SET : reverse[n];
+
+                 /* Set forward if forward dependence and not inhibited.  */
+                 if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
+                   reverse[n] = (this_dep == GFC_DEP_FORWARD) ?
+                                GFC_FORWARD_SET : reverse[n];
+
+                 /* Flag up overlap if dependence not compatible with
+                    the overall state of the expression.  */
+                 if (reverse && reverse[n] == GFC_REVERSE_SET
+                       && this_dep == GFC_DEP_FORWARD)
+                   {
+                     reverse[n] = GFC_INHIBIT_REVERSE;
+                     this_dep = GFC_DEP_OVERLAP;
+                   }
+                 else if (reverse && reverse[n] == GFC_FORWARD_SET
+                       && this_dep == GFC_DEP_BACKWARD)
+                   {
+                     reverse[n] = GFC_INHIBIT_REVERSE;
+                     this_dep = GFC_DEP_OVERLAP;
+                   }
+
+                 /* If no intention of reversing or reversing is explicitly
+                    inhibited, convert backward dependence to overlap.  */
+                 if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
+                     || (reverse != NULL && reverse[n] == GFC_INHIBIT_REVERSE))
+                   this_dep = GFC_DEP_OVERLAP;
+               }
+
              /* Overlap codes are in order of priority.  We only need to
              /* Overlap codes are in order of priority.  We only need to
-                know the worst one.*/
+                know the worst one.*/
              if (this_dep > fin_dep)
                fin_dep = this_dep;
            }
              if (this_dep > fin_dep)
                fin_dep = this_dep;
            }
+
+         /* If this is an equal element, we have to keep going until we find
+            the "real" array reference.  */
+         if (lref->u.ar.type == AR_ELEMENT
+               && rref->u.ar.type == AR_ELEMENT
+               && fin_dep == GFC_DEP_EQUAL)
+           break;
+
          /* Exactly matching and forward overlapping ranges don't cause a
             dependency.  */
          /* Exactly matching and forward overlapping ranges don't cause a
             dependency.  */
-         if (fin_dep < GFC_DEP_OVERLAP)
+         if (fin_dep < GFC_DEP_BACKWARD)
            return 0;
 
          /* Keep checking.  We only have a dependency if
            return 0;
 
          /* Keep checking.  We only have a dependency if
@@ -773,9 +1878,9 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
   /* If we haven't seen any array refs then something went wrong.  */
   gcc_assert (fin_dep != GFC_DEP_ERROR);
 
   /* If we haven't seen any array refs then something went wrong.  */
   gcc_assert (fin_dep != GFC_DEP_ERROR);
 
-  if (fin_dep < GFC_DEP_OVERLAP)
-    return 0;
-  else
+  /* Assume the worst if we nest to different depths.  */
+  if (lref || rref)
     return 1;
     return 1;
-}
 
 
+  return fin_dep == GFC_DEP_OVERLAP;
+}
About OSDN
Find Software
Develop Software
Help