Hi All,
The "fix" for PR84674 caused this regression.
The diagnostics that I had used for PR117763 allowed me to find a much
better fix for PR84674 and so this patch reverts the chunk in resolve.cc.
The chunk in class.cc works because non_overridable typebound procedures,
whose parent is abstract, do not have the 'overridden' field set. This
caused an immediate return from 'add_proc_comp' and this led to viable
typebound procedures being rejected. The fix checks the vtype component for
a specific typebound procedure that is abstract and uses this to suppress
the immediate return. I tested not adding the initialization expression if
the specific is abstract but, although this version regression tested OK,
decided to keep the patch as minimal as possible.
OK for mainline and, after a decent interval, to backport the chunk in
class.cc to the branches affected by PR84674?
Regards
Paul
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 --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 59ac0d97e08..64a0e726eeb 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 0d3845f9ce3..afed8db7852 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 00000000000..f9cf46421c1
--- /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
+
