https://gcc.gnu.org/g:3a26cb6c0082a7ca1d0399e8c545df1138e91a18
commit r16-9105-g3a26cb6c0082a7ca1d0399e8c545df1138e91a18 Author: Jerry DeLisle <[email protected]> Date: Fri Jun 5 10:20:36 2026 -0700 fortran: ASSOCIATE with contained-function selector rejecting type-bound calls Two issues prevented ASSOCIATE constructs whose selector is a call to a contained function from subsequently calling type-bound procedures on the associate name. When the selector is a contained function, resolving it at parse time (before CONTAINS is fully processed) prematurely set the function's attribute to FL_PROCEDURE/EXTERNAL, conflicting with its later declaration as an internal procedure and giving a spurious "attribute conflict" error. When the first access is a generic type-bound procedure name, no candidate type was found, and the associate name got no type, giving "no IMPLICIT type". Now also search type-bound procedure names via gfc_find_typebound_proc; exclude vtable types to avoid false positives. Assisted-by: Claude Sonnet 4.6 PR fortran/125530 gcc/fortran/ChangeLog: * match.cc (gfc_match_call): Route ASSOCIATE names followed by '%' to match_typebound_call without first resolving the selector, to avoid prematurely marking a contained-function selector as EXTERNAL. * symbol.cc (find_derived_types): Also search type-bound procedure names via gfc_find_typebound_proc when inferring the type of an inferred-type ASSOCIATE name; exclude vtable types. gcc/testsuite/ChangeLog: * gfortran.dg/associate_contained_func_typebound.f90: New test. * gfortran.dg/associate_contained_func_typebound_2.f90: New run-time test exercising generic resolution and a module-scope selector. (cherry picked from commit 3ea639715f6076dbdda113e9330924262e938164) Diff: --- gcc/fortran/match.cc | 18 ++++-- gcc/fortran/symbol.cc | 6 +- .../associate_contained_func_typebound.f90 | 54 ++++++++++++++++ .../associate_contained_func_typebound_2.f90 | 73 ++++++++++++++++++++++ 4 files changed, 144 insertions(+), 7 deletions(-) diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 62bdb8687e5a..3fd42890239b 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5854,12 +5854,18 @@ gfc_match_call (void) target type. */ if (((sym->attr.flavor != FL_PROCEDURE || gfc_is_function_return_value (sym, gfc_current_ns)) - && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) - || - (sym->assoc && sym->assoc->target - && gfc_resolve_expr (sym->assoc->target) - && (sym->assoc->target->ts.type == BT_DERIVED - || sym->assoc->target->ts.type == BT_CLASS))) + && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) + || + /* Skip gfc_resolve_expr for ASSOCIATE names followed by '%'. + resolving a contained-function selector before CONTAINS is + parsed prematurely, marks it EXTERNAL, conflicting with its + later INTERNAL declaration. */ + (sym->assoc && sym->assoc->target && gfc_peek_ascii_char () == '%') + || + (sym->assoc && sym->assoc->target + && gfc_resolve_expr (sym->assoc->target) + && (sym->assoc->target->ts.type == BT_DERIVED + || sym->assoc->target->ts.type == BT_CLASS))) return match_typebound_call (st); /* If it does not seem to be callable (include functions so that the diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index e1b49b0ba0da..39f707f38927 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -2491,7 +2491,11 @@ find_derived_types (gfc_symbol *sym, gfc_symtree *st, const char *name, if (st->n.sym && st->n.sym->attr.flavor == FL_DERIVED && !st->n.sym->attr.is_class && ((contained && st->n.sym->attr.use_assoc) || !contained) - && gfc_find_component (st->n.sym, name, true, true, NULL)) + && !st->n.sym->attr.vtype + && (gfc_find_component (st->n.sym, name, true, true, NULL) + || (st->n.sym->f2k_derived + && gfc_find_typebound_proc (st->n.sym, NULL, name, true, + NULL)))) { /* Do the stashing, if required. */ cts++; diff --git a/gcc/testsuite/gfortran.dg/associate_contained_func_typebound.f90 b/gcc/testsuite/gfortran.dg/associate_contained_func_typebound.f90 new file mode 100644 index 000000000000..f71447173491 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_contained_func_typebound.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! { dg-options "" } +! +! PR fortran/125530 +! ASSOCIATE with a contained-function selector giving spurious errors when +! type-bound (including generic) procedures are called on the associate name. + +module tbp_m + implicit none + type :: t + integer :: n = 0 + contains + procedure :: direct_call + procedure :: target_of_generic + generic :: generic_call => target_of_generic + end type +contains + subroutine direct_call (self) + class(t), intent(in) :: self + print *, self%n + end subroutine + subroutine target_of_generic (self) + class(t), intent(in) :: self + print *, self%n + end subroutine +end module + +! Direct type-bound call. +subroutine test_direct () + use tbp_m + implicit none + associate (x => make_t()) + call x%direct_call() + end associate +contains + function make_t() result(r) + type(t) :: r + r%n = 1 + end function +end subroutine + +! Generic type-bound call. +subroutine test_generic () + use tbp_m + implicit none + associate (x => make_t()) + call x%generic_call() + end associate +contains + function make_t() result(r) + type(t) :: r + r%n = 2 + end function +end subroutine diff --git a/gcc/testsuite/gfortran.dg/associate_contained_func_typebound_2.f90 b/gcc/testsuite/gfortran.dg/associate_contained_func_typebound_2.f90 new file mode 100644 index 000000000000..eaa85083011f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_contained_func_typebound_2.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +! { dg-options "" } +! +! PR fortran/125530 +! ASSOCIATE with a contained-function selector must allow type-bound +! (including generic) procedure calls on the associate name, and resolve +! them to the correct target. Run-time companion to +! associate_contained_func_typebound.f90. + +module m + implicit none + type :: t + integer :: n = 0 + contains + procedure :: direct_call + procedure :: target_of_generic1 + procedure :: target_of_generic2 + generic :: generic_call => target_of_generic1, target_of_generic2 + end type + integer :: ctr = 0 +contains + subroutine direct_call (self) + class(t), intent(in) :: self + ctr = ctr + self%n + end subroutine + subroutine target_of_generic1 (self) + class(t), intent(in) :: self + ctr = ctr + self%n * 10 + end subroutine + subroutine target_of_generic2 (self, arg) + class(t), intent(in) :: self + integer, intent(in) :: arg + ctr = ctr + (self%n + arg) * 100 + end subroutine +end module + +module m2 + use m + implicit none +contains + ! Selector is a contained function. + subroutine test_direct () + associate (x => make_t ()) + call x%direct_call () + end associate + contains + function make_t () result (r) + type(t) :: r + r%n = 1 + end function + end subroutine + + ! Selector is the module-scope function; generic resolved by argument count. + subroutine test_generic () + associate (x => make_t ()) + call x%generic_call () + call x%generic_call (1) + end associate + end subroutine + + function make_t () result (r) + type(t) :: r + r%n = 2 + end function +end module + +program p + use m + use m2 + call test_generic ! 2*10 + (2+1)*100 = 320 + call test_direct ! + 1 = 321 + if (ctr /= 321) stop 1 +end program p
