https://gcc.gnu.org/g:2aac5a6fa777753277216b30c3d8aa0f6c277f55
commit r16-3135-g2aac5a6fa777753277216b30c3d8aa0f6c277f55
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Mon Aug 11 21:34:07 2025 +0100
Fortran: gfortran rejects procedure binding on PDT [PR121398]
2025-08-11 Paul Thomas <pa...@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.
Diff:
---
gcc/fortran/resolve.cc | 42 ++++++++++++-
gcc/testsuite/gfortran.dg/pdt_generic_1.f90 | 94 +++++++++++++++++++++++++++++
2 files changed, 135 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c33bd17da2dc..68aaee846873 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 000000000000..a6c0f6ac584e
--- /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
