backport: re PR fortran/78443 ([OOP] Incorrect behavior with non_overridable keyword)

2016-12-04  Janus Weil  <janus@gcc.gnu.org>

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

2016-12-04  Janus Weil  <janus@gcc.gnu.org>

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

From-SVN: r243230

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 26eb9d60dc591160553cbc942ed3d5cf5d64058b..7d7e9f2998a1569720ede77e152e2330c3173128 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2016-12-04  Janus Weil  <janus@gcc.gnu.org>
+
+       Backport from trunk
+       PR fortran/78443
+       * class.c (add_proc_comp): Add a vtype component for non-overridable
+       procedures that are overriding.
+
 2016-12-01  Steven G. Kargl  <kargl@gcc.gnu.org>
 
        PR fortran/78279

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 7f9256c3ba1d64e5799100091ffda90defe69f06..4ab96524b24cffae30618a396dcfcc64145903c7 100644 (file)
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -748,7 +748,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);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ab1f24dbca59d1b37c97afc08a12b77c372bfc86..b73a8c241e63c4339b9e9784472e71a7634c4076 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2016-12-04  Janus Weil  <janus@gcc.gnu.org>
+
+       Backport from trunk
+       PR fortran/78443
+       * gfortran.dg/typebound_proc_35.f90: New test case.
+
 2016-12-02  Kyrylo Tkachov  <kyrylo.tkachov@arm.com>
 
        Backport from mainline

diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_35.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_35.f90
new file mode 100644 (file)
index 0000000..18b1ed9
--- /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 <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.) call abort()
+    if ( t2 % test( 2. ) /= 4.) call abort()
+    if ( t3 % test( 2. ) /= 4.) call abort()
+end program