Hi All, This patch eliminates errors that arose in the use of generic bindings in PDT templates and their instances. This came about because none of the pdt instances matched the PDT template types and some of them might not match not match the containing specific type; ie. with different kind parameters. The comments in the patch explain the workings.
Regtests on FC42/x86_64 - OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c33bd17da2d..68aaee84687 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 00000000000..a6c0f6ac584
--- /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
