[multiple changes]

2007-10-29  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/31217
        PR fortran/33811
        PR fortran/33686
        * trans-array.c (gfc_conv_loop_setup): Send a complete type to
        gfc_trans_create_temp_array if the temporary is character.
        * trans-stmt.c (gfc_trans_assign_need_temp): Do likewise for
        allocate_temp_for_forall_nest.
        (forall_replace): New function.
        (forall_replace_symtree): New function.
        (forall_restore): New function.
        (forall_restore_symtree): New function.
        (forall_make_variable_temp): New function.
        (check_forall_dependencies): New function.
        (cleanup_forall_symtrees): New function.
        gfc_trans_forall_1): Add and initialize pre and post blocks.
        Call check_forall_dependencies to check for all dependencies
        and either trigger second forall block to copy temporary or
        copy lval, outside the forall construct and replace all
        dependent references. After assignment clean-up and coalesce
        the blocks at the end of the function.
        * gfortran.h : Add prototypes for gfc_traverse_expr and
        find_forall_index.
        expr.c (gfc_traverse_expr): New function to traverse expression
        and visit all subexpressions, under control of a logical flag,
        a symbol and an integer pointer. The slave function is caller
        defined and is only called on EXPR_VARIABLE.
        (expr_set_symbols_referenced): Called by above to set symbols
        referenced.
        (gfc_expr_set_symbols_referenced): Rework of this function to
        use two new functions above.
        * resolve.c (find_forall_index): Rework with gfc_traverse_expr,
        using forall_index.
        (forall_index): New function used by previous.
        * dependency.c (gfc_check_dependency): Use gfc_dep_resolver for
        all references, not just REF_ARRAY.
        (gfc_dep_resolver): Correct the logic for substrings so that
        overlapping arrays are handled correctly.

2007-10-29 Paul Thomas <pault@gcc.gnu.org>

        PR fortran/31217
        PR fortran/33811
        * gfortran.dg/forall_12.f90: New test.

        PR fortran/33686
        * gfortran.dg/forall_13.f90: New test.

From-SVN: r129720

10 files changed, 448 insertions, 160 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c75af08..a761a95 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,44 @@
+2007-10-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31217
+	PR fortran/33811
+	PR fortran/33686
+
+	* trans-array.c (gfc_conv_loop_setup): Send a complete type to
+	gfc_trans_create_temp_array if the temporary is character.
+	* trans-stmt.c (gfc_trans_assign_need_temp): Do likewise for
+	allocate_temp_for_forall_nest.
+	(forall_replace): New function.
+	(forall_replace_symtree): New function.
+	(forall_restore): New function.
+	(forall_restore_symtree): New function.
+	(forall_make_variable_temp): New function.
+	(check_forall_dependencies): New function.
+	(cleanup_forall_symtrees): New function.
+	gfc_trans_forall_1): Add and initialize pre and post blocks.
+	Call check_forall_dependencies to check for all dependencies
+	and either trigger second forall block to copy temporary or
+	copy lval, outside the forall construct and replace all
+	dependent references. After assignment clean-up and coalesce
+	the blocks at the end of the function.
+	* gfortran.h : Add prototypes for gfc_traverse_expr and
+	find_forall_index.
+	expr.c (gfc_traverse_expr): New function to traverse expression
+	and visit all subexpressions, under control of a logical flag,
+	a symbol and an integer pointer. The slave function is caller
+	defined and is only called on EXPR_VARIABLE.
+	(expr_set_symbols_referenced): Called by above to set symbols
+	referenced.
+	(gfc_expr_set_symbols_referenced): Rework of this function to
+	use two new functions above.
+	* resolve.c (find_forall_index): Rework with gfc_traverse_expr,
+	using forall_index.
+	(forall_index): New function used by previous.
+	* dependency.c (gfc_check_dependency): Use gfc_dep_resolver for
+	all references, not just REF_ARRAY.
+	(gfc_dep_resolver): Correct the logic for substrings so that
+	overlapping arrays are handled correctly.
+
 2007-10-28  Tobias Schlüter  <tobi@gcc.gnu.org>
 
 	PR fortran/32147
diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index 1c5bf04..29a5237 100644
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -657,8 +657,7 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
 
       /* Identical and disjoint 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)
+      if (expr1->ref && expr2->ref)
 	return gfc_dep_resolver (expr1->ref, expr2->ref);
 
       return 1;
@@ -1197,8 +1196,9 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
 	  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:
 	  if (lref->u.ar.dimen != rref->u.ar.dimen)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 2edf7ad..c7edb49 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -2998,32 +2998,36 @@ gfc_get_variable_expr (gfc_symtree *var)
 }
 
 
-/* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
+/* General expression traversal function.  */
 
-void
-gfc_expr_set_symbols_referenced (gfc_expr *expr)
+bool
+gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
+		   bool (*func)(gfc_expr *, gfc_symbol *, int*),
+		   int f)
 {
-  gfc_actual_arglist *arg;
-  gfc_constructor *c;
+  gfc_array_ref ar;
   gfc_ref *ref;
+  gfc_actual_arglist *args;
+  gfc_constructor *c;
   int i;
 
-  if (!expr) return;
+  if (!expr)
+    return false;
 
   switch (expr->expr_type)
     {
-    case EXPR_OP:
-      gfc_expr_set_symbols_referenced (expr->value.op.op1);
-      gfc_expr_set_symbols_referenced (expr->value.op.op2);
-      break;
+    case EXPR_VARIABLE:
+      gcc_assert (expr->symtree->n.sym);
 
-    case EXPR_FUNCTION:
-      for (arg = expr->value.function.actual; arg; arg = arg->next)
-	gfc_expr_set_symbols_referenced (arg->expr);
-      break;
+      if ((*func) (expr, sym, &f))
+	return true;
 
-    case EXPR_VARIABLE:
-      gfc_set_sym_referenced (expr->symtree->n.sym);
+    case EXPR_FUNCTION:
+      for (args = expr->value.function.actual; args; args = args->next)
+	{
+	  if (gfc_traverse_expr (args->expr, sym, func, f))
+	    return true;
+	}
       break;
 
     case EXPR_CONSTANT:
@@ -3037,33 +3041,67 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
 	gfc_expr_set_symbols_referenced (c->expr);
       break;
 
+    case EXPR_OP:
+      if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
+	return true;
+      if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
+	return true;
+      break;
+
     default:
       gcc_unreachable ();
       break;
     }
 
-    for (ref = expr->ref; ref; ref = ref->next)
+  ref = expr->ref;
+  while (ref != NULL)
+    {
       switch (ref->type)
 	{
-	case REF_ARRAY:
-	  for (i = 0; i < ref->u.ar.dimen; i++)
+	case  REF_ARRAY:
+	  ar = ref->u.ar;
+	  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
 	    {
-	      gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
-	      gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
-	      gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
+	      if (gfc_traverse_expr (ar.start[i], sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (ar.end[i], sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (ar.stride[i], sym, func, f))
+		return true;
 	    }
 	  break;
-	   
-	case REF_COMPONENT:
-	  break;
-	   
+
 	case REF_SUBSTRING:
-	  gfc_expr_set_symbols_referenced (ref->u.ss.start);
-	  gfc_expr_set_symbols_referenced (ref->u.ss.end);
+	  if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
+	    return true;
+	  if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
+	    return true;
 	  break;
-	   
+
+	  case REF_COMPONENT:
+	    break;
+
 	default:
 	  gcc_unreachable ();
-	  break;
 	}
+      ref = ref->next;
+    }
+  return false;
+}
+
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
+
+static bool
+expr_set_symbols_referenced (gfc_expr *expr,
+			     gfc_symbol *sym ATTRIBUTE_UNUSED,
+			     int *f ATTRIBUTE_UNUSED)
+{
+  gfc_set_sym_referenced (expr->symtree->n.sym);
+  return false;
+}
+
+void
+gfc_expr_set_symbols_referenced (gfc_expr *expr)
+{
+  gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
 }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 347cced..bc8fad6 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2233,6 +2233,9 @@ try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
 gfc_expr *gfc_default_initializer (gfc_typespec *);
 gfc_expr *gfc_get_variable_expr (gfc_symtree *);
 
+bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
+			bool (*)(gfc_expr *, gfc_symbol *, int*),
+			int);
 void gfc_expr_set_symbols_referenced (gfc_expr *);
 
 /* st.c */
@@ -2252,6 +2255,7 @@ int gfc_impure_variable (gfc_symbol *);
 int gfc_pure (gfc_symbol *);
 int gfc_elemental (gfc_symbol *);
 try gfc_resolve_iterator (gfc_iterator *, bool);
+try find_forall_index (gfc_expr *, gfc_symbol *, int);
 try gfc_resolve_index (gfc_expr *, int);
 try gfc_resolve_dim_arg (gfc_expr *);
 int gfc_is_formal_arg (void);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 582bb92..69d2c51 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4322,131 +4322,39 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
 }
 
 
-/* Check whether the FORALL index appears in the expression or not.
-   Returns SUCCESS if SYM is found in EXPR.  */
+/* Traversal function for find_forall_index.  f == 2 signals that
+   that variable itself is not to be checked - only the references.  */
 
-static try
-find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
+static bool
+forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
 {
-  gfc_array_ref ar;
-  gfc_ref *tmp;
-  gfc_actual_arglist *args;
-  int i;
+  gcc_assert (expr->expr_type == EXPR_VARIABLE);
 
-  if (!expr)
-    return FAILURE;
-
-  switch (expr->expr_type)
+  /* A scalar assignment  */
+  if (!expr->ref || *f == 1)
     {
-    case EXPR_VARIABLE:
-      gcc_assert (expr->symtree->n.sym);
-
-      /* A scalar assignment  */
-      if (!expr->ref)
-	{
-	  if (expr->symtree->n.sym == symbol)
-	    return SUCCESS;
-	  else
-	    return FAILURE;
-	}
-
-      /* the expr is array ref, substring or struct component.  */
-      tmp = expr->ref;
-      while (tmp != NULL)
-	{
-	  switch (tmp->type)
-	    {
-	    case  REF_ARRAY:
-	      /* Check if the symbol appears in the array subscript.  */
-	      ar = tmp->u.ar;
-	      for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
-		{
-		  if (ar.start[i])
-		    if (find_forall_index (ar.start[i], symbol) == SUCCESS)
-		      return SUCCESS;
-
-		  if (ar.end[i])
-		    if (find_forall_index (ar.end[i], symbol) == SUCCESS)
-		      return SUCCESS;
-
-		  if (ar.stride[i])
-		    if (find_forall_index (ar.stride[i], symbol) == SUCCESS)
-		      return SUCCESS;
-		}  /* end for  */
-	      break;
-
-	    case REF_SUBSTRING:
-	      if (expr->symtree->n.sym == symbol)
-		return SUCCESS;
-	      tmp = expr->ref;
-	      /* Check if the symbol appears in the substring section.  */
-	      if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
-		return SUCCESS;
-	      if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
-		return SUCCESS;
-	      break;
-
-	    case REF_COMPONENT:
-	      break;
-
-	    default:
-	      gfc_error("expression reference type error at %L", &expr->where);
-	    }
-	  tmp = tmp->next;
-	}
-      break;
-
-    /* If the expression is a function call, then check if the symbol
-       appears in the actual arglist of the function.  */
-    case EXPR_FUNCTION:
-      for (args = expr->value.function.actual; args; args = args->next)
-	{
-	  if (find_forall_index(args->expr,symbol) == SUCCESS)
-	    return SUCCESS;
-	}
-      break;
-
-    /* It seems not to happen.  */
-    case EXPR_SUBSTRING:
-      if (expr->ref)
-	{
-	  tmp = expr->ref;
-	  gcc_assert (expr->ref->type == REF_SUBSTRING);
-	  if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
-	    return SUCCESS;
-	  if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
-	    return SUCCESS;
-	}
-      break;
-
-    /* It seems not to happen.  */
-    case EXPR_STRUCTURE:
-    case EXPR_ARRAY:
-      gfc_error ("Unsupported statement while finding forall index in "
-		 "expression");
-      break;
+      if (expr->symtree->n.sym == sym)
+	return true;
+      else
+	return false;
+    }
 
-    case EXPR_OP:
-      /* Find the FORALL index in the first operand.  */
-      if (expr->value.op.op1)
-	{
-	  if (find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
-	    return SUCCESS;
-	}
+  if (*f == 2)
+    *f = 1;
+  return false;
+}
 
-      /* Find the FORALL index in the second operand.  */
-      if (expr->value.op.op2)
-	{
-	  if (find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
-	    return SUCCESS;
-	}
-      break;
 
-    default:
-      break;
-    }
+/* Check whether the FORALL index appears in the expression or not.
+   Returns SUCCESS if SYM is found in EXPR.  */
 
-  return FAILURE;
+try
+find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
+{
+  if (gfc_traverse_expr (expr, sym, forall_index, f))
+    return SUCCESS;
+  else
+    return FAILURE;
 }
 
 
@@ -4502,11 +4410,11 @@ resolve_forall_iterators (gfc_forall_iterator *it)
     for (iter2 = iter; iter2; iter2 = iter2->next)
       {
 	if (find_forall_index (iter2->start,
-			       iter->var->symtree->n.sym) == SUCCESS
+			       iter->var->symtree->n.sym, 0) == SUCCESS
 	    || find_forall_index (iter2->end,
-				  iter->var->symtree->n.sym) == SUCCESS
+				  iter->var->symtree->n.sym, 0) == SUCCESS
 	    || find_forall_index (iter2->stride,
-				  iter->var->symtree->n.sym) == SUCCESS)
+				  iter->var->symtree->n.sym, 0) == SUCCESS)
 	  gfc_error ("FORALL index '%s' may not appear in triplet "
 		     "specification at %L", iter->var->symtree->name,
 		     &iter2->start->where);
@@ -5726,7 +5634,7 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
 	  /* If one of the FORALL index variables doesn't appear in the
 	     assignment target, then there will be a many-to-one
 	     assignment.  */
-	  if (find_forall_index (code->expr, forall_index) == FAILURE)
+	  if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
 	    gfc_error ("The FORALL with index '%s' cause more than one "
 		       "assignment to this object at %L",
 		       var_expr[n]->symtree->name, &code->expr->where);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 680d3b4..1c47b24 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3376,6 +3376,13 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
   if (loop->temp_ss != NULL)
     {
       gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
+
+      /* Make absolutely sure that this is a complete type.  */
+      if (loop->temp_ss->string_length)
+	loop->temp_ss->data.temp.type
+		= gfc_get_character_type_len (gfc_default_character_kind,
+					      loop->temp_ss->string_length);
+
       tmp = loop->temp_ss->data.temp.type;
       len = loop->temp_ss->string_length;
       n = loop->temp_ss->data.temp.dimen;
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 0bf0387..cbb15a5 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1510,6 +1510,205 @@ gfc_trans_select (gfc_code * code)
 }
 
 
+/* Traversal function to substitute a replacement symtree if the symbol
+   in the expression is the same as that passed.  f == 2 signals that
+   that variable itself is not to be checked - only the references.
+   This group of functions is used when the variable expression in a
+   FORALL assignment has internal references.  For example:
+		FORALL (i = 1:4) p(p(i)) = i
+   The only recourse here is to store a copy of 'p' for the index
+   expression.  */
+
+static gfc_symtree *new_symtree;
+static gfc_symtree *old_symtree;
+
+static bool
+forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
+{
+  gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+  if (*f == 2)
+    *f = 1;
+  else if (expr->symtree->n.sym == sym)
+    expr->symtree = new_symtree;
+
+  return false;
+}
+
+static void
+forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
+{
+  gfc_traverse_expr (e, sym, forall_replace, f);
+}
+
+static bool
+forall_restore (gfc_expr *expr,
+		gfc_symbol *sym ATTRIBUTE_UNUSED,
+		int *f ATTRIBUTE_UNUSED)
+{
+  gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+  if (expr->symtree == new_symtree)
+    expr->symtree = old_symtree;
+
+  return false;
+}
+
+static void
+forall_restore_symtree (gfc_expr *e)
+{
+  gfc_traverse_expr (e, NULL, forall_restore, 0);
+}
+
+static void
+forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
+{
+  gfc_se tse;
+  gfc_se rse;
+  gfc_expr *e;
+  gfc_symbol *new_sym;
+  gfc_symbol *old_sym;
+  gfc_symtree *root;
+  tree tmp;
+
+  /* Build a copy of the lvalue.  */
+  old_symtree = c->expr->symtree;
+  old_sym = old_symtree->n.sym;
+  e = gfc_lval_expr_from_sym (old_sym);
+  if (old_sym->attr.dimension)
+    {
+      gfc_init_se (&tse, NULL);
+      gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN);
+      gfc_add_block_to_block (pre, &tse.pre);
+      gfc_add_block_to_block (post, &tse.post);
+      tse.expr = build_fold_indirect_ref (tse.expr);
+
+      if (e->ts.type != BT_CHARACTER)
+	{
+	  /* Use the variable offset for the temporary.  */
+	  tmp = gfc_conv_descriptor_offset (tse.expr);
+	  gfc_add_modify_expr (pre, tmp,
+		gfc_conv_array_offset (old_sym->backend_decl));
+	}
+    }
+  else
+    {
+      gfc_init_se (&tse, NULL);
+      gfc_init_se (&rse, NULL);
+      gfc_conv_expr (&rse, e);
+      if (e->ts.type == BT_CHARACTER)
+	{
+	  tse.string_length = rse.string_length;
+	  tmp = gfc_get_character_type_len (gfc_default_character_kind,
+					    tse.string_length);
+	  tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
+					  rse.string_length);
+	  gfc_add_block_to_block (pre, &tse.pre);
+	  gfc_add_block_to_block (post, &tse.post);
+	}
+      else
+	{
+	  tmp = gfc_typenode_for_spec (&e->ts);
+	  tse.expr = gfc_create_var (tmp, "temp");
+	}
+
+      tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
+				     e->expr_type == EXPR_VARIABLE);
+      gfc_add_expr_to_block (pre, tmp);
+    }
+  gfc_free_expr (e);
+
+  /* Create a new symbol to represent the lvalue.  */
+  new_sym = gfc_new_symbol (old_sym->name, NULL);
+  new_sym->ts = old_sym->ts;
+  new_sym->attr.referenced = 1;
+  new_sym->attr.dimension = old_sym->attr.dimension;
+  new_sym->attr.flavor = old_sym->attr.flavor;
+
+  /* Use the temporary as the backend_decl.  */
+  new_sym->backend_decl = tse.expr;
+
+  /* Create a fake symtree for it.  */
+  root = NULL;
+  new_symtree = gfc_new_symtree (&root, old_sym->name);
+  new_symtree->n.sym = new_sym;
+  gcc_assert (new_symtree == root);
+
+  /* Go through the expression reference replacing the old_symtree
+     with the new.  */
+  forall_replace_symtree (c->expr, old_sym, 2);
+
+  /* Now we have made this temporary, we might as well use it for
+  the right hand side.  */
+  forall_replace_symtree (c->expr2, old_sym, 1);
+}
+
+
+/* Handles dependencies in forall assignments.  */
+static int
+check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
+{
+  gfc_ref *lref;
+  gfc_ref *rref;
+  int need_temp;
+  gfc_symbol *lsym;
+
+  lsym = c->expr->symtree->n.sym;
+  need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
+
+  /* Now check for dependencies within the 'variable'
+     expression itself.  These are treated by making a complete
+     copy of variable and changing all the references to it
+     point to the copy instead.  Note that the shallow copy of
+     the variable will not suffice for derived types with
+     pointer components.  We therefore leave these to their
+     own devices.  */
+  if (lsym->ts.type == BT_DERIVED
+	&& lsym->ts.derived->attr.pointer_comp)
+    return need_temp;
+
+  new_symtree = NULL;
+  if (find_forall_index (c->expr, lsym, 2) == SUCCESS)
+    {
+      forall_make_variable_temp (c, pre, post);
+      need_temp = 0;
+    }
+
+  /* Substrings with dependencies are treated in the same
+     way.  */
+  if (c->expr->ts.type == BT_CHARACTER
+	&& c->expr->ref
+	&& c->expr2->expr_type == EXPR_VARIABLE
+	&& lsym == c->expr2->symtree->n.sym)
+    {
+      for (lref = c->expr->ref; lref; lref = lref->next)
+	if (lref->type == REF_SUBSTRING)
+	  break;
+      for (rref = c->expr2->ref; rref; rref = rref->next)
+	if (rref->type == REF_SUBSTRING)
+	  break;
+
+      if (rref && lref
+	    && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
+	{
+	  forall_make_variable_temp (c, pre, post);
+	  need_temp = 0;
+	}
+    }
+  return need_temp;
+}
+
+
+static void
+cleanup_forall_symtrees (gfc_code *c)
+{
+  forall_restore_symtree (c->expr);
+  forall_restore_symtree (c->expr2);
+  gfc_free (new_symtree->n.sym);
+  gfc_free (new_symtree);
+}
+
+
 /* Generate the loops for a FORALL block, specified by FORALL_TMP.  BODY
    is the contents of the FORALL block/stmt to be iterated.  MASK_FLAG
    indicates whether we should generate code to test the FORALLs mask
@@ -2172,7 +2371,20 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
 					&lss, &rss);
 
   /* The type of LHS. Used in function allocate_temp_for_forall_nest */
-  type = gfc_typenode_for_spec (&expr1->ts);
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length)
+    {
+      if (!expr1->ts.cl->backend_decl)
+	{
+	  gfc_se tse;
+	  gfc_init_se (&tse, NULL);
+	  gfc_conv_expr (&tse, expr1->ts.cl->length);
+	  expr1->ts.cl->backend_decl = tse.expr;
+	}
+      type = gfc_get_character_type_len (gfc_default_character_kind,
+				         expr1->ts.cl->backend_decl);
+    }
+  else
+    type = gfc_typenode_for_spec (&expr1->ts);
 
   /* Allocate temporary for nested forall construct according to the
      information in nested_forall_info and inner_size.  */
@@ -2412,6 +2624,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
 static tree
 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
 {
+  stmtblock_t pre;
+  stmtblock_t post;
   stmtblock_t block;
   stmtblock_t body;
   tree *var;
@@ -2459,7 +2673,9 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
   /* Allocate the space for info.  */
   info = (forall_info *) gfc_getmem (sizeof (forall_info));
 
-  gfc_start_block (&block);
+  gfc_start_block (&pre);
+  gfc_init_block (&post);
+  gfc_init_block (&block);
 
   n = 0;
   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
@@ -2619,8 +2835,11 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
       switch (c->op)
 	{
 	case EXEC_ASSIGN:
-          /* A scalar or array assignment.  */
-	  need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
+          /* A scalar or array assignment.  DO the simple check for
+	     lhs to rhs dependencies.  These make a temporary for the
+	     rhs and form a second forall block to copy to variable.  */
+	  need_temp = check_forall_dependencies(c, &pre, &post);
+
           /* Temporaries due to array assignment data dependencies introduce
              no end of problems.  */
 	  if (need_temp)
@@ -2637,6 +2856,11 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
               gfc_add_expr_to_block (&block, tmp);
             }
 
+	  /* Cleanup any temporary symtrees that have been made to deal
+	     with dependencies.  */
+	  if (new_symtree)
+	    cleanup_forall_symtrees (c);
+
 	  break;
 
         case EXEC_WHERE:
@@ -2706,7 +2930,10 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
   if (maskindex)
     pushdecl (maskindex);
 
-  return gfc_finish_block (&block);
+  gfc_add_block_to_block (&pre, &block);
+  gfc_add_block_to_block (&pre, &post);
+
+  return gfc_finish_block (&pre);
 }
 
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index cecd5f0..5c533f3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2007-10-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31217
+	PR fortran/33811
+	* gfortran.dg/forall_12.f90: New test.
+
+	PR fortran/33686
+	* gfortran.dg/forall_13.f90: New test.
+
 2007-10-28  Paolo Carlini  <pcarlini@suse.de>
 	    Mark Mitchell  <mark@codesourcery.com>
 
diff --git a/gcc/testsuite/gfortran.dg/forall_12.f90 b/gcc/testsuite/gfortran.dg/forall_12.f90
new file mode 100644
index 0000000..207977c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/forall_12.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+! Tests the fix for PR31217 and PR33811 , in which dependencies were not
+! correctly handled for the assignments below and, when this was fixed,
+! the last two ICEd on trying to create the temorary.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!              Dominique d'Humieres <dominiq@lps.ens.fr>
+!                   and Paul Thomas <pault@gcc.gnu.org>
+!
+  character(len=1) :: a = "1"
+  character(len=1) :: b(4) = (/"1","2","3","4"/), c(4)
+  c = b
+  forall(i=1:1) a(i:i) = a(i:i)         ! This was the original PR31217
+  forall(i=1:1) b(i:i) = b(i:i)         ! The rest were found to be broken
+  forall(i=1:1) b(:)(i:i) = b(:)(i:i)
+  forall(i=1:1) b(1:3)(i:i) = b(2:4)(i:i)
+  if (any (b .ne. (/"2","3","4","4"/))) call abort ()
+  b = c
+  forall(i=1:1) b(2:4)(i:i) = b(1:3)(i:i)
+  if (any (b .ne. (/"1","1","2","3"/))) call abort ()
+  b = c
+  do i = 1, 1
+    b(2:4)(i:i) = b(1:3)(i:i)           ! This was PR33811 and Paul's bit
+  end do
+  if (any (b .ne. (/"1","1","2","3"/))) call abort ()
+  call foo
+contains
+  subroutine foo
+    character(LEN=12) :: a(2) = "123456789012"
+    character(LEN=12) :: b = "123456789012"
+! These are Dominique's
+    forall (i = 3:10) a(:)(i:i+2) = a(:)(i-2:i)
+    IF (a(1) .ne. "121234567890") CALL abort ()
+    forall (i = 3:10) a(2)(i:i+2) = a(1)(i-2:i)
+    IF (a(2) .ne. "121212345678") call abort ()
+    forall (i = 3:10) b(i:i+2) = b(i-2:i)
+    IF (b .ne. "121234567890") CALL abort ()
+  end subroutine
+end
+
diff --git a/gcc/testsuite/gfortran.dg/forall_13.f90 b/gcc/testsuite/gfortran.dg/forall_13.f90
new file mode 100644
index 0000000..97f6062
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/forall_13.f90
@@ -0,0 +1,14 @@
+! { dg-do run }
+! Tests the fix for PR33686, in which dependencies were not
+! correctly handled for the assignments below.
+!
+! Contributed by Dick Hendrickson on comp.lang.fortran,
+! " Most elegant syntax for inverting a permutation?" 20071006
+!
+  integer :: p(4) = (/2,4,1,3/)
+  forall (i = 1:4) p(p(i)) = i                ! This was the original
+  if (any (p .ne. (/3,1,4,2/))) call abort ()
+
+  forall (i = 1:4) p(5 - p(i)) = p(5 - i)     ! This is a more complicated version
+  if (any (p .ne. (/1,2,3,4/))) call abort ()
+end