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

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 3653 bytes --]

:ADDPATCH fortran:

The first version of this patch was posted on
http://gcc.gnu.org/ml/fortran/2007-06/msg00526.html. FX reviewed and
OK'd it.  I was about to commit, when I thought that this was the sort
of patch that would break cp2k and this turned out to be true.....
Diagnosing the problem turned out to be a real head-ache but the fix
was easy and entirely associated with gfc_get_parentheses and its
resolution.  Look at the differences in matchexp.c and resolve.c
between the two patches.

Since the original posting, Tobias Burnus provoked me to go back to
some of the remaining bugs in the iso_varying_string testsuite by
Lawrie Schonfeld.  This patch fixes it and has resulted in a second
testcase (PR32842).

As I wrote originally, 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 work on this function to
checking for references with character expressions.  I believe that
this will be unnecessary when I complete the character patch ("next
week's task" Hah! I'm stuck on this one too but at the level of
weeding out old kludges that do not seem to want to be weeded out...)
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).  This version of the patch actually implements the
standard, up to the problem with characters, by making all expressions
in parentheses "data entities".

The first testcase is the reporter's for the original PR and the
second is described above.

This version allows compilation and execution of cp2k... phew!

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

Paul

2007-07-23 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-23 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.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr31205.diff --]
[-- Type: text/plain; name=pr31205.diff; charset=ANSI_X3.4-1968, Size: 14962 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(révision 126835)
--- gcc/fortran/trans-expr.c	(copie de travail)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2250,2266 ****
  		    && 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
--- 2250,2255 ----
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(révision 126835)
--- gcc/fortran/symbol.c	(copie de travail)
*************** done:
*** 1959,1964 ****
--- 1959,1993 ----
  }
  
  
+ /*******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	(révision 126835)
--- gcc/fortran/matchexp.c	(copie de travail)
*************** gfc_get_parentheses (gfc_expr *e)
*** 131,136 ****
--- 131,143 ----
  {
    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;
*************** match_primary (gfc_expr **result)
*** 181,193 ****
      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);
  
    if (m != MATCH_YES)
      {
--- 188,196 ----
      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, 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	(révision 126835)
--- gcc/fortran/gfortran.h	(copie de travail)
*************** void gfc_free_st_label (gfc_st_label *);
*** 2120,2125 ****
--- 2120,2127 ----
  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	(révision 126835)
--- gcc/fortran/resolve.c	(copie de travail)
*************** resolve_operator (gfc_expr *e)
*** 2928,2943 ****
  
        break;
  
      case INTRINSIC_NOT:
      case INTRINSIC_UPLUS:
      case INTRINSIC_UMINUS:
!     case INTRINSIC_PARENTHESES:
        e->rank = op1->rank;
  
        if (e->shape == NULL)
  	e->shape = gfc_copy_shape (op1->shape, op1->rank);
  
-       /* Simply copy arrayness attribute */
        break;
  
      default:
--- 2928,2951 ----
  
        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:
!       /* Simply copy arrayness attribute */
        e->rank = op1->rank;
  
        if (e->shape == NULL)
  	e->shape = gfc_copy_shape (op1->shape, op1->rank);
  
        break;
  
      default:
*************** gfc_resolve_blocks (gfc_code *b, gfc_nam
*** 5701,5706 ****
--- 5709,5729 ----
  }
  
  
+ 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.  */
  
*************** resolve_code (gfc_code *code, gfc_namesp
*** 5820,5825 ****
--- 5843,5851 ----
  
  	  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 "
*************** resolve_code (gfc_code *code, gfc_namesp
*** 5827,5832 ****
--- 5853,5867 ----
  			     &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;
  	    }
  
*************** apply_default_init (gfc_symbol *sym)
*** 6404,6426 ****
      }
  
    /* 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;
!     }
  
    /* Add the code at scope entry.  */
    init_st = gfc_get_code ();
--- 6439,6445 ----
      }
  
    /* Build an l-value expression for the result.  */
!   lval = gfc_lval_expr_from_sym (sym);
  
    /* Add the code at scope entry.  */
    init_st = gfc_get_code ();
*************** resolve_fl_var_and_proc (gfc_symbol *sym
*** 6473,6493 ****
  	 }
      }
    return SUCCESS;
- }
- 
- 
- 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;
  }
  
  
--- 6492,6497 ----
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(révision 126835)
--- gcc/fortran/trans-decl.c	(copie de travail)
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 2725,2736 ****
    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 (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
        && current_fake_result_decl != NULL)
--- 2725,2759 ----
    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 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	(révision 126835)
--- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90	(copie de travail)
*************** contains
*** 139,144 ****
      end subroutine check_alloc2
  
  end program alloc
! ! { dg-final { scan-tree-dump-times "deallocate" 33 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  ! { dg-final { cleanup-modules "alloc_m" } }
--- 139,144 ----
      end subroutine check_alloc2
  
  end program alloc
! ! { 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	(révision 0)
--- gcc/testsuite/gfortran.dg/interface_assignment_1.f90	(révision 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" } }
Index: gcc/testsuite/gfortran.dg/interface_assignment_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/interface_assignment_2.f90	(révision 0)
--- gcc/testsuite/gfortran.dg/interface_assignment_2.f90	(révision 0)
***************
*** 0 ****
--- 1,49 ----
+ ! { dg-do run }
+ ! Checks the fix for PR32842, in which the interface assignment
+ ! below caused a segfault.  This testcase is reduced from vst_2.f95
+ ! in the iso_varying_string testsuite, from Lawrie Schonfelder
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ module iso_varying_string
+   implicit none
+   integer, parameter :: GET_BUFFER_LEN = 256
+   type varying_string
+      character(LEN=1), dimension(:), allocatable :: chars
+   end type varying_string
+   interface assignment(=)
+      module procedure op_assign_VS_CH
+   end interface assignment(=)
+ contains
+   elemental subroutine op_assign_VS_CH (var, expr)
+     type(varying_string), intent(out) :: var
+     character(LEN=*), intent(in)      :: expr
+     var = var_str(expr)
+   end subroutine op_assign_VS_CH
+   elemental function var_str (chr) result (string)
+     character(LEN=*), intent(in) :: chr
+     type(varying_string)         :: string
+     integer                      :: length
+     integer                      :: i_char
+     length = LEN(chr)
+     ALLOCATE(string%chars(length))
+     forall(i_char = 1:length)
+        string%chars(i_char) = chr(i_char:i_char)
+     end forall
+   end function var_str
+ end module iso_varying_string
+ 
+ PROGRAM VST_2
+   USE ISO_VARYING_STRING
+   IMPLICIT NONE
+   CHARACTER(LEN=5)     :: char_arb(2)
+   CHARACTER(LEN=1)     :: char_elm(10)
+   equivalence (char_arb, char_elm)
+   type(VARYING_STRING) :: str_ara(2)
+   char_arb(1)= "Hello"
+   char_arb(2)= "World"
+   str_ara = char_arb
+   if (any (str_ara(1)%chars(1:5) .ne. char_elm(1:5))) call abort
+   if (any (str_ara(2)%chars(1:5) .ne. char_elm(6:10))) call abort
+ END PROGRAM VST_2
+ ! { dg-final { cleanup-modules "iso_varying_string" } }

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

[Tobias Burnus]

Hi all,

Paul Richard Thomas wrote:
> Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk?
OK. Thanks for the patch.

Tobias

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

[Paul Richard Thomas]

Tobias,

> OK. Thanks for the patch.

The deed is done -thanks

Paul

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

[Paul Thomas]

FX,

I had an opportunity to commit this patch last night but, given my new 
found ability so to do, I tested it on CP2K.  Needless to say, it broke 
it :-)

I therefore withdraw this patch and will resubmit when I have figured 
out what the problem is.

Thanks

Paul

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

[Paul Thomas]

FX,
>
> OK
It will have to wait until next weekend, I'm afraid
>
>>>     * gfortran.dg/alloc_comp_basics_1.f90 : Restore number of
>>>     "deallocates" to 24, since patch has code rid of much spurious
>>>     code.
>
> s/code/gotten/
>
>
s/gotten/got/

Paul

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

[FX Coudert]

>> 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.

OK

>>     * gfortran.dg/alloc_comp_basics_1.f90 : Restore number of
>>     "deallocates" to 24, since patch has code rid of much spurious
>>     code.

s/code/gotten/

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

[FX Coudert]

> 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.

Looks OK to me.

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

[Paul Thomas]

PING**0.5  (since I am not doing my share of reviewing right now :-( )

This is partly to remind myself but if anybody does have a bit of time 
to cast an eye over the patch, I'd be grateful.  This is a bit more 
intrusive than some of my recent one-liners.

Paul

PS I mention the character patch - I am just on that now.
> :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" } }
>   

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 2450 bytes --]

: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.

[-- Attachment #2: pr31205.diff --]
[-- Type: text/x-patch, Size: 9932 bytes --]

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