https://gcc.gnu.org/g:63bc852f446dc2d588c22466533ce6ec35975f9b
commit r16-4909-g63bc852f446dc2d588c22466533ce6ec35975f9b Author: Paul Thomas <[email protected]> Date: Fri Oct 31 12:59:23 2025 +0000 Fortran: Use specific PDT constructors from a generic list [PR122452] 2025-10-31 Paul Thomas <[email protected]> gcc/fortran PR fortran/122452 * primary.cc (gfc_match_rvalue): Give priority to specific procedures in a generic interface with the same name as a PDT template. If found, use as the procedure instead of the constructor generated from the PDT template. gcc/testsuite/ PR fortran/122452 * gfortran.dg/pdt_65.f03: New test. Diff: --- gcc/fortran/primary.cc | 35 +++++++-- gcc/testsuite/gfortran.dg/pdt_65.f03 | 135 +++++++++++++++++++++++++++++++++++ 2 files changed, 163 insertions(+), 7 deletions(-) diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 0722c76d9e5d..1dcb1c3b5614 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -3835,6 +3835,9 @@ gfc_match_rvalue (gfc_expr **result) gfc_typespec *ts; bool implicit_char; gfc_ref *ref; + gfc_symtree *pdt_st; + gfc_symbol *found_specific = NULL; + m = gfc_match ("%%loc"); if (m == MATCH_YES) @@ -4082,22 +4085,36 @@ gfc_match_rvalue (gfc_expr **result) break; } + gfc_gobble_whitespace (); + found_specific = NULL; + + /* Even if 'name' is that of a PDT template, priority has to be given to + possible specific procedures in the generic interface. */ + gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st); + if (sym->generic && sym->generic->next + && gfc_peek_ascii_char() != '(') + { + gfc_actual_arglist *arg = actual_arglist; + for (; arg && pdt_st; arg = arg->next) + gfc_resolve_expr (arg->expr); + found_specific = gfc_search_interface (sym->generic, 0, + &actual_arglist); + } + /* Check to see if this is a PDT constructor. The format of these constructors is rather unusual: name [(type_params)](component_values) where, component_values excludes the type_params. With the present gfortran representation this is rather awkward because the two are not distinguished, other than by their attributes. */ - if (sym->attr.generic) + if (sym->attr.generic && pdt_st != NULL && found_specific == NULL) { - gfc_symtree *pdt_st; gfc_symbol *pdt_sym; gfc_actual_arglist *ctr_arglist = NULL, *tmp; gfc_component *c; - /* Obtain the template. */ - gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st); - if (pdt_st && pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template) + /* Use the template. */ + if (pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template) { bool type_spec_list = false; pdt_sym = pdt_st->n.sym; @@ -4155,8 +4172,12 @@ gfc_match_rvalue (gfc_expr **result) tmp = tmp->next; } - gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name), - NULL, 1, &symtree); + if (found_specific) + gfc_find_sym_tree (found_specific->name, + NULL, 1, &symtree); + else + gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name), + NULL, 1, &symtree); if (!symtree) { gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) , diff --git a/gcc/testsuite/gfortran.dg/pdt_65.f03 b/gcc/testsuite/gfortran.dg/pdt_65.f03 new file mode 100644 index 000000000000..d5e45c290ae1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_65.f03 @@ -0,0 +1,135 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test fix for PR122452 +! +! Contributed by Damian Rouson <[email protected]> +! +module kind_parameters_m + integer, parameter :: default_real = kind(1e0) + integer, parameter :: double_precision = kind(1d0) +end module + +module tensor_m + use kind_parameters_m, only : default_real, double_precision + implicit none + + private + public :: tensor_t + + type tensor_t(k) + integer, kind :: k = default_real + real(k), allocatable, private :: values_(:) + contains + generic :: values => default_real_values, double_precision_values + procedure, private, non_overridable :: default_real_values, double_precision_values + generic :: num_components => default_real_num_components, double_precision_num_components + procedure, private :: default_real_num_components, double_precision_num_components + end type + + interface tensor_t + + pure module function construct_default_real(values) result(tensor) + implicit none + real, intent(in) :: values(:) + type(tensor_t) tensor + end function + + pure module function construct_double_precision(values) result(tensor) + implicit none + double precision, intent(in) :: values(:) + type(tensor_t(double_precision)) tensor + end function + + end interface + + interface + + pure module function default_real_values(self) result(tensor_values) + implicit none + class(tensor_t), intent(in) :: self + real, allocatable :: tensor_values(:) + end function + + pure module function double_precision_values(self) result(tensor_values) + implicit none + class(tensor_t(double_precision)), intent(in) :: self + double precision, allocatable :: tensor_values(:) + end function + + pure module function default_real_num_components(self) result(n) + implicit none + class(tensor_t), intent(in) :: self + integer n + end function + + pure module function double_precision_num_components(self) result(n) + implicit none + class(tensor_t(double_precision)), intent(in) :: self + integer n + end function + + end interface + +end module tensor_m + +submodule(tensor_m) tensor_s +contains + + pure module function construct_default_real(values) result(tensor) + implicit none + real, intent(in) :: values(:) + type(tensor_t) tensor + tensor = tensor_t ()(values) + end function + + pure module function construct_double_precision(values) result(tensor) + implicit none + double precision, intent(in) :: values(:) + type(tensor_t(double_precision)) tensor + tensor = tensor_t (double_precision)(values) + end function + + pure module function default_real_values(self) result(tensor_values) + implicit none + class(tensor_t), intent(in) :: self + real, allocatable :: tensor_values(:) + tensor_values = self%values_ + end function + + pure module function double_precision_values(self) result(tensor_values) + implicit none + class(tensor_t(double_precision)), intent(in) :: self + double precision, allocatable :: tensor_values(:) + tensor_values = self%values_ + end function + + + pure module function default_real_num_components(self) result(n) + implicit none + class(tensor_t), intent(in) :: self + integer n + n = default_real + end function + + pure module function double_precision_num_components(self) result(n) + implicit none + class(tensor_t(double_precision)), intent(in) :: self + integer n + n = double_precision + end function + +end submodule tensor_s + + + use tensor_m + type(tensor_t(kind(0e0))) :: a + type(tensor_t(kind(0D0))) :: b + a = tensor_t ([1e0,2e0]) + print *, a%num_components (), a%values () + b = tensor_t ([3d0,4d0]) + print *, b%num_components (), b%values () +end +! { dg-final { scan-tree-dump-times "construct_" 4 "original" } } +! { dg-final { scan-tree-dump-times "_components" 4 "original" } } +! { dg-final { scan-tree-dump-times "_values" 4 "original" } }
