+2010-06-05 Paul Thomas <pault@gcc.gnu.org>
+ Janus Weil <janus@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.
+ (resolve_typebound_function,resolve_typebound_subroutine): Avoid
+ freeing 'class_ref->next' twice.
+
2010-06-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/43895
}
+/* 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. */
{
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;
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;
}
}
-/* 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. */
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");
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");
--- /dev/null
+! { 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" } }
projects / thirdparty / gcc.git / commitdiff
