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
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;
}
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
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;
}
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR 50919: [OOP] Don't use vtable for NON_OVERRIDABLE TBP
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+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" } }