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.

7 files changed, 302 insertions, 182 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;