From f7f3a91852f779cb4a1f9346e53c261c9ee00097 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Mon, 7 Nov 2011 18:41:12 +0000 Subject: 2011-11-07 Janus Weil PR fortran/50919 * class.c (add_proc_comp): Don't add non-overridable procedures to the vtable. * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): Don't generate a dynamic _vptr call for non-overridable procedures. 2011-11-07 Janus Weil PR fortran/50919 * gfortran.dg/typebound_call_21.f03: New. git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@181107 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 8 ++++ gcc/fortran/class.c | 4 ++ gcc/fortran/resolve.c | 64 +++++++++++++++---------- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/typebound_call_21.f03 | 39 +++++++++++++++ 5 files changed, 94 insertions(+), 26 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_call_21.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ea828c88f0f..1dae389d361 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2011-11-07 Janus Weil + + PR fortran/50919 + * class.c (add_proc_comp): Don't add non-overridable procedures to the + vtable. + * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): + Don't generate a dynamic _vptr call for non-overridable procedures. + 2011-11-07 Janne Blomqvist * intrinsic.texi (MCLOCK, MCLOCK8, TIME, TIME8): Functions clock diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index f64cc1b2a81..574d22b0b12 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -288,6 +288,10 @@ static void add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) { gfc_component *c; + + if (tb->non_overridable) + return; + c = gfc_find_component (vtype, name, true, true); if (c == NULL) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ab251b57e70..0e882399902 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5868,11 +5868,13 @@ resolve_typebound_function (gfc_expr* e) const char *name; gfc_typespec ts; gfc_expr *expr; + bool overridable; st = e->symtree; /* Deal with typebound operators for CLASS objects. */ expr = e->value.compcall.base_object; + overridable = !e->value.compcall.tbp->non_overridable; if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name) { /* Since the typebound operators are generic, we have to ensure @@ -5923,22 +5925,26 @@ resolve_typebound_function (gfc_expr* e) return FAILURE; ts = e->ts; - /* Then convert the expression to a procedure pointer component call. */ - e->value.function.esym = NULL; - e->symtree = st; + if (overridable) + { + /* Convert the expression to a procedure pointer component call. */ + e->value.function.esym = NULL; + e->symtree = st; - if (new_ref) - e->ref = new_ref; + if (new_ref) + e->ref = new_ref; - /* '_vptr' points to the vtab, which contains the procedure pointers. */ - gfc_add_vptr_component (e); - gfc_add_component_ref (e, name); + /* '_vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_vptr_component (e); + gfc_add_component_ref (e, name); + + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + e->ts = ts; + } - /* Recover the typespec for the expression. This is really only - necessary for generic procedures, where the additional call - to gfc_add_component_ref seems to throw the collection of the - correct typespec. */ - e->ts = ts; return SUCCESS; } @@ -5957,11 +5963,13 @@ resolve_typebound_subroutine (gfc_code *code) const char *name; gfc_typespec ts; gfc_expr *expr; + bool overridable; st = code->expr1->symtree; /* Deal with typebound operators for CLASS objects. */ expr = code->expr1->value.compcall.base_object; + overridable = !code->expr1->value.compcall.tbp->non_overridable; if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name) { /* Since the typebound operators are generic, we have to ensure @@ -6006,22 +6014,26 @@ resolve_typebound_subroutine (gfc_code *code) return FAILURE; ts = code->expr1->ts; - /* Then convert the expression to a procedure pointer component call. */ - code->expr1->value.function.esym = NULL; - code->expr1->symtree = st; + if (overridable) + { + /* Convert the expression to a procedure pointer component call. */ + code->expr1->value.function.esym = NULL; + code->expr1->symtree = st; + + if (new_ref) + 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_vptr_component (code->expr1); + gfc_add_component_ref (code->expr1, name); - /* '_vptr' points to the vtab, which contains the procedure pointers. */ - gfc_add_vptr_component (code->expr1); - gfc_add_component_ref (code->expr1, name); + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + code->expr1->ts = ts; + } - /* Recover the typespec for the expression. This is really only - necessary for generic procedures, where the additional call - to gfc_add_component_ref seems to throw the collection of the - correct typespec. */ - code->expr1->ts = ts; return SUCCESS; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0dd3896bd51..365f3b1b4c1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-11-07 Janus Weil + + PR fortran/50919 + * gfortran.dg/typebound_call_21.f03: New. + 2011-11-07 Nathan Sidwell * gcc.dg/profile-dir-1.c: Adjust final scan. diff --git a/gcc/testsuite/gfortran.dg/typebound_call_21.f03 b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 new file mode 100644 index 00000000000..5f7d67283c4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 50919: [OOP] Don't use vtable for NON_OVERRIDABLE TBP +! +! Contributed by Tobias Burnus + +module m + +type t +contains + procedure, nopass, NON_OVERRIDABLE :: testsub + procedure, nopass, NON_OVERRIDABLE :: testfun +end type t + +contains + + subroutine testsub() + print *, "t's test" + end subroutine + + integer function testfun() + testfun = 1 + end function + +end module m + + + use m + class(t), allocatable :: x + allocate(x) + call x%testsub() + print *,x%testfun() +end + +! { dg-final { scan-tree-dump-times "_vptr->" 0 "original" } } + +! { dg-final { cleanup-modules "m" } } +! { dg-final { cleanup-tree-dump "original" } } -- cgit v1.2.3