Fortran: Fix non_overridable typebound proc problems [PR84674/117730].

2024-11-24  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran/ChangeLog

	PR fortran/117730
	* class.cc (add_proc_comp): Only reject a non_overridable if it
	has no overridden procedure and the component is already
	present in the vtype.
	PR fortran/84674
	* resolve.cc (resolve_fl_derived): Do not build a vtable for a
	derived type extension that is completely empty.

gcc/testsuite/ChangeLog

	PR fortran/117730
	* gfortran.dg/pr117730_a.f90: New test.
	* gfortran.dg/pr117730_b.f90: New test.

	PR fortran/84674
	* gfortran.dg/pr84674.f90: New test.

5 files changed, 159 insertions, 2 deletions

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index da09d21..59ac0d9 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -885,11 +885,12 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
 {
   gfc_component *c;
 
-  if (tb->non_overridable && !tb->overridden)
-    return;
 
   c = gfc_find_component (vtype, name, true, true, NULL);
 
+  if (tb->non_overridable && !tb->overridden && c)
+    return;
+
   if (c == NULL)
     {
       /* Add procedure component.  */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index b817192..b1740ce 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16287,6 +16287,10 @@ resolve_fl_derived (gfc_symbol *sym)
       && sym->ns->proc_name
       && sym->ns->proc_name->attr.flavor == FL_MODULE
       && sym->attr.access != ACCESS_PRIVATE
+      && !(sym->attr.extension
+	   && sym->attr.zero_comp
+	   && !sym->f2k_derived->tb_sym_root
+	   && !sym->f2k_derived->tb_uop_root)
       && !(sym->attr.vtype || sym->attr.pdt_template))
     {
       gfc_symbol *vtab = gfc_find_derived_vtab (sym);
diff --git a/gcc/testsuite/gfortran.dg/pr117730_a.f90 b/gcc/testsuite/gfortran.dg/pr117730_a.f90
new file mode 100644
index 0000000..12e2821
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117730_a.f90
@@ -0,0 +1,50 @@
+! { dg-do compile }
+!
+! Test the fix for PR117730 in which the non_overrridable procedures in 'child'
+! were mixied up in the vtable for the extension 'child2' in pr117730_b.f90.
+! This resulted in 'this%calc()' in 'function child_get(this)' returning garbage
+! when 'this' was of dynamic type 'child2'.
+!
+! Contributed by  <daraja@web.de> in comment 4 of PR84674.
+!
+module module1
+    implicit none
+    private
+    public :: child
+
+    type, abstract :: parent
+    contains
+        procedure, pass :: reset => parent_reset
+    end type parent
+
+    type, extends(parent), abstract :: child
+    contains
+        procedure, pass, non_overridable :: reset => child_reset
+        procedure, pass, non_overridable :: get => child_get
+        procedure(calc_i), pass, deferred :: calc
+    end type child
+
+    abstract interface
+        pure function calc_i(this) result(value)
+            import :: child
+            class(child), intent(in) :: this
+            integer                 :: value
+        end function calc_i
+    end interface
+
+contains
+    pure subroutine parent_reset(this)
+        class(parent), intent(inout) :: this
+    end subroutine parent_reset
+
+    pure subroutine child_reset(this)
+        class(child), intent(inout) :: this
+    end subroutine child_reset
+
+    function child_get(this) result(value)
+        class(child), intent(inout) :: this
+        integer                   :: value
+
+        value = this%calc()
+    end function child_get
+end module module1
diff --git a/gcc/testsuite/gfortran.dg/pr117730_b.f90 b/gcc/testsuite/gfortran.dg/pr117730_b.f90
new file mode 100644
index 0000000..0970788
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117730_b.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+! { dg-compile-aux-modules "pr117730_a.f90" }
+! { dg-additional-sources pr117730_a.f90 }
+!
+! Test the fix for PR117730 in which the non_overrridable procedures in
+! pr117730_a.f90 were mixied up in the vtable for 'child2' below. This resulted
+! in 'this%calc()' in 'function child_get(this)' returning garbage.
+!
+! Contributed by  <daraja@web.de> in comment 4 of PR84674.
+!
+module module2
+    use module1, only: child
+
+    implicit none
+    private
+    public :: child2
+
+    type, extends(child) :: child2
+    contains
+        procedure, pass :: calc => child2_calc
+    end type child2
+
+contains
+
+    pure function child2_calc(this) result(value)
+        class(child2), intent(in) :: this
+        integer :: value
+
+        value = 1
+    end function child2_calc
+
+end module module2
+
+program test
+    use module2, only: child2
+
+    implicit none
+
+    type(child2) :: F
+
+    if (F%calc() /= 1) stop 1
+
+    print *, "---------------"
+    if (F%get() /= 1) stop 2
+
+end program test
+! { dg-final { cleanup-modules "module1" } }
diff --git a/gcc/testsuite/gfortran.dg/pr84674.f90 b/gcc/testsuite/gfortran.dg/pr84674.f90
new file mode 100644
index 0000000..c58ae9e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr84674.f90
@@ -0,0 +1,55 @@
+! { dg-do run }
+!
+! Test the fix for PR84674, in which the non-overridable variant of the
+! procedure ff below caused a runtime segfault.
+!
+! Contributed by Jakub Benda  <albandil@atlas.cz>
+!
+ module m
+  implicit none
+
+  type, abstract :: t1
+   integer :: i
+  contains
+   procedure(i_f), pass(u), deferred :: ff
+  end type t1
+
+  type, abstract, extends(t1) :: t2
+  contains
+   procedure, non_overridable, pass(u) :: ff => f ! Segmentation fault
+   !procedure, pass(u) :: ff => f ! worked
+  end type t2
+
+  type, extends(t2) :: DerivedType
+  end type DerivedType
+
+  abstract interface
+   subroutine i_f(u)
+    import :: t1
+    class(t1), intent(inout) :: u
+   end subroutine i_f
+  end interface
+
+ contains
+
+  subroutine f(u)
+   class(t2), intent(inout) :: u
+    u%i = 3*u%i
+  end subroutine f
+
+ end module m
+
+
+ program p
+
+  use m
+
+  implicit none
+
+  class(t1), allocatable :: v
+
+  allocate(DerivedType::v)
+  v%i = 2
+  call v%ff()
+  if (v%i /= 6) stop
+ end program p