https://gcc.gnu.org/g:d145946aa4e65dd0f5afb2d29564cb1514f28358
commit r17-1814-gd145946aa4e65dd0f5afb2d29564cb1514f28358 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. gcc/testsuite/ChangeLog: * gfortran.dg/select_type_53.f90: New test. Diff: --- gcc/fortran/trans-array.cc | 13 ++++++++- gcc/fortran/trans-types.cc | 17 ++++-------- gcc/testsuite/gfortran.dg/select_type_53.f90 | 41 ++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+), 13 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index cde5d3e4b32a..75780afccc6b 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 5bccea960aaa..6798f54beb23 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/testsuite/gfortran.dg/select_type_53.f90 b/gcc/testsuite/gfortran.dg/select_type_53.f90 new file mode 100644 index 000000000000..98f16dccfb1e --- /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
