[Patch, fortran] PR31205 - aliased operator assignment produces wrong result

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

:ADDPATCH fortran:

This one was 'fun'!  Neither aliased lhs and rhs in operator
assignments, nor INTENT(IN) actual arguments, aliased with an
INTENT(OUT) argument, would produce the correct result, if the
argument was a derived type with a default initializer.

The steps taken to fix this problem were:

(i) Generate a temporary for the rhs/INTENT(IN), using
gfc_get_parentheses.  This required a bit of improvement to this
function; resolving the argument and checking for references with
non-numeric expressions.  I believe that this latter will be
unnecessary when I complete the character patch (next week's task) and
will update accordingly.

(ii) Remove the initialization of derived types with a default
initializer from the caller to the callee.  The reasons for doing this
are discussed in the PR.  It has a gratifying effect on passing
derived types with allocatable components, in that the amount of
generated code goes down (see alloc_comp_basics_1.f90).

Note (i) involved what I believe is a misinterpretation of the
standard - see the comment and the relevant paragraph in the standard
(7.1.7.2).

The testcase is the reporter's.

Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk?

Paul

2007-06-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31205
	* trans-expr.c (gfc_conv_function_call): Remove the default
	initialization of intent(out) derived types.
	* symbol.c (gfc_lval_expr_from_sym): New function.
	* matchexp.c (gfc_get_parentheses): Rsolve argument expression
	and return argument, if it is not numeric and posseses a ref.
	* gfortran.h : Add prototype for gfc_lval_expr_from_sym.
	* resolve.c (has_default_initializer): Move higher up in file.
	(resolve_code): On detecting an interface assignment, check
	if the rhs and the lhs are the same symbol.  If this is so,
	enclose the rhs in parenetheses to generate a temporary and
	prevent any possible aliasing.
	(apply_default_init): Remove code making the lval and call
	gfc_lval_expr_from_sym instead.
	* trans-decl.c (gfc_trans_deferred_vars): Apply the a default
	initializer, if any, to an intent(out) derived type, using
	gfc_lval_expr_from_sym and gfc_trans_assignment.  Check if
	the dummy is present.


2007-06-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31205
	* gfortran.dg/alloc_comp_basics_1.f90 : Restore number of
	"deallocates" to 24, since patch has code rid of much spurious
	code.
	* gfortran.dg/interface_assignment_1.f90 : New test.

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 126090)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2186,17 +2186,6 @@ gfc_conv_function_call (gfc_se * se, gfc
 		    && fsym->attr.optional)
 		gfc_conv_missing_dummy (&parmse, e, fsym->ts);
 
-	      /* If an INTENT(OUT) dummy of derived type has a default
-		 initializer, it must be (re)initialized here.  */
-	      if (fsym->attr.intent == INTENT_OUT
-		    && fsym->ts.type == BT_DERIVED
-		    && fsym->value)
-		{
-		  gcc_assert (!fsym->attr.allocatable);
-		  tmp = gfc_trans_assignment (e, fsym->value, false);
-		  gfc_add_expr_to_block (&se->pre, tmp);
-		}
-
 	      /* Obtain the character length of an assumed character
 		 length procedure from the typespec.  */
 	      if (fsym->ts.type == BT_CHARACTER
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 126090)
+++ gcc/fortran/symbol.c	(working copy)
@@ -1857,6 +1857,35 @@ done:
 }
 
 
+/*******A helper function for creating new expressions*************/
+
+
+gfc_expr *
+gfc_lval_expr_from_sym (gfc_symbol *sym)
+{
+  gfc_expr *lval;
+  lval = gfc_get_expr ();
+  lval->expr_type = EXPR_VARIABLE;
+  lval->where = sym->declared_at;
+  lval->ts = sym->ts;
+  lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+
+  /* It will always be a full array.  */
+  lval->rank = sym->as ? sym->as->rank : 0;
+  if (lval->rank)
+    {
+      lval->ref = gfc_get_ref ();
+      lval->ref->type = REF_ARRAY;
+      lval->ref->u.ar.type = AR_FULL;
+      lval->ref->u.ar.dimen = lval->rank;
+      lval->ref->u.ar.where = sym->declared_at;
+      lval->ref->u.ar.as = sym->as;
+    }
+
+  return lval;
+}
+
+
 /************** Symbol table management subroutines ****************/
 
 /* Basic details: Fortran 95 requires a potentially unlimited number
Index: gcc/fortran/matchexp.c
===================================================================
--- gcc/fortran/matchexp.c	(revision 126090)
+++ gcc/fortran/matchexp.c	(working copy)
@@ -130,6 +130,11 @@ gfc_expr *
 gfc_get_parentheses (gfc_expr *e)
 {
   gfc_expr *e2;
+  if (gfc_resolve_expr (e) == FAILURE)
+    return e;
+  
+  if (!gfc_numeric_ts (&e->ts) && e->ref)
+    return e;
 
   e2 = gfc_get_expr();
   e2->expr_type = EXPR_OP;
@@ -181,13 +186,9 @@ match_primary (gfc_expr **result)
     gfc_error ("Expected a right parenthesis in expression at %C");
 
   /* Now we have the expression inside the parentheses, build the
-     expression pointing to it. By 7.1.7.2 the integrity of
-     parentheses is only conserved in numerical calculations, so we
-     don't bother to keep the parentheses otherwise.  */
-  if(!gfc_numeric_ts(&e->ts))
-    *result = e;
-  else
-    *result = gfc_get_parentheses (e);
+     expression pointing to it. By 7.1.7.2, any expression in
+     parentheses shall be treated as a data entity.  */
+  *result = gfc_get_parentheses (e);
 
   if (m != MATCH_YES)
     {
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 126090)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2007,6 +2007,8 @@ void gfc_free_st_label (gfc_st_label *);
 void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *);
 try gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
 
+gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
+
 gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
 gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
 gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 126090)
+++ gcc/fortran/resolve.c	(working copy)
@@ -5112,6 +5112,21 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
 }
 
 
+static gfc_component *
+has_default_initializer (gfc_symbol *der)
+{
+  gfc_component *c;
+  for (c = der->components; c; c = c->next)
+    if ((c->ts.type != BT_DERIVED && c->initializer)
+        || (c->ts.type == BT_DERIVED
+              && !c->pointer
+              && has_default_initializer (c->ts.derived)))
+      break;
+
+  return c;
+}
+
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -5231,6 +5246,9 @@ resolve_code (gfc_code *code, gfc_namesp
 
 	  if (gfc_extend_assign (code, ns) == SUCCESS)
 	    {
+	      gfc_expr *lhs = code->ext.actual->expr;
+	      gfc_expr *rhs = code->ext.actual->next->expr;
+
 	      if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
 		{
 		  gfc_error ("Subroutine '%s' called instead of assignment at "
@@ -5238,6 +5256,15 @@ resolve_code (gfc_code *code, gfc_namesp
 			     &code->loc);
 		  break;
 		}
+
+	      /* Make a temporary rhs when there is a default initializer
+		 and rhs is the same symbol as the lhs.  */
+	      if (rhs->expr_type == EXPR_VARIABLE
+		    && rhs->symtree->n.sym->ts.type == BT_DERIVED
+		    && has_default_initializer (rhs->symtree->n.sym->ts.derived)
+		    && (lhs->symtree->n.sym == rhs->symtree->n.sym))
+	        code->ext.actual->next->expr = gfc_get_parentheses (rhs);
+
 	      goto call;
 	    }
 
@@ -5615,23 +5642,7 @@ apply_default_init (gfc_symbol *sym)
     }
 
   /* Build an l-value expression for the result.  */
-  lval = gfc_get_expr ();
-  lval->expr_type = EXPR_VARIABLE;
-  lval->where = sym->declared_at;
-  lval->ts = sym->ts;
-  lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
-
-  /* It will always be a full array.  */
-  lval->rank = sym->as ? sym->as->rank : 0;
-  if (lval->rank)
-    {
-      lval->ref = gfc_get_ref ();
-      lval->ref->type = REF_ARRAY;
-      lval->ref->u.ar.type = AR_FULL;
-      lval->ref->u.ar.dimen = lval->rank;
-      lval->ref->u.ar.where = sym->declared_at;
-      lval->ref->u.ar.as = sym->as;
-    }
+  lval = gfc_lval_expr_from_sym (sym);
 
   /* Add the code at scope entry.  */
   init_st = gfc_get_code ();
@@ -5687,21 +5698,6 @@ resolve_fl_var_and_proc (gfc_symbol *sym
 }
 
 
-static gfc_component *
-has_default_initializer (gfc_symbol *der)
-{
-  gfc_component *c;
-  for (c = der->components; c; c = c->next)
-    if ((c->ts.type != BT_DERIVED && c->initializer)
-        || (c->ts.type == BT_DERIVED
-              && !c->pointer
-              && has_default_initializer (c->ts.derived)))
-      break;
-
-  return c;
-}
-
-
 /* Resolve symbols with flavor variable.  */
 
 static try
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 126090)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -2707,12 +2707,35 @@ gfc_trans_deferred_vars (gfc_symbol * pr
   gfc_init_block (&body);
 
   for (f = proc_sym->formal; f; f = f->next)
-    if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
-      {
-	gcc_assert (f->sym->ts.cl->backend_decl != NULL);
-	if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
-	  gfc_trans_vla_type_sizes (f->sym, &body);
-      }
+    {
+      if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+	{
+	  gcc_assert (f->sym->ts.cl->backend_decl != NULL);
+	  if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
+	    gfc_trans_vla_type_sizes (f->sym, &body);
+	}
+
+      /* If an INTENT(OUT) dummy of derived type has a default
+	 initializer, it must be initialized here.  */
+      if (f->sym && f->sym->attr.referenced
+	    && f->sym->attr.intent == INTENT_OUT
+	    && f->sym->ts.type == BT_DERIVED
+	    && !f->sym->ts.derived->attr.alloc_comp
+	    && f->sym->value)
+	{
+	  gfc_expr *tmpe;
+	  tree tmp, present;
+	  gcc_assert (!f->sym->attr.allocatable);
+	  tmpe = gfc_lval_expr_from_sym (f->sym);
+	  tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
+
+	  present = gfc_conv_expr_present (f->sym);
+	  tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+			tmp, build_empty_stmt ());
+	  gfc_add_expr_to_block (&body, tmp);
+	  gfc_free_expr (tmpe);
+	}
+    }
 
   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
       && current_fake_result_decl != NULL)
Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90	(revision 126090)
+++ gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90	(working copy)
@@ -139,6 +139,6 @@ contains
     end subroutine check_alloc2
 
 end program alloc
-! { dg-final { scan-tree-dump-times "deallocate" 33 "original" } }
+! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 ! { dg-final { cleanup-modules "alloc_m" } }
Index: gcc/testsuite/gfortran.dg/interface_assignment_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_assignment_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/interface_assignment_1.f90	(revision 0)
@@ -0,0 +1,39 @@
+! { dg-do run }
+! Checks the fix for PR31205, in which temporaries were not
+! written for the interface assignment and the parentheses below.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+MODULE TT
+ TYPE data_type
+   INTEGER :: I=2
+ END TYPE data_type
+ INTERFACE ASSIGNMENT (=)
+   MODULE PROCEDURE set
+ END INTERFACE
+CONTAINS
+  PURE SUBROUTINE set(x1,x2)
+    TYPE(data_type), INTENT(IN) :: x2
+    TYPE(data_type), INTENT(OUT) :: x1
+    CALL S1(x1,x2)
+  END SUBROUTINE
+  PURE SUBROUTINE S1(x1,x2)
+    TYPE(data_type), INTENT(IN) :: x2
+    TYPE(data_type), INTENT(OUT) :: x1
+    x1%i=x2%i
+  END SUBROUTINE
+END MODULE
+
+USE TT
+TYPE(data_type) :: D,E
+
+D%I=4
+D=D
+
+E%I=4
+CALL set(E,(E))
+
+IF (D%I.NE.4) call abort ()
+IF (4.NE.E%I) call abort ()
+END
+! { dg-final { cleanup-modules "TT" } }