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

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.

From-SVN: r242703

4 files changed, 100 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 109aca3..48c533d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+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-20  Harald Anlauf  <anlauf@gmx.de>
 
 	PR fortran/69741
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 9db86b4..ba965c9 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 1e761df..b125a55 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-11-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/78443
+	* gfortran.dg/typebound_proc_35.f90: New test case.
+
 2016-11-22  Georg-Johann Lay  <avr@gjlay.de>
 
 	* 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 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