This patch turned out to be straightforward once the source of the problems were identified:
The problem with type matching came about because the component initializers were given BT_UNKNOWN before reduction was done. This was cured by giving the untreated initializers the same type as the component. Matching the template component initializers must be done with gfc_match_expr to prevent the reduction in gfc_match_init_expr from rendering them unusable for the PDT instances or to avoid the errors resulting from parameterized expressions. Where necessary, initializer expressions must have the parameter values substituted. Finally, generic intrinsic ops attempt to add the same entities to interfaces for each PDT instance. Suppress this in the same way as for entities used in submodules. The new testcase is an expanded version of the reporter's to check that the correct procedures are selected, when the intrinsic operators are referenced. Regtests on FC42/x86_64. OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 5da3c267245..569786abe99 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3101,7 +3101,16 @@ variable_decl (int elem)
goto cleanup;
}
- m = gfc_match_init_expr (&initializer);
+ if (gfc_comp_struct (gfc_current_state ())
+ && gfc_current_block ()->attr.pdt_template)
+ {
+ m = gfc_match_expr (&initializer);
+ if (initializer && initializer->ts.type == BT_UNKNOWN)
+ initializer->ts = current_ts;
+ }
+ else
+ m = gfc_match_init_expr (&initializer);
+
if (m == MATCH_NO)
{
gfc_error ("Expected an initialization expression at %C");
@@ -3179,7 +3188,7 @@ variable_decl (int elem)
gfc_error ("BOZ literal constant at %L cannot appear as an "
"initializer", &initializer->where);
m = MATCH_ERROR;
- goto cleanup;
+ goto cleanup;
}
param->value = gfc_copy_expr (initializer);
}
@@ -4035,8 +4044,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
ok = gfc_simplify_expr (kind_expr, 1);
- /* Variable expressions seem to default to BT_PROCEDURE.
- TODO find out why this is and fix it. */
+ /* Variable expressions default to BT_PROCEDURE in the absence of an
+ initializer so allow for this. */
if (kind_expr->ts.type != BT_INTEGER
&& kind_expr->ts.type != BT_PROCEDURE)
{
@@ -4271,6 +4280,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
if (!c2->initializer && c1->initializer)
c2->initializer = gfc_copy_expr (c1->initializer);
+
+ if (c2->initializer)
+ gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
}
/* Copy the array spec. */
@@ -4374,7 +4386,21 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
}
else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
|| c2->attr.pdt_array) && c1->initializer)
- c2->initializer = gfc_copy_expr (c1->initializer);
+ {
+ c2->initializer = gfc_copy_expr (c1->initializer);
+ if (c2->initializer->ts.type == BT_UNKNOWN)
+ c2->initializer->ts = c2->ts;
+ gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
+ /* The template initializers are parsed using gfc_match_expr rather
+ than gfc_match_init_expr. Apply the missing reduction to the
+ PDT instance initializers. */
+ if (!gfc_reduce_init_expr (c2->initializer))
+ {
+ gfc_free_expr (c2->initializer);
+ goto error_return;
+ }
+ gfc_simplify_expr (c2->initializer, 1);
+ }
}
if (alloc_seen)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f419f5c7559..370f55e993a 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16074,10 +16074,13 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
/* Preempt 'gfc_check_new_interface' for submodules, where the
mechanism for handling module procedures winds up resolving
- operator interfaces twice and would otherwise cause an error. */
+ operator interfaces twice and would otherwise cause an error.
+ Likewise, new instances of PDTs can cause the operator inter-
+ faces to be resolved multiple times. */
for (intr = derived->ns->op[op]; intr; intr = intr->next)
if (intr->sym == target_proc
- && target_proc->attr.used_in_submodule)
+ && (target_proc->attr.used_in_submodule
+ || derived->attr.pdt_type))
return true;
if (!gfc_check_new_interface (derived->ns->op[op],
diff --git a/gcc/testsuite/gfortran.dg/pdt_60.f03 b/gcc/testsuite/gfortran.dg/pdt_60.f03
new file mode 100644
index 00000000000..dc9f7f23454
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_60.f03
@@ -0,0 +1,65 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR122290.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module hyperparameters_m
+ implicit none
+
+ type hyperparameters_t(k)
+ integer, kind :: k = kind(1.)
+ real(k) :: learning_rate_ = real(1.5,k) ! Gave "Invalid kind for REAL"
+ contains
+ generic :: operator(==) => default_real_equals, real8_equals ! Gave "Entity ‘default_real_equals’ at (1)
+ ! is already present in the interface"
+ generic :: g => default_real_equals, real8_equals ! Make sure that ordinary generic is OK
+ procedure default_real_equals
+ procedure real8_equals
+ end type
+
+ interface
+ logical module function default_real_equals(lhs, rhs)
+ implicit none
+ class(hyperparameters_t), intent(in) :: lhs, rhs
+ end function
+ logical module function real8_equals(lhs, rhs)
+ implicit none
+ class(hyperparameters_t(kind(1d0))), intent(in) :: lhs, rhs
+ end function
+ end interface
+end module
+
+! Added to test generic procedures are the correct ones.
+submodule(hyperparameters_m) hyperparameters_s
+contains
+ logical module function default_real_equals(lhs, rhs)
+ implicit none
+ class(hyperparameters_t), intent(in) :: lhs, rhs
+ default_real_equals = (lhs%learning_rate_ == rhs%learning_rate_)
+ end function
+ logical module function real8_equals(lhs, rhs)
+ implicit none
+ class(hyperparameters_t(kind(1d0))), intent(in) :: lhs, rhs
+ real8_equals = (lhs%learning_rate_ == rhs%learning_rate_)
+ end function
+end submodule
+
+ use hyperparameters_m
+ type (hyperparameters_t) :: a, b
+ type (hyperparameters_t(kind(1d0))) :: c, d
+ if (.not.(a == b)) stop 1
+ if (.not.a%g(b)) stop 2
+ a%learning_rate_ = real(2.5,a%k)
+ if (a == b) stop 3
+ if (a%g(b)) stop 4
+
+ if (.not.(c == d)) stop 5
+ if (.not.c%g(d)) stop 6
+ c%learning_rate_ = real(2.5,c%k)
+ if (c == d) stop 7
+ if (c%g(d)) stop 8
+end
+! { dg-final { scan-tree-dump-times "default_real_equals" 8 "original" } }
+! { dg-final { scan-tree-dump-times "real8_equals" 8 "original" } }
