Fortran: Fix testsuite regressions after r15-5083 [PR117797]

2024-12-12  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/117797
	* trans-array.cc (class_array_element_size): New function.
	(gfc_get_array_span): Refactor, using class_array_element_size
	to return the span for descriptors that are the _data component
	of a class expression and then class dummy references. Revert
	the conditions to those before r15-5083 tidying up using 'sym'.

gcc/testsuite/
	PR fortran/117797
	* gfortran.dg/pr117797.f90: New test.

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9a8477650f4aa8fffa973ef558d31ec3f8549c0d..82a2ae1f7479f7d72c2aa9fcb2bd31f19f29500b 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -955,6 +955,26 @@ get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
 }
 
 
+/* A helper function for gfc_get_array_span that returns the array element size
+   of a class entity.  */
+static tree
+class_array_element_size (tree decl, bool unlimited)
+{
+  /* Class dummys usually require extraction from the saved descriptor,
+     which gfc_class_vptr_get does for us if necessary. This, of course,
+     will be a component of the class object.  */
+  tree vptr = gfc_class_vptr_get (decl);
+  /* If this is an unlimited polymorphic entity with a character payload,
+     the element size will be corrected for the string length.  */
+  if (unlimited)
+    return gfc_resize_class_size_with_len (NULL,
+                                          TREE_OPERAND (vptr, 0),
+                                          gfc_vptr_size_get (vptr));
+  else
+    return gfc_vptr_size_get (vptr);
+}
+
+
 /* Return the span of an array.  */
 
 tree
@@ -984,49 +1004,20 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
        desc = build_fold_indirect_ref_loc (input_location, desc);
       tmp = gfc_conv_descriptor_span_get (desc);
     }
-  else if (UNLIMITED_POLY (expr)
-          || (sym && UNLIMITED_POLY (sym)))
-    {
-      /* Treat unlimited polymorphic expressions separately because
-        the element size need not be the same as the span.  Obtain
-        the class container, which is simplified here by there being
-        no component references.  */
-      if (sym && sym->attr.dummy)
-       {
-         tmp = gfc_get_symbol_decl (sym);
-         tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
-         if (INDIRECT_REF_P (tmp))
-           tmp = TREE_OPERAND (tmp, 0);
-       }
-      else
-       {
-         gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
-         tmp = TREE_OPERAND (desc, 0);
-       }
-      tmp = gfc_class_data_get (tmp);
-      tmp = gfc_conv_descriptor_span_get (tmp);
-    }
   else if (TREE_CODE (desc) == COMPONENT_REF
           && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
           && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
-    {
-      /* The descriptor is a class _data field. Use the vtable size
-        since it is guaranteed to have been set and is always OK for
-        class array descriptors that are not unlimited.  */
-      tmp = gfc_get_vptr_from_expr (desc);
-      tmp = gfc_vptr_size_get (tmp);
-    }
+    /* The descriptor is the _data field of a class object.  */
+    tmp = class_array_element_size (TREE_OPERAND (desc, 0),
+                                   UNLIMITED_POLY (expr));
   else if (sym && sym->ts.type == BT_CLASS
           && expr->ref->type == REF_COMPONENT
           && expr->ref->next->type == REF_ARRAY
           && expr->ref->next->next == NULL
           && CLASS_DATA (sym)->attr.dimension)
-    {
-      /* Class dummys usually require extraction from the saved
-        descriptor, which gfc_class_vptr_get does for us.  */
-      tmp = gfc_class_vptr_get (sym->backend_decl);
-      tmp = gfc_vptr_size_get (tmp);
-    }
+    /* Having escaped the above, this can only be a class array dummy.  */
+    tmp = class_array_element_size (sym->backend_decl,
+                                   UNLIMITED_POLY (sym));
   else
     {
       /* If none of the fancy stuff works, the span is the element

diff --git a/gcc/testsuite/gfortran.dg/pr117797.f90 b/gcc/testsuite/gfortran.dg/pr117797.f90
new file mode 100644 (file)
index 0000000..25c0c04
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117797.f90
@@ -0,0 +1,55 @@
+! { dg-do run }
+!
+! Test the fix for the regression caused by r15-5083.
+!
+! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
+!
+module foo
+
+  type, public :: any_matrix
+    private
+    class(*), allocatable :: value(:,:)
+  end type
+
+contains
+
+  function bar(this) result(uptr)
+    class(any_matrix), target, intent(in) :: this
+    class(*), pointer :: uptr(:,:)
+    uptr => this%value ! Seg. fault in trans-array.cc(gfc_get_array_span) here
+  end function
+
+  function build(this) result (res)
+    class(*) :: this(:,:)
+    type(any_matrix) :: res
+    res%value = this
+  end function
+
+  function evaluate (this) result (res)
+    class(*) :: this(:,:)
+    character(len = 2, kind = 1), allocatable :: res(:)
+      select type (ans => this)
+        type is (character(*))
+          res = reshape (ans, [4])
+        type is (integer)
+          allocate (res (8))
+          write (res, '(i2)') ans
+        class default
+          res = ['no','t ','OK','!!']
+      end select
+  end
+
+end module
+
+  use foo
+  class(*), allocatable :: up (:, :)
+  character(len = 2, kind = 1) :: chr(2,2) = reshape (['ab','cd','ef','gh'], [2,2])
+  integer :: i(2,2) = reshape ([1,2,3,4], [2,2])
+  up = bar (build (chr))
+  if (any (evaluate (up) /= reshape (chr, [4]))) stop 1
+
+  up = bar (build (i))
+  if (any (evaluate (up) /= [' 1',' 2',' 3',' 4'])) stop 2
+
+  deallocate (up)
+end