https://gcc.gnu.org/g:dd6dbbb5111fba960ad0ee7999a225783e0ae80e
commit r15-5628-gdd6dbbb5111fba960ad0ee7999a225783e0ae80e
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Sun Nov 24 08:50:58 2024 +0000
Fortran: Fix non_overridable typebound proc problems [PR84674/117730].
2024-11-24 Paul Thomas <pa...@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.
Diff:
---
gcc/fortran/class.cc | 5 +--
gcc/fortran/resolve.cc | 4 +++
gcc/testsuite/gfortran.dg/pr117730_a.f90 | 50 +++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr117730_b.f90 | 47 +++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr84674.f90 | 55 ++++++++++++++++++++++++++++++++
5 files changed, 159 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index da09d210b4b5..59ac0d97e080 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 b817192cd930..b1740cec3881 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 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
