re PR fortran/31205 (aliased operator assignment produces wrong result)

2007-07-24 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/31205
	PR fortran/32842
	* 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): Return argument, if it is
	character 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.
	(resolve_operator): Give a parentheses expression a type-
	spec if it has no type.
	* 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-07-24 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.

	PR fortran/32842
	* gfortran.dg/interface_assignment_2.f90 : New test.

From-SVN: r126885

gcc/fortran/ChangeLog

@@ -1,3 +1,27 @@
+2007-07-24 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/31205
+	PR fortran/32842
+	* 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): Return argument, if it is
+	character 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.
+	(resolve_operator): Give a parentheses expression a type-
+	spec if it has no type.
+	* 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-07-24  Daniel Franke  <franke.daniel@gmail.com>
 
 	PR fortran/32867

gcc/fortran/gfortran.h

@@ -2120,6 +2120,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 *);

gcc/fortran/matchexp.c

@@ -131,6 +131,13 @@ gfc_get_parentheses (gfc_expr *e)
 {
   gfc_expr *e2;
 
+  /* This is a temporary fix, awaiting the patch for various
+     other character problems.  The resolution and translation
+     of substrings and concatenations are so kludged up that
+     putting parentheses around them breaks everything.  */
+  if (e->ts.type == BT_CHARACTER && e->ref)
+    return e;
+
   e2 = gfc_get_expr();
   e2->expr_type = EXPR_OP;
   e2->ts = e->ts;
@@ -181,13 +188,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)
     {

gcc/fortran/resolve.c

@@ -2937,16 +2937,24 @@ resolve_operator (gfc_expr *e)
 
       break;
 
+    case INTRINSIC_PARENTHESES:
+
+      /*  This is always correct and sometimes necessary!  */
+      if (e->ts.type == BT_UNKNOWN)
+	e->ts = op1->ts;
+
+      if (e->ts.type == BT_CHARACTER && !e->ts.cl)
+	e->ts.cl = op1->ts.cl;
+
     case INTRINSIC_NOT:
     case INTRINSIC_UPLUS:
     case INTRINSIC_UMINUS:
-    case INTRINSIC_PARENTHESES:
+      /* Simply copy arrayness attribute */
       e->rank = op1->rank;
 
       if (e->shape == NULL)
 	e->shape = gfc_copy_shape (op1->shape, op1->rank);
 
-      /* Simply copy arrayness attribute */
       break;
 
     default:
@@ -5710,6 +5718,21 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 }
 
 
+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.  */
 
@@ -5829,6 +5852,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 
 	  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 "
@@ -5836,6 +5862,15 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 			     &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;
 	    }
 
@@ -6413,23 +6448,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 ();
@@ -6485,21 +6504,6 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 }
 
 
-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

gcc/fortran/symbol.c

@@ -1959,6 +1959,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

gcc/fortran/trans-decl.c

@@ -2725,12 +2725,35 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
   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)

gcc/fortran/trans-expr.c

@@ -2245,17 +2245,6 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		    && 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

gcc/testsuite/ChangeLog

@@ -1,3 +1,14 @@
+2007-07-24 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.
+
+	PR fortran/32842
+	* gfortran.dg/interface_assignment_2.f90 : New test.
+
 2007-07-24  Daniel Franke  <franke.daniel@gmail.com>
 
 	PR fortran/32867

gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90

@@ -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" } }