https://gcc.gnu.org/g:db896263a5f476223958cf9ffeb1922759601362
commit r17-5670-gdb896263a5f476223958cf9ffeb1922759601362 Author: Jerry DeLisle <[email protected]> Date: Sat Oct 24 19:33:17 2026 -0400 fortran: [PR128144] ICE for type-bound call through inferred ASSOCIATE name When an ASSOCIATE selector is a contained function that has not been parsed yet, the associate name gets a guessed type and its references are fixed up during resolution by gfc_fixup_inferred_type_refs. That only happened for variables. A type-bound procedure call or a procedure pointer component call through the associate name, such as q%c2%get (), kept the references built from the guess: the '_data' reference after a CLASS associate name was missing, components could belong to the wrongly guessed type, and the binding itself had been looked up in that type. This gave internal compiler error: in gfc_conv_component_ref, at fortran/trans-expr.cc:2939 or, with a wrong guess, a call of the wrong procedure or a bogus type mismatch error. Fix up the references of these calls in the same way before they are resolved, and look the binding up again in the corrected type. The call of gfc_fixup_inferred_type_refs in gfc_conv_variable, which was meant to catch expressions that escaped resolution, now finds nothing to do, and it misbehaved on reference chains that callers cut short temporarily, so remove it. For an element of an array valued associate name of this kind, the array reference has no array spec, so find_array_spec is used. It did not take the array spec of a CLASS array component, which is held by its '_data' component, and rejected valid code such as size (q(1)%c2) with "Invalid array reference of a non-array entity". Use the array spec of the '_data' component when the array reference follows the CLASS component directly. PR fortran/128144 gcc/fortran/ChangeLog: * resolve.cc (find_array_spec): Handle CLASS array components followed directly by an array reference. (fixup_inferred_compcall_refs): New function. (resolve_typebound_function, resolve_typebound_subroutine) (resolve_ppc_call, resolve_expr_ppc): Use it. * trans-expr.cc (gfc_conv_variable): Do not call gfc_fixup_inferred_type_refs. gcc/testsuite/ChangeLog: * gfortran.dg/associate_95.f90: New test. * gfortran.dg/associate_96.f90: New test. Diff: --- gcc/fortran/resolve.cc | 63 +++++++++++++++ gcc/fortran/trans-expr.cc | 4 - gcc/testsuite/gfortran.dg/associate_95.f90 | 120 +++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/associate_96.f90 | 63 +++++++++++++++ 4 files changed, 246 insertions(+), 4 deletions(-) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 099f996e54f2..f931fb86f180 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5682,6 +5682,15 @@ find_array_spec (gfc_expr *e) gfc_internal_error ("find_array_spec(): unused as(1)"); as = c->as; } + else if (c->ts.type == BT_CLASS && CLASS_DATA (c) + && CLASS_DATA (c)->attr.dimension + && ref->next && ref->next->type == REF_ARRAY) + { + /* CLASS array component with an implicit '_data' reference. */ + if (as != NULL) + gfc_internal_error ("find_array_spec(): unused as(1)"); + as = CLASS_DATA (c)->as; + } break; @@ -8048,6 +8057,52 @@ resolve_compcall (gfc_expr* e, const char **name) static bool resolve_fl_derived (gfc_symbol *sym); +/* Fix up the references of the EXPR_COMPCALL or EXPR_PPC E, whose base + object is an inferred type associate name, as for the equivalent + variable. Look up the type-bound procedure again in the corrected + type. */ + +static void +fixup_inferred_compcall_refs (gfc_expr *e) +{ + gfc_symbol *sym, *dt; + gfc_symtree *tbp; + gfc_expr *var; + bool t; + + sym = e->symtree->n.sym; + if (!sym->assoc || !sym->assoc->inferred_type + || (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)) + return; + + if (e->ref) + { + var = gfc_get_expr (); + var->expr_type = EXPR_VARIABLE; + var->symtree = e->symtree; + var->ref = e->ref; + var->ts = sym->ts; + var->where = e->where; + gfc_fixup_inferred_type_refs (var); + e->ref = var->ref; + var->ref = NULL; + gfc_free_expr (var); + } + + if (e->expr_type != EXPR_COMPCALL || !e->value.compcall.name) + return; + + dt = get_declared_from_expr (NULL, NULL, e, true); + if (dt->attr.is_class && dt->components) + dt = dt->components->ts.u.derived; + + tbp = gfc_find_typebound_proc (dt, &t, e->value.compcall.name, false, + &e->where); + if (tbp && t) + e->value.compcall.tbp = tbp->n.tb; +} + + /* Resolve a typebound function, or 'method'. First separate all the non-CLASS references by calling resolve_compcall directly. */ @@ -8116,6 +8171,8 @@ resolve_typebound_function (gfc_expr* e) if (st == NULL) return resolve_compcall (e, NULL); + fixup_inferred_compcall_refs (e); + if (!gfc_resolve_ref (e)) return false; @@ -8265,6 +8322,8 @@ resolve_typebound_subroutine (gfc_code *code) if (st == NULL) return resolve_typebound_call (code, NULL, NULL); + fixup_inferred_compcall_refs (code->expr1); + if (!gfc_resolve_ref (code->expr1)) return false; @@ -8319,6 +8378,8 @@ resolve_ppc_call (gfc_code* c) { gfc_component *comp; + fixup_inferred_compcall_refs (c->expr1); + comp = gfc_get_proc_ptr_comp (c->expr1); gcc_assert (comp != NULL); @@ -8357,6 +8418,8 @@ resolve_expr_ppc (gfc_expr* e) { gfc_component *comp; + fixup_inferred_compcall_refs (e); + comp = gfc_get_proc_ptr_comp (e); gcc_assert (comp != NULL); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index a2903eeeba1f..c81051f71623 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -3325,10 +3325,6 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) free (msg); } - /* Some expressions leak through that haven't been fixed up. */ - if (IS_INFERRED_TYPE (expr) && expr->ref) - gfc_fixup_inferred_type_refs (expr); - gfc_typespec *ts = &sym->ts; while (ref) { diff --git a/gcc/testsuite/gfortran.dg/associate_95.f90 b/gcc/testsuite/gfortran.dg/associate_95.f90 new file mode 100644 index 000000000000..6b6611fdb56a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_95.f90 @@ -0,0 +1,120 @@ +! { dg-do run } +! PR fortran/128144 +! Type-bound procedure and procedure pointer component calls through +! components of an associate name whose selector is a contained function +! that has not been parsed yet. 'other_t' has a component 'c2' with a +! binding and a procedure pointer of the same names, so it can be guessed +! wrongly. +! +module m + implicit none + abstract interface + integer function ifn (k) + integer, intent(in) :: k + end function + real function rfn (x) + real, intent(in) :: x + end function + end interface + type :: oleaf_t + procedure (rfn), pointer, nopass :: pp => null () + contains + procedure :: get => oget + procedure :: put => oput + end type + type :: other_t + type(oleaf_t) :: c2 + end type + type :: leaf_t + integer :: bar = 0 + procedure (ifn), pointer, nopass :: pp => null () + contains + procedure :: get + procedure :: put + procedure :: eget + end type + type, extends (leaf_t) :: leaf2_t + integer :: baz(4) = 7 + contains + procedure :: get => get2 + end type + type :: mid_t + class(leaf_t), allocatable :: c2 + class(leaf_t), allocatable :: arr(:) + end type +contains + integer function oget (this) + class(oleaf_t), intent(in) :: this + oget = -1 + end function + subroutine oput (this, k) + class(oleaf_t), intent(in) :: this + integer, intent(out) :: k + k = -1 + end subroutine + integer function get (this) + class(leaf_t), intent(in) :: this + get = this%bar + 100 + end function + integer function get2 (this) + class(leaf2_t), intent(in) :: this + get2 = this%bar + 1000 + end function + subroutine put (this, k) + class(leaf_t), intent(in) :: this + integer, intent(out) :: k + k = this%bar + 200 + end subroutine + elemental integer function eget (this) + class(leaf_t), intent(in) :: this + eget = this%bar * 10 + end function + integer function dbl (k) + integer, intent(in) :: k + dbl = 2 * k + end function +end module + +program p + use m + implicit none + integer :: i, j, k, s, r(3) + + associate (q => cfcn ()) + i = q%c2%get () + call q%c2%put (j) + k = q%c2%pp (21) + s = storage_size (q%c2) + r = q%arr%eget () + end associate + if (i /= 1005) stop 1 + if (j /= 205) stop 2 + if (k /= 42) stop 3 + if (s /= storage_size (leaf2_t ())) stop 4 + if (any (r /= [10, 20, 30])) stop 5 + + associate (q => lfcn ()) + i = q%get () + call q%put (j) + end associate + if (i /= 1005) stop 6 + if (j /= 205) stop 7 + +contains + + function cfcn () result (y) + class(mid_t), allocatable :: y + allocate (y) + allocate (leaf2_t :: y%c2) + y%c2%bar = 5 + y%c2%pp => dbl + allocate (y%arr(3)) + y%arr%bar = [1, 2, 3] + end function + + function lfcn () result (y) + class(leaf_t), allocatable :: y + allocate (leaf2_t :: y) + y%bar = 5 + end function +end program diff --git a/gcc/testsuite/gfortran.dg/associate_96.f90 b/gcc/testsuite/gfortran.dg/associate_96.f90 new file mode 100644 index 000000000000..5e2448547aa7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_96.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! PR fortran/128144 +! References to CLASS array components of an element of an associate name +! whose selector is an array valued contained function that has not been +! parsed yet. +! +module m + implicit none + type :: leaf_t + integer :: bar = 0 + contains + procedure :: get + end type + type, extends (leaf_t) :: leaf2_t + contains + procedure :: get => get2 + end type + type :: mid_t + class(leaf_t), allocatable :: c2(:) + end type + type :: top_t + class(leaf_t), pointer :: c2(:,:) => null () + class(mid_t), allocatable :: cm + end type +contains + integer function get (this) + class(leaf_t), intent(in) :: this + get = this%bar + 100 + end function + integer function get2 (this) + class(leaf2_t), intent(in) :: this + get2 = this%bar + 1000 + end function +end module + +program p + use m + implicit none + integer :: i, s(2) + + associate (q => cfcn ()) + if (size (q(1)%cm%c2) /= 3) stop 1 + if (any (q(1)%cm%c2%bar /= [1, 2, 3])) stop 2 + i = q(1)%cm%c2(2)%get () + if (i /= 1002) stop 3 + s = shape (q(2)%c2) + if (any (s /= [2, 3])) stop 4 + if (q(2)%c2(2,3)%bar /= 6) stop 5 + i = q(2)%c2(1,2)%get () + if (i /= 1003) stop 6 + end associate + +contains + + function cfcn () result (y) + type(top_t) :: y(2) + allocate (y(1)%cm) + allocate (leaf2_t :: y(1)%cm%c2(3)) + y(1)%cm%c2%bar = [1, 2, 3] + allocate (leaf2_t :: y(2)%c2(2,3)) + y(2)%c2%bar = reshape ([1, 2, 3, 4, 5, 6], [2, 3]) + end function +end program
