https://gcc.gnu.org/g:e33129b871c30276acfaed2b435ae5b505b73655
commit r17-5743-ge33129b871c30276acfaed2b435ae5b505b73655 Author: Jerry DeLisle <[email protected]> Date: Tue Oct 27 10:50:08 2026 -0400 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. Assisted-by: Claude Opus 5.5 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. Diff: --- 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(-) diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 8eab4e7b9bd6..84481cf35ae9 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 f931fb86f180..514263c1bc52 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 73f0280645d7..00c86041550d 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 aa370752e9da..43cecf192335 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 000000000000..a7883f06d7a7 --- /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
