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 --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cde5d3e4b32a709cca61c400b8d7fc2f6c155bba..75780afccc6b0c19f7740ae673a003f00c2c0b19 100644 (file)
--- 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 5bccea960aaa0500009a6974d69302fb8525bec2..6798f54beb2335abba2db6fb99641186f21bb6d0 100644 (file)
--- 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 (file)
index 0000000..98f16dc
--- /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