Here is another small patch. Discovered while working another issue.
If I don't see a reply back, I will commit this as simple and obvious.
New test case provided.
Regression tested on x86_64.
OK for mainline?
Regards.
Jerry
---
fortran: Wrong SAME_TYPE_AS through inferred CLASS associate
name
When the selector of an associate name is a function that has not been
parsed yet, the type of the associate name is guessed and corrected
later in gfc_fixup_inferred_type_refs. For a CLASS associate name,
resolve_variable then also called gfc_fix_class_refs on references such
as
q%c1(4)%c2
where c2 is a CLASS array component. gfc_fix_class_refs added a '_data'
reference in front of the array reference that ends the chain, so the
expression was no longer polymorphic and SAME_TYPE_AS was folded to
.false. at compile time. The same reference through an associate name
whose type is known when it is parsed never goes through this call.
Skip gfc_fix_class_refs for inferred-type references, which
gfc_fixup_inferred_type_refs has already fixed up.
gcc/fortran/ChangeLog:
* resolve.cc (resolve_variable): Do not call gfc_fix_class_refs
for an inferred-type reference.
gcc/testsuite/ChangeLog:
* gfortran.dg/associate_92.f90: New test.
---From bc71a4150428796f925a7bd82ab743613076f48e Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sat, 24 Oct 2026 09:47:44 -0400
Subject: [PATCH] fortran: Wrong SAME_TYPE_AS through inferred CLASS associate
name
When the selector of an associate name is a function that has not been
parsed yet, the type of the associate name is guessed and corrected
later in gfc_fixup_inferred_type_refs. For a CLASS associate name,
resolve_variable then also called gfc_fix_class_refs on references such
as
q%c1(4)%c2
where c2 is a CLASS array component. gfc_fix_class_refs added a '_data'
reference in front of the array reference that ends the chain, so the
expression was no longer polymorphic and SAME_TYPE_AS was folded to
.false. at compile time. The same reference through an associate name
whose type is known when it is parsed never goes through this call.
Skip gfc_fix_class_refs for inferred-type references, which
gfc_fixup_inferred_type_refs has already fixed up.
gcc/fortran/ChangeLog:
* resolve.cc (resolve_variable): Do not call gfc_fix_class_refs
for an inferred-type reference.
gcc/testsuite/ChangeLog:
* gfortran.dg/associate_92.f90: New test.
---
gcc/fortran/resolve.cc | 3 +-
gcc/testsuite/gfortran.dg/associate_92.f90 | 40 ++++++++++++++++++++++
2 files changed, 42 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/associate_92.f90
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index ab0002a9d13..11a102098a7 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -6717,7 +6717,8 @@ resolve_variable (gfc_expr *e)
TODO Understand why class scalar expressions must be excluded. */
if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
{
- if (sym->ts.type == BT_CLASS)
+ /* Inferred-type references are already fixed up above. */
+ if (sym->ts.type == BT_CLASS && !IS_INFERRED_TYPE (e))
gfc_fix_class_refs (e);
if (!sym->attr.dimension && !sym->attr.codimension && e->ref
&& e->ref->type == REF_ARRAY)
diff --git a/gcc/testsuite/gfortran.dg/associate_92.f90 b/gcc/testsuite/gfortran.dg/associate_92.f90
new file mode 100644
index 00000000000..7433f6794df
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_92.f90
@@ -0,0 +1,40 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! A CLASS array component referenced through an associate name whose CLASS
+! type was inferred lost its polymorphism, so SAME_TYPE_AS folded to false.
+!
+module m
+ type :: leaf_t
+ integer :: bar = 0
+ end type
+ type, extends (leaf_t) :: leaf2_t
+ integer :: baz = 7
+ end type
+ type :: mid_t
+ class(leaf_t), allocatable :: c2(:)
+ end type
+ type :: outer_t
+ class(mid_t), allocatable :: c1(:)
+ end type
+end module
+
+program p
+ use m
+ implicit none
+
+ associate (q => gfcn ())
+ if (.not. same_type_as (q%c1(4)%c2, leaf2_t ())) stop 1
+ if (same_type_as (q%c1(4)%c2, leaf_t ())) stop 2
+ if (.not. same_type_as (q%c1(4)%c2(2:3), leaf2_t ())) stop 3
+ end associate
+
+contains
+
+ function gfcn () result (y)
+ class(outer_t), allocatable :: y
+ allocate (y)
+ end function
+end program
+
+! { dg-final { scan-tree-dump-times "c2\\._vptr->_hash" 3 "original" } }
--
2.56.0
