See attached patch.
I incorporated Mikael's comments from the PR.
I regression tested this and also verified the original test case is fixed.
I also added a new test case.
OK for mainline?
Regards,
Jerry
---
fortran: [PR125761] Unlimited-poly character array section base
When a CLASS(*) array section carrying a CHARACTER payload is passed
as the base of an array reference, build_array_ref and
gfc_build_array_ref computed the element span from the dynamic type's
vptr size alone, ignoring the unlimited-polymorphic object's _len
field. For a deferred-length character payload this gave the wrong
element size, so the section's data pointer was offset incorrectly by
the lower bound, producing wrong code (no ICE needed to reproduce: a
section of a CLASS(*) character array passed to a procedure reads from
the wrong address).
PR fortran/125761
gcc/fortran/ChangeLog:
* trans-array.cc (build_array_ref): When the descriptor's
canonical type is a class type, pass the class container as
'decl' to gfc_build_array_ref for genuine array element
references (rank > 0), so the element size can be corrected
for an unlimited-polymorphic character payload.
* trans-types.cc (gfc_typenode_for_spec): Move setting the
GFC_CLASS_TYPE_P bit to..
(gfc_get_derived_type): .. and use attr.is_class.
(gfc_get_derived_type): Move setting the GFC_CLASS_TYPE_P bit
as the last step before returning the derived->backend_decl
if the derived->attr.is_class is true.
* trans.cc (gfc_build_array_ref): Recognize a class container
via its canonical type as well as GFC_CLASS_TYPE_P, and apply
the _len-based span correction in that case too.
gcc/testsuite/ChangeLog:
* gfortran.dg/select_type_53.f90: New test.
commit 59ab0a7d5063c659bfc59f41d8a3f3ab26c68977
Author: Jerry DeLisle <[email protected]>
Date: Tue Jun 23 12:56:24 2026 -0700
fortran: [PR125761] Unlimited-poly character array section base
When a CLASS(*) array section carrying a CHARACTER payload is passed
as the base of an array reference, build_array_ref and
gfc_build_array_ref computed the element span from the dynamic type's
vptr size alone, ignoring the unlimited-polymorphic object's _len
field. For a deferred-length character payload this gave the wrong
element size, so the section's data pointer was offset incorrectly by
the lower bound, producing wrong code (no ICE needed to reproduce: a
section of a CLASS(*) character array passed to a procedure reads from
the wrong address).
PR fortran/125761
gcc/fortran/ChangeLog:
* trans-array.cc (build_array_ref): When the descriptor's
canonical type is a class type, pass the class container as
'decl' to gfc_build_array_ref for genuine array element
references (rank > 0), so the element size can be corrected
for an unlimited-polymorphic character payload.
* trans-types.cc (gfc_typenode_for_spec): Move setting the
GFC_CLASS_TYPE_P bit to..
(gfc_get_derived_type): .. and use attr.is_class.
(gfc_get_derived_type): Move setting the GFC_CLASS_TYPE_P bit
as the last step before returning the derived->backend_decl
if the derived->attr.is_class is true.
* trans.cc (gfc_build_array_ref): Recognize a class container
via its canonical type as well as GFC_CLASS_TYPE_P, and apply
the _len-based span correction in that case too.
gcc/testsuite/ChangeLog:
* gfortran.dg/select_type_53.f90: New test.
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cde5d3e4b32..75780afccc6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -4493,7 +4493,18 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr)
type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
if (TYPE_CANONICAL (type)
&& GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
- vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
+ {
+ vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
+ /* Pass the class container as decl so that gfc_build_array_ref can
+ correct the element size for an unlimited polymorphic character
+ payload (the _len field), which the vptr size alone omits. Only do
+ this for a genuine array element reference; a scalar coarray has
+ nothing to span-correct and gfc_build_array_ref asserts decl is null
+ for it. */
+ if (decl == NULL_TREE
+ && GFC_TYPE_ARRAY_RANK (TREE_TYPE (cdesc)) > 0)
+ decl = TREE_OPERAND (cdesc, 0);
+ }
}
tmp = gfc_conv_array_data (desc);
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 5bccea960aa..6798f54beb2 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1380,9 +1380,6 @@ gfc_typenode_for_spec (gfc_typespec * spec, int codim)
case BT_CLASS:
basetype = gfc_get_derived_type (spec->u.derived, codim);
- if (spec->type == BT_CLASS)
- GFC_CLASS_TYPE_P (basetype) = 1;
-
/* If we're dealing with either C_PTR or C_FUNPTR, we modified the
type and kind to fit a (void *) and the basetype returned was a
ptr_type_node. We need to pass up this new information to the
@@ -2970,6 +2967,8 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
TYPE_NAME (typenode) = get_identifier (derived->name);
TYPE_PACKED (typenode) = flag_pack_derived;
derived->backend_decl = typenode;
+ if (derived->attr.is_class)
+ GFC_CLASS_TYPE_P (typenode) = 1;
}
if (derived->components
@@ -3132,15 +3131,6 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
ptr_mode, true);
- /* Ensure that the CLASS language specific flag is set. */
- if (c->ts.type == BT_CLASS)
- {
- if (POINTER_TYPE_P (field_type))
- GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
- else
- GFC_CLASS_TYPE_P (field_type) = 1;
- }
-
field = gfc_add_field_to_struct (typenode,
get_identifier (c->name),
field_type, &chain);
@@ -3213,6 +3203,9 @@ copy_derived_types:
break;
}
+ if (derived->attr.is_class)
+ GFC_CLASS_TYPE_P (derived->backend_decl) = 1;
+
return derived->backend_decl;
}
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index adf392cec6f..c10484ff636 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -524,8 +524,13 @@ gfc_build_array_ref (tree base, tree offset, tree decl,
span = gfc_vptr_size_get (vptr);
/* Check if this is an unlimited polymorphic object carrying a character
- payload. In this case, the 'len' field is non-zero. */
- if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
+ payload. In this case, the 'len' field is non-zero. The class
+ container type does not always carry GFC_CLASS_TYPE_P, but its
+ canonical type does. */
+ if (decl
+ && (GFC_CLASS_TYPE_P (TREE_TYPE (decl))
+ || (TYPE_CANONICAL (TREE_TYPE (decl))
+ && GFC_CLASS_TYPE_P (TYPE_CANONICAL (TREE_TYPE (decl))))))
span = gfc_resize_class_size_with_len (NULL, decl, span);
}
else if (decl)
diff --git a/gcc/testsuite/gfortran.dg/select_type_53.f90 b/gcc/testsuite/gfortran.dg/select_type_53.f90
new file mode 100644
index 00000000000..98f16dccfb1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_53.f90
@@ -0,0 +1,41 @@
+! { dg-do run }
+!
+! PR fortran/125761
+!
+! Passing an array section of an unlimited-polymorphic array with a CHARACTER
+! payload addressed the section data with the wrong element size: the section
+! base data pointer was offset using the vptr size (the kind size, 1) rather
+! than the _len-corrected element size, so every element but the first was
+! wrong.
+
+program p
+ character(4), target :: arr(5) = ["aaaa", "bbbb", "cccc", "dddd", "eeee"]
+ character(2), target :: arr2(4) = ["xx", "yy", "zz", "ww"]
+ class(*), pointer :: ptr(:)
+
+ ptr => arr
+ call check (ptr(2:4), ["bbbb", "cccc", "dddd"]) ! contiguous
+ call check (ptr(1:5:2), ["aaaa", "cccc", "eeee"]) ! strided
+
+ ptr => arr2
+ call check (ptr(2:3), ["yy", "zz"])
+
+contains
+
+ subroutine check (x, expect)
+ class(*) :: x(:)
+ character(*), intent(in) :: expect(:)
+ integer :: i
+ select type (x)
+ type is (character(*))
+ if (len (x) /= len (expect)) stop 1
+ if (size (x) /= size (expect)) stop 2
+ do i = 1, size (x)
+ if (x(i) /= expect(i)) stop 3
+ end do
+ class default
+ stop 4
+ end select
+ end subroutine
+
+end program p
