[Patch, Fortran, OOP] PR 78443: Incorrect behavior with non_overridable keyword

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

here is a patch for a wrong-code problem with non_overridable
type-bound procedures. For details see the PR. Regtests cleanly. Ok
for trunk?

Since the patch is very simple and it fixes wrong code which can
silently give bad runtime results, I think backporting to the release
branches might be a good idea as well. Ok?

Cheers,
Janus


2016-11-22  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/78443
    * class.c (add_proc_comp): Add a vtype component for non-overridable
    procedures that are overriding.

2016-11-22  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/78443
    * gfortran.dg/typebound_proc_35.f90: New test case.

Attachment: pr78443.diff
Description: Text document

! { 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.0 ) /= -100) call abort()
    if ( t2 % test( 2.0 ) /= 4) call abort()
    if ( t3 % test( 2.0 ) /= 4) call abort()
end program