See the attached patch.
This one discovered while working on PR126968. In the meantime, a regressionwas
found on the PR126968 commit with -m32. I forgot to get the LD_LIBRARY_PATH set
right so did not see the failure. I will have another followup patch for the
regression which is a result of the search order looking for the correct names.
More explanation will follow when I submit that one.
Regression tested on x86_64.
OK for mainline?
Best regards,
Jerry
---
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.
---From f97aaa9a9c39b337efb982b8ad8e2351a9ed5480 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sat, 24 Oct 2026 19:33:17 -0400
Subject: [PATCH] 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.
---
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(-)
create mode 100644 gcc/testsuite/gfortran.dg/associate_95.f90
create mode 100644 gcc/testsuite/gfortran.dg/associate_96.f90
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 9334cbff9bc..a6e05920e91 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 ed1dc62dc2c..1b580858ef4 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 00000000000..6b6611fdb56
--- /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 00000000000..5e2448547aa
--- /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
--
2.56.0
