re PR fortran/43945 ([OOP] Derived type with GENERIC: resolved to the wrong specific TBP)

2010-06-05  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43945
	* resolve.c (get_declared_from_expr): Move to before
	resolve_typebound_generic_call.  Make new_ref and class_ref
	ignorable if set to NULL.
	(resolve_typebound_generic_call): Once we have resolved the
	generic call, check that the specific instance is that which
	is bound to the declared type.
	(resolve_typebound_function,resolve_typebound_subroutine): Avoid
	freeing 'class_ref->next' twice.


2010-06-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43945
	* gfortran.dg/generic_23.f03: New test.

Co-Authored-By: Janus Weil <janus@gcc.gnu.org>

From-SVN: r160335

1 files changed, 56 insertions, 42 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 48bb618..7e5a4f9 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5160,6 +5160,43 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
 }
 
 
+/* Get the ultimate declared type from an expression.  In addition,
+   return the last class/derived type reference and the copy of the
+   reference list.  */
+static gfc_symbol*
+get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
+			gfc_expr *e)
+{
+  gfc_symbol *declared;
+  gfc_ref *ref;
+
+  declared = NULL;
+  if (class_ref)
+    *class_ref = NULL;
+  if (new_ref)
+    *new_ref = gfc_copy_ref (e->ref);
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type != REF_COMPONENT)
+	continue;
+
+      if (ref->u.c.component->ts.type == BT_CLASS
+	    || ref->u.c.component->ts.type == BT_DERIVED)
+	{
+	  declared = ref->u.c.component->ts.u.derived;
+	  if (class_ref)
+	    *class_ref = ref;
+	}
+    }
+
+  if (declared == NULL)
+    declared = e->symtree->n.sym->ts.u.derived;
+
+  return declared;
+}
+
+
 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
    which of the specific bindings (if any) matches the arglist and transform
    the expression into a call of that binding.  */
@@ -5169,6 +5206,8 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)
 {
   gfc_typebound_proc* genproc;
   const char* genname;
+  gfc_symtree *st;
+  gfc_symbol *derived;
 
   gcc_assert (e->expr_type == EXPR_COMPCALL);
   genname = e->value.compcall.name;
@@ -5236,6 +5275,19 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)
   return FAILURE;
 
 success:
+  /* Make sure that we have the right specific instance for the name.  */
+  genname = e->value.compcall.tbp->u.specific->name;
+
+  /* Is the symtree name a "unique name".  */
+  if (*genname == '@')
+    genname = e->value.compcall.tbp->u.specific->n.sym->name;
+
+  derived = get_declared_from_expr (NULL, NULL, e);
+
+  st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
+  if (st)
+    e->value.compcall.tbp = st->n.tb;
+
   return SUCCESS;
 }
 
@@ -5343,38 +5395,6 @@ resolve_compcall (gfc_expr* e, const char **name)
 }
 
 
-/* Get the ultimate declared type from an expression.  In addition,
-   return the last class/derived type reference and the copy of the
-   reference list.  */
-static gfc_symbol*
-get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
-			gfc_expr *e)
-{
-  gfc_symbol *declared;
-  gfc_ref *ref;
-
-  declared = NULL;
-  *class_ref = NULL;
-  *new_ref = gfc_copy_ref (e->ref);
-  for (ref = *new_ref; ref; ref = ref->next)
-    {
-      if (ref->type != REF_COMPONENT)
-	continue;
-
-      if (ref->u.c.component->ts.type == BT_CLASS
-	    || ref->u.c.component->ts.type == BT_DERIVED)
-	{
-	  declared = ref->u.c.component->ts.u.derived;
-	  *class_ref = ref;
-	}
-    }
-
-  if (declared == NULL)
-    declared = e->symtree->n.sym->ts.u.derived;
-
-  return declared;
-}
-
 
 /* Resolve a typebound function, or 'method'. First separate all
    the non-CLASS references by calling resolve_compcall directly.  */
@@ -5423,11 +5443,8 @@ resolve_typebound_function (gfc_expr* e)
   e->value.function.esym = NULL;
   e->symtree = st;
 
-  if (class_ref)  
-    {
-      gfc_free_ref_list (class_ref->next);
-      e->ref = new_ref;
-    }
+  if (new_ref)  
+    e->ref = new_ref;
 
   /* '$vptr' points to the vtab, which contains the procedure pointers.  */
   gfc_add_component_ref (e, "$vptr");
@@ -5496,11 +5513,8 @@ resolve_typebound_subroutine (gfc_code *code)
   code->expr1->value.function.esym = NULL;
   code->expr1->symtree = st;
 
-  if (class_ref)  
-    {
-      gfc_free_ref_list (class_ref->next);
-      code->expr1->ref = new_ref;
-    }
+  if (new_ref)
+    code->expr1->ref = new_ref;
 
   /* '$vptr' points to the vtab, which contains the procedure pointers.  */
   gfc_add_component_ref (code->expr1, "$vptr");