From 3faaefb65850f6364eb5c568e3ef1bff917eb344 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 26 Oct 2025 07:49:09 +0000 Subject: [PATCH] Fortran: Fix generic user operators in PDTs [PR122290] 2025-10-26 Paul Thomas gcc/fortran PR fortran/122290 * decl.cc (variable_decl): Matching component initializer expressions in PDT templates should be done with gfc_match_expr to avoid reduction too early. If the expression type is unknown copy the component typespec. (gfc_get_pdt_instance): Change comment from a TODO to an explanation. Insert parameter values in initializers. For components that are not marked with PDT attributes, do the full reduction for init expressions. * primary.cc (gfc_match_actual_arglist): Convert PDT kind exprs using the component initializer. * resolve.cc (resolve_typebound_intrinsic_op): Preempt gfc_check_new_interface for pdt_types as well as entities used in submodules. * simplify.cc (get_kind): Remove PDT kind conversion. gcc/testsuite/ PR fortran/122290 * gfortran.dg/pdt_60.f03: New test. --- gcc/fortran/decl.cc | 36 ++++++++++++--- gcc/fortran/primary.cc | 17 ++++++++ gcc/fortran/resolve.cc | 7 ++- gcc/fortran/simplify.cc | 16 ------- gcc/testsuite/gfortran.dg/pdt_60.f03 | 65 ++++++++++++++++++++++++++++ 5 files changed, 118 insertions(+), 23 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_60.f03 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/primary.cc b/gcc/fortran/primary.cc index cba4208a89f..2d2c664f10a 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2071,6 +2071,23 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt) } } + /* PDT kind expressions are acceptable as initialization expressions. + However, intrinsics with a KIND argument reject them. Convert the + expression now by use of the component initializer. */ + if (tail->expr + && tail->expr->expr_type == EXPR_VARIABLE + && gfc_expr_attr (tail->expr).pdt_kind) + { + gfc_ref *ref; + gfc_expr *tmp = NULL; + for (ref = tail->expr->ref; ref; ref = ref->next) + if (!ref->next && ref->type == REF_COMPONENT + && ref->u.c.component->attr.pdt_kind + && ref->u.c.component->initializer) + tmp = gfc_copy_expr (ref->u.c.component->initializer); + if (tmp) + gfc_replace_expr (tail->expr, tmp); + } next: if (gfc_match_char (')') == MATCH_YES) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 1c49ccf4711..0d5444848f0 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -16077,10 +16077,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/fortran/simplify.cc b/gcc/fortran/simplify.cc index 00b02f34120..b25cd2c2388 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -120,26 +120,10 @@ static int get_kind (bt type, gfc_expr *k, const char *name, int default_kind) { int kind; - gfc_expr *tmp; if (k == NULL) return default_kind; - if (k->expr_type == EXPR_VARIABLE - && k->symtree->n.sym->ts.type == BT_DERIVED - && k->symtree->n.sym->ts.u.derived->attr.pdt_type) - { - gfc_ref *ref; - for (ref = k->ref; ref; ref = ref->next) - if (!ref->next && ref->type == REF_COMPONENT - && ref->u.c.component->attr.pdt_kind - && ref->u.c.component->initializer) - { - tmp = gfc_copy_expr (ref->u.c.component->initializer); - gfc_replace_expr (k, tmp); - } - } - if (k->expr_type != EXPR_CONSTANT) { gfc_error ("KIND parameter of %s at %L must be an initialization " 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 +! +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" } } -- 2.47.3