diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 109aca33261..48c533d1eaf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2016-11-22 Janus Weil + + PR fortran/78443 + * class.c (add_proc_comp): Add a vtype component for non-overridable + procedures that are overriding. + 2016-11-20 Harald Anlauf PR fortran/69741 diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 9db86b409b5..ba965c96114 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -751,7 +751,7 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) { gfc_component *c; - if (tb->non_overridable) + if (tb->non_overridable && !tb->overridden) return; c = gfc_find_component (vtype, name, true, true, NULL); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1e761df3d79..b125a5518a9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-11-22 Janus Weil + + PR fortran/78443 + * gfortran.dg/typebound_proc_35.f90: New test case. + 2016-11-22 Georg-Johann Lay * gcc.c-torture/execute/pr30778.c (memset): Use size_t for 3rd diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_35.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_35.f90 new file mode 100644 index 00000000000..18b1ed98668 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_35.f90 @@ -0,0 +1,88 @@ +! { dg-do run } +! +! PR 78443: [OOP] Incorrect behavior with non_overridable keyword +! +! Contributed by federico + +module types + implicit none + + + ! Abstract parent class and its child type + type, abstract :: P1 + contains + procedure :: test => test1 + procedure (square_interface), deferred :: square + endtype + + ! Deferred procedure interface + abstract interface + function square_interface( this, x ) result( y ) + import P1 + class(P1) :: this + real :: x, y + end function square_interface + end interface + + type, extends(P1) :: C1 + contains + procedure, non_overridable :: square => C1_square + endtype + + ! Non-abstract parent class and its child type + type :: P2 + contains + procedure :: test => test2 + procedure :: square => P2_square + endtype + + type, extends(P2) :: C2 + contains + procedure, non_overridable :: square => C2_square + endtype + +contains + + real function test1( this, x ) + class(P1) :: this + real :: x + test1 = this % square( x ) + end function + + real function test2( this, x ) + class(P2) :: this + real :: x + test2 = this % square( x ) + end function + + function P2_square( this, x ) result( y ) + class(P2) :: this + real :: x, y + y = -100. ! dummy + end function + + function C1_square( this, x ) result( y ) + class(C1) :: this + real :: x, y + y = x**2 + end function + + function C2_square( this, x ) result( y ) + class(C2) :: this + real :: x, y + y = x**2 + end function + +end module + +program main + use types + implicit none + type(P2) :: t1 + type(C2) :: t2 + type(C1) :: t3 + + if ( t1 % test( 2. ) /= -100.) call abort() + if ( t2 % test( 2. ) /= 4.) call abort() + if ( t3 % test( 2. ) /= 4.) call abort() +end program