Fortran: gfortran rejects procedure binding on PDT [PR121398]

2025-08-11  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/121398
	* resolve.cc (check_pdt_args): New function.
	(check_generic_tbp_ambiguity): Use it to ensure that args to
	typebound procedures that do not have the same declared type as
	the containing derived type have 'pass1/2' set to null. This
	avoids false ambiguity errors.
	(resolve_typebound_procedure): Do not generate a wrong type
	error for typebound procedures marked as pass if they are of a
	different declared type to the containing pdt_type.

gcc/testsuite/
	PR fortran/121398
	* gfortran.dg/pdt_generic_1.f90: New test.

2 files changed, 135 insertions, 1 deletions

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c33bd17..68aaee8 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -15604,6 +15604,31 @@ error:
 }
 
 
+static gfc_symbol * containing_dt;
+
+/* Helper function for check_generic_tbp_ambiguity, which ensures that passed
+   arguments whose declared types are PDT instances only transmit the PASS arg
+   if they match the enclosing derived type.  */
+
+static bool
+check_pdt_args (gfc_tbp_generic* t, const char *pass)
+{
+  gfc_formal_arglist *dummy_args;
+  if (pass && containing_dt != NULL && containing_dt->attr.pdt_type)
+    {
+      dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym);
+      while (dummy_args && strcmp (pass, dummy_args->sym->name))
+	dummy_args = dummy_args->next;
+      gcc_assert (strcmp (pass, dummy_args->sym->name) == 0);
+      if (dummy_args->sym->ts.type == BT_CLASS
+	  && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name,
+		     containing_dt->name))
+	return true;
+    }
+  return false;
+}
+
+
 /* Check if two GENERIC targets are ambiguous and emit an error is they are.  */
 
 static bool
@@ -15661,6 +15686,17 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
 	pass2 = NULL;
     }
 
+  /* Care must be taken with pdt types and templates because the declared type
+     of the argument that is not 'no_pass' need not be the same as the
+     containing derived type.  If this is the case, subject the argument to
+     the full interface check, even though it cannot be used in the type
+     bound context.  */
+  pass1 = check_pdt_args (t1, pass1) ? NULL : pass1;
+  pass2 = check_pdt_args (t2, pass2) ? NULL : pass2;
+
+  if (containing_dt != NULL && containing_dt->attr.pdt_template)
+    pass1 = pass2 = NULL;
+
   /* Compare the interfaces.  */
   if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
 			      NULL, 0, pass1, pass2))
@@ -16108,8 +16144,10 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	  goto error;
 	}
 
-      /* The derived type is not a PDT template.  Resolve as usual.  */
+      /* The derived type is not a PDT template or type.  Resolve as usual.  */
       if (!resolve_bindings_derived->attr.pdt_template
+	  && !(containing_dt && containing_dt->attr.pdt_type
+	       && CLASS_DATA (me_arg)->ts.u.derived != containing_dt)
 	  && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
 	{
 	  gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
@@ -16256,6 +16294,7 @@ resolve_typebound_procedures (gfc_symbol* derived)
   resolve_bindings_derived = derived;
   resolve_bindings_result = true;
 
+  containing_dt = derived;  /* Needed for checks of PDTs.  */
   if (derived->f2k_derived->tb_sym_root)
     gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
 			  &resolve_typebound_procedure);
@@ -16263,6 +16302,7 @@ resolve_typebound_procedures (gfc_symbol* derived)
   if (derived->f2k_derived->tb_uop_root)
     gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
 			  &resolve_typebound_user_op);
+  containing_dt = NULL;
 
   for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
     {
diff --git a/gcc/testsuite/gfortran.dg/pdt_generic_1.f90 b/gcc/testsuite/gfortran.dg/pdt_generic_1.f90
new file mode 100644
index 0000000..a6c0f6ac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_generic_1.f90
@@ -0,0 +1,94 @@
+! { dg-do run }
+!
+! Check the fix for pr121398
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module tensor_m
+  implicit none
+  private
+  public tensor_t
+
+  type tensor_t(k)
+    integer, kind :: k
+    integer :: n
+  contains
+    procedure, private :: default_real_num_components
+    procedure, private :: default_real_num_components2
+    procedure, private ::  double_precision_num_components
+    procedure, private, pass(self) ::  quad_precision_num_components
+    generic :: num_components => default_real_num_components, &   ! Failed ambiguity test
+                                 default_real_num_components2, &
+                                 double_precision_num_components, &
+                                 quad_precision_num_components
+  end type
+
+  interface
+
+    module function default_real_num_components(self) result(res)
+      implicit none
+      class(tensor_t(kind(0.))) self
+      integer :: res
+    end function
+
+    module function default_real_num_components2(self, another) result(res)
+      implicit none
+      class(tensor_t(kind(0.))) self, another
+      integer :: res
+    end function
+
+    module function double_precision_num_components(self) result(res)
+      implicit none
+      class(tensor_t(kind(0.0_8))) self
+      integer :: res
+    end function
+
+    module function quad_precision_num_components(l, self) result(res)
+      implicit none
+      class(tensor_t(kind(0.0_16))) self
+      integer :: l
+      integer :: res
+    end function
+
+  end interface
+
+end module 
+
+submodule (tensor_m) tensor_m_components
+contains
+    module procedure default_real_num_components
+      implicit none
+      self%n = 10
+      res = 1
+    end
+
+    module procedure default_real_num_components2
+      implicit none
+      self%n = 2 * another%n
+      res = 1
+    end
+
+    module procedure double_precision_num_components
+      implicit none
+      self%n = 20
+      res = 2
+    end
+
+    module procedure quad_precision_num_components
+      implicit none
+      self%n = 10 * l
+      res = l
+    end
+end
+
+    use tensor_m
+    type (tensor_t(kind(0.))) :: a
+    type (tensor_t(kind(0.))) :: ap
+    type (tensor_t(kind(0.0_8))) :: b
+    type (tensor_t(kind(0.0_16))) :: c
+    if (a%num_components () /= 1) stop 1
+    if (ap%num_components (a) /= 1) stop 2
+    if (2 * a%n /= ap%n) stop 3
+    if (b%num_components () /= 2 ) stop 4
+    if (c%num_components (42) /= 42 ) stop 5
+end