https://gcc.gnu.org/g:fed871f93c235da8ccba29d7beb715abc1482e59
commit r15-5716-gfed871f93c235da8ccba29d7beb715abc1482e59
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Wed Nov 27 09:20:23 2024 +0000
Fortran: Fix non_overridable typebound proc problems [PR84674/117768].
2024-11-27 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran/ChangeLog
PR fortran/84674
* class.cc (add_proc_comp): If the component points to a tbp
that is abstract, do not return since the new version is more
likely to be usable.
PR fortran/117768
* resolve.cc (resolve_fl_derived): Remove the condition that
rejected a completely empty derived type extension.
gcc/testsuite/ChangeLog
PR fortran/117768
* gfortran.dg/pr117768.f90: New test.
Diff:
---
gcc/fortran/class.cc | 14 ++++++-
gcc/fortran/resolve.cc | 8 +---
gcc/testsuite/gfortran.dg/pr117768.f90 | 76 ++++++++++++++++++++++++++++++++++
3 files changed, 90 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 59ac0d97e080..64a0e726eeb4 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -884,11 +884,21 @@ static void
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
{
gfc_component *c;
-
+ bool is_abstract = false;
c = gfc_find_component (vtype, name, true, true, NULL);
- if (tb->non_overridable && !tb->overridden && c)
+ /* 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)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 0d3845f9ce35..afed8db7852b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3229,8 +3229,8 @@ static bool check_pure_function (gfc_expr *e)
const char *name = NULL;
code_stack *stack;
bool saw_block = false;
-
- /* A BLOCK construct within a DO CONCURRENT construct leads to
+
+ /* A BLOCK construct within a DO CONCURRENT construct leads to
gfc_do_concurrent_flag = 0 when the check for an impure function
occurs. Check the stack to see if the source code has a nested
BLOCK construct. */
@@ -16305,10 +16305,6 @@ 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/pr117768.f90
b/gcc/testsuite/gfortran.dg/pr117768.f90
new file mode 100644
index 000000000000..f9cf46421c15
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117768.f90
@@ -0,0 +1,76 @@
+! { dg-do compile }
+!
+! Fix a regession caused by the first patch for PR84674.
+!
+! Contributed by Juergen Reuter <juergen.reu...@desy.de>
+!
+module m1
+ implicit none
+ private
+ public :: t1
+ type, abstract :: t1
+ end type t1
+end module m1
+
+module t_base
+ use m1, only: t1
+ implicit none
+ private
+ public :: t_t
+ type, abstract :: t_t
+ contains
+ procedure (t_out), deferred :: output
+ end type t_t
+
+ abstract interface
+ subroutine t_out (t, handle)
+ import
+ class(t_t), intent(inout) :: t
+ class(t1), intent(inout), optional :: handle
+ end subroutine t_out
+ end interface
+
+end module t_base
+
+
+module t_ascii
+ use m1, only: t1
+ use t_base
+ implicit none
+ private
+
+ type, abstract, extends (t_t) :: t1_t
+ contains
+ procedure :: output => t_ascii_output
+ end type t1_t
+ type, extends (t1_t) :: t2_t
+ end type t2_t
+ type, extends (t1_t) :: t3_t
+ logical :: verbose = .true.
+ end type t3_t
+
+ interface
+ module subroutine t_ascii_output &
+ (t, handle)
+ class(t1_t), intent(inout) :: t
+ class(t1), intent(inout), optional :: handle
+ end subroutine t_ascii_output
+ end interface
+end module t_ascii
+
+submodule (t_ascii) t_ascii_s
+ implicit none
+contains
+ module subroutine t_ascii_output &
+ (t, handle)
+ class(t1_t), intent(inout) :: t
+ class(t1), intent(inout), optional :: handle
+ select type (t)
+ type is (t3_t)
+ type is (t2_t)
+ class default
+ return
+ end select
+ end subroutine t_ascii_output
+end submodule t_ascii_s
+
