Hi All,
I was going through some of the older regressions and found pr84674, which
was distinctly low hanging fruit because the contributor has found the
offending bit of code. However, buried in this PR, on the grounds that it
looked similar, was what has now become pr117730. This was quite difficult
to diagnose and the cause of the problem was only found by instrumenting
class.c (add_proc_comp) to check the order in which non_overridable
procedure components were added to the vtables of derived type extensions
that are in different modules to the parent. Failure to keep the order the
same results, of course, in the wrong procedure being called.
The fixes for these PRs verge on 'obvious' but I thought that I should
submit them to the list because I want to push and backport them together.
Although PR117730 is not a regression, I think that it is sufficiently
limiting that it should be backported to active branches.
OK for mainline and, after a week or two, backporting to 13- and
14-branches/
Paul
Fortran: Fix non_overridable typebound proc problems [PR84674/117730].
2024-11-23 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran/ChangeLog
PR fortran/117730
* class.c (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.
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index fc709fec322..388891a2fd5 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -886,11 +886,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 e8f780d1ef9..79f73e7ec40 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16288,6 +16288,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 00000000000..12e28214b02
--- /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 <dar...@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 00000000000..09707882989
--- /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 <dar...@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 00000000000..c58ae9efff6
--- /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 <alban...@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
