Fortran: Fix non_overridable typebound proc problems [PR84674/117768].

2024-11-27  Paul Thomas  <pault@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 59ac0d97e08058365ba7fd679343cde71895d642..64a0e726eeb42db8937c1a184c2250bc804a5854 100644 (file)
--- 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 0d3845f9ce350c7b4511ae05269513c4fcc4a111..afed8db7852bc53f70beaa463c0717f771942276 100644 (file)
--- 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 (file)
index 0000000..f9cf464
--- /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.reuter@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
+