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.

14 files changed, 824 insertions, 186 deletions

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c7d2446..ed0ad54 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6803,6 +6803,9 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
 
   size = gfc_index_one_node;
   offset = gfc_index_zero_node;
+  stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
+  if (stride && VAR_P (stride))
+    gfc_add_modify (pblock, stride, gfc_index_one_node);
   for (dim = 0; dim < as->rank; dim++)
     {
       /* Evaluate non-constant array bound expressions.
@@ -7148,7 +7151,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
       || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
     return;
 
-  if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
+  if ((!is_classarray
+       || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
+      && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
     {
       gfc_trans_g77_array (sym, block);
       return;
@@ -8647,15 +8652,17 @@ is_pointer (gfc_expr *e)
 /* Convert an array for passing as an actual parameter.  */
 
 void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
+gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
 			  const gfc_symbol *fsym, const char *proc_name,
-			  tree *size)
+			  tree *size, tree *lbshift, tree *packed)
 {
   tree ptr;
   tree desc;
   tree tmp = NULL_TREE;
   tree stmt;
   tree parent = DECL_CONTEXT (current_function_decl);
+  tree ctree;
+  tree pack_attr;
   bool full_array_var;
   bool this_array_result;
   bool contiguous;
@@ -8767,20 +8774,28 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
   /* There is no need to pack and unpack the array, if it is contiguous
      and not a deferred- or assumed-shape array, or if it is simply
      contiguous.  */
-  no_pack = ((sym && sym->as
-		  && !sym->attr.pointer
-		  && sym->as->type != AS_DEFERRED
-		  && sym->as->type != AS_ASSUMED_RANK
-		  && sym->as->type != AS_ASSUMED_SHAPE)
-		      ||
-	     (ref && ref->u.ar.as
-		  && ref->u.ar.as->type != AS_DEFERRED
+  no_pack = false;
+  // clang-format off
+  if (sym)
+    {
+      symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
+				 ? CLASS_DATA (sym)->attr : sym->attr);
+      gfc_array_spec *as = IS_CLASS_ARRAY (sym)
+			   ? CLASS_DATA (sym)->as : sym->as;
+      no_pack = (as
+		 && !attr->pointer
+		 && as->type != AS_DEFERRED
+		 && as->type != AS_ASSUMED_RANK
+		 && as->type != AS_ASSUMED_SHAPE);
+    }
+  if (ref && ref->u.ar.as)
+    no_pack = no_pack
+	      || (ref->u.ar.as->type != AS_DEFERRED
 		  && ref->u.ar.as->type != AS_ASSUMED_RANK
-		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
-		      ||
-	     gfc_is_simply_contiguous (expr, false, true));
-
-  no_pack = contiguous && no_pack;
+		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
+  no_pack = contiguous
+	    && (no_pack || gfc_is_simply_contiguous (expr, false, true));
+  // clang-format on
 
   /* If we have an EXPR_OP or a function returning an explicit-shaped
      or allocatable array, an array temporary will be generated which
@@ -8835,6 +8850,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
       return;
     }
 
+  if (fsym && fsym->ts.type == BT_CLASS)
+    {
+      gcc_assert (se->expr);
+      ctree = se->expr;
+    }
+  else
+    ctree = NULL_TREE;
+
   if (this_array_result)
     {
       /* Result of the enclosing function.  */
@@ -8853,7 +8876,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
   else
     {
       /* Every other type of array.  */
-      se->want_pointer = 1;
+      se->want_pointer = (ctree) ? 0 : 1;
       gfc_conv_expr_descriptor (se, expr);
 
       if (size)
@@ -8861,6 +8884,55 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 			      build_fold_indirect_ref_loc (input_location,
 							    se->expr),
 			      expr, size);
+      if (ctree)
+	{
+	  stmtblock_t block;
+
+	  gfc_init_block (&block);
+	  if (lbshift && *lbshift)
+	    {
+	      /* Apply a shift of the lbound when supplied.  */
+	      for (int dim = 0; dim < expr->rank; ++dim)
+		gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
+						  *lbshift);
+	    }
+	  tmp = gfc_class_data_get (ctree);
+	  if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
+	      && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
+	    {
+	      tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
+	      gfc_conv_descriptor_data_set (&block, arr,
+					    gfc_conv_descriptor_data_get (
+					      se->expr));
+	      gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+					      gfc_index_zero_node);
+	      gfc_conv_descriptor_ubound_set (
+		&block, arr, gfc_index_zero_node,
+		gfc_conv_descriptor_size (se->expr, expr->rank));
+	      gfc_conv_descriptor_stride_set (
+		&block, arr, gfc_index_zero_node,
+		gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
+	      gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+			      gfc_conv_descriptor_dtype (se->expr));
+	      gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+			      build_int_cst (signed_char_type_node, 1));
+	      gfc_conv_descriptor_span_set (&block, arr,
+					    gfc_conv_descriptor_span_get (arr));
+	      gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+	      se->expr = arr;
+	    }
+	  gfc_class_array_data_assign (&block, tmp, se->expr, true);
+
+	  /* Handle optional.  */
+	  if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
+			    gfc_finish_block (&block),
+			    build_empty_stmt (input_location));
+	  else
+	    tmp = gfc_finish_block (&block);
+
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
     }
 
   /* Deallocate the allocatable components of structures that are
@@ -8880,12 +8952,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
   if (g77 || (fsym && fsym->attr.contiguous
 	      && !gfc_is_simply_contiguous (expr, false, true)))
     {
-      tree origptr = NULL_TREE;
+      tree origptr = NULL_TREE, packedptr = NULL_TREE;
 
       desc = se->expr;
 
       /* For contiguous arrays, save the original value of the descriptor.  */
-      if (!g77)
+      if (!g77 && !ctree)
 	{
 	  origptr = gfc_create_var (pvoid_type_node, "origptr");
 	  tmp = build_fold_indirect_ref_loc (input_location, desc);
@@ -8924,18 +8996,51 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 	  return;
 	}
 
-      ptr = build_call_expr_loc (input_location,
-			     gfor_fndecl_in_pack, 1, desc);
-
-      if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+      if (ctree)
 	{
-	  tmp = gfc_conv_expr_present (sym);
-	  ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
-			tmp, fold_convert (TREE_TYPE (se->expr), ptr),
-			fold_convert (TREE_TYPE (se->expr), null_pointer_node));
+	  packedptr
+	    = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
+							      "packed"));
+	  if (fsym)
+	    {
+	      int pack_mask = 0;
+
+	      /* Set bit 0 to the mask, when this is an unlimited_poly
+		 class.  */
+	      if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
+		pack_mask = 1 << 0;
+	      pack_attr = build_int_cst (integer_type_node, pack_mask);
+	    }
+	  else
+	    pack_attr = integer_zero_node;
+
+	  gfc_add_expr_to_block (
+	    &se->pre,
+	    build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
+				 packedptr,
+				 gfc_build_addr_expr (NULL_TREE, ctree),
+				 size_in_bytes (TREE_TYPE (ctree)), pack_attr));
+	  ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
+	  se->expr = packedptr;
+	  if (packed)
+	    *packed = packedptr;
 	}
+      else
+	{
+	  ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
+				     desc);
+
+	  if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+	    {
+	      tmp = gfc_conv_expr_present (sym);
+	      ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
+				tmp, fold_convert (TREE_TYPE (se->expr), ptr),
+				fold_convert (TREE_TYPE (se->expr),
+					      null_pointer_node));
+	    }
 
-      ptr = gfc_evaluate_now (ptr, &se->pre);
+	  ptr = gfc_evaluate_now (ptr, &se->pre);
+	}
 
       /* Use the packed data for the actual argument, except for contiguous arrays,
 	 where the descriptor's data component is set.  */
@@ -8947,8 +9052,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 
 	  gfc_ss * ss = gfc_walk_expr (expr);
 	  if (!transposed_dims (ss))
-	    gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
-	  else
+	    {
+	      if (!ctree)
+		gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
+	    }
+	  else if (!ctree)
 	    {
 	      tree old_field, new_field;
 
@@ -9021,22 +9129,36 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
       /* Copy the data back.  */
       if (fsym == NULL || fsym->attr.intent != INTENT_IN)
 	{
-	  tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_in_unpack, 2, desc, ptr);
+	  if (ctree)
+	    {
+	      tmp = gfc_build_addr_expr (NULL_TREE, ctree);
+	      tmp = build_call_expr_loc (input_location,
+					 gfor_fndecl_in_unpack_class, 4, tmp,
+					 packedptr,
+					 size_in_bytes (TREE_TYPE (ctree)),
+					 pack_attr);
+	    }
+	  else
+	    tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
+				       desc, ptr);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
+      else if (ctree && fsym->attr.intent == INTENT_IN)
+	{
+	  /* Need to free the memory for class arrays, that got packed.  */
+	  gfc_add_expr_to_block (&block, gfc_call_free (ptr));
+	}
 
       /* Free the temporary.  */
-      tmp = gfc_call_free (ptr);
-      gfc_add_expr_to_block (&block, tmp);
+      if (!ctree)
+	gfc_add_expr_to_block (&block, gfc_call_free (ptr));
 
       stmt = gfc_finish_block (&block);
 
       gfc_init_block (&block);
       /* Only if it was repacked.  This code needs to be executed before the
          loop cleanup code.  */
-      tmp = build_fold_indirect_ref_loc (input_location,
-				     desc);
+      tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
       tmp = gfc_conv_array_data (tmp);
       tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
 			     fold_convert (TREE_TYPE (tmp), ptr), tmp);
@@ -9054,11 +9176,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
       gfc_init_block (&se->post);
 
       /* Reset the descriptor pointer.  */
-      if (!g77)
-        {
-          tmp = build_fold_indirect_ref_loc (input_location, desc);
-          gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
-        }
+      if (!g77 && !ctree)
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location, desc);
+	  gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
+	}
 
       gfc_add_block_to_block (&se->post, &block);
     }
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index a51e9a5..29499a3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -152,8 +152,9 @@ tree gfc_get_array_span (tree, gfc_expr *);
 /* Evaluate an array expression.  */
 void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
 /* Convert an array for passing as an actual function parameter.  */
-void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool,
-			       const gfc_symbol *, const char *, tree *);
+void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *,
+			       const char *, tree *, tree * = nullptr,
+			       tree * = nullptr);
 
 /* These work with both descriptors and descriptorless arrays.  */
 tree gfc_conv_array_data (tree);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 11247dd..54ab60b 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -118,6 +118,8 @@ tree gfor_fndecl_fdate;
 tree gfor_fndecl_ttynam;
 tree gfor_fndecl_in_pack;
 tree gfor_fndecl_in_unpack;
+tree gfor_fndecl_in_pack_class;
+tree gfor_fndecl_in_unpack_class;
 tree gfor_fndecl_associated;
 tree gfor_fndecl_system_clock4;
 tree gfor_fndecl_system_clock8;
@@ -3916,9 +3918,19 @@ gfc_build_builtin_function_decls (void)
 	get_identifier (PREFIX("internal_unpack")), ". w R ",
 	void_type_node, 2, pvoid_type_node, pvoid_type_node);
 
+  gfor_fndecl_in_pack_class = gfc_build_library_function_decl_with_spec (
+    get_identifier (PREFIX ("internal_pack_class")), ". w R r r ",
+    void_type_node, 4, pvoid_type_node, pvoid_type_node, size_type_node,
+    integer_type_node);
+
+  gfor_fndecl_in_unpack_class = gfc_build_library_function_decl_with_spec (
+    get_identifier (PREFIX ("internal_unpack_class")), ". w R r r ",
+    void_type_node, 4, pvoid_type_node, pvoid_type_node, size_type_node,
+    integer_type_node);
+
   gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
-	get_identifier (PREFIX("associated")), ". R R ",
-	integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
+    get_identifier (PREFIX ("associated")), ". R R ", integer_type_node, 2,
+    ppvoid_type_node, ppvoid_type_node);
   DECL_PURE_P (gfor_fndecl_associated) = 1;
   TREE_NOTHROW (gfor_fndecl_associated) = 1;
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 477c272..3ff2485 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -598,7 +598,6 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
     }
 }
 
-
 /* Set the vptr of a class in to from the type given in from.  If from is NULL,
    then reset the vptr to the default or to.  */
 
@@ -606,6 +605,7 @@ void
 gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
 {
   tree tmp, vptr_ref;
+  gfc_symbol *type;
 
   vptr_ref = gfc_get_vptr_from_expr (to);
   if (POINTER_TYPE_P (TREE_TYPE (from))
@@ -614,38 +614,44 @@ gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
       gfc_add_modify (block, vptr_ref,
 		      fold_convert (TREE_TYPE (vptr_ref),
 				    gfc_get_vptr_from_expr (from)));
+      return;
     }
-  else if (VAR_P (from)
-	   && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
+  tmp = gfc_get_vptr_from_expr (from);
+  if (tmp)
+    {
+      gfc_add_modify (block, vptr_ref,
+		      fold_convert (TREE_TYPE (vptr_ref), tmp));
+      return;
+    }
+  if (VAR_P (from)
+      && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
     {
       gfc_add_modify (block, vptr_ref,
 		      gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
+      return;
     }
-  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
-	   && GFC_CLASS_TYPE_P (
-	     TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
+      && GFC_CLASS_TYPE_P (
+	TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
     {
       gfc_add_modify (block, vptr_ref,
 		      fold_convert (TREE_TYPE (vptr_ref),
 				    gfc_get_vptr_from_expr (TREE_OPERAND (
 				      TREE_OPERAND (from, 0), 0))));
+      return;
     }
-  else
-    {
-      tree vtab;
-      gfc_symbol *type;
-      tmp = TREE_TYPE (from);
-      if (POINTER_TYPE_P (tmp))
-	tmp = TREE_TYPE (tmp);
-      gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
-		       &type);
-      vtab = gfc_find_derived_vtab (type)->backend_decl;
-      gcc_assert (vtab);
-      gfc_add_modify (block, vptr_ref,
-		      gfc_build_addr_expr (TREE_TYPE (vptr_ref), vtab));
-    }
-}
 
+  /* If nothing of the above matches, set the vtype according to the type.  */
+  tmp = TREE_TYPE (from);
+  if (POINTER_TYPE_P (tmp))
+    tmp = TREE_TYPE (tmp);
+  gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
+		   &type);
+  tmp = gfc_find_derived_vtab (type)->backend_decl;
+  gcc_assert (tmp);
+  gfc_add_modify (block, vptr_ref,
+		  gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
+}
 
 /* Reset the len for unlimited polymorphic objects.  */
 
@@ -739,10 +745,9 @@ gfc_get_vptr_from_expr (tree expr)
   return NULL_TREE;
 }
 
-
-static void
-class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
-			 bool lhs_type)
+void
+gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
+			     bool lhs_type)
 {
   tree tmp, tmp2, type;
 
@@ -766,9 +771,8 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
   gfc_add_modify (block, tmp, tmp2);
 }
 
-
 /* Takes a derived type expression and returns the address of a temporary
-   class object of the 'declared' type.  If vptr is not NULL, this is
+   class object of the 'declared' type.  If opt_vptr_src is not NULL, this is
    used for the temporary class object.
    optional_alloc_ptr is false when the dummy is neither allocatable
    nor a pointer; that's only relevant for the optional handling.
@@ -776,49 +780,65 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
    expression for deallocation of allocatable components. Assumed rank
    formal arguments made this necessary.  */
 void
-gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
-			   gfc_typespec class_ts, tree vptr, bool optional,
-			   bool optional_alloc_ptr,
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
+			   tree opt_vptr_src, bool optional,
+			   bool optional_alloc_ptr, const char *proc_name,
 			   tree *derived_array)
 {
-  gfc_symbol *vtab;
   tree cond_optional = NULL_TREE;
   gfc_ss *ss;
   tree ctree;
   tree var;
   tree tmp;
-  int dim;
+  tree packed = NULL_TREE;
 
-  /* The derived type needs to be converted to a temporary
-     CLASS object.  */
-  tmp = gfc_typenode_for_spec (&class_ts);
+  /* The derived type needs to be converted to a temporary CLASS object.  */
+  tmp = gfc_typenode_for_spec (&fsym->ts);
   var = gfc_create_var (tmp, "class");
 
   /* Set the vptr.  */
-  ctree =  gfc_class_vptr_get (var);
-
-  if (vptr != NULL_TREE)
-    {
-      /* Use the dynamic vptr.  */
-      tmp = vptr;
-    }
+  if (opt_vptr_src)
+    gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
   else
-    {
-      /* In this case the vtab corresponds to the derived type and the
-	 vptr must point to it.  */
-      vtab = gfc_find_derived_vtab (e->ts.u.derived);
-      gcc_assert (vtab);
-      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
-    }
-  gfc_add_modify (&parmse->pre, ctree,
-		  fold_convert (TREE_TYPE (ctree), tmp));
+    gfc_reset_vptr (&parmse->pre, e, var);
 
   /* Now set the data field.  */
-  ctree =  gfc_class_data_get (var);
+  ctree = gfc_class_data_get (var);
 
   if (optional)
     cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
 
+  /* Set the _len as early as possible.  */
+  if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
+      && fsym->ts.u.derived->components->ts.u.derived->attr
+	   .unlimited_polymorphic)
+    {
+      /* Take care about initializing the _len component correctly.  */
+      tree len_tree = gfc_class_len_get (var);
+      if (UNLIMITED_POLY (e))
+	{
+	  gfc_expr *len;
+	  gfc_se se;
+
+	  len = gfc_find_and_cut_at_last_class_ref (e);
+	  gfc_add_len_component (len);
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, len);
+	  if (optional)
+	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
+			      cond_optional, se.expr,
+			      fold_convert (TREE_TYPE (se.expr),
+					    integer_zero_node));
+	  else
+	    tmp = se.expr;
+	  gfc_free_expr (len);
+	}
+      else
+	tmp = integer_zero_node;
+      gfc_add_modify (&parmse->pre, len_tree,
+		      fold_convert (TREE_TYPE (len_tree), tmp));
+    }
+
   if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
     {
       /* If there is a ready made pointer to a derived type, use it
@@ -847,7 +867,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 	  gfc_conv_expr_reference (parmse, e);
 
 	  /* Scalar to an assumed-rank array.  */
-	  if (class_ts.u.derived->components->as)
+	  if (fsym->ts.u.derived->components->as)
 	    {
 	      tree type;
 	      type = get_scalar_to_descriptor_type (parmse->expr,
@@ -878,15 +898,23 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 	  stmtblock_t block;
 	  gfc_init_block (&block);
 	  gfc_ref *ref;
+	  int dim;
+	  tree lbshift = NULL_TREE;
 
-	  parmse->ss = ss;
-	  parmse->use_offset = 1;
-	  gfc_conv_expr_descriptor (parmse, e);
+	  /* Array refs with sections indicate, that a for a formal argument
+	     expecting contiguous repacking needs to be done.  */
+	  for (ref = e->ref; ref; ref = ref->next)
+	    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+	      break;
+	  if (IS_CLASS_ARRAY (fsym)
+	      && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
+		  || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
+	      && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
+	    fsym->attr.contiguous = 1;
 
 	  /* Detect any array references with vector subscripts.  */
 	  for (ref = e->ref; ref; ref = ref->next)
-	    if (ref->type == REF_ARRAY
-		&& ref->u.ar.type != AR_ELEMENT
+	    if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
 		&& ref->u.ar.type != AR_FULL)
 	      {
 		for (dim = 0; dim < ref->u.ar.dimen; dim++)
@@ -895,37 +923,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 		if (dim < ref->u.ar.dimen)
 		  break;
 	      }
-
-	  /* Array references with vector subscripts and non-variable expressions
-	     need be converted to a one-based descriptor.  */
+	  /* Array references with vector subscripts and non-variable
+	     expressions need be converted to a one-based descriptor.  */
 	  if (ref || e->expr_type != EXPR_VARIABLE)
-	    {
-	      for (dim = 0; dim < e->rank; ++dim)
-		gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
-						  gfc_index_one_node);
-	    }
+	    lbshift = gfc_index_one_node;
 
-	  if (e->rank != class_ts.u.derived->components->as->rank)
-	    {
-	      gcc_assert (class_ts.u.derived->components->as->type
-			  == AS_ASSUMED_RANK);
-	      if (derived_array
-		  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
-		{
-		  *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
-						   "array");
-		  gfc_add_modify (&block, *derived_array , parmse->expr);
-		}
-	      class_array_data_assign (&block, ctree, parmse->expr, false);
-	    }
-	  else
+	  parmse->expr = var;
+	  gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
+				    &lbshift, &packed);
+
+	  if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
 	    {
-	      if (gfc_expr_attr (e).codimension)
-		parmse->expr = fold_build1_loc (input_location,
-						VIEW_CONVERT_EXPR,
-						TREE_TYPE (ctree),
-						parmse->expr);
-	      gfc_add_modify (&block, ctree, parmse->expr);
+	      *derived_array
+		= gfc_create_var (TREE_TYPE (parmse->expr), "array");
+	      gfc_add_modify (&block, *derived_array, parmse->expr);
 	    }
 
 	  if (optional)
@@ -947,47 +958,19 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 	}
     }
 
-  if (class_ts.u.derived->components->ts.type == BT_DERIVED
-      && class_ts.u.derived->components->ts.u.derived
-		 ->attr.unlimited_polymorphic)
-    {
-      /* Take care about initializing the _len component correctly.  */
-      ctree = gfc_class_len_get (var);
-      if (UNLIMITED_POLY (e))
-	{
-	  gfc_expr *len;
-	  gfc_se se;
-
-	  len = gfc_find_and_cut_at_last_class_ref (e);
-	  gfc_add_len_component (len);
-	  gfc_init_se (&se, NULL);
-	  gfc_conv_expr (&se, len);
-	  if (optional)
-	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
-			      cond_optional, se.expr,
-			      fold_convert (TREE_TYPE (se.expr),
-					    integer_zero_node));
-	  else
-	    tmp = se.expr;
-	  gfc_free_expr (len);
-	}
-      else
-	tmp = integer_zero_node;
-      gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
-							  tmp));
-    }
   /* Pass the address of the class object.  */
-  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+  if (packed)
+    parmse->expr = packed;
+  else
+    parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
 
   if (optional && optional_alloc_ptr)
-    parmse->expr = build3_loc (input_location, COND_EXPR,
-			       TREE_TYPE (parmse->expr),
-			       cond_optional, parmse->expr,
-			       fold_convert (TREE_TYPE (parmse->expr),
-					     null_pointer_node));
+    parmse->expr
+      = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
+		    cond_optional, parmse->expr,
+		    fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
 }
 
-
 /* Create a new class container, which is required as scalar coarrays
    have an array descriptor while normal scalars haven't. Optionally,
    NULL pointer checks are added if the argument is OPTIONAL.  */
@@ -1292,7 +1275,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 	  gfc_conv_descriptor_data_set (&block, ctree, tmp);
 	}
       else
-	class_array_data_assign (&block, ctree, parmse->expr, false);
+	gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
     }
   else
     {
@@ -1318,7 +1301,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 					 gfc_conv_descriptor_data_get (ctree)));
 	    }
 	  else
-	    class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
+	    gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
+					 true);
 	}
       else
 	gfc_add_modify (&parmse->post, parmse->expr, ctree);
@@ -6530,13 +6514,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  /* The derived type needs to be converted to a temporary
 	     CLASS object.  */
 	  gfc_init_se (&parmse, se);
-	  gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
+	  gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
 				     fsym->attr.optional
-				     && e->expr_type == EXPR_VARIABLE
-				     && e->symtree->n.sym->attr.optional,
+				       && e->expr_type == EXPR_VARIABLE
+				       && e->symtree->n.sym->attr.optional,
 				     CLASS_DATA (fsym)->attr.class_pointer
-				     || CLASS_DATA (fsym)->attr.allocatable,
-				     &derived_array);
+				       || CLASS_DATA (fsym)->attr.allocatable,
+				     sym->name, &derived_array);
 	}
       else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
 	       && e->ts.type != BT_PROCEDURE
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index ee2cc56..7ab82fa 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2462,8 +2462,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
 		  || (ts->type == BT_CLASS
 		      && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
 		gfc_conv_derived_to_class (se, code->expr1,
-					   dtio_sub->formal->sym->ts,
-					   vptr, false, false);
+					   dtio_sub->formal->sym, vptr, false,
+					   false, "transfer");
 	      addr_expr = se->expr;
 	      function = iocall[IOCALL_X_DERIVED];
 	      break;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 703a705..41740ab 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2118,11 +2118,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	{
 	  /* This is bound to be a class array element.  */
 	  gfc_conv_expr_reference (&se, e);
-	  /* Get the _vptr component of the class object.  */
-	  tmp = gfc_get_vptr_from_expr (se.expr);
 	  /* Obtain a temporary class container for the result.  */
-	  gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
-	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+	  gfc_conv_derived_to_class (&se, e, sym, se.expr, false, false,
+				     e->symtree->name);
 	  need_len_assign = false;
 	}
       else
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ec04aed..fdcce20 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -464,8 +464,9 @@ bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
 void gfc_finalize_tree_expr (gfc_se *, gfc_symbol *, symbol_attribute, int);
 bool gfc_assignment_finalizer_call (gfc_se *, gfc_expr *, bool);
 
-void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
-				bool, tree *derived_array = NULL);
+void gfc_class_array_data_assign (stmtblock_t *, tree, tree, bool);
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_symbol *fsym, tree,
+				bool, bool, const char *, tree * = nullptr);
 void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
 			      bool, bool);
 
@@ -872,6 +873,8 @@ extern GTY(()) tree gfor_fndecl_ctime;
 extern GTY(()) tree gfor_fndecl_fdate;
 extern GTY(()) tree gfor_fndecl_in_pack;
 extern GTY(()) tree gfor_fndecl_in_unpack;
+extern GTY(()) tree gfor_fndecl_in_pack_class;
+extern GTY(()) tree gfor_fndecl_in_unpack_class;
 extern GTY(()) tree gfor_fndecl_associated;
 extern GTY(()) tree gfor_fndecl_system_clock4;
 extern GTY(()) tree gfor_fndecl_system_clock8;
diff --git a/gcc/testsuite/gfortran.dg/class_dummy_11.f90 b/gcc/testsuite/gfortran.dg/class_dummy_11.f90
new file mode 100644
index 0000000..a5c0fa6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_dummy_11.f90
@@ -0,0 +1,194 @@
+! { dg-do run }
+
+! PR fortran/96992
+
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+! From the standard:
+! An actual argument that represents an element sequence and
+! corresponds to a dummy argument that is an array is sequence
+! associated with the dummy argument. The rank and shape of the
+! actual argument need not agree with the rank and shape of the
+! dummy argument, but the number of elements in the dummy argument
+! shall not exceed the number of elements in the element sequence
+! of the actual argument. If the dummy argument is assumed-size,
+! the number of elements in the dummy argument is exactly
+! the number of elements in the element sequence.
+
+! Check that walking the sequence starts with an initialized stride
+! for dim == 0.
+
+module foo_mod
+
+  implicit none
+
+  type foo
+     integer :: i
+  end type foo
+
+contains
+
+  subroutine d1(x,n)
+    integer, intent(in) :: n
+    integer :: i
+    class (foo), intent(out), dimension(n) :: x
+
+    x(:)%i = (/ (42 + i, i = 1, n ) /)
+  end subroutine d1
+
+  subroutine d2(x,n,sb)
+    integer, intent(in) :: n
+    integer :: i, sb
+    class (foo), intent(in), dimension(n,n,n) :: x
+
+    if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 1
+  end subroutine d2
+
+  subroutine d3(x,n)
+    integer, intent(in) :: n
+    integer :: i
+    class (foo), intent(inout) :: x(n)
+
+    x%i = -x%i               ! Simply negate elements
+  end subroutine d3
+
+  subroutine d4(a,n)
+    integer, intent(in) :: n
+    class (foo), intent(inout) :: a(*)
+
+    call d3(a,n)
+  end subroutine d4
+  
+  subroutine d1s(x,n, sb)
+    integer, intent(in) :: n, sb
+    integer :: i
+    class (*), intent(out), dimension(n) :: x
+
+    select type(x)
+    class is(foo)
+       x(:)%i = (/ (42 + i, i = 1, n ) /)
+    class default
+       stop sb + 2
+    end select
+  end subroutine d1s
+
+  subroutine d2s(x,n,sb)
+    integer, intent(in) :: n,sb
+    integer :: i
+    class (*), intent(in), dimension(n,n,n) :: x
+
+    select type (x)
+    class is (foo)
+       if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 3
+    class default
+       stop sb + 4
+    end select
+  end subroutine d2s
+
+  subroutine d3s(x,n,sb)
+    integer, intent(in) :: n, sb
+    integer :: i
+    class (*), intent(inout) :: x(n)
+
+    select type (x)
+    class is (foo)
+       x%i = -x%i               ! Simply negate elements
+    class default
+       stop sb + 5
+    end select
+  end subroutine d3s
+
+end module foo_mod
+
+program main
+
+  use foo_mod
+
+  implicit none
+
+  type (foo), dimension(:), allocatable :: f
+  type (foo), dimension(27) :: g
+  type (foo), dimension(3, 9) :: td
+  integer :: n,i,np3
+
+  n = 3
+  np3 = n **3
+  allocate (f(np3))
+  call d1(f, np3)
+  call d2(f, n, 0)
+
+  call d1s(f, np3, 0)
+  call d2s(f, n, 0)
+
+  ! Use negative stride
+  call d1(f(np3:1:-1), np3)
+  if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 6
+  call d2(f(np3:1:-1), n, 0)
+  call d3(f(1:np3:4), np3/4)
+  if ( any( f%i /= (/ (merge(-(42 + (np3 - i)),  & 
+                               42 + (np3 - i),   &
+                             MOD(i, 4) == 0 .AND. i < 21), &
+                       i = 0, np3 - 1 ) /) ))    &
+    stop 7
+  call d4(f(1:np3:4), np3/4)
+  if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 8
+
+  call d1s(f(np3:1:-1), np3, 0)
+  if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 9
+  call d2s(f(np3:1:-1), n, 0)
+  call d3s(f(1:np3:4), np3/4, 0)
+  if ( any( f%i /= (/ (merge(-(42 + (np3 - i)),  & 
+                               42 + (np3 - i),   &
+                             MOD(i, 4) == 0 .AND. i < 21), &
+                       i = 0, np3 - 1 ) /) ))    &
+    stop 10
+
+  deallocate (f)
+
+  call d1(g, np3)
+  call d2(g, n, 11)
+
+  call d1s(g, np3, 11)
+  call d2s(g, n, 11)
+
+  ! Use negative stride
+  call d1(g(np3:1:-1), np3)
+  if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 17
+  call d2(g(np3:1:-1), n, 11)
+  call d3(g(1:np3:4), np3/4)
+  if ( any( g%i /= (/ (merge(-(42 + (np3 - i)),  & 
+                               42 + (np3 - i),   &
+                             MOD(i, 4) == 0 .AND. i < 21), &
+                       i = 0, np3 - 1 ) /) ))    &
+    stop 18
+
+  call d1s(g(np3:1:-1), np3, 11)
+  if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 19
+  call d2s(g(np3:1:-1), n, 11)
+  call d3s(g(1:np3:4), np3/4, 11)
+  if ( any( g%i /= (/ (merge(-(42 + (np3 - i)),  & 
+                               42 + (np3 - i),   &
+                             MOD(i, 4) == 0 .AND. i < 21), &
+                       i = 0, np3 - 1 ) /) ))    &
+    stop 20
+
+  ! Check for 2D
+  call d1(td, np3)
+  call d2(td, n, 21)
+
+  call d1s(td, np3, 21)
+  call d2s(td, n, 21)
+
+  ! Use negative stride
+  call d1(td(3:1:-1,9:1:-1), np3)
+  if ( any( reshape(td%i, [np3]) /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 26
+  call d2(td(3:1:-1,9:1:-1), n, 21)
+  call d3(td(2,1:n), n)
+  if ( any( reshape(td%i, [np3]) /= (/ (merge(-(42 + (np3 - i)),  & 
+                               42 + (np3 - i),   &
+                             MOD(i, 3) == 1 .AND. i < 9), &
+                       i = 0, np3 - 1 ) /) ))    &
+    stop 27
+
+end program main
+
diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am
index ab605d4..8524cc6 100644
--- a/libgfortran/Makefile.am
+++ b/libgfortran/Makefile.am
@@ -156,7 +156,9 @@ intrinsics/selected_real_kind.f90 \
 intrinsics/trigd.c \
 intrinsics/unpack_generic.c \
 runtime/in_pack_generic.c \
-runtime/in_unpack_generic.c
+runtime/in_unpack_generic.c \
+runtime/in_pack_class.c \
+runtime/in_unpack_class.c
 
 if !LIBGFOR_MINIMAL
 
diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index ced10e9..6c6c89c 100644
--- a/libgfortran/Makefile.in
+++ b/libgfortran/Makefile.in
@@ -569,8 +569,8 @@ am__objects_58 = intrinsics/associated.lo intrinsics/abort.lo \
 	intrinsics/selected_int_kind.lo \
 	intrinsics/selected_real_kind.lo intrinsics/trigd.lo \
 	intrinsics/unpack_generic.lo runtime/in_pack_generic.lo \
-	runtime/in_unpack_generic.lo $(am__objects_56) \
-	$(am__objects_57)
+	runtime/in_unpack_generic.lo runtime/in_pack_class.lo \
+	runtime/in_unpack_class.lo $(am__objects_56) $(am__objects_57)
 @IEEE_SUPPORT_TRUE@am__objects_59 = ieee/ieee_arithmetic.lo \
 @IEEE_SUPPORT_TRUE@	ieee/ieee_exceptions.lo \
 @IEEE_SUPPORT_TRUE@	ieee/ieee_features.lo
@@ -985,7 +985,8 @@ gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
 	intrinsics/selected_int_kind.f90 \
 	intrinsics/selected_real_kind.f90 intrinsics/trigd.c \
 	intrinsics/unpack_generic.c runtime/in_pack_generic.c \
-	runtime/in_unpack_generic.c $(am__append_4) $(am__append_5)
+	runtime/in_unpack_generic.c runtime/in_pack_class.c \
+	runtime/in_unpack_class.c $(am__append_4) $(am__append_5)
 @IEEE_SUPPORT_TRUE@gfor_ieee_helper_src = ieee/ieee_helper.c
 @IEEE_SUPPORT_FALSE@gfor_ieee_src = 
 @IEEE_SUPPORT_TRUE@gfor_ieee_src = \
@@ -3174,6 +3175,10 @@ runtime/in_pack_generic.lo: runtime/$(am__dirstamp) \
 	runtime/$(DEPDIR)/$(am__dirstamp)
 runtime/in_unpack_generic.lo: runtime/$(am__dirstamp) \
 	runtime/$(DEPDIR)/$(am__dirstamp)
+runtime/in_pack_class.lo: runtime/$(am__dirstamp) \
+	runtime/$(DEPDIR)/$(am__dirstamp)
+runtime/in_unpack_class.lo: runtime/$(am__dirstamp) \
+	runtime/$(DEPDIR)/$(am__dirstamp)
 intrinsics/access.lo: intrinsics/$(am__dirstamp) \
 	intrinsics/$(DEPDIR)/$(am__dirstamp)
 intrinsics/c99_functions.lo: intrinsics/$(am__dirstamp) \
@@ -4223,7 +4228,9 @@ distclean-compile:
 @AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/environ.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/error.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/fpu.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_pack_class.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_pack_generic.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_unpack_class.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_unpack_generic.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/main.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/memory.Plo@am__quote@
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 4a5a037..82f8f3c 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1770,3 +1770,9 @@ GFORTRAN_14 {
   global:
     _gfortran_selected_logical_kind;
 } GFORTRAN_13;
+
+GFORTRAN_15 {
+  global:
+    _gfortran_internal_pack_class;
+    _gfortran_internal_unpack_class;
+} GFORTRAN_14;
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index 5c59ec2..effa373 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -570,6 +570,29 @@ typedef GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_INTEGER_4) gfc_full_a
 #define GFC_UNALIGNED_C8(x) (((uintptr_t)(x)) & \
 			     (__alignof__(GFC_COMPLEX_8) - 1))
 
+/* Generic vtab structure.  */
+typedef struct
+{
+  GFC_INTEGER_4 _hash;
+  size_t _size;
+  struct gfc_vtype_generic_t *_extends;
+  void *_def_init;
+  void (*_copy) (const void *, void *);
+  void *(*_final);
+  void (*_deallocate) (void *);
+} gfc_vtype_generic_t;
+
+/* Generic class structure.  */
+#define GFC_CLASS_T(type) \
+  struct \
+  { \
+    type _data; \
+    gfc_vtype_generic_t *_vptr; \
+    size_t _len; \
+  }
+
+typedef GFC_CLASS_T (GFC_ARRAY_DESCRIPTOR (void)) gfc_class_array_t;
+
 /* Runtime library include.  */
 #define stringize(x) expand_macro(x)
 #define expand_macro(x) # x
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);
+}