From ab7306ed7c5cda180b852b95dc6971dfc0311b39 Mon Sep 17 00:00:00 2001
From: Janus Weil <janus@gcc.gnu.org>
Date: Thu, 15 Jul 2010 15:36:28 +0200
Subject: [PATCH] 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
---
gcc/fortran/ChangeLog | 8 +++
gcc/fortran/resolve.c | 18 ++----
gcc/testsuite/ChangeLog | 5 ++
.../gfortran.dg/typebound_generic_9.f03 | 63 +++++++++++++++++++
4 files changed, 80 insertions(+), 14 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/typebound_generic_9.f03
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 874f828b5767..29ae010326b6 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 15b67d46ca18..95dbeee43b24 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 47d81f7ad0ab..896929301bcb 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 000000000000..f85bb3857062
--- /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" } }
+
--
GitLab