Fortran: Fix rejecting class arrays of different ranks as storage association argument and add un/pack_class. [PR96992]

Removing the assert in trans-expr, lead to initial strides not set
which is now fixed.  When the array needs repacking, this is done for
class arrays now, too.

Packing class arrays was done using the regular internal pack
function in the past.  But that does not use the vptr's copy
function and breaks OOP paradigms (e.g. deep copy).  The new
un-/pack_class functions use the vptr's copy functionality to
implement OOP paradigms correctly.

	PR fortran/96992

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_trans_array_bounds): Set a starting
	stride, when descriptor expects a variable for the stride.
	(gfc_trans_dummy_array_bias): Allow storage association for
	dummy class arrays, when they are not elemental.
	(gfc_conv_array_parameter): Add more general class support
	and packing for classes, too.
	* trans-array.h (gfc_conv_array_parameter): Add lbound shift
	for class arrays.
	* trans-decl.cc (gfc_build_builtin_function_decls): Add decls
	for internal_un-/pack_class.
	* trans-expr.cc (gfc_reset_vptr): Allow supplying a type-tree
	to generate the vtab from.
	(gfc_class_set_vptr): Allow supplying a class-tree to take the
	vptr from.
	(class_array_data_assign): Rename to gfc_class_array_data_assign
	and make usable from other compile units.
	(gfc_class_array_data_assign): Renamed from class_array_data_
	assign.
	(gfc_conv_derived_to_class): Remove assert to
	allow converting derived to class type arrays with assumed
	rank.  Reduce code base and use gfc_conv_array_parameter also
	for classes.
	(gfc_conv_class_to_class): Use gfc_class_data_assign.
	(gfc_conv_procedure_call): Adapt to new signature of
	gfc_conv_derived_to_class.
	* trans-io.cc (transfer_expr): Same.
	* trans-stmt.cc (trans_associate_var): Same.
	* trans.h (gfc_conv_derived_to_class): Signature changed.
	(gfc_class_array_data_assign): Made public.
	(gfor_fndecl_in_pack_class): Added declaration.
	(gfor_fndecl_in_unpack_class): Same.

libgfortran/ChangeLog:

	* Makefile.am: Add in_un-/pack_class.c to build.
	* Makefile.in: Regenerated from Makefile.am.
	* gfortran.map: Added new functions and bumped ABI.
	* libgfortran.h (GFC_CLASS_T): Added for generating class
	representation at runtime.
	* runtime/in_pack_class.c: New file.
	* runtime/in_unpack_class.c: New file.

gcc/testsuite/ChangeLog:

	* gfortran.dg/class_dummy_11.f90: New test.

2 files changed, 286 insertions, 0 deletions

diff --git a/libgfortran/runtime/in_pack_class.c b/libgfortran/runtime/in_pack_class.c
new file mode 100644
index 0000000..248689c
--- /dev/null
+++ b/libgfortran/runtime/in_pack_class.c
@@ -0,0 +1,152 @@
+/* Class specific helper function for repacking arrays.
+   Copyright (C) 2003-2024 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "libgfortran.h"
+#include <string.h>
+
+extern void
+internal_pack_class (gfc_class_array_t *, gfc_class_array_t *, const size_t,
+		     const int);
+export_proto (internal_pack_class);
+
+/* attr is a bitfield.  The bits in use are:
+   0 - _len is present.
+ */
+void
+internal_pack_class (gfc_class_array_t *dest_class,
+		     gfc_class_array_t *source_class, const size_t size_class,
+		     const int attr)
+{
+#define BIT_TEST(mask, bit) (((mask) & (1U << (bit))) == (1U << (bit)))
+
+  index_type count[GFC_MAX_DIMENSIONS];
+  index_type extent[GFC_MAX_DIMENSIONS];
+  index_type stride[GFC_MAX_DIMENSIONS];
+  index_type stride0;
+  index_type dim;
+  index_type ssize;
+  index_type dest_stride;
+  index_type n;
+  const void *src;
+  void *dest;
+  int packed;
+  index_type size;
+  gfc_array_void *source_arr;
+  gfc_array_void *dest_arr;
+  size_t dest_offset;
+  bool len_present = BIT_TEST (attr, 0);
+  gfc_vtype_generic_t *vtab;
+  void (*copyfn) (const void *, void *);
+
+  /* Always make sure the dest is initialized.  */
+  memcpy (dest_class, source_class, size_class);
+  if (source_class->_data.base_addr == NULL)
+    return;
+
+  source_arr = (gfc_array_void *) &(source_class->_data);
+  size = GFC_DESCRIPTOR_SIZE (source_arr);
+  dim = GFC_DESCRIPTOR_RANK (source_arr);
+  ssize = 1;
+  packed = 1;
+  for (n = 0; n < dim; n++)
+    {
+      count[n] = 0;
+      stride[n] = GFC_DESCRIPTOR_STRIDE (source_arr, n);
+      extent[n] = GFC_DESCRIPTOR_EXTENT (source_arr, n);
+      if (extent[n] <= 0)
+	{
+	  /* Do nothing.  */
+	  packed = 1;
+	  break;
+	}
+
+      if (ssize != stride[n])
+	packed = 0;
+
+      ssize *= extent[n];
+    }
+
+  /* When the data is packed already, nothing needs to be done and unpack, will
+     quit immediately, because _data is identical and nothing needs to be done.
+   */
+  if (packed)
+    return;
+
+  /* Allocate storage for the destination.  */
+  dest_arr = (gfc_array_void *) &dest_class->_data;
+  dest_stride = 1;
+  dest_offset = 0;
+  for (n = 0; n < dim; ++n)
+    {
+      GFC_DESCRIPTOR_LBOUND (dest_arr, n) = 1;
+      GFC_DESCRIPTOR_UBOUND (dest_arr, n) = extent[n];
+      GFC_DESCRIPTOR_STRIDE (dest_arr, n) = dest_stride;
+      dest_offset -= dest_stride * 1 /* GFC_DESCRIPTOR_LBOUND (dest_arr, n) */;
+      dest_stride *= GFC_DESCRIPTOR_EXTENT (dest_arr, n);
+    }
+  dest_arr->offset = dest_offset;
+  dest_arr->base_addr = xmallocarray (ssize, size);
+  dest = (void *) dest_arr->base_addr;
+  src = source_arr->base_addr;
+  stride0 = stride[0] * size;
+  /* Can not use the dimension here, because the class may be allocated for
+     a higher dimensional array, but only a smaller amount is present.  */
+  vtab = *(gfc_vtype_generic_t **) (((void *) source_class) + size_class
+				    - (len_present ? sizeof (size_t) : 0)
+				    - sizeof (void *)); /* _vptr */
+  copyfn = vtab->_copy;
+
+  while (src)
+    {
+      /* Copy the data.  */
+      copyfn (src, dest);
+      /* Advance to the next element.  */
+      dest += size;
+      src += stride0;
+      count[0]++;
+      /* Advance to the next source element.  */
+      n = 0;
+      while (count[n] == extent[n])
+	{
+	  /* When we get to the end of a dimension, reset it and increment
+	     the next dimension.  */
+	  count[n] = 0;
+	  /* We could precalculate these products, but this is a less
+	     frequently used path so probably not worth it.  */
+	  src -= stride[n] * extent[n] * size;
+	  n++;
+	  if (n == dim)
+	    {
+	      src = NULL;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      src += stride[n] * size;
+	    }
+	}
+    }
+}
diff --git a/libgfortran/runtime/in_unpack_class.c b/libgfortran/runtime/in_unpack_class.c
new file mode 100644
index 0000000..467f0ce
--- /dev/null
+++ b/libgfortran/runtime/in_unpack_class.c
@@ -0,0 +1,134 @@
+/* Class helper function for repacking arrays.
+   Copyright (C) 2003-2024 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "libgfortran.h"
+#include <string.h>
+
+extern void
+internal_unpack_class (gfc_class_array_t *, gfc_class_array_t *, const size_t,
+		       const int);
+export_proto (internal_unpack_class);
+
+void
+internal_unpack_class (gfc_class_array_t *dest_class,
+		       gfc_class_array_t *source_class, const size_t size_class,
+		       const int attr)
+{
+#define BIT_TEST(mask, bit) (((mask) & (1U << (bit))) == (1U << (bit)))
+
+  index_type count[GFC_MAX_DIMENSIONS];
+  index_type extent[GFC_MAX_DIMENSIONS];
+  index_type stride[GFC_MAX_DIMENSIONS];
+  index_type stride0;
+  index_type dim;
+  index_type dsize;
+  void *dest;
+  const void *src;
+  index_type size;
+  const gfc_array_void *src_arr;
+  gfc_array_void *dest_arr;
+  bool len_present = BIT_TEST (attr, 0);
+  gfc_vtype_generic_t *vtab;
+  void (*copyfn) (const void *, void *);
+
+  /* This check may be redundant, but do it anyway.  */
+  if (!source_class || !dest_class || !source_class->_data.base_addr
+      || !dest_class->_data.base_addr)
+    return;
+
+  dest_arr = (gfc_array_void *) &(dest_class->_data);
+  dest = dest_arr->base_addr;
+  size = GFC_DESCRIPTOR_SIZE (dest_arr);
+  dim = GFC_DESCRIPTOR_RANK (dest_arr);
+  dsize = 1;
+  for (index_type n = 0; n < dim; n++)
+    {
+      count[n] = 0;
+      stride[n] = GFC_DESCRIPTOR_STRIDE (dest_arr, n);
+      extent[n] = GFC_DESCRIPTOR_EXTENT (dest_arr, n);
+      if (extent[n] <= 0)
+	return;
+
+      if (dsize == stride[n])
+	dsize *= extent[n];
+      else
+	dsize = 0;
+    }
+
+  src_arr = (gfc_array_void *) &source_class->_data;
+  src = src_arr->base_addr;
+
+  vtab = *(gfc_vtype_generic_t **) (((void *) source_class) + size_class
+				    - (len_present ? sizeof (size_t) : 0)
+				    - sizeof (void *)); /* _vptr */
+  copyfn = vtab->_copy;
+
+  if (dsize != 0)
+    {
+      for (index_type n = 0; n < dsize; ++n)
+	{
+	  copyfn (src, dest);
+	  src += size;
+	  dest += size;
+	}
+      free (src_arr->base_addr);
+      return;
+    }
+
+  stride0 = stride[0] * size;
+
+  while (dest)
+    {
+      /* Copy the data.  */
+      copyfn (src, dest);
+      /* Advance to the next element.  */
+      src += size;
+      dest += stride0;
+      count[0]++;
+      /* Advance to the next source element.  */
+      index_type n = 0;
+      while (count[n] == extent[n])
+	{
+	  /* When we get to the end of a dimension, reset it and increment
+	     the next dimension.  */
+	  count[n] = 0;
+	  /* We could precalculate these products, but this is a less
+	     frequently used path so probably not worth it.  */
+	  dest -= stride[n] * extent[n] * size;
+	  n++;
+	  if (n == dim)
+	    {
+	      dest = NULL;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      dest += stride[n] * size;
+	    }
+	}
+    }
+  free (src_arr->base_addr);
+}