From: janus Date: Sun, 6 Jun 2010 02:04:04 +0000 (+0000) Subject: 2010-06-05 Paul Thomas X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=8913205507893383ed27be9d58b7a8c0f5952261;p=thirdparty%2Fgcc.git 2010-06-05 Paul Thomas Janus Weil 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 PR fortran/43945 * gfortran.dg/generic_23.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160335 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d9ab021cd87c..9b517100fafa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2010-06-05 Paul Thomas + Janus Weil + + 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 PR fortran/43895 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 48bb6187c171..7e5a4f957737 100644 --- a/gcc/fortran/resolve.c +++ b/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); - e->ref = new_ref; - } + 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); - code->expr1->ref = new_ref; - } + 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"); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 37caab695fc6..e84da1929d9e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-06-05 Paul Thomas + + PR fortran/43945 + * gfortran.dg/generic_23.f03: New test. + 2010-06-05 Paul Thomas PR fortran/43895 diff --git a/gcc/testsuite/gfortran.dg/generic_23.f03 b/gcc/testsuite/gfortran.dg/generic_23.f03 new file mode 100644 index 000000000000..eab185b483dc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_23.f03 @@ -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 +! and reported to clf by Salvatore Filippone +! +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" } }