diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 85589ee..3803b88 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e)
 	      attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
 	    }
 	}
+      else if (e->value.function.isym
+	       && e->value.function.isym->transformational
+	       && e->ts.type == BT_CLASS)
+	attr = CLASS_DATA (e)->attr;
       else
 	attr = gfc_variable_attr (e, NULL);
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 87178a4..3bb057d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9834,10 +9834,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 		     "requires %<-frealloc-lhs%>", &lhs->where);
 	  return false;
 	}
-      /* See PR 43366.  */
-      gfc_error ("Assignment to an allocatable polymorphic variable at %L "
-		 "is not yet supported", &lhs->where);
-      return false;
     }
   else if (lhs->ts.type == BT_CLASS)
     {
@@ -10740,6 +10736,19 @@ start:
 	      break;
 
 	    gfc_check_pointer_assign (code->expr1, code->expr2);
+
+	    /* Assigning a class object always is a regular assign.  */
+	    if (code->expr2->ts.type == BT_CLASS
+		&& !CLASS_DATA (code->expr2)->attr.dimension
+		&& !(UNLIMITED_POLY (code->expr2)
+		     && code->expr1->ts.type == BT_DERIVED
+		     && (code->expr1->ts.u.derived->attr.sequence
+			 || code->expr1->ts.u.derived->attr.is_bind_c))
+		&& !(gfc_expr_attr (code->expr1).proc_pointer
+		     && code->expr2->expr_type == EXPR_VARIABLE
+		     && code->expr2->symtree->n.sym->attr.flavor
+			== FL_PROCEDURE))
+	      code->op = EXEC_ASSIGN;
 	    break;
 	  }
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 37cca79..c59e872 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
 	type = build_pointer_type (type);
     }
   else
-    type = gfc_typenode_for_spec (&expr->ts);
+    type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
+				  ? &CLASS_DATA (expr)->ts : &expr->ts);
 
   /* See if the constructor determines the loop bounds.  */
   dynamic = false;
@@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
   tree type;
   tree size;
   tree offset;
-  tree decl;
+  tree decl = NULL_TREE;
   tree tmp;
   gfc_expr *expr = se->ss->info->expr;
   gfc_ref *ref;
-  gfc_ref *class_ref;
+  gfc_ref *class_ref = NULL;
   gfc_typespec *ts;
 
-  if (expr == NULL
-      || (expr->ts.type != BT_CLASS
-	  && !gfc_is_alloc_class_array_function (expr)))
-    return false;
-
-  if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
-    ts = &expr->symtree->n.sym->ts;
+  if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
+      && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
+      && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
+    decl = se->expr;
   else
-    ts = NULL;
-  class_ref = NULL;
-
-  for (ref = expr->ref; ref; ref = ref->next)
     {
-      if (ref->type == REF_COMPONENT
-	    && ref->u.c.component->ts.type == BT_CLASS
-	    && ref->next && ref->next->type == REF_COMPONENT
-	    && strcmp (ref->next->u.c.component->name, "_data") == 0
-	    && ref->next->next
-	    && ref->next->next->type == REF_ARRAY
-	    && ref->next->next->u.ar.type != AR_ELEMENT)
+      if (expr == NULL
+	  || (expr->ts.type != BT_CLASS
+	      && !gfc_is_alloc_class_array_function (expr)
+	      && !gfc_is_class_array_ref (expr, NULL)))
+	return false;
+
+      if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+	ts = &expr->symtree->n.sym->ts;
+      else
+	ts = NULL;
+
+      for (ref = expr->ref; ref; ref = ref->next)
 	{
-	  ts = &ref->u.c.component->ts;
-	  class_ref = ref;
-	  break;
+	  if (ref->type == REF_COMPONENT
+	      && ref->u.c.component->ts.type == BT_CLASS
+	      && ref->next && ref->next->type == REF_COMPONENT
+	      && strcmp (ref->next->u.c.component->name, "_data") == 0
+	      && ref->next->next
+	      && ref->next->next->type == REF_ARRAY
+	      && ref->next->next->u.ar.type != AR_ELEMENT)
+	    {
+	      ts = &ref->u.c.component->ts;
+	      class_ref = ref;
+	      break;
+	    }
 	}
-    }
 
-  if (ts == NULL)
-    return false;
+      if (ts == NULL)
+	return false;
+    }
 
-  if (class_ref == NULL && expr->symtree->n.sym->attr.function
+  if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
       && expr->symtree->n.sym == expr->symtree->n.sym->result)
     {
       gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
       decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
     }
-  else if (gfc_is_alloc_class_array_function (expr))
+  else if (expr && gfc_is_alloc_class_array_function (expr))
     {
       size = NULL_TREE;
       decl = NULL_TREE;
@@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
     }
   else if (class_ref == NULL)
     {
-      decl = expr->symtree->n.sym->backend_decl;
+      if (decl == NULL_TREE)
+	decl = expr->symtree->n.sym->backend_decl;
       /* For class arrays the tree containing the class is stored in
 	 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
 	 For all others it's sym's backend_decl directly.  */
@@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
       class_ref->next = NULL;
       gfc_init_se (&tmpse, NULL);
       gfc_conv_expr (&tmpse, expr);
+      gfc_add_block_to_block (&se->pre, &tmpse.pre);
       decl = tmpse.expr;
       class_ref->next = ref;
     }
@@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 						loop.from, loop.to, 0,
 						GFC_ARRAY_UNKNOWN, false);
 	  parm = gfc_create_var (parmtype, "parm");
+
+	  /* When expression is a class object, then add the class' handle to
+	     the parm_decl.  */
+	  if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
+	    {
+	      gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+	      gfc_se classse;
+
+	      /* class_expr can be NULL, when no _class ref is in expr.
+		 We must not fix this here with a gfc_fix_class_ref ().  */
+	      if (class_expr)
+		{
+		  gfc_init_se (&classse, NULL);
+		  gfc_conv_expr (&classse, class_expr);
+		  gfc_free_expr (class_expr);
+
+		  gcc_assert (classse.pre.head == NULL_TREE
+			      && classse.post.head == NULL_TREE);
+		  gfc_allocate_lang_decl (parm);
+		  GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
+		}
+	    }
 	}
 
       offset = gfc_index_zero_node;
@@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	      : base;
 	  gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
 	}
+      else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed
+	       && (!rank_remap || se->use_offset)
+	       && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+	{
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm,
+					 gfc_conv_descriptor_offset_get (desc));
+	}
       else if (onebased && (!rank_remap || se->use_offset)
 	  && expr->symtree
 	  && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
@@ -7290,6 +7329,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	    GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
 	  : expr->symtree->n.sym->backend_decl;
     }
+  else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
+	   && IS_CLASS_ARRAY (expr))
+    {
+      tree vtype;
+      gfc_allocate_lang_decl (desc);
+      tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
+      GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
+      vtype = gfc_class_vptr_get (tmp);
+      gfc_add_modify (&se->pre, vtype,
+		      gfc_build_addr_expr (TREE_TYPE (vtype),
+				      gfc_find_vtab (&expr->ts)->backend_decl));
+    }
   if (!se->direct_byref || se->byref_noassign)
     {
       /* Get a pointer to the new descriptor.  */
@@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
-	      /* Add reference to '_data' component.  */
-	      tmp = CLASS_DATA (c)->backend_decl;
-	      comp = fold_build3_loc (input_location, COMPONENT_REF,
-				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
+
+	      comp = gfc_class_data_get (comp);
 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
 		gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
 	      else
@@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
   if (!expr->ref)
     return false;
 
+  /* An allocatable class variable with no reference.  */
+  if (expr->symtree->n.sym->ts.type == BT_CLASS
+      && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
+      && expr->ref && expr->ref->type == REF_COMPONENT
+      && strcmp (expr->ref->u.c.component->name, "_data") == 0
+      && expr->ref->next == NULL)
+    return true;
+
   /* An allocatable variable.  */
   if (expr->symtree->n.sym->attr.allocatable
 	&& expr->ref
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6b974db..10fe9b9 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -350,7 +350,7 @@ gfc_expr *
 gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
 {
   gfc_expr *base_expr;
-  gfc_ref *ref, *class_ref, *tail, *array_ref;
+  gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
 
   /* Find the last class reference.  */
   class_ref = NULL;
@@ -383,7 +383,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
       tail = class_ref->next;
       class_ref->next = NULL;
     }
-  else
+  else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     {
       tail = e->ref;
       e->ref = NULL;
@@ -397,7 +397,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
       gfc_free_ref_list (class_ref->next);
       class_ref->next = tail;
     }
-  else
+  else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     {
       gfc_free_ref_list (e->ref);
       e->ref = tail;
@@ -1453,7 +1453,12 @@ gfc_trans_class_init_assign (gfc_code *code)
 
   if (code->expr1->ts.type == BT_CLASS
       && CLASS_DATA (code->expr1)->attr.dimension)
-    tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+    {
+      gfc_array_spec *tmparr = gfc_get_array_spec ();
+      *tmparr = *CLASS_DATA (code->expr1)->as;
+      gfc_add_full_array_ref (lhs, tmparr);
+      tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+    }
   else
     {
       sz = gfc_copy_expr (code->expr1);
@@ -1498,114 +1503,6 @@ gfc_trans_class_init_assign (gfc_code *code)
 }
 
 
-/* Translate an assignment to a CLASS object
-   (pointer or ordinary assignment).  */
-
-tree
-gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
-{
-  stmtblock_t block;
-  tree tmp;
-  gfc_expr *lhs;
-  gfc_expr *rhs;
-  gfc_ref *ref;
-
-  gfc_start_block (&block);
-
-  ref = expr1->ref;
-  while (ref && ref->next)
-     ref = ref->next;
-
-  /* Class valued proc_pointer assignments do not need any further
-     preparation.  */
-  if (ref && ref->type == REF_COMPONENT
-	&& ref->u.c.component->attr.proc_pointer
-	&& expr2->expr_type == EXPR_VARIABLE
-	&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
-	&& op == EXEC_POINTER_ASSIGN)
-    goto assign;
-
-  if (expr2->ts.type != BT_CLASS)
-    {
-      /* Insert an additional assignment which sets the '_vptr' field.  */
-      gfc_symbol *vtab = NULL;
-      gfc_symtree *st;
-
-      lhs = gfc_copy_expr (expr1);
-      gfc_add_vptr_component (lhs);
-
-      if (UNLIMITED_POLY (expr1)
-	  && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
-	{
-	  rhs = gfc_get_null_expr (&expr2->where);
- 	  goto assign_vptr;
-	}
-
-      if (expr2->expr_type == EXPR_NULL)
-	vtab = gfc_find_vtab (&expr1->ts);
-      else
-	vtab = gfc_find_vtab (&expr2->ts);
-      gcc_assert (vtab);
-
-      rhs = gfc_get_expr ();
-      rhs->expr_type = EXPR_VARIABLE;
-      gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
-      rhs->symtree = st;
-      rhs->ts = vtab->ts;
-assign_vptr:
-      tmp = gfc_trans_pointer_assignment (lhs, rhs);
-      gfc_add_expr_to_block (&block, tmp);
-
-      gfc_free_expr (lhs);
-      gfc_free_expr (rhs);
-    }
-  else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
-    {
-      /* F2003:C717 only sequence and bind-C types can come here.  */
-      gcc_assert (expr1->ts.u.derived->attr.sequence
-		  || expr1->ts.u.derived->attr.is_bind_c);
-      gfc_add_data_component (expr2);
-      goto assign;
-    }
-  else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION)
-    {
-      /* Insert an additional assignment which sets the '_vptr' field.  */
-      lhs = gfc_copy_expr (expr1);
-      gfc_add_vptr_component (lhs);
-
-      rhs = gfc_copy_expr (expr2);
-      gfc_add_vptr_component (rhs);
-
-      tmp = gfc_trans_pointer_assignment (lhs, rhs);
-      gfc_add_expr_to_block (&block, tmp);
-
-      gfc_free_expr (lhs);
-      gfc_free_expr (rhs);
-    }
-
-  /* Do the actual CLASS assignment.  */
-  if (expr2->ts.type == BT_CLASS
-      && !CLASS_DATA (expr2)->attr.dimension)
-    op = EXEC_ASSIGN;
-  else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS
-	   || !CLASS_DATA (expr2)->attr.dimension)
-    gfc_add_data_component (expr1);
-
-assign:
-
-  if (op == EXEC_ASSIGN)
-    tmp = gfc_trans_assignment (expr1, expr2, false, true);
-  else if (op == EXEC_POINTER_ASSIGN)
-    tmp = gfc_trans_pointer_assignment (expr1, expr2);
-  else
-    gcc_unreachable();
-
-  gfc_add_expr_to_block (&block, tmp);
-
-  return gfc_finish_block (&block);
-}
-
-
 /* End of prototype trans-class.c  */
 
 
@@ -5903,6 +5800,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
   if (comp)
     ts = comp->ts;
+  else if (sym->ts.type == BT_CLASS)
+    ts = CLASS_DATA (sym)->ts;
   else
     ts = sym->ts;
 
@@ -5973,7 +5872,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		&& GFC_DESCRIPTOR_TYPE_P
 			(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
 	    se->expr = build_fold_indirect_ref_loc (input_location,
-						se->expr);
+						    se->expr);
 
 	  /* If the lhs of an assignment x = f(..) is allocatable and
 	     f2003 is allowed, we must do the automatic reallocation.
@@ -6259,6 +6158,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	}
     }
 
+  /* Associate the rhs class object's meta-data with the result, when the
+     result is a temporary.  */
+  if (args && args->expr && args->expr->ts.type == BT_CLASS
+      && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
+      && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
+    {
+      gfc_se parmse;
+      gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
+
+      gfc_init_se (&parmse, NULL);
+      parmse.data_not_needed = 1;
+      gfc_conv_expr (&parmse, class_expr);
+      if (!DECL_LANG_SPECIFIC (result))
+	gfc_allocate_lang_decl (result);
+      GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
+      gfc_free_expr (class_expr);
+      gcc_assert (parmse.pre.head == NULL_TREE
+		  && parmse.post.head == NULL_TREE);
+    }
+
   /* Follow the function call with the argument post block.  */
   if (byref)
     {
@@ -7881,6 +7800,201 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
 }
 
 
+/* Get the _len component for an unlimited polymorphic expression.  */
+
+static tree
+trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
+{
+  gfc_se se;
+  gfc_ref *ref = expr->ref;
+
+  gfc_init_se (&se, NULL);
+  while (ref && ref->next)
+    ref = ref->next;
+  gfc_add_len_component (expr);
+  gfc_conv_expr (&se, expr);
+  gfc_add_block_to_block (block, &se.pre);
+  gcc_assert (se.post.head == NULL_TREE);
+  if (ref)
+    {
+      gfc_free_ref_list (ref->next);
+      ref->next = NULL;
+    }
+  else
+    {
+      gfc_free_ref_list (expr->ref);
+      expr->ref = NULL;
+    }
+  return se.expr;
+}
+
+
+/* Assign _vptr and _len components as appropriate.  BLOCK should be a
+   statement-list outside of the scalarizer-loop.  When code is generated, that
+   depends on the scalarized expression, it is added to RSE.PRE.
+   Returns le's _vptr tree and when set the len expressions in to_lenp and
+   from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
+   expression.  */
+
+static tree
+trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
+				 gfc_expr * re, gfc_se *rse,
+				 tree * to_lenp, tree * from_lenp)
+{
+  gfc_se se;
+  gfc_expr * vptr_expr;
+  tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
+  bool set_vptr = false, temp_rhs = false;
+  stmtblock_t *pre = block;
+
+  /* Create a temporary for complicated expressions.  */
+  if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
+      && rse->expr != NULL_TREE && !DECL_P (rse->expr))
+    {
+      tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
+      pre = &rse->pre;
+      gfc_add_modify (&rse->pre, tmp, rse->expr);
+      rse->expr = tmp;
+      temp_rhs = true;
+    }
+
+  /* Get the _vptr for the left-hand side expression.  */
+  gfc_init_se (&se, NULL);
+  vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
+  if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
+    {
+      /* Care about _len for unlimited polymorphic entities.  */
+      if (UNLIMITED_POLY (vptr_expr)
+	  || (vptr_expr->ts.type == BT_DERIVED
+	      && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
+	to_len = trans_get_upoly_len (block, vptr_expr);
+      gfc_add_vptr_component (vptr_expr);
+      set_vptr = true;
+    }
+  else
+    vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
+  se.want_pointer = 1;
+  gfc_conv_expr (&se, vptr_expr);
+  gfc_free_expr (vptr_expr);
+  gfc_add_block_to_block (block, &se.pre);
+  gcc_assert (se.post.head == NULL_TREE);
+  lhs_vptr = se.expr;
+  STRIP_NOPS (lhs_vptr);
+
+  /* Set the _vptr only when the left-hand side of the assignment is a
+     class-object.  */
+  if (set_vptr)
+    {
+      /* Get the vptr from the rhs expression only, when it is variable.
+	 Functions are expected to be assigned to a temporary beforehand.  */
+      vptr_expr = re->expr_type == EXPR_VARIABLE
+	  ? gfc_find_and_cut_at_last_class_ref (re)
+	  : NULL;
+      if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
+	{
+	  if (to_len != NULL_TREE)
+	    {
+	      /* Get the _len information from the rhs.  */
+	      if (UNLIMITED_POLY (vptr_expr)
+		  || (vptr_expr->ts.type == BT_DERIVED
+		      && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
+		from_len = trans_get_upoly_len (block, vptr_expr);
+	    }
+	  gfc_add_vptr_component (vptr_expr);
+	}
+      else
+	{
+	  if (re->expr_type == EXPR_VARIABLE
+	      && DECL_P (re->symtree->n.sym->backend_decl)
+	      && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
+	      && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
+	      && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
+					   re->symtree->n.sym->backend_decl))))
+	    {
+	      vptr_expr = NULL;
+	      se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
+					     re->symtree->n.sym->backend_decl));
+	      if (to_len)
+		from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
+					     re->symtree->n.sym->backend_decl));
+	    }
+	  else if (temp_rhs && re->ts.type == BT_CLASS)
+	    {
+	      vptr_expr = NULL;
+	      se.expr = gfc_class_vptr_get (rse->expr);
+	    }
+	  else if (re->expr_type != EXPR_NULL)
+	    /* Only when rhs is non-NULL use its declared type for vptr
+	       initialisation.  */
+	    vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
+	  else
+	    /* When the rhs is NULL use the vtab of lhs' declared type.  */
+	    vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
+	}
+
+      if (vptr_expr)
+	{
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, vptr_expr);
+	  gfc_free_expr (vptr_expr);
+	  gfc_add_block_to_block (block, &se.pre);
+	  gcc_assert (se.post.head == NULL_TREE);
+	}
+      gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
+						se.expr));
+
+      if (to_len != NULL_TREE)
+	{
+	  /* The _len component needs to be set.  Figure how to get the
+	     value of the right-hand side.  */
+	  if (from_len == NULL_TREE)
+	    {
+	      if (rse->string_length != NULL_TREE)
+		from_len = rse->string_length;
+	      else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
+		{
+		  from_len = gfc_get_expr_charlen (re);
+		  gfc_init_se (&se, NULL);
+		  gfc_conv_expr (&se, re->ts.u.cl->length);
+		  gfc_add_block_to_block (block, &se.pre);
+		  gcc_assert (se.post.head == NULL_TREE);
+		  from_len = gfc_evaluate_now (se.expr, block);
+		}
+	      else
+		from_len = integer_zero_node;
+	    }
+	  gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
+						     from_len));
+	}
+    }
+
+  /* Return the _len trees only, when requested.  */
+  if (to_lenp)
+    *to_lenp = to_len;
+  if (from_lenp)
+    *from_lenp = from_len;
+  return lhs_vptr;
+}
+
+/* Indentify class valued proc_pointer assignments.  */
+
+static bool
+pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
+{
+  gfc_ref * ref;
+
+  ref = expr1->ref;
+  while (ref && ref->next)
+     ref = ref->next;
+
+  return ref && ref->type == REF_COMPONENT
+      && ref->u.c.component->attr.proc_pointer
+      && expr2->expr_type == EXPR_VARIABLE
+      && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
+}
+
+
 tree
 gfc_trans_pointer_assign (gfc_code * code)
 {
@@ -7893,20 +8007,22 @@ gfc_trans_pointer_assign (gfc_code * code)
 tree
 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 {
-  gfc_expr *expr1_vptr = NULL;
   gfc_se lse;
   gfc_se rse;
   stmtblock_t block;
   tree desc;
   tree tmp;
   tree decl;
-  bool scalar;
+  bool scalar, non_proc_pointer_assign;
   gfc_ss *ss;
 
   gfc_start_block (&block);
 
   gfc_init_se (&lse, NULL);
 
+  /* Usually testing whether this is not a proc pointer assignment.  */
+  non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+
   /* Check whether the expression is a scalar or not; we cannot use
      expr1->rank as it can be nonzero for proc pointers.  */
   ss = gfc_walk_expr (expr1);
@@ -7915,7 +8031,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
     gfc_free_ss_chain (ss);
 
   if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
-      && expr2->expr_type != EXPR_FUNCTION)
+      && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
     {
       gfc_add_data_component (expr2);
       /* The following is required as gfc_add_data_component doesn't
@@ -7932,6 +8048,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       rse.want_pointer = 1;
       gfc_conv_expr (&rse, expr2);
 
+      if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+	{
+	  trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
+					   NULL);
+	  lse.expr = gfc_class_data_get (lse.expr);
+	}
+
       if (expr1->symtree->n.sym->attr.proc_pointer
 	  && expr1->symtree->n.sym->attr.dummy)
 	lse.expr = build_fold_indirect_ref_loc (input_location,
@@ -7945,27 +8068,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
 
-      /* For string assignments to unlimited polymorphic pointers add an
-	 assignment of the string_length to the _len component of the
-	 pointer.  */
-      if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED)
-	  && expr1->ts.u.derived->attr.unlimited_polymorphic
-	  && (expr2->ts.type == BT_CHARACTER ||
-	      ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
-	       && expr2->ts.u.derived->attr.unlimited_polymorphic)))
-	{
-	  gfc_expr *len_comp;
-	  gfc_se se;
-	  len_comp = gfc_get_len_component (expr1);
-	  gfc_init_se (&se, NULL);
-	  gfc_conv_expr (&se, len_comp);
-
-	  /* ptr % _len = len (str)  */
-	  gfc_add_modify (&block, se.expr, rse.string_length);
-	  lse.string_length = se.expr;
-	  gfc_free_expr (len_comp);
-	}
-
       /* Check character lengths if character expression.  The test is only
 	 really added if -fbounds-check is enabled.  Exclude deferred
 	 character length lefthand sides.  */
@@ -7992,9 +8094,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 			    build_int_cst (gfc_charlen_type_node, 0));
 	}
 
-      if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS)
-	rse.expr = gfc_class_data_get (rse.expr);
-
       gfc_add_modify (&block, lse.expr,
 		      fold_convert (TREE_TYPE (lse.expr), rse.expr));
 
@@ -8005,6 +8104,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
     {
       gfc_ref* remap;
       bool rank_remap;
+      tree expr1_vptr = NULL_TREE;
       tree strlen_lhs;
       tree strlen_rhs = NULL_TREE;
 
@@ -8021,9 +8121,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_init_se (&lse, NULL);
       if (remap)
 	lse.descriptor_only = 1;
-      if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS
-	  && expr1->ts.type == BT_CLASS)
-	expr1_vptr = gfc_copy_expr (expr1);
       gfc_conv_expr_descriptor (&lse, expr1);
       strlen_lhs = lse.string_length;
       desc = lse.expr;
@@ -8049,16 +8146,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 		rse.expr = gfc_class_data_get (rse.expr);
 	      else
 		{
+		  expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+								expr2, &rse,
+								NULL, NULL);
 		  gfc_add_block_to_block (&block, &rse.pre);
 		  tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
 		  gfc_add_modify (&lse.pre, tmp, rse.expr);
 
-		  gfc_add_vptr_component (expr1_vptr);
-		  gfc_init_se (&rse, NULL);
-		  rse.want_pointer = 1;
-		  gfc_conv_expr (&rse, expr1_vptr);
-		  gfc_add_modify (&lse.pre, rse.expr,
-				  fold_convert (TREE_TYPE (rse.expr),
+		  gfc_add_modify (&lse.pre, expr1_vptr,
+				  fold_convert (TREE_TYPE (expr1_vptr),
 						gfc_class_vptr_get (tmp)));
 		  rse.expr = gfc_class_data_get (tmp);
 		}
@@ -8086,6 +8182,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	    {
 	      gfc_conv_expr_descriptor (&rse, expr2);
 	      strlen_rhs = rse.string_length;
+	      if (expr1->ts.type == BT_CLASS)
+		expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+							      expr2, &rse,
+							      NULL, NULL);
 	    }
 	}
       else if (expr2->expr_type == EXPR_VARIABLE)
@@ -8104,12 +8204,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	      gfc_init_se (&rse, NULL);
 	      rse.descriptor_only = 1;
 	      gfc_conv_expr (&rse, expr2);
+	      if (expr1->ts.type == BT_CLASS)
+		trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
+						 NULL, NULL);
 	      tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
 	      tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
 	      if (!INTEGER_CST_P (tmp))
 		gfc_add_block_to_block (&lse.post, &rse.pre);
 	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
 	    }
+	  else if (expr1->ts.type == BT_CLASS)
+	    {
+	      rse.expr = NULL_TREE;
+	      rse.string_length = NULL_TREE;
+	      trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
+					       NULL, NULL);
+	    }
 	}
       else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
 	{
@@ -8123,16 +8233,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	    }
 	  else
 	    {
+	      expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+							    expr2, &rse, NULL,
+							    NULL);
 	      gfc_add_block_to_block (&block, &rse.pre);
 	      tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
 	      gfc_add_modify (&lse.pre, tmp, rse.expr);
 
-	      gfc_add_vptr_component (expr1_vptr);
-	      gfc_init_se (&rse, NULL);
-	      rse.want_pointer = 1;
-	      gfc_conv_expr (&rse, expr1_vptr);
-	      gfc_add_modify (&lse.pre, rse.expr,
-			      fold_convert (TREE_TYPE (rse.expr),
+	      gfc_add_modify (&lse.pre, expr1_vptr,
+			      fold_convert (TREE_TYPE (expr1_vptr),
 					gfc_class_vptr_get (tmp)));
 	      rse.expr = gfc_class_data_get (tmp);
 	      gfc_add_modify (&lse.pre, desc, rse.expr);
@@ -8151,9 +8260,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  gfc_add_modify (&lse.pre, desc, tmp);
 	}
 
-      if (expr1_vptr)
-	gfc_free_expr (expr1_vptr);
-
       gfc_add_block_to_block (&block, &lse.pre);
       if (rank_remap)
 	gfc_add_block_to_block (&block, &rse.pre);
@@ -8403,7 +8509,6 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 
       if (rse->string_length != NULL_TREE)
 	{
-	  gcc_assert (rse->string_length != NULL_TREE);
 	  gfc_conv_string_parameter (rse);
 	  gfc_add_block_to_block (&block, &rse->pre);
 	  rlen = rse->string_length;
@@ -9359,14 +9464,101 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
   return false;
 }
 
+
+static tree
+trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
+			gfc_se *lse, gfc_se *rse, bool use_vptr_copy)
+{
+  tree tmp;
+  tree fcn;
+  tree stdcopy, to_len, from_len;
+  vec<tree, va_gc> *args = NULL;
+
+  tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
+					 &from_len);
+
+  fcn = gfc_vptr_copy_get (tmp);
+
+  tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
+      ? gfc_class_data_get (rse->expr) : rse->expr;
+  if (use_vptr_copy)
+    {
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp))
+	  || INDIRECT_REF_P (tmp)
+	  || (rhs->ts.type == BT_DERIVED
+	      && rhs->ts.u.derived->attr.unlimited_polymorphic
+	      && !rhs->ts.u.derived->attr.pointer
+	      && !rhs->ts.u.derived->attr.allocatable)
+	  || (UNLIMITED_POLY (rhs)
+	      && !CLASS_DATA (rhs)->attr.pointer
+	      && !CLASS_DATA (rhs)->attr.allocatable))
+	vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
+      else
+	vec_safe_push (args, tmp);
+      tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+	  ? gfc_class_data_get (lse->expr) : lse->expr;
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp))
+	  || INDIRECT_REF_P (tmp)
+	  || (lhs->ts.type == BT_DERIVED
+	      && lhs->ts.u.derived->attr.unlimited_polymorphic
+	      && !lhs->ts.u.derived->attr.pointer
+	      && !lhs->ts.u.derived->attr.allocatable)
+	  || (UNLIMITED_POLY (lhs)
+	      && !CLASS_DATA (lhs)->attr.pointer
+	      && !CLASS_DATA (lhs)->attr.allocatable))
+	vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
+      else
+	vec_safe_push (args, tmp);
+
+      stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
+
+      if (to_len != NULL_TREE && !integer_zerop (from_len))
+	{
+	  tree extcopy;
+	  vec_safe_push (args, from_len);
+	  vec_safe_push (args, to_len);
+	  extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
+
+	  tmp = fold_build2_loc (input_location, GT_EXPR,
+				 boolean_type_node, from_len,
+				 integer_zero_node);
+	  return fold_build3_loc (input_location, COND_EXPR,
+				  void_type_node, tmp,
+				  extcopy, stdcopy);
+	}
+      else
+	return stdcopy;
+    }
+  else
+    {
+      tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+	  ? gfc_class_data_get (lse->expr) : lse->expr;
+      stmtblock_t tblock;
+      gfc_init_block (&tblock);
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+      if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
+	rhst = gfc_build_addr_expr (NULL_TREE, rhst);
+      /* When coming from a ptr_copy lhs and rhs are swapped.  */
+      gfc_add_modify_loc (input_location, &tblock, rhst,
+			  fold_convert (TREE_TYPE (rhst), tmp));
+      return gfc_finish_block (&tblock);
+    }
+}
+
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
    init_flag indicates initialization expressions and dealloc that no
-   deallocate prior assignment is needed (if in doubt, set true).  */
+   deallocate prior assignment is needed (if in doubt, set true).
+   When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
+   routine instead of a pointer assignment.  Alias resolution is only done,
+   when MAY_ALIAS is set (the default).  This flag is used by ALLOCATE()
+   where it is known, that newly allocated memory on the lhs can never be
+   an alias of the rhs.  */
 
 static tree
 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
-			bool dealloc)
+			bool dealloc, bool use_vptr_copy, bool may_alias)
 {
   gfc_se lse;
   gfc_se rse;
@@ -9382,7 +9574,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   tree string_length;
   int n;
   bool maybe_workshare = false;
-  symbol_attribute lhs_caf_attr, rhs_caf_attr;
+  symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
 
   /* Assignment of the form lhs = rhs.  */
   gfc_start_block (&block);
@@ -9403,8 +9595,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  || gfc_is_alloc_class_scalar_function (expr2)))
     expr2->must_finalize = 1;
 
-  lhs_caf_attr = gfc_caf_attr (expr1);
-  rhs_caf_attr = gfc_caf_attr (expr2);
+  /* Only analyze the expressions for coarray properties, when in coarray-lib
+     mode.  */
+  if (flag_coarray == GFC_FCOARRAY_LIB)
+    {
+      lhs_caf_attr = gfc_caf_attr (expr1);
+      rhs_caf_attr = gfc_caf_attr (expr2);
+    }
 
   if (lss != gfc_ss_terminator)
     {
@@ -9437,7 +9634,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
 	loop.reverse[n] = GFC_ENABLE_REVERSE;
       /* Resolve any data dependencies in the statement.  */
-      gfc_conv_resolve_dependencies (&loop, lss, rss);
+      if (may_alias)
+	gfc_conv_resolve_dependencies (&loop, lss, rss);
       /* Setup the scalarizing loops.  */
       gfc_conv_loop_setup (&loop, &expr2->where);
 
@@ -9584,9 +9782,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	gfc_add_block_to_block (&loop.post, &rse.post);
     }
 
-  if (flag_coarray == GFC_FCOARRAY_LIB
-      && lhs_caf_attr.codimension && rhs_caf_attr.codimension
-      && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
+  lhs_attr = gfc_expr_attr (expr1);
+  if ((use_vptr_copy || lhs_attr.pointer
+       || (lhs_attr.allocatable && !lhs_attr.dimension))
+      && (expr1->ts.type == BT_CLASS
+	  || (gfc_is_class_array_ref (expr1, NULL)
+	      || gfc_is_class_scalar_expr (expr1))
+	  || (gfc_is_class_array_ref (expr2, NULL)
+	      || gfc_is_class_scalar_expr (expr2))))
+    {
+      tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+				    use_vptr_copy || (lhs_attr.allocatable
+						      && !lhs_attr.dimension));
+      /* Modify the expr1 after the assignment, to allow the realloc below.
+	 Therefore only needed, when realloc_lhs is enabled.  */
+      if (flag_realloc_lhs && !lhs_attr.pointer)
+	gfc_add_data_component (expr1);
+    }
+  else if (flag_coarray == GFC_FCOARRAY_LIB
+	   && lhs_caf_attr.codimension && rhs_caf_attr.codimension
+	   && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
     {
       gfc_code code;
       gfc_actual_arglist a1, a2;
@@ -9604,7 +9819,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 				   || scalar_to_array
 				   || expr2->expr_type == EXPR_ARRAY,
 				   !(l_is_temp || init_flag) && dealloc);
+  /* Add the pre blocks to the body.  */
+  gfc_add_block_to_block (&body, &rse.pre);
+  gfc_add_block_to_block (&body, &lse.pre);
   gfc_add_expr_to_block (&body, tmp);
+  /* Add the post blocks to the body.  */
+  gfc_add_block_to_block (&body, &rse.post);
+  gfc_add_block_to_block (&body, &lse.post);
 
   if (lss == gfc_ss_terminator)
     {
@@ -9719,7 +9940,7 @@ copyable_array_p (gfc_expr * expr)
 
 tree
 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
-		      bool dealloc)
+		      bool dealloc, bool use_vptr_copy, bool may_alias)
 {
   tree tmp;
 
@@ -9762,7 +9983,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
     }
 
   /* Fallback to the scalarizer to generate explicit loops.  */
-  return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
+  return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
+				 use_vptr_copy, may_alias);
 }
 
 tree
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index ef5153e..4280b77 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5439,7 +5439,10 @@ gfc_trans_allocate (gfc_code * code)
 	  if (code->expr3->rank != 0
 	      && ((!attr.allocatable && !attr.pointer)
 		  || (code->expr3->expr_type == EXPR_FUNCTION
-		      && code->expr3->ts.type != BT_CLASS)))
+		      && (code->expr3->ts.type != BT_CLASS
+			  || (code->expr3->value.function.isym
+			      && code->expr3->value.function.isym
+							 ->transformational)))))
 	    gfc_conv_expr_descriptor (&se, code->expr3);
 	  else
 	    gfc_conv_expr_reference (&se, code->expr3);
@@ -5623,73 +5626,6 @@ gfc_trans_allocate (gfc_code * code)
 	  else
 	    expr3_esize = TYPE_SIZE_UNIT (
 		  gfc_typenode_for_spec (&code->expr3->ts));
-
-	  /* The routine gfc_trans_assignment () already implements all
-	     techniques needed.  Unfortunately we may have a temporary
-	     variable for the source= expression here.  When that is the
-	     case convert this variable into a temporary gfc_expr of type
-	     EXPR_VARIABLE and used it as rhs for the assignment.  The
-	     advantage is, that we get scalarizer support for free,
-	     don't have to take care about scalar to array treatment and
-	     will benefit of every enhancements gfc_trans_assignment ()
-	     gets.
-	     No need to check whether e3_is is E3_UNSET, because that is
-	     done by expr3 != NULL_TREE.
-	     Exclude variables since the following block does not handle
-	     array sections. In any case, there is no harm in sending
-	     variables to gfc_trans_assignment because there is no
-	     evaluation of variables.  */
-	  if (code->expr3->expr_type != EXPR_VARIABLE
-	      && e3_is != E3_MOLD && expr3 != NULL_TREE
-	      && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
-	    {
-	      /* Build a temporary symtree and symbol.  Do not add it to
-		 the current namespace to prevent accidently modifying
-		 a colliding symbol's as.  */
-	      newsym = XCNEW (gfc_symtree);
-	      /* The name of the symtree should be unique, because
-		 gfc_create_var () took care about generating the
-		 identifier.  */
-	      newsym->name = gfc_get_string (IDENTIFIER_POINTER (
-					       DECL_NAME (expr3)));
-	      newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
-	      /* The backend_decl is known.  It is expr3, which is inserted
-		 here.  */
-	      newsym->n.sym->backend_decl = expr3;
-	      e3rhs = gfc_get_expr ();
-	      e3rhs->ts = code->expr3->ts;
-	      e3rhs->rank = code->expr3->rank;
-	      e3rhs->symtree = newsym;
-	      /* Mark the symbol referenced or gfc_trans_assignment will
-		 bug.  */
-	      newsym->n.sym->attr.referenced = 1;
-	      e3rhs->expr_type = EXPR_VARIABLE;
-	      e3rhs->where = code->expr3->where;
-	      /* Set the symbols type, upto it was BT_UNKNOWN.  */
-	      newsym->n.sym->ts = e3rhs->ts;
-	      /* Check whether the expr3 is array valued.  */
-	      if (e3rhs->rank)
-		{
-		  gfc_array_spec *arr;
-		  arr = gfc_get_array_spec ();
-		  arr->rank = e3rhs->rank;
-		  arr->type = AS_DEFERRED;
-		  /* Set the dimension and pointer attribute for arrays
-		     to be on the safe side.  */
-		  newsym->n.sym->attr.dimension = 1;
-		  newsym->n.sym->attr.pointer = 1;
-		  newsym->n.sym->as = arr;
-		  gfc_add_full_array_ref (e3rhs, arr);
-		}
-	      else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
-		newsym->n.sym->attr.pointer = 1;
-	      /* The string length is known to.  Set it for char arrays.  */
-	      if (e3rhs->ts.type == BT_CHARACTER)
-		newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
-	      gfc_commit_symbol (newsym->n.sym);
-	    }
-	  else
-	    e3rhs = gfc_copy_expr (code->expr3);
 	}
       gcc_assert (expr3_esize);
       expr3_esize = fold_convert (sizetype, expr3_esize);
@@ -5723,6 +5659,95 @@ gfc_trans_allocate (gfc_code * code)
 	}
     }
 
+  /* The routine gfc_trans_assignment () already implements all
+     techniques needed.  Unfortunately we may have a temporary
+     variable for the source= expression here.  When that is the
+     case convert this variable into a temporary gfc_expr of type
+     EXPR_VARIABLE and used it as rhs for the assignment.  The
+     advantage is, that we get scalarizer support for free,
+     don't have to take care about scalar to array treatment and
+     will benefit of every enhancements gfc_trans_assignment ()
+     gets.
+     No need to check whether e3_is is E3_UNSET, because that is
+     done by expr3 != NULL_TREE.
+     Exclude variables since the following block does not handle
+     array sections.  In any case, there is no harm in sending
+     variables to gfc_trans_assignment because there is no
+     evaluation of variables.  */
+  if (code->expr3)
+    {
+      if (code->expr3->expr_type != EXPR_VARIABLE
+	  && e3_is != E3_MOLD && expr3 != NULL_TREE
+	  && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+	{
+	  /* Build a temporary symtree and symbol.  Do not add it to the current
+	     namespace to prevent accidently modifying a colliding
+	     symbol's as.  */
+	  newsym = XCNEW (gfc_symtree);
+	  /* The name of the symtree should be unique, because gfc_create_var ()
+	     took care about generating the identifier.  */
+	  newsym->name = gfc_get_string (IDENTIFIER_POINTER (
+							    DECL_NAME (expr3)));
+	  newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
+	  /* The backend_decl is known.  It is expr3, which is inserted
+	     here.  */
+	  newsym->n.sym->backend_decl = expr3;
+	  e3rhs = gfc_get_expr ();
+	  e3rhs->rank = code->expr3->rank;
+	  e3rhs->symtree = newsym;
+	  /* Mark the symbol referenced or gfc_trans_assignment will bug.  */
+	  newsym->n.sym->attr.referenced = 1;
+	  e3rhs->expr_type = EXPR_VARIABLE;
+	  e3rhs->where = code->expr3->where;
+	  /* Set the symbols type, upto it was BT_UNKNOWN.  */
+	  if (IS_CLASS_ARRAY (code->expr3)
+	      && code->expr3->expr_type == EXPR_FUNCTION
+	      && code->expr3->value.function.isym
+	      && code->expr3->value.function.isym->transformational)
+	    {
+	      e3rhs->ts = CLASS_DATA (code->expr3)->ts;
+	    }
+	  else if (code->expr3->ts.type == BT_CLASS
+		   && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))
+	    e3rhs->ts = CLASS_DATA (code->expr3)->ts;
+	  else
+	    e3rhs->ts = code->expr3->ts;
+	  newsym->n.sym->ts = e3rhs->ts;
+	  /* Check whether the expr3 is array valued.  */
+	  if (e3rhs->rank)
+	    {
+	      gfc_array_spec *arr;
+	      arr = gfc_get_array_spec ();
+	      arr->rank = e3rhs->rank;
+	      arr->type = AS_DEFERRED;
+	      /* Set the dimension and pointer attribute for arrays
+	     to be on the safe side.  */
+	      newsym->n.sym->attr.dimension = 1;
+	      newsym->n.sym->attr.pointer = 1;
+	      newsym->n.sym->as = arr;
+	      if (IS_CLASS_ARRAY (code->expr3)
+		  && code->expr3->expr_type == EXPR_FUNCTION
+		  && code->expr3->value.function.isym
+		  && code->expr3->value.function.isym->transformational)
+		{
+		  gfc_array_spec *tarr;
+		  tarr = gfc_get_array_spec ();
+		  *tarr = *arr;
+		  e3rhs->ts.u.derived->as = tarr;
+		}
+	      gfc_add_full_array_ref (e3rhs, arr);
+	    }
+	  else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+	    newsym->n.sym->attr.pointer = 1;
+	  /* The string length is known to.  Set it for char arrays.  */
+	  if (e3rhs->ts.type == BT_CHARACTER)
+	    newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
+	  gfc_commit_symbol (newsym->n.sym);
+	}
+      else
+	e3rhs = gfc_copy_expr (code->expr3);
+    }
+
   /* Loop over all objects to allocate.  */
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
     {
@@ -5960,8 +5985,9 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_add_expr_to_block (&block, tmp);
 	}
 
-      /* Set the vptr.  */
-      if (al_vptr != NULL_TREE)
+      /* Set the vptr only when no source= is set.  When source= is set, then
+	 the trans_assignment below will set the vptr.  */
+      if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
 	{
 	  if (expr3_vptr != NULL_TREE)
 	    /* The vtab is already known, so just assign it.  */
@@ -6046,153 +6072,34 @@ gfc_trans_allocate (gfc_code * code)
       if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
 	{
 	  /* Initialization via SOURCE block (or static default initializer).
-	     Classes need some special handling, so catch them first.  */
-	  if (expr3 != NULL_TREE
-	      && TREE_CODE (expr3) != POINTER_PLUS_EXPR
-	      && code->expr3->ts.type == BT_CLASS
-	      && (expr->ts.type == BT_CLASS
-		  || expr->ts.type == BT_DERIVED))
-	    {
-	      /* copy_class_to_class can be used for class arrays, too.
-		 It just needs to be ensured, that the decl_saved_descriptor
-		 has a way to get to the vptr.  */
-	      tree to;
-	      to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
-	      tmp = gfc_copy_class_to_class (expr3, to,
-					     nelems, upoly_expr);
-	    }
-	  else if (al->expr->ts.type == BT_CLASS)
-	    {
-	      gfc_actual_arglist *actual, *last_arg;
-	      gfc_expr *ppc;
-	      gfc_code *ppc_code;
-	      gfc_ref *ref, *dataref;
-	      gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
-
-	      /* Do a polymorphic deep copy.  */
-	      actual = gfc_get_actual_arglist ();
-	      actual->expr = gfc_copy_expr (rhs);
-	      if (rhs->ts.type == BT_CLASS)
-		gfc_add_data_component (actual->expr);
-	      last_arg = actual->next = gfc_get_actual_arglist ();
-	      last_arg->expr = gfc_copy_expr (al->expr);
-	      last_arg->expr->ts.type = BT_CLASS;
-	      gfc_add_data_component (last_arg->expr);
-
-	      dataref = NULL;
-	      /* Make sure we go up through the reference chain to
-		 the _data reference, where the arrayspec is found.  */
-	      for (ref = last_arg->expr->ref; ref; ref = ref->next)
-		if (ref->type == REF_COMPONENT
-		    && strcmp (ref->u.c.component->name, "_data") == 0)
-		  dataref = ref;
-
-	      if (dataref && dataref->u.c.component->as)
-		{
-		  gfc_array_spec *as = dataref->u.c.component->as;
-		  gfc_free_ref_list (dataref->next);
-		  dataref->next = NULL;
-		  gfc_add_full_array_ref (last_arg->expr, as);
-		  gfc_resolve_expr (last_arg->expr);
-		  gcc_assert (last_arg->expr->ts.type == BT_CLASS
-			      || last_arg->expr->ts.type == BT_DERIVED);
-		  last_arg->expr->ts.type = BT_CLASS;
-		}
-	      if (rhs->ts.type == BT_CLASS)
-		{
-		  if (rhs->ref)
-		    ppc = gfc_find_and_cut_at_last_class_ref (rhs);
-		  else
-		    ppc = gfc_copy_expr (rhs);
-		  gfc_add_vptr_component (ppc);
-		}
-	      else
-		ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts));
-	      gfc_add_component_ref (ppc, "_copy");
-
-	      ppc_code = gfc_get_code (EXEC_CALL);
-	      ppc_code->resolved_sym = ppc->symtree->n.sym;
-	      ppc_code->loc = al->expr->where;
-	      /* Although '_copy' is set to be elemental in class.c, it is
-		 not staying that way.  Find out why, sometime....  */
-	      ppc_code->resolved_sym->attr.elemental = 1;
-	      ppc_code->ext.actual = actual;
-	      ppc_code->expr1 = ppc;
-	      /* Since '_copy' is elemental, the scalarizer will take care
-		 of arrays in gfc_trans_call.  */
-	      tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
-	      /* We need to add the
-		   if (al_len > 0)
-		     al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
-		   else
-		     al_vptr->copy (expr3_data, al_data);
-		 block, because al is unlimited polymorphic or a deferred
-		 length char array, whose copy routine needs the array lengths
-		 as third and fourth arguments.  */
-	      if (al_len && UNLIMITED_POLY (code->expr3))
-		{
-		  tree stdcopy, extcopy;
-		  /* Add al%_len.  */
-		  last_arg->next = gfc_get_actual_arglist ();
-		  last_arg = last_arg->next;
-		  last_arg->expr = gfc_find_and_cut_at_last_class_ref (
-			al->expr);
-		  gfc_add_len_component (last_arg->expr);
-		  /* Add expr3's length.  */
-		  last_arg->next = gfc_get_actual_arglist ();
-		  last_arg = last_arg->next;
-		  if (code->expr3->ts.type == BT_CLASS)
-		    {
-		      last_arg->expr =
-			  gfc_find_and_cut_at_last_class_ref (code->expr3);
-		      gfc_add_len_component (last_arg->expr);
-		    }
-		  else if (code->expr3->ts.type == BT_CHARACTER)
-		    last_arg->expr =
-			gfc_copy_expr (code->expr3->ts.u.cl->length);
-		  else
-		    gcc_unreachable ();
-
-		  stdcopy = tmp;
-		  extcopy = gfc_trans_call (ppc_code, true, NULL, NULL, false);
-
-		  tmp = fold_build2_loc (input_location, GT_EXPR,
-					 boolean_type_node, expr3_len,
-					 integer_zero_node);
-		  tmp = fold_build3_loc (input_location, COND_EXPR,
-					 void_type_node, tmp, extcopy, stdcopy);
-		}
-	      gfc_free_statements (ppc_code);
-	      if (rhs != e3rhs)
-		gfc_free_expr (rhs);
-	    }
-	  else
-	    {
-	      /* Switch off automatic reallocation since we have just
-		 done the ALLOCATE.  */
-	      int realloc_lhs = flag_realloc_lhs;
-	      gfc_expr *init_expr = gfc_expr_to_initialize (expr);
-	      flag_realloc_lhs = 0;
-	      tmp = gfc_trans_assignment (init_expr, e3rhs, false, false);
-	      flag_realloc_lhs = realloc_lhs;
-	      /* Free the expression allocated for init_expr.  */
-	      gfc_free_expr (init_expr);
-	    }
+	     Switch off automatic reallocation since we have just done the
+	     ALLOCATE.  */
+	  int realloc_lhs = flag_realloc_lhs;
+	  gfc_expr *init_expr = gfc_expr_to_initialize (expr);
+	  gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
+	  flag_realloc_lhs = 0;
+	  tmp = gfc_trans_assignment (init_expr, rhs, false, false, true,
+				      false);
+	  flag_realloc_lhs = realloc_lhs;
+	  /* Free the expression allocated for init_expr.  */
+	  gfc_free_expr (init_expr);
+	  if (rhs != e3rhs)
+	    gfc_free_expr (rhs);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
-     else if (code->expr3 && code->expr3->mold
-	      && code->expr3->ts.type == BT_CLASS)
+      else if (code->expr3 && code->expr3->mold
+	       && code->expr3->ts.type == BT_CLASS)
 	{
-	  /* Since the _vptr has already been assigned to the allocate
-	     object, we can use gfc_copy_class_to_class in its
-	     initialization mode.  */
-	  tmp = TREE_OPERAND (se.expr, 0);
-	  tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems,
-					 upoly_expr);
+	  /* Use class_init_assign to initialize expr.  */
+	  gfc_code *ini;
+	  ini = gfc_get_code (EXEC_INIT_ASSIGN);
+	  ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr);
+	  tmp = gfc_trans_class_init_assign (ini);
+	  gfc_free_statements (ini);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
 
-       gfc_free_expr (expr);
+      gfc_free_expr (expr);
     } // for-loop
 
   if (e3rhs)
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index f9c8e74..e4d4a67 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *);
 tree gfc_trans_pointer_assign (gfc_code *);
 tree gfc_trans_init_assign (gfc_code *);
 tree gfc_trans_class_init_assign (gfc_code *);
-tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op);
 
 /* trans-stmt.c */
 tree gfc_trans_cycle (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 9210e0f..fba0d9a 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond)
 	  break;
 
 	case EXEC_ASSIGN:
-	  if (code->expr1->ts.type == BT_CLASS)
-	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
-	  else
-	    res = gfc_trans_assign (code);
+	  res = gfc_trans_assign (code);
 	  break;
 
         case EXEC_LABEL_ASSIGN:
@@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond)
           break;
 
 	case EXEC_POINTER_ASSIGN:
-	  if (code->expr1->ts.type == BT_CLASS)
-	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
-	  else if (UNLIMITED_POLY (code->expr2)
-		   && code->expr1->ts.type == BT_DERIVED
-		   && (code->expr1->ts.u.derived->attr.sequence
-		       || code->expr1->ts.u.derived->attr.is_bind_c))
-	    /* F2003: C717  */
-	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
-	  else
-	    res = gfc_trans_pointer_assign (code);
+	  res = gfc_trans_pointer_assign (code);
 	  break;
 
 	case EXEC_INIT_ASSIGN:
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4d3d207..f76fff8 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree);
 tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
 
 /* Generate code for an assignment, includes scalarization.  */
-tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
+tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false,
+			   bool a = true);
 
 /* Generate code for a pointer assignment.  */
 tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03
new file mode 100644
index 0000000..1d9450f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03
@@ -0,0 +1,74 @@
+! { dg-do run }
+!
+! Contributed by Vladimir Fuka
+! Check that pr61337 is fixed.
+
+module array_list
+
+  type container
+    class(*), allocatable :: items(:)
+  end type
+
+contains
+
+  subroutine add_item(a, e)
+    type(container),allocatable,intent(inout) :: a(:)
+    class(*),intent(in) :: e(:)
+    type(container),allocatable :: tmp(:)
+
+      if (.not.allocated(a)) then
+        allocate(a(1))
+        allocate(a(1)%items(size(e)), source = e)
+      else
+        call move_alloc(a,tmp)
+        allocate(a(size(tmp)+1))
+        a(1:size(tmp)) = tmp
+        allocate(a(size(tmp)+1)%items(size(e)), source=e)
+      end if
+   end subroutine
+
+end module
+
+program test_pr61337
+
+  use array_list
+
+  type(container), allocatable :: a_list(:)
+  integer(kind = 8) :: i
+
+  call add_item(a_list, [1, 2])
+  call add_item(a_list, [3.0_8, 4.0_8])
+  call add_item(a_list, [.true., .false.])
+!  call add_item(a_list, ["bar", "foo", "bla"])
+
+  if (size(a_list) /= 3) call abort()
+  do i = 1, size(a_list)
+          call checkarr(a_list(i))
+  end do
+
+  deallocate(a_list)
+
+contains
+
+  subroutine checkarr(c)
+    type(container) :: c
+
+    if (allocated(c%items)) then
+      select type (x=>c%items)
+        type is (integer)
+          if (any(x /= [1, 2])) call abort()
+        type is (real(kind=8))
+          if (any(x /= [3.0_8, 4.0_8])) call abort()
+        type is (logical)
+          if (any(x .neqv. [.true., .false.])) call abort()
+! TODO: ICE when the next line is present, pr???
+!        type is (character(len=:))
+!          if (any(x /= ["bar", "foo", "bla"])) call abort()
+        class default
+          call abort()
+      end select
+    else
+        call abort()
+    end if
+  end subroutine
+end
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_21.f90 b/gcc/testsuite/gfortran.dg/class_allocate_21.f90
new file mode 100644
index 0000000..a8ed291
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_21.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+!
+! Testcase for pr57117
+
+implicit none
+
+  type :: ti
+    integer :: i
+  end type
+
+  class(ti), allocatable :: x(:,:), z(:)
+  integer :: i
+
+  allocate(x(3,3))
+  x%i = reshape([( i, i = 1, 9 )], [3, 3])
+  allocate(z(9), source=reshape(x, (/ 9 /)))
+
+  if (any( z%i /= [( i, i = 1, 9 )])) call abort()
+  deallocate (x, z)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_22.f90 b/gcc/testsuite/gfortran.dg/class_allocate_22.f90
new file mode 100644
index 0000000..5fec72f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_22.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+!
+! Check pr57117 is fixed.
+
+program pr57117
+  implicit none
+
+  type :: ti
+    integer :: i
+  end type
+
+  class(ti), allocatable :: x(:,:), y(:,:)
+  integer :: i
+
+  allocate(x(2,6))
+  select type (x)
+    class is (ti)
+       x%i = reshape([(i,i=1, 12)],[2,6])
+  end select
+  allocate(y, source=transpose(x))
+
+  if (any( ubound(y) /= [6,2])) call abort()
+  if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) call abort()
+  deallocate (x,y)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08 b/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08
new file mode 100644
index 0000000..53b8330
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08
@@ -0,0 +1,24 @@
+! { dg-do run }
+
+  type :: t
+    integer :: i
+  end type
+
+  type, extends(t) :: r
+    real :: r
+  end type
+
+  class(t), allocatable :: x
+  class(r), allocatable :: foo ! Need this declared of copy_R is not generated.
+  type(r) :: y = r (3, 42)
+
+  x = y
+  if (x%i /= 3) call abort()
+  select type(x)
+    class is (r)
+      if (x%r /= 42.0) call abort()
+    class default
+      call abort()
+  end select
+end
+
