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

2 files changed, 44 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;
 }