https://gcc.gnu.org/g:071942e587734672e561f50837794fbddc94559a
commit r16-5044-g071942e587734672e561f50837794fbddc94559a Author: Paul Thomas <[email protected]> Date: Wed Nov 5 12:11:00 2025 +0000 Fortran: Fix PDT constructors in associate [PR122501, PR122524] 2025-11-05 Paul Thomas <[email protected]> gcc/fortran PR fortran/122501 PR fortran/122524 * primary.cc (gfc_convert_to_structure_constructor): Correct whitespace issue. (gfc_match_rvalue): Remove the attempt to match specific procs before filling out PDT constructor. Instead, defer this until resolution with the condition that there not be a following arglist and more than one procedure in the generic interface. gcc/testsuite/ PR fortran/122501 * gfortran.dg/pdt_66.f03: New test. PR fortran/122524 * gfortran.dg/pdt_67.f03: New test. Diff: --- gcc/fortran/primary.cc | 40 +++++++++----------------- gcc/testsuite/gfortran.dg/pdt_66.f03 | 54 ++++++++++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pdt_67.f03 | 36 ++++++++++++++++++++++++ 3 files changed, 103 insertions(+), 27 deletions(-) diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 1dcb1c3b5614..496ee45294e4 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -3543,7 +3543,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c } /* Find the current component in the structure definition and check - its access is not private. */ + its access is not private. */ if (comp) this_comp = gfc_find_component (sym, comp->name, false, false, NULL); else @@ -3836,8 +3836,6 @@ gfc_match_rvalue (gfc_expr **result) bool implicit_char; gfc_ref *ref; gfc_symtree *pdt_st; - gfc_symbol *found_specific = NULL; - m = gfc_match ("%%loc"); if (m == MATCH_YES) @@ -4085,29 +4083,21 @@ 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 && pdt_st != NULL && found_specific == NULL) + distinguished, other than by their attributes. + + Even if 'name' is that of a PDT template, priority has to be given to + specific procedures, other than the constructor, in the generic + interface. */ + + gfc_gobble_whitespace (); + gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st); + if (sym->attr.generic && pdt_st != NULL + && !(sym->generic->next && gfc_peek_ascii_char() != '(')) { gfc_symbol *pdt_sym; gfc_actual_arglist *ctr_arglist = NULL, *tmp; @@ -4172,12 +4162,8 @@ gfc_match_rvalue (gfc_expr **result) tmp = tmp->next; } - 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); + 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_66.f03 b/gcc/testsuite/gfortran.dg/pdt_66.f03 new file mode 100644 index 000000000000..269f6b451a11 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_66.f03 @@ -0,0 +1,54 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Check the fix for PR122501. +! +! Contributed by Damian Rouson <[email protected]> +! +module tensor_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k), allocatable, private :: values_(:) + contains + procedure default_real_values + end type + + interface tensor_t + type(tensor_t) module function construct_default_real(values) + implicit none + real values(:) + end function + end interface + + interface + module function default_real_values(self) result(tensor_values) + implicit none + class(tensor_t) self + real, allocatable :: tensor_values(:) + end function + end interface +end module + + use tensor_m + implicit none +contains + function copy(tensor) + type(tensor_t) tensor, copy, norm_copy + associate(tensor_values => tensor%default_real_values()) + +! This gave: "Component ‘values_’ at (1) is a PRIVATE component of ‘tensor_t’" + copy = tensor_t(tensor_values) + + end associate + +! Make sure that the fix really works :-) + associate(f => tensor%default_real_values()) + associate(tensor_values => tensor%default_real_values()) + norm_copy = tensor_t(tensor_values/maxval(f)) + end associate + end associate + end function +end +! { dg-final { scan-tree-dump-times "default_real_values" 3 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_67.f03 b/gcc/testsuite/gfortran.dg/pdt_67.f03 new file mode 100644 index 000000000000..b59d20140ced --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_67.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Check the fix for PR122524. +! +! Contributed by Damian Rouson <[email protected]> +! +module tensor_map_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k), allocatable :: values_(:) + end type + + interface tensor_t + module function tensor(values) + implicit none + double precision values(:) + type(tensor_t(kind(0D0))) tensor + end function + end interface + + type tensor_map_t(k) + integer, kind :: k = kind(1.) + real(k) slope_ + end type + +contains + function unnormalized_tensor(self, tensor) + type(tensor_map_t(kind(0D0))) self + type(tensor_t(kind(0D0))) tensor, unnormalized_tensor + associate(unnormalized_values => tensor%values_*self%slope_) + unnormalized_tensor = tensor_t(unnormalized_values) ! Caused an ICE. + end associate + end function +end module
