[PATCH] Fortran: Fix PR125761 Wrong code: array section of an unlimited-polymorphic CHARACTER array

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