re PR fortran/29389 (Statement functions are not recognized as pure when they are)

2007-11-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29389
	*resolve.c (resolve_ordinary_assign): Use find_sym_in_expr to
	test if a temporary should be written for a vector subscript
	on the lhs.

	PR fortran/33850
	* restore.c (pure_stmt_function): Add prototype and new
	function. Calls impure_stmt_fcn.
	(pure_function): Call it.
	(impure_stmt_fcn): New function.

	* expr.c (gfc_traverse_expr): Call *func for all expression
	types, not just variables. Add traversal of character lengths,
	iterators and component character lengths and arrayspecs.
	(expr_set_symbols_referenced): Return false if not a variable.
	* trans-stmt.c (forall_replace, forall_restore): Ditto.
	* resolve.c (forall_index): Ditto.
	(sym_in_expr): New function.
	(find_sym_in_expr): Rewrite to traverse expression calling
	sym_in_expr.
	*trans-decl.c (expr_decls): New function.
	(generate_expr_decls): Rewrite to traverse expression calling
	expr_decls.
	*match.c (check_stmt_fcn): New function.
	(recursive_stmt_fcn): Rewrite to traverse expression calling
	check_stmt_fcn.

2007-11-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29389
	* gfortran.dg/stfunc_6.f90: New test.

	PR fortran/33850
	* gfortran.dg/assign_10.f90: New test.

From-SVN: r130472

gcc/fortran/ChangeLog

 2007-11-27  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/29389
+	*resolve.c (resolve_ordinary_assign): Use find_sym_in_expr to
+	test if a temporary should be written for a vector subscript
+	on the lhs.
+
+	PR fortran/33850
+	* restore.c (pure_stmt_function): Add prototype and new
+	function. Calls impure_stmt_fcn.
+	(pure_function): Call it.
+	(impure_stmt_fcn): New function.
+
+	* expr.c (gfc_traverse_expr): Call *func for all expression
+	types, not just variables. Add traversal of character lengths,
+	iterators and component character lengths and arrayspecs.
+	(expr_set_symbols_referenced): Return false if not a variable.
+	* trans-stmt.c (forall_replace, forall_restore): Ditto.
+	* resolve.c (forall_index): Ditto.
+	(sym_in_expr): New function.
+	(find_sym_in_expr): Rewrite to traverse expression calling
+	sym_in_expr.
+	*trans-decl.c (expr_decls): New function.
+	(generate_expr_decls): Rewrite to traverse expression calling
+	expr_decls.
+	*match.c (check_stmt_fcn): New function.
+	(recursive_stmt_fcn): Rewrite to traverse expression calling
+	check_stmt_fcn.
+
+2007-11-27  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/33541
 	*interface.c (compare_actual_formal): Exclude assumed size
 	arrays from the possibility of scalar to array mapping.

gcc/fortran/expr.c

@@ -3010,14 +3010,18 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
   if (!expr)
     return false;
 
-  switch (expr->expr_type)
-    {
-    case EXPR_VARIABLE:
-      gcc_assert (expr->symtree->n.sym);
+  if ((*func) (expr, sym, &f))
+    return true;
 
-      if ((*func) (expr, sym, &f))
-	return true;
+  if (expr->ts.type == BT_CHARACTER
+	&& expr->ts.cl
+	&& expr->ts.cl->length
+	&& expr->ts.cl->length->expr_type != EXPR_CONSTANT
+	&& gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
+    return true;
 
+  switch (expr->expr_type)
+    {
     case EXPR_FUNCTION:
       for (args = expr->value.function.actual; args; args = args->next)
 	{
@@ -3026,6 +3030,7 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
 	}
       break;
 
+    case EXPR_VARIABLE:
     case EXPR_CONSTANT:
     case EXPR_NULL:
     case EXPR_SUBSTRING:
@@ -3034,7 +3039,21 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
     case EXPR_STRUCTURE:
     case EXPR_ARRAY:
       for (c = expr->value.constructor; c; c = c->next)
-	gfc_expr_set_symbols_referenced (c->expr);
+	{
+	  if (gfc_traverse_expr (c->expr, sym, func, f))
+	    return true;
+	  if (c->iterator)
+	    {
+	      if (gfc_traverse_expr (c->iterator->var, sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (c->iterator->start, sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (c->iterator->end, sym, func, f))
+		return true;
+	      if (gfc_traverse_expr (c->iterator->step, sym, func, f))
+		return true;
+	    }
+	}
       break;
 
     case EXPR_OP:
@@ -3074,8 +3093,27 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
 	    return true;
 	  break;
 
-	  case REF_COMPONENT:
-	    break;
+	case REF_COMPONENT:
+	  if (ref->u.c.component->ts.type == BT_CHARACTER
+		&& ref->u.c.component->ts.cl
+		&& ref->u.c.component->ts.cl->length
+		&& ref->u.c.component->ts.cl->length->expr_type
+		     != EXPR_CONSTANT
+		&& gfc_traverse_expr (ref->u.c.component->ts.cl->length,
+				      sym, func, f))
+	    return true;
+
+	  if (ref->u.c.component->as)
+	    for (i = 0; i < ref->u.c.component->as->rank; i++)
+	      {
+		if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
+				       sym, func, f))
+		  return true;
+		if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
+				       sym, func, f))
+		  return true;
+	      }
+	  break;
 
 	default:
 	  gcc_unreachable ();
@@ -3092,6 +3130,8 @@ expr_set_symbols_referenced (gfc_expr *expr,
 			     gfc_symbol *sym ATTRIBUTE_UNUSED,
 			     int *f ATTRIBUTE_UNUSED)
 {
+  if (expr->expr_type != EXPR_VARIABLE)
+    return false;
   gfc_set_sym_referenced (expr->symtree->n.sym);
   return false;
 }

gcc/fortran/match.c

@@ -3209,13 +3209,12 @@ cleanup:
    12.5.4 requires that any variable of function that is implicitly typed
    shall have that type confirmed by any subsequent type declaration.  The
    implicit typing is conveniently done here.  */
+static bool
+recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
 
 static bool
-recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
 {
-  gfc_actual_arglist *arg;
-  gfc_ref *ref;
-  int i;
 
   if (e == NULL)
     return false;
@@ -3223,12 +3222,6 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
   switch (e->expr_type)
     {
     case EXPR_FUNCTION:
-      for (arg = e->value.function.actual; arg; arg = arg->next)
-	{
-	  if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
-	    return true;
-	}
-
       if (e->symtree == NULL)
 	return false;
 
@@ -3255,46 +3248,18 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
 	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
       break;
 
-    case EXPR_OP:
-      if (recursive_stmt_fcn (e->value.op.op1, sym)
-	  || recursive_stmt_fcn (e->value.op.op2, sym))
-	return true;
-      break;
-
     default:
       break;
     }
 
-  /* Component references do not need to be checked.  */
-  if (e->ref)
-    {
-      for (ref = e->ref; ref; ref = ref->next)
-	{
-	  switch (ref->type)
-	    {
-	    case REF_ARRAY:
-	      for (i = 0; i < ref->u.ar.dimen; i++)
-		{
-		  if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
-		      || recursive_stmt_fcn (ref->u.ar.end[i], sym)
-		      || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
-		    return true;
-		}
-	      break;
-
-	    case REF_SUBSTRING:
-	      if (recursive_stmt_fcn (ref->u.ss.start, sym)
-		  || recursive_stmt_fcn (ref->u.ss.end, sym))
-		return true;
+  return false;
+}
 
-	      break;
 
-	    default:
-	      break;
-	    }
-	}
-    }
-  return false;
+static bool
+recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+{
+  return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
 }
 
 

gcc/fortran/resolve.c

@@ -1665,6 +1665,8 @@ is_external_proc (gfc_symbol *sym)
 /* Figure out if a function reference is pure or not.  Also set the name
    of the function for a potential error message.  Return nonzero if the
    function is PURE, zero if not.  */
+static int
+pure_stmt_function (gfc_expr *, gfc_symbol *);
 
 static int
 pure_function (gfc_expr *e, const char **name)
@@ -1676,7 +1678,7 @@ pure_function (gfc_expr *e, const char **name)
   if (e->symtree != NULL
         && e->symtree->n.sym != NULL
         && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
-    return 1;
+    return pure_stmt_function (e, e->symtree->n.sym);
 
   if (e->value.function.esym)
     {
@@ -1700,6 +1702,31 @@ pure_function (gfc_expr *e, const char **name)
 }
 
 
+static bool
+impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
+		 int *f ATTRIBUTE_UNUSED)
+{
+  const char *name;
+
+  /* Don't bother recursing into other statement functions
+     since they will be checked individually for purity.  */
+  if (e->expr_type != EXPR_FUNCTION
+	|| !e->symtree
+	|| e->symtree->n.sym == sym
+	|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
+    return false;
+
+  return pure_function (e, &name) ? false : true;
+}
+
+
+static int
+pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
+{
+  return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
+}
+
+
 static try
 is_scalar_expr_ptr (gfc_expr *expr)
 {
@@ -4369,8 +4396,9 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
 static bool
 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
 {
-  gcc_assert (expr->expr_type == EXPR_VARIABLE);
-
+  if (expr->expr_type != EXPR_VARIABLE)
+    return false;
+  
   /* A scalar assignment  */
   if (!expr->ref || *f == 1)
     {
@@ -4552,85 +4580,20 @@ resolve_deallocate_expr (gfc_expr *e)
 }
 
 
-/* Returns true if the expression e contains a reference the symbol sym.  */
+/* Returns true if the expression e contains a reference to the symbol sym.  */
 static bool
-find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
 {
-  gfc_actual_arglist *arg;
-  gfc_ref *ref;
-  int i;
-  bool rv = false;
-
-  if (e == NULL)
-    return rv;
-
-  switch (e->expr_type)
-    {
-    case EXPR_FUNCTION:
-      for (arg = e->value.function.actual; arg; arg = arg->next)
-	rv = rv || find_sym_in_expr (sym, arg->expr);
-      break;
-
-    /* If the variable is not the same as the dependent, 'sym', and
-       it is not marked as being declared and it is in the same
-       namespace as 'sym', add it to the local declarations.  */
-    case EXPR_VARIABLE:
-      if (sym == e->symtree->n.sym)
-	return true;
-      break;
-
-    case EXPR_OP:
-      rv = rv || find_sym_in_expr (sym, e->value.op.op1);
-      rv = rv || find_sym_in_expr (sym, e->value.op.op2);
-      break;
-
-    default:
-      break;
-    }
-
-  if (e->ref)
-    {
-      for (ref = e->ref; ref; ref = ref->next)
-	{
-	  switch (ref->type)
-	    {
-	    case REF_ARRAY:
-	      for (i = 0; i < ref->u.ar.dimen; i++)
-		{
-		  rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
-		  rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
-		  rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
-		}
-	      break;
-
-	    case REF_SUBSTRING:
-	      rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
-	      rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
-	      break;
+  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
+    return true;
 
-	    case REF_COMPONENT:
-	      if (ref->u.c.component->ts.type == BT_CHARACTER
-		  && ref->u.c.component->ts.cl->length->expr_type
-		     != EXPR_CONSTANT)
-		rv = rv
-		     || find_sym_in_expr (sym,
-					  ref->u.c.component->ts.cl->length);
+  return false;
+}
 
-	      if (ref->u.c.component->as)
-		for (i = 0; i < ref->u.c.component->as->rank; i++)
-		  {
-		    rv = rv
-			 || find_sym_in_expr (sym,
-					      ref->u.c.component->as->lower[i]);
-		    rv = rv
-			 || find_sym_in_expr (sym,
-					      ref->u.c.component->as->upper[i]);
-		  }
-	      break;
-	    }
-	}
-    }
-  return rv;
+static bool
+find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+{
+  return gfc_traverse_expr (e, sym, sym_in_expr, 0);
 }
 
 
@@ -5970,14 +5933,16 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
     }
 
   /* Ensure that a vector index expression for the lvalue is evaluated
-     to a temporary.  */
+     to a temporary if the lvalue symbol is referenced in it.  */
   if (lhs->rank)
     {
       for (ref = lhs->ref; ref; ref= ref->next)
 	if (ref->type == REF_ARRAY)
 	  {
 	    for (n = 0; n < ref->u.ar.dimen; n++)
-	      if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+	      if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
+		    && find_sym_in_expr (lhs->symtree->n.sym,
+					 ref->u.ar.start[n]))
 		ref->u.ar.start[n]
 			= gfc_get_parentheses (ref->u.ar.start[n]);
 	  }

gcc/fortran/trans-decl.c

@@ -2893,80 +2893,26 @@ gfc_generate_contained_functions (gfc_namespace * parent)
 static void
 generate_local_decl (gfc_symbol *);
 
-static void
-generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
-{
-  gfc_actual_arglist *arg;
-  gfc_ref *ref;
-  int i;
-
-  if (e == NULL)
-    return;
-
-  switch (e->expr_type)
-    {
-    case EXPR_FUNCTION:
-      for (arg = e->value.function.actual; arg; arg = arg->next)
-	generate_expr_decls (sym, arg->expr);
-      break;
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
 
-    /* If the variable is not the same as the dependent, 'sym', and
-       it is not marked as being declared and it is in the same
-       namespace as 'sym', add it to the local declarations.  */
-    case EXPR_VARIABLE:
-      if (sym == e->symtree->n.sym
+static bool
+expr_decls (gfc_expr *e, gfc_symbol *sym,
+	    int *f ATTRIBUTE_UNUSED)
+{
+  if (e->expr_type != EXPR_VARIABLE
+	    || sym == e->symtree->n.sym
 	    || e->symtree->n.sym->mark
 	    || e->symtree->n.sym->ns != sym->ns)
-	return;
-
-      generate_local_decl (e->symtree->n.sym);
-      break;
-
-    case EXPR_OP:
-      generate_expr_decls (sym, e->value.op.op1);
-      generate_expr_decls (sym, e->value.op.op2);
-      break;
-
-    default:
-      break;
-    }
-
-  if (e->ref)
-    {
-      for (ref = e->ref; ref; ref = ref->next)
-	{
-	  switch (ref->type)
-	    {
-	    case REF_ARRAY:
-	      for (i = 0; i < ref->u.ar.dimen; i++)
-		{
-		  generate_expr_decls (sym, ref->u.ar.start[i]);
-		  generate_expr_decls (sym, ref->u.ar.end[i]);
-		  generate_expr_decls (sym, ref->u.ar.stride[i]);
-		}
-	      break;
+	return false;
 
-	    case REF_SUBSTRING:
-	      generate_expr_decls (sym, ref->u.ss.start);
-	      generate_expr_decls (sym, ref->u.ss.end);
-	      break;
+  generate_local_decl (e->symtree->n.sym);
+  return false;
+}
 
-	    case REF_COMPONENT:
-	      if (ref->u.c.component->ts.type == BT_CHARACTER
-		    && ref->u.c.component->ts.cl->length->expr_type
-						!= EXPR_CONSTANT)
-		generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
-
-	      if (ref->u.c.component->as)
-	        for (i = 0; i < ref->u.c.component->as->rank; i++)
-		  {
-		    generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
-		    generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
-		  }
-	      break;
-	    }
-	}
-    }
+static void
+generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
+{
+  gfc_traverse_expr (e, sym, expr_decls, 0);
 }
 
 

gcc/fortran/trans-stmt.c

@@ -1523,7 +1523,8 @@ 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 (expr->expr_type != EXPR_VARIABLE)
+    return false;
 
   if (*f == 2)
     *f = 1;
@@ -1544,7 +1545,8 @@ forall_restore (gfc_expr *expr,
 		gfc_symbol *sym ATTRIBUTE_UNUSED,
 		int *f ATTRIBUTE_UNUSED)
 {
-  gcc_assert (expr->expr_type == EXPR_VARIABLE);
+  if (expr->expr_type != EXPR_VARIABLE)
+    return false;
 
   if (expr->symtree == new_symtree)
     expr->symtree = old_symtree;

gcc/testsuite/ChangeLog

 2007-11-27  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/29389
+	* gfortran.dg/stfunc_6.f90: New test.
+
+	PR fortran/33850
+	* gfortran.dg/assign_10.f90: New test.
+
+2007-11-27  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/33541
 	* gfortran.dg/use_11.f90: New test.
 

gcc/testsuite/gfortran.dg/assign_10.f90

+! { dg-do run }
+! { dg-options "-O3 -fdump-tree-original" }
+! Tests the fix for PR33850, in which one of the two assignments
+! below would produce an unnecessary temporary for the index
+! expression, following the fix for PR33749.
+!
+! Contributed by Dick Hendrickson on comp.lang.fortran,
+! " Most elegant syntax for inverting a permutation?" 20071006
+!
+  integer(4) :: p4(4) = (/2,4,1,3/)
+  integer(4) :: q4(4) = (/2,4,1,3/)
+  integer(8) :: p8(4) = (/2,4,1,3/)
+  integer(8) :: q8(4) = (/2,4,1,3/)
+  p4(q4) = (/(i, i = 1, 4)/)
+  q4(q4) = (/(i, i = 1, 4)/)
+  p8(q8) = (/(i, i = 1, 4)/)
+  q8(q8) = (/(i, i = 1, 4)/)
+  if (any(p4 .ne. q4)) call abort ()
+  if (any(p8 .ne. q8)) call abort ()
+end
+! Whichever is the default length for array indices will yield
+! parm 9 times, because a temporary is not necessary.  The other
+! cases will all yield a temporary, so that atmp appears 27 times.
+! Note that it is the kind conversion that generates the temp.
+!
+! { dg-final { scan-tree-dump-times "parm" 9 "original" } }
+! { dg-final { scan-tree-dump-times "atmp" 27 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/stfunc_6.f90

+! { dg-do compile }
+! Tests the fix for the second bit of PR29389, in which the
+! statement function would not be recognised as not PURE
+! when it referenced a procedure that is not PURE.
+!
+! This is based on stfunc_4.f90 with the statement function made
+! impure by a reference to 'v'.
+!
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+  INTEGER :: st1, i = 99, a(4), q = 6
+  st1 (i) = i * i * i 
+  FORALL(i=1:4) a(i) = st1 (i) 
+  FORALL(i=1:4) a(i) = u (a(i)) - a(i)** 2 
+  if (any (a .ne. 0)) call abort ()
+  if (i .ne. 99) call abort ()
+contains
+  pure integer function u (x)
+    integer,intent(in) :: x
+    st2 (i) = i * v(i) ! { dg-error "non-PURE procedure" }
+    u = st2(x)
+  end function
+  integer function v (x)
+    integer,intent(in) :: x
+    v = i
+  end function
+end