[Patch, fortran] PR46897 - [OOP] type-bound defined ASSIGNMENT(=) not used for derived type component in intrinsic assign

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

Dear All,

Please find attached a patch and testcase for the above PR.  The
comment before generate_component_assignments explains the need for
the patch, which itself is fairly self explanatory.

Bootstrapped and regtested on Fc9/x86_64 - OK for trunk?

Best regards

Paul and Alessandro.

2012-08-13   Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
	     Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46897
	* resolve.c (add_comp_ref): New function.
	(generate_component_assignments): New function that calls
	add_comp_ref.
	(resolve_code): Call generate_component_assignments.

2012-08-13   Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
	     Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46897
	* gfortran.dg/defined_assignment_1.f90: New test.

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 190338)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_ordinary_assign (gfc_code *code,
*** 9485,9490 ****
--- 9485,9614 ----
  }
  
  
+ /* Add a component reference onto an expression.  */
+ 
+ static void
+ add_comp_ref (gfc_expr *e, gfc_component *c)
+ {
+   gfc_ref **ref;
+   ref = &(e->ref);
+   while (*ref)
+     ref = &((*ref)->next);
+   *ref = gfc_get_ref();
+   (*ref)->type = REF_COMPONENT;
+   (*ref)->u.c.sym = c->ts.u.derived;
+   (*ref)->u.c.component = c;
+   e->ts = c->ts;
+ }
+ 
+ 
+ /* Implement 7.2.1.3 of the F08 standard:
+    "An intrinsic assignment where the variable is of derived type is
+    performed as if each component of the variable were assigned from the
+    corresponding component of expr using pointer assignment (7.2.2) for
+    each pointer component, deïned assignment for each nonpointer
+    nonallocatable component of a type that has a type-bound deïned
+    assignment consistent with the component, intrinsic assignment for
+    each other nonpointer nonallocatable component, ..." 
+ 
+    The pointer assignments are taken care of by the intrinsic
+    assignment of the structure itself.  This function recursively adds
+    defined assignments where required.  */
+ 
+ static void
+ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
+ {
+   gfc_component *comp1, *comp2;
+   gfc_code *this_code, *next, *root, *previous;
+ 
+   /* Filter out continuing processing after an error.  */
+   if ((*code)->expr1->ts.type != BT_DERIVED
+       || (*code)->expr2->ts.type != BT_DERIVED)
+     return;
+ 
+   comp1 = (*code)->expr1->ts.u.derived->components;
+   comp2 = (*code)->expr2->ts.u.derived->components;
+ 
+   for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
+     {
+       if (comp1->ts.type != BT_DERIVED
+ 	  || comp1->ts.u.derived == NULL
+ 	  || (comp1->attr.pointer || comp1->attr.allocatable)
+ 	  || (*code)->expr1->ts.u.derived == comp1->ts.u.derived)
+ 	continue;
+ 
+       /* Make an assigment for this component.  */
+       this_code = gfc_get_code ();
+       this_code->op = EXEC_ASSIGN;
+       this_code->next = NULL;
+       this_code->expr1 = gfc_copy_expr ((*code)->expr1);
+       this_code->expr2 = gfc_copy_expr ((*code)->expr2);
+ 
+       add_comp_ref (this_code->expr1, comp1);
+       add_comp_ref (this_code->expr2, comp2);
+ 
+       root = this_code;
+ 
+       /* Convert the assignment if there is a defined assignment for
+ 	 this type.  Otherwise, recurse into its components.  */
+       if (resolve_ordinary_assign (this_code, ns)
+ 	  && this_code->op == EXEC_COMPCALL)
+ 	resolve_typebound_subroutine (this_code);
+       else if (this_code && this_code->op == EXEC_ASSIGN)
+ 	generate_component_assignments (&this_code, ns);
+ 
+       previous = NULL;
+       this_code = root;
+ 
+       /* Go through the code chain eliminating all but calls to
+ 	 typebound procedures. Since we have been through
+ 	 resolve_typebound_subroutine. */
+       for (; this_code; this_code = this_code->next)
+ 	{
+ 	  if (this_code->op == EXEC_ASSIGN_CALL)
+ 	    {
+ 	      gfc_symbol *fsym = this_code->symtree->n.sym->formal->sym;
+ 	      /* Check that there is a defined assignment.  If so, then
+ 	         resolve the call.  */
+ 	      if (fsym->ts.type == BT_CLASS
+ 		  && CLASS_DATA (fsym)->ts.u.derived->f2k_derived
+ 		  && CLASS_DATA (fsym)->ts.u.derived->f2k_derived
+ 			->tb_op[INTRINSIC_ASSIGN])
+ 		{
+ 		  resolve_call (this_code);
+ 		  goto next;
+ 		}
+ 	    }
+ 
+ 	  next = this_code->next;
+ 	  if (this_code == root)
+ 	    root = next;
+ 	  else
+ 	    previous->next = next;
+ 
+ 	  next = this_code;
+ 	  next->next = NULL;
+ 	  gfc_free_statements (next);
+ 	next:
+ 	  previous = this_code;
+ 	}
+ 
+       /* Now attach the remaining code chain to the input code. Step on
+ 	 to the end of the new code since resolution is complete.  */
+       if (root)
+ 	{
+ 	  next = (*code)->next;
+ 	  (*code)->next = root;
+ 	  for (;root; root = root->next)
+ 	    if (!root->next)
+ 	      break;
+ 	  root->next = next;
+ 	  *code = root;
+ 	}
+    }
+ }
+ 
+ 
  /* Given a block of code, recursively resolve everything pointed to by this
     code block.  */
  
*************** resolve_code (gfc_code *code, gfc_namesp
*** 9647,9652 ****
--- 9771,9781 ----
  	      else
  		goto call;
  	    }
+ 
+ 	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
+ 	  if (code->expr1->ts.type == BT_DERIVED)
+ 	    generate_component_assignments (&code, ns);
+ 
  	  break;
  
  	case EXEC_LABEL_ASSIGN:
Index: gcc/testsuite/gfortran.dg/defined_assignment_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/defined_assignment_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/defined_assignment_1.f90	(revision 0)
***************
*** 0 ****
--- 1,90 ----
+ ! { dg-do run }
+ ! Test the fix for PR46897.
+ !
+ ! Contributed by Rouson Damian <rouson@sandia.gov>
+ !
+ module m0
+   implicit none
+   type component
+     integer :: i
+   contains
+     procedure :: assign0
+     generic :: assignment(=)=>assign0
+   end type
+   type parent
+     type(component) :: foo
+   end type
+   type, extends(parent) :: child
+     integer :: j
+   end type
+ contains
+   subroutine assign0(lhs,rhs)
+     class(component), intent(out) :: lhs
+     class(component), intent(in) :: rhs
+     lhs%i = 20
+   end subroutine 
+   type(child) function new_child()
+   end function
+ end module 
+ 
+ module m1
+   implicit none
+   type component
+     integer :: i
+   contains
+     procedure :: assign1
+     generic :: assignment(=)=>assign1
+   end type
+   type t
+     type(component) :: foo
+   end type
+ contains
+   subroutine assign1(lhs,rhs)
+     class(component), intent(out) :: lhs
+     class(component), intent(in) :: rhs
+     lhs%i = 21
+   end subroutine
+ end module
+ 
+ module m2
+   implicit none
+   type component2
+     integer :: i = 2
+   end type
+   interface assignment(=)
+     module procedure assign2
+   end interface
+   type t2
+     type(component2) :: foo
+   end type
+ contains
+   subroutine assign2(lhs,rhs)
+     type(component2), intent(out) :: lhs
+     type(component2), intent(in) :: rhs
+     lhs%i = 22
+   end subroutine
+ end module 
+ 
+ program main
+   use m0
+   use m1
+   use m2
+   implicit none
+   type(child) :: infant0
+   type(t) :: infant1, newchild1
+   type(t2) :: infant2, newchild2
+ 
+ ! Test the reported problem.
+   infant0 = new_child()
+   if (infant0%parent%foo%i .ne. 20) call abort
+ 
+ ! Test the case of comment #1 of the PR.
+   infant1 = newchild1
+   if (infant1%foo%i .ne. 21) call abort
+ 
+ ! Test the case of comment #2 of the PR.
+   infant2 = newchild2
+   if (infant2%foo%i .ne. 2) call abort
+ end
+ 
+