See the following attached patch.
This was actually a nasty problem. It could only be seen if the testcase that
failed happened to be written in a certain way and only showed up with -m32.
I tested this patch on x86_64. The failure also reproduces with an
arm-linux-gnueabihf cross compiler (same 6 errors in associate_91); the patch
fixes it there as well..
OK for mainline?
Regards,
Jerry
---
[PATCH] fortran: [PR126968] Make inferred ASSOCIATE type guess
target-independent
The test associate_91.f90, added for PR126968, failed with -m32.
When an ASSOCIATE selector is a function that has not been parsed yet,
gfc_match_varspec guesses the type of the associate name from the first
component reference. Any accessible derived type with a component of
that name is a candidate, and the first candidate is used. The
candidates were collected by a pre-order walk of the symtree. The shape
of the symtree depends on how many symbols were inserted before, which
differs between targets. With -m32 the guess for associate_91 became a
type in which the component is a scalar integer, so the rest of the
reference, q%c1(4)%c2(:)%bar, could not be parsed.
Pick the first candidate in which the whole component chain exists, and
collect the candidates by an in-order walk so that the guess no longer
depends on the target.
With the guess now predictable, associate_93.f90 is changed so that both
of its blocks start from a wrong guess. This exposed a case that was
never exercised on x86_64: when the guessed component is a scalar
character, a following section such as t(2:3) is parsed as a substring.
When the real component is an array, turn the substring back into an
array section.
PR fortran/126968
gcc/fortran/ChangeLog:
* primary.cc (skip_ref_groups): New function.
(inferred_type_chain_ok): New function.
(gfc_match_varspec): Use it to choose among the candidate types of
an inferred-type associate name.
* resolve.cc (fixup_inferred_component_array_ref): Turn a substring
into an array section when the component is a rank-1 array.
* symbol.cc (find_derived_types): Walk the symtree in order.
gcc/testsuite/ChangeLog:
* gfortran.dg/associate_93.f90: Rename the guessed types so that
they are tried first.
* gfortran.dg/associate_97.f90: New test.
---From 64d3acbaabd74ae2648afd805b6ad7378ad439e2 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Tue, 27 Oct 2026 10:50:08 -0400
Subject: [PATCH] fortran: [PR126968] Make inferred ASSOCIATE type guess
target-independent
The test associate_91.f90, added for PR126968, failed with -m32.
When an ASSOCIATE selector is a function that has not been parsed yet,
gfc_match_varspec guesses the type of the associate name from the first
component reference. Any accessible derived type with a component of
that name is a candidate, and the first candidate is used. The
candidates were collected by a pre-order walk of the symtree. The shape
of the symtree depends on how many symbols were inserted before, which
differs between targets. With -m32 the guess for associate_91 became a
type in which the component is a scalar integer, so the rest of the
reference, q%c1(4)%c2(:)%bar, could not be parsed.
Pick the first candidate in which the whole component chain exists, and
collect the candidates by an in-order walk so that the guess no longer
depends on the target.
With the guess now predictable, associate_93.f90 is changed so that both
of its blocks start from a wrong guess. This exposed a case that was
never exercised on x86_64: when the guessed component is a scalar
character, a following section such as t(2:3) is parsed as a substring.
When the real component is an array, turn the substring back into an
array section.
PR fortran/126968
gcc/fortran/ChangeLog:
* primary.cc (skip_ref_groups): New function.
(inferred_type_chain_ok): New function.
(gfc_match_varspec): Use it to choose among the candidate types of
an inferred-type associate name.
* resolve.cc (fixup_inferred_component_array_ref): Turn a substring
into an array section when the component is a rank-1 array.
* symbol.cc (find_derived_types): Walk the symtree in order.
gcc/testsuite/ChangeLog:
* gfortran.dg/associate_93.f90: Rename the guessed types so that
they are tried first.
* gfortran.dg/associate_97.f90: New test.
---
gcc/fortran/primary.cc | 110 ++++++++++++++++++++-
gcc/fortran/resolve.cc | 15 +++
gcc/fortran/symbol.cc | 7 +-
gcc/testsuite/gfortran.dg/associate_93.f90 | 6 +-
gcc/testsuite/gfortran.dg/associate_97.f90 | 67 +++++++++++++
5 files changed, 195 insertions(+), 10 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/associate_97.f90
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index d7a880b3983..7b951d77619 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2173,6 +2173,99 @@ is_inquiry_ref (const char *name, gfc_ref **ref)
}
+/* Skip any parenthesized or bracketed groups at the current locus. */
+
+static void
+skip_ref_groups (void)
+{
+ for (;;)
+ {
+ gfc_gobble_whitespace ();
+ gfc_char_t c = gfc_peek_char ();
+ if (c != '(' && c != '[')
+ return;
+
+ int depth = 0;
+ gfc_char_t quote = ' ';
+ do
+ {
+ c = gfc_next_char_literal (quote == ' ' ? NONSTRING
+ : INSTRING_NOWARN);
+ if (c == '\n')
+ return;
+ if (quote != ' ')
+ {
+ if (c == quote)
+ quote = ' ';
+ }
+ else if (c == '\'' || c == '"')
+ quote = c;
+ else if (c == '(' || c == '[')
+ depth++;
+ else if (c == ')' || c == ']')
+ depth--;
+ }
+ while (depth > 0);
+ }
+}
+
+
+/* Return true if the component references at the current locus can be
+ followed starting from derived type DT. The locus is not changed. */
+
+static bool
+inferred_type_chain_ok (gfc_symbol *dt)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ locus old_loc = gfc_current_locus;
+ bool ok = true;
+
+ while (gfc_match_name (name) == MATCH_YES)
+ {
+ gfc_component *c = gfc_find_component (dt, name, true, true, NULL);
+ if (!c)
+ {
+ ok = dt->f2k_derived
+ && gfc_find_typebound_proc (dt, NULL, name, true, NULL);
+ break;
+ }
+
+ /* A subscript needs an array, a substring or a procedure pointer. */
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_char () == '('
+ && !c->as && c->ts.type != BT_CHARACTER && !c->attr.proc_pointer
+ && !(c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->as))
+ {
+ ok = false;
+ break;
+ }
+ skip_ref_groups ();
+
+ if (gfc_match_char ('%') != MATCH_YES)
+ break;
+
+ if (c->ts.type == BT_DERIVED)
+ dt = c->ts.u.derived;
+ else if (c->ts.type == BT_CLASS)
+ {
+ if (!c->attr.class_ok || !CLASS_DATA (c))
+ break;
+ dt = CLASS_DATA (c)->ts.u.derived;
+ }
+ else
+ {
+ ok = gfc_match_name (name) == MATCH_YES
+ && is_inquiry_ref (name, NULL);
+ break;
+ }
+ }
+
+ gfc_current_locus = old_loc;
+ return ok;
+}
+
+
/* Check to see if functions in operator expressions can be resolved now. */
static bool
@@ -2456,6 +2549,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
{
bool sym_present, resolved = false;
gfc_symbol *tgt_sym;
+ int ndt;
sym_present = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym;
tgt_sym = sym_present ? tgt_expr->symtree->n.sym : NULL;
@@ -2492,15 +2586,23 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|| (!resolved && tgt_expr->expr_type == EXPR_OP))
&& (sym->ts.type == BT_UNKNOWN
|| (inferred_type && sym->ts.type != BT_COMPLEX))
- && gfc_find_derived_types (sym, gfc_current_ns, name, true))
+ && (ndt = gfc_find_derived_types (sym, gfc_current_ns, name, true)))
{
sym->assoc->inferred_type = 1;
- /* The first returned type is as good as any at this stage. The final
- determination is made in 'gfc_fixup_inferred_type_refs'*/
+ /* Pick a candidate type for now. The final determination is made in
+ 'gfc_fixup_inferred_type_refs'. Prefer the first candidate that
+ has the whole component chain. */
gfc_symbol **dts = &sym->assoc->derived_types;
+ gfc_symbol *dt = *dts;
+ for (gfc_symbol *cand = *dts; cand && ndt-- > 0; cand = cand->dt_next)
+ if (inferred_type_chain_ok (cand))
+ {
+ dt = cand;
+ break;
+ }
tgt_expr->ts.type = BT_DERIVED;
tgt_expr->ts.kind = 0;
- tgt_expr->ts.u.derived = *dts;
+ tgt_expr->ts.u.derived = dt;
sym->ts = tgt_expr->ts;
primary->ts = sym->ts;
/* Delete the dt list even if this process has to be done again for
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index a6e05920e91..99bfbd00552 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -7048,6 +7048,21 @@ fixup_inferred_component_array_ref (gfc_expr *e, gfc_component *c,
/* Leave the array ref of a scalar to find_array_spec to diagnose. */
ref->u.ar.as = NULL;
}
+ else if (as && as->rank == 1 && ref && ref->type == REF_SUBSTRING)
+ {
+ /* An array section misidentified as a substring. */
+ gfc_expr *start = ref->u.ss.start;
+ gfc_expr *end = ref->u.ss.end;
+ memset (&ref->u, 0, sizeof (ref->u));
+ ref->type = REF_ARRAY;
+ ref->u.ar.type = AR_SECTION;
+ ref->u.ar.dimen = 1;
+ ref->u.ar.dimen_type[0] = DIMEN_RANGE;
+ ref->u.ar.start[0] = start;
+ ref->u.ar.end[0] = end;
+ ref->u.ar.as = as;
+ ref->u.ar.where = e->where;
+ }
else if (as)
{
/* Supply the full array ref of a component guessed to be scalar. */
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 73f0280645d..00c86041550 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -2494,6 +2494,10 @@ static void
find_derived_types (gfc_symbol *sym, gfc_symtree *st, const char *name,
bool contained, bool stash)
{
+ /* Visit in order so that the result does not depend on the tree shape. */
+ if (st->left)
+ find_derived_types (sym, st->left, name, contained, stash);
+
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)
@@ -2513,9 +2517,6 @@ find_derived_types (gfc_symbol *sym, gfc_symtree *st, const char *name,
}
}
- if (st->left)
- find_derived_types (sym, st->left, name, contained, stash);
-
if (st->right)
find_derived_types (sym, st->right, name, contained, stash);
}
diff --git a/gcc/testsuite/gfortran.dg/associate_93.f90 b/gcc/testsuite/gfortran.dg/associate_93.f90
index aa370752e9d..43cecf19233 100644
--- a/gcc/testsuite/gfortran.dg/associate_93.f90
+++ b/gcc/testsuite/gfortran.dg/associate_93.f90
@@ -1,7 +1,7 @@
! { dg-do run }
! PR fortran/126968
! Array references after components of an associate name whose type was
-! guessed wrongly ('g*_t') must follow the array spec of the real component.
+! guessed wrongly ('w*_t') must follow the array spec of the real component.
!
module m
type :: leaf_t
@@ -10,7 +10,7 @@ module m
type :: w1_t
type(leaf_t) :: b(2)
end type
- type :: g_t
+ type :: w_t
type(w1_t) :: a(4)
integer :: v(3) = 9
character(4) :: s(3) = 'gggg'
@@ -25,7 +25,7 @@ module m
character(4) :: s = 'abcd'
integer :: m(2,2) = reshape ([1, 2, 3, 4], [2, 2])
end type
- type :: g2_t
+ type :: w2_t
integer :: w = 9
character(4) :: t = 'gggg'
class(leaf_t), allocatable :: c
diff --git a/gcc/testsuite/gfortran.dg/associate_97.f90 b/gcc/testsuite/gfortran.dg/associate_97.f90
new file mode 100644
index 00000000000..a7883f06d7a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_97.f90
@@ -0,0 +1,67 @@
+! { dg-do run }
+! PR fortran/126968
+! The parse-time type guess for an associate name must pick a candidate
+! type in which the whole component chain exists ('wrong_t' and 'zz_t' are
+! tried first).
+!
+module m
+ type :: leaf_t
+ integer :: bar = 0
+ complex :: z = (1.0, 2.0)
+ character(5) :: s = 'hello'
+ contains
+ procedure :: get
+ end type
+ type :: mid_t
+ class(leaf_t), allocatable :: c2(:)
+ end type
+ type :: outer_t
+ type(mid_t) :: c1(5)
+ end type
+ type :: wrong_t
+ integer :: c1 = 1
+ end type
+ type :: zz_t
+ character(8) :: c1 = 'zzzzzzzz'
+ end type
+contains
+ integer function get (this)
+ class(leaf_t), intent(in) :: this
+ get = this%bar + 100
+ end function
+end module
+
+program p
+ use m
+ implicit none
+ integer :: i, k
+ real :: r
+ character(3) :: c
+
+ associate (q => tfcn ())
+ i = q%c1(index ("a(b)c", "(") + 2)%c2(2)%bar
+ if (i /= 42) stop 1
+ i = q%c1(3)% &
+ c2(1)%bar
+ if (i /= 31) stop 2
+ r = q%c1(4)%c2(1)%z%im
+ if (r /= 2.0) stop 3
+ k = q%c1(4)%c2(3)%s%len
+ if (k /= 5) stop 4
+ c = q%c1(4)%c2(3)%s(2:4)
+ if (c /= 'ell') stop 5
+ i = q%c1(2)%c2(1)%get ()
+ if (i /= 121) stop 6
+ end associate
+
+contains
+
+ function tfcn () result (y)
+ type(outer_t) :: y
+ integer :: k
+ do k = 1, 5
+ allocate (y%c1(k)%c2(3))
+ y%c1(k)%c2(:)%bar = [10*k+1, 10*k+2, 10*k+3]
+ end do
+ end function
+end program
--
2.56.0
