re PR fortran/46896 (Wrong code with transpose(a) passed to subroutine)

2011-01-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46896
	* trans-expr.c (gfc_conv_procedure_call): With a non-copying
	procedure argument (eg TRANSPOSE) use a temporary if there is
	any chance of aliasing due to host or use association.
	(arrayfunc_assign_needs_temporary): Correct logic for function
	results and do not use a temporary for implicitly PURE
	variables.  Use a temporary for Cray pointees.
	* symbol.c (gfc_add_save): Explicit SAVE not compatible with
	implicit pureness of containing procedure.
	* decl.c (match_old_style_init, gfc_match_data): Where decl
	would fail in PURE procedure, set implicit_pure to zero.
	* gfortran.h : Add implicit_pure to structure symbol_attr and
	add prototype for function gfc_implicit_pure.
	* expr.c (gfc_check_pointer_assign, gfc_check_vardef_context):
	Where decl would fail in PURE procedure, reset implicit_pure.
	* io.c (match_vtag, gfc_match_open, gfc_match_close,
	gfc_match_print, gfc_match_inquire, gfc_match_wait): The same.
	* match.c (gfc_match_critical, gfc_match_stopcode,
	sync_statement, gfc_match_allocate, gfc_match_deallocate): The
	same.
	* parse.c (decode_omp_directive): The same.
	(parse_contained): If not PURE, set implicit pure attribute.
	* resolve.c (resolve_formal_arglist, resolve_structure_cons,
	resolve_function, resolve_ordinary_assign) : The same.
	(gfc_implicit_pure): New function.
	* module.c (mio_symbol_attribute): Introduce AB_IMPLICIT_PURE
	to ab_attribute enum and use it in this function.

2011-01-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46896
	* gfortran.dg/transpose_optimization_2.f90 : New test.

From-SVN: r168600

1 files changed, 72 insertions, 1 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1d8a7b6..fec84cc 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1,5 +1,6 @@
 /* Perform type resolution on the various structures.
-   Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+   2010, 2011
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -273,6 +274,9 @@ resolve_formal_arglist (gfc_symbol *proc)
 	      continue;
 	    }
 
+	  if (proc->attr.implicit_pure && !gfc_pure(sym))
+	    proc->attr.implicit_pure = 0;
+
 	  if (gfc_elemental (proc))
 	    {
 	      gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
@@ -345,6 +349,16 @@ resolve_formal_arglist (gfc_symbol *proc)
 		       &sym->declared_at);
 	}
 
+      if (proc->attr.implicit_pure && !sym->attr.pointer
+	  && sym->attr.flavor != FL_PROCEDURE)
+	{
+	  if (proc->attr.function && sym->attr.intent != INTENT_IN)
+	    proc->attr.implicit_pure = 0;
+
+	  if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+	    proc->attr.implicit_pure = 0;
+	}
+
       if (gfc_elemental (proc))
 	{
 	  /* F2008, C1289.  */
@@ -1124,6 +1138,12 @@ resolve_structure_cons (gfc_expr *expr, int init)
 		     comp->name, &cons->expr->where);
 	}
 
+      if (gfc_implicit_pure (NULL)
+	    && cons->expr->expr_type == EXPR_VARIABLE
+	    && (gfc_impure_variable (cons->expr->symtree->n.sym)
+		|| gfc_is_coindexed (cons->expr)))
+	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
     }
 
   return t;
@@ -3067,6 +3087,9 @@ resolve_function (gfc_expr *expr)
 	}
     }
 
+  if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
+    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
   /* Functions without the RECURSIVE attribution are not allowed to
    * call themselves.  */
   if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
@@ -8812,6 +8835,26 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 	}
     }
 
+  if (gfc_implicit_pure (NULL))
+    {
+      if (lhs->expr_type == EXPR_VARIABLE
+	    && lhs->symtree->n.sym != gfc_current_ns->proc_name
+	    && lhs->symtree->n.sym->ns != gfc_current_ns)
+	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+      if (lhs->ts.type == BT_DERIVED
+	    && lhs->expr_type == EXPR_VARIABLE
+	    && lhs->ts.u.derived->attr.pointer_comp
+	    && rhs->expr_type == EXPR_VARIABLE
+	    && (gfc_impure_variable (rhs->symtree->n.sym)
+		|| gfc_is_coindexed (rhs)))
+	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+      /* Fortran 2008, C1283.  */
+      if (gfc_is_coindexed (lhs))
+	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+    }
+
   /* F03:7.4.1.2.  */
   /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
      and coindexed; cf. F2008, 7.2.1.2 and PR 43366.  */
@@ -12764,6 +12807,34 @@ gfc_pure (gfc_symbol *sym)
 }
 
 
+/* Test whether a symbol is implicitly pure or not.  For a NULL pointer,
+   checks if the current namespace is implicitly pure.  Note that this
+   function returns false for a PURE procedure.  */
+
+int
+gfc_implicit_pure (gfc_symbol *sym)
+{
+  symbol_attribute attr;
+
+  if (sym == NULL)
+    {
+      /* Check if the current namespace is implicit_pure.  */
+      sym = gfc_current_ns->proc_name;
+      if (sym == NULL)
+	return 0;
+      attr = sym->attr;
+      if (attr.flavor == FL_PROCEDURE
+	    && attr.implicit_pure && !attr.pure)
+	return 1;
+      return 0;
+    }
+
+  attr = sym->attr;
+
+  return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
+}
+
+
 /* Test whether the current procedure is elemental or not.  */
 
 int