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

gcc/fortran/ChangeLog

+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

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,30 +3783,15 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
   actual->next = gfc_get_actual_arglist ();
   actual->next->expr = rhs;
 
-  sym = NULL;
-
-  for (; ns; ns = ns->parent)
-    {
-      sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
-      if (sym != NULL)
-	break;
-    }
-
   /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
 
-  if (sym == NULL)
-    {
-      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);
+  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)
     {
+      /* 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);
@@ -3816,25 +3799,32 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
       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;
+  /* 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);
+      if (sym != NULL)
+	break;
     }
 
-  /* Replace the assignment with the call.  */
+  if (sym)
+    {
+      /* 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;
+    }
+
+  /* Failure: No assignment procedure found.  */
+  free (actual->next);
+  free (actual);
+  return false;
 }
 
 

gcc/testsuite/ChangeLog

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

gcc/testsuite/gfortran.dg/typebound_assignment_7.f90

+! { 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" } }