gcc/testsuite/gfortran.dg/typebound_proc_35.f90

! { dg-do run }
!
! PR 78443: [OOP] Incorrect behavior with non_overridable keyword
!
! Contributed by federico <perini@wisc.edu>

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.) STOP 1
    if ( t2 % test( 2. ) /= 4.) STOP 2
    if ( t3 % test( 2. ) /= 4.) STOP 3
end program