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

gcc/fortran/ChangeLog

 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/43895
 	* trans-array.c (structure_alloc_comps): Dereference scalar

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);
+  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);
+  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");

gcc/testsuite/ChangeLog

 2010-06-05  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/43945
+	* gfortran.dg/generic_23.f03: New test.
+
+2010-06-05  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/43895
 	* gfortran.dg/alloc_comp_class_1.f90 : New test.
 

gcc/testsuite/gfortran.dg/generic_23.f03

+! { dg-do run }
+! Test the fix for PR43945 in which the over-ridding of 'doit' and
+! 'getit' in type 'foo2' was missed in the specific binding to 'do' and 'get'.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+! and reported to clf by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module foo_mod
+  type foo
+    integer :: i
+  contains
+    procedure, pass(a) :: doit
+    procedure, pass(a) :: getit
+    generic, public :: do  => doit
+    generic, public :: get => getit
+  end type foo
+  private doit,getit
+contains
+  subroutine  doit(a)
+    class(foo) :: a
+    a%i = 1
+    write(*,*) 'FOO%DOIT base version'
+  end subroutine doit
+  function getit(a) result(res)
+    class(foo) :: a
+    integer :: res
+    res = a%i
+  end function getit
+end module foo_mod
+
+module foo2_mod
+  use foo_mod
+  type, extends(foo) :: foo2
+    integer :: j
+  contains
+    procedure, pass(a) :: doit  => doit2
+    procedure, pass(a) :: getit => getit2
+!!$    generic, public :: do  => doit
+!!$    generic, public :: get => getit
+  end type foo2
+  private doit2, getit2
+
+contains
+
+  subroutine  doit2(a)
+    class(foo2) :: a
+    a%i = 2
+    a%j = 3
+  end subroutine doit2
+  function getit2(a) result(res)
+    class(foo2) :: a
+    integer :: res
+    res = a%j
+  end function getit2
+end module foo2_mod
+
+program testd15
+  use foo2_mod
+  type(foo2) :: af2
+
+  call af2%do()
+  if (af2%i .ne. 2) call abort
+  if (af2%get() .ne. 3) call abort
+
+end program testd15
+
+! { dg-final { cleanup-modules "foo_mod foo2_mod" } }