This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, fortran] PR43945 - [OOP] Derived type with GENERIC: resolved to the wrong specific TBP


The attached patch is explained by the ChangeLog and the comments.

Boostrapped and regtested on RHEL5.4/i686 - OK for trunk and 4.5?

Paul

2010-05-06  Paul Thomas  <pault@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.

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

	PR fortran/43945
	* gfortran.dg/generic_23.f03: New test.
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 158958)
+++ gcc/fortran/resolve.c	(working copy)
@@ -5123,6 +5123,43 @@
 }
 
 
+/* 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.  */
@@ -5132,6 +5169,8 @@
 {
   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;
@@ -5199,6 +5238,19 @@
   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;
 }
 
@@ -5306,39 +5358,7 @@
 }
 
 
-/* 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.  */
 
Index: gcc/testsuite/gfortran.dg/generic_23.f03
===================================================================
--- gcc/testsuite/gfortran.dg/generic_23.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/generic_23.f03	(revision 0)
@@ -0,0 +1,67 @@
+! { 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" } }

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]