re PR fortran/57843 ([OOP] Type-bound assignment is resolved to non-polymorphic procedure call)

2013-08-23  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/57843
	* interface.c (gfc_extend_assign): Look for type-bound assignment
	procedures before non-typebound.


2013-08-23  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/57843
	* gfortran.dg/typebound_assignment_7.f90: New.

From-SVN: r201946

4 files changed, 115 insertions, 48 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 122f6c6..35f970e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2013-08-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/57843
+	* interface.c (gfc_extend_assign): Look for type-bound assignment
+	procedures before non-typebound.
+
 2013-08-23  Mikael Morin  <mikael@gcc.gnu.org>
 
 	* trans-array.c (gfc_conv_section_startstride): Move &loop->pre access
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 9055cf5..aa88b3c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3754,20 +3754,18 @@ gfc_extend_expr (gfc_expr *e)
 }
 
 
-/* Tries to replace an assignment code node with a subroutine call to
-   the subroutine associated with the assignment operator.  Return
-   true if the node was replaced.  On false, no error is
-   generated.  */
+/* Tries to replace an assignment code node with a subroutine call to the
+   subroutine associated with the assignment operator. Return true if the node
+   was replaced. On false, no error is generated.  */
 
 bool
 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 {
   gfc_actual_arglist *actual;
-  gfc_expr *lhs, *rhs;
-  gfc_symbol *sym;
-  const char *gname;
-
-  gname = NULL;
+  gfc_expr *lhs, *rhs, *tb_base;
+  gfc_symbol *sym = NULL;
+  const char *gname = NULL;
+  gfc_typebound_proc* tbo;
 
   lhs = c->expr1;
   rhs = c->expr2;
@@ -3785,8 +3783,26 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
   actual->next = gfc_get_actual_arglist ();
   actual->next->expr = rhs;
 
-  sym = NULL;
+  /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
+
+  /* See if we find a matching type-bound assignment.  */
+  tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
+			       NULL, &gname);
+
+  if (tbo)
+    {
+      /* Success: Replace the expression with a type-bound call.  */
+      gcc_assert (tb_base);
+      c->expr1 = gfc_get_expr ();
+      build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
+      c->expr1->value.compcall.assign = 1;
+      c->expr1->where = c->loc;
+      c->expr2 = NULL;
+      c->op = EXEC_COMPCALL;
+      return true;
+    }
 
+  /* See if we find an 'ordinary' (non-typebound) assignment procedure.  */
   for (; ns; ns = ns->parent)
     {
       sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
@@ -3794,47 +3810,21 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 	break;
     }
 
-  /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
-
-  if (sym == NULL)
+  if (sym)
     {
-      gfc_typebound_proc* tbo;
-      gfc_expr* tb_base;
-
-      /* See if we find a matching type-bound assignment.  */
-      tbo = matching_typebound_op (&tb_base, actual,
-				   INTRINSIC_ASSIGN, NULL, &gname);
-
-      /* If there is one, replace the expression with a call to it and
-	 succeed.  */
-      if (tbo)
-	{
-	  gcc_assert (tb_base);
-	  c->expr1 = gfc_get_expr ();
-	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
-	  c->expr1->value.compcall.assign = 1;
-	  c->expr1->where = c->loc;
-	  c->expr2 = NULL;
-	  c->op = EXEC_COMPCALL;
-
-	  /* c is resolved from the caller, so no need to do it here.  */
-
-	  return true;
-	}
-
-      free (actual->next);
-      free (actual);
-      return false;
+      /* Success: Replace the assignment with the call.  */
+      c->op = EXEC_ASSIGN_CALL;
+      c->symtree = gfc_find_sym_in_symtree (sym);
+      c->expr1 = NULL;
+      c->expr2 = NULL;
+      c->ext.actual = actual;
+      return true;
     }
 
-  /* Replace the assignment with the call.  */
-  c->op = EXEC_ASSIGN_CALL;
-  c->symtree = gfc_find_sym_in_symtree (sym);
-  c->expr1 = NULL;
-  c->expr2 = NULL;
-  c->ext.actual = actual;
-
-  return true;
+  /* Failure: No assignment procedure found.  */
+  free (actual->next);
+  free (actual);
+  return false;
 }
 
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 47196da..5d9c3bb 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-08-23  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/57843
+	* gfortran.dg/typebound_assignment_7.f90: New.
+
 2013-08-23  Jan Hubicka  <jh@suse.cz>
 
 	* g++.dg/ipa/devirt-13.C: New testcase.
diff --git a/gcc/testsuite/gfortran.dg/typebound_assignment_7.f90 b/gcc/testsuite/gfortran.dg/typebound_assignment_7.f90
new file mode 100644
index 0000000..2c5b837
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_assignment_7.f90
@@ -0,0 +1,66 @@
+! { dg-do run }
+!
+! PR 57843: [OOP] Type-bound assignment is resolved to non-polymorphic procedure call
+!
+! Contributed by John <jwmwalrus@gmail.com>
+
+module mod1
+  implicit none
+  type :: itemType
+  contains
+    procedure :: the_assignment => assign_itemType
+    generic :: assignment(=) => the_assignment
+  end type
+contains
+  subroutine assign_itemType(left, right)
+    class(itemType), intent(OUT) :: left
+    class(itemType), intent(IN) :: right
+  end subroutine
+end module
+
+module mod2
+  use mod1
+  implicit none
+  type, extends(itemType) :: myItem
+    character(3) :: name = ''
+  contains
+    procedure :: the_assignment => assign_myItem
+  end type
+contains
+  subroutine assign_myItem(left, right)
+    class(myItem), intent(OUT) :: left
+    class(itemType), intent(IN) :: right
+    select type (right)
+    type is (myItem)
+      left%name = right%name
+    end select
+  end subroutine
+end module
+
+
+program test_assign
+
+  use mod2
+  implicit none
+
+  class(itemType), allocatable :: item1, item2
+
+  allocate (myItem :: item1)
+  select type (item1)
+    type is (myItem)
+      item1%name = 'abc'
+  end select
+
+  allocate (myItem :: item2)
+  item2 = item1
+
+  select type (item2)
+    type is (myItem)
+      if (item2%name /= 'abc') call abort()
+    class default
+      call abort()
+  end select
+
+end
+
+! { dg-final { cleanup-modules "mod1 mod2" } }