re PR fortran/44936 ([OOP] Generic TBP not resolved correctly at compile time)

2010-07-15  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44936
	* resolve.c (resolve_typebound_generic_call): Resolve generic
	non-polymorphic type-bound procedure calls to the correct specific
	procedure.
	(resolve_typebound_subroutine): Remove superfluous code.


2010-07-15  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44936
	* gfortran.dg/typebound_generic_9.f03: New.

From-SVN: r162221

4 files changed, 80 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 874f828..29ae010 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2010-07-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44936
+	* resolve.c (resolve_typebound_generic_call): Resolve generic
+	non-polymorphic type-bound procedure calls to the correct specific
+	procedure.
+	(resolve_typebound_subroutine): Remove superfluous code.
+
 2010-07-15  Daniel Kraft  <d@domob.eu>
 
 	PR fortran/44709
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 15b67d4..95dbeee 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5336,10 +5336,11 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)
 	  if (matches)
 	    {
 	      e->value.compcall.tbp = g->specific;
+	      genname = g->specific_st->name;
 	      /* Pass along the name for CLASS methods, where the vtab
 		 procedure pointer component has to be referenced.  */
 	      if (name)
-		*name = g->specific_st->name;
+		*name = genname;
 	      goto success;
 	    }
 	}
@@ -5352,12 +5353,6 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)
 
 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);
@@ -5539,8 +5534,6 @@ resolve_typebound_function (gfc_expr* e)
 static gfc_try
 resolve_typebound_subroutine (gfc_code *code)
 {
-  gfc_symbol *declared;
-  gfc_component *c;
   gfc_ref *new_ref;
   gfc_ref *class_ref;
   gfc_symtree *st;
@@ -5555,7 +5548,7 @@ resolve_typebound_subroutine (gfc_code *code)
     return FAILURE;
 
   /* Get the CLASS declared type.  */
-  declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
+  get_declared_from_expr (&class_ref, &new_ref, code->expr1);
 
   /* Weed out cases of the ultimate component being a derived type.  */
   if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
@@ -5563,10 +5556,7 @@ resolve_typebound_subroutine (gfc_code *code)
     {
       gfc_free_ref_list (new_ref);
       return resolve_typebound_call (code, NULL);
-    } 
-
-  c = gfc_find_component (declared, "$data", true, true);
-  declared = c->ts.u.derived;
+    }
 
   if (resolve_typebound_call (code, &name) == FAILURE)
     return FAILURE;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 47d81f7..8969293 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-07-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44936
+	* gfortran.dg/typebound_generic_9.f03: New.
+
 2010-07-15  Richard Guenther  <rguenther@suse.de>
 
 	PR tree-optimization/44946
diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_9.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_9.f03
new file mode 100644
index 0000000..f85bb38
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_generic_9.f03
@@ -0,0 +1,63 @@
+! { dg-do run }
+!
+! PR 44936: [OOP] Generic TBP not resolved correctly at compile time
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+
+module foo_mod
+  type foo
+    integer :: i
+  contains
+    procedure, pass(a) :: doit => doit1
+    procedure, pass(a) :: getit=> getit1
+    generic, public :: do  => doit
+    generic, public :: get => getit
+  end type foo
+  private doit1,getit1
+contains
+  subroutine  doit1(a)
+    class(foo) :: a
+    a%i = 1
+    write(*,*) 'FOO%DOIT base version'
+  end subroutine doit1
+  function getit1(a) result(res)
+    class(foo) :: a
+    integer :: res
+    res = a%i
+  end function getit1
+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
+  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" } }
+