https://gcc.gnu.org/g:e33257cab75c1f8a07ea8d5c829b8aec7069683e
commit r13-9254-ge33257cab75c1f8a07ea8d5c829b8aec7069683e
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Sun Dec 15 14:48:59 2024 +0000
Fortran: Fix non_overridable typebound proc problems [PR84674/117730].
2024-12-15 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran/ChangeLog
PR fortran/117730
PR fortran/84674
* class.cc (add_proc_comp): If the present typebound procedure
component is abstract, unconditionally check the replacement.
Only reject a non_overridable if it has no overridden procedure
and the component is already present in the vtype.
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.
(cherry picked from commit 1572e634dec4a09593f68645939b5b5043de8de6)
Diff:
---
gcc/fortran/class.cc | 17 ++++++++--
gcc/testsuite/gfortran.dg/pr117730_a.f90 | 50 +++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr117730_b.f90 | 47 +++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr84674.f90 | 55 ++++++++++++++++++++++++++++++++
4 files changed, 166 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ddf840761605..1ef7af09737e 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -818,12 +818,23 @@ static void
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
{
gfc_component *c;
-
- if (tb->non_overridable && !tb->overridden)
- return;
+ bool is_abstract = false;
c = gfc_find_component (vtype, name, true, true, NULL);
+ /* If the present component typebound proc is abstract, the new version
+ should unconditionally be tested if it is a suitable replacement. */
+ if (c && c->tb && c->tb->u.specific
+ && c->tb->u.specific->n.sym->attr.abstract)
+ is_abstract = true;
+
+ /* Pass on the new tb being not overridable if a component is found and
+ either there is not an overridden specific or the present component
+ tb is abstract. This ensures that possible, viable replacements are
+ loaded. */
+ if (tb->non_overridable && !tb->overridden && !is_abstract && c)
+ return;
+
if (c == NULL)
{
/* Add procedure component. */
diff --git a/gcc/testsuite/gfortran.dg/pr117730_a.f90
b/gcc/testsuite/gfortran.dg/pr117730_a.f90
new file mode 100644
index 000000000000..12e28214b02b
--- /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 000000000000..09707882989e
--- /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 000000000000..c58ae9efff69
--- /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
