From: Janus Weil Date: Thu, 15 Jul 2010 13:36:28 +0000 (+0200) Subject: re PR fortran/44936 ([OOP] Generic TBP not resolved correctly at compile time) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ab7306ed7c5cda180b852b95dc6971dfc0311b39;p=gcc.git re PR fortran/44936 ([OOP] Generic TBP not resolved correctly at compile time) 2010-07-15 Janus Weil 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 PR fortran/44936 * gfortran.dg/typebound_generic_9.f03: New. From-SVN: r162221 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 874f828b576..29ae010326b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2010-07-15 Janus Weil + + 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 PR fortran/44709 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 15b67d46ca1..95dbeee43b2 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 47d81f7ad0a..896929301bc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-07-15 Janus Weil + + PR fortran/44936 + * gfortran.dg/typebound_generic_9.f03: New. + 2010-07-15 Richard Guenther 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 00000000000..f85bb385706 --- /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 + +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" } } +