gcc-7.1.0gcc-7.1.0

1 files changed, 1001 insertions, 356 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 18358a4e03..7bced25df4 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1,5 +1,5 @@
 /* Expression translation
-   Copyright (C) 2002-2016 Free Software Foundation, Inc.
+   Copyright (C) 2002-2017 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -72,6 +72,13 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
   desc = gfc_create_var (type, "desc");
   DECL_ARTIFICIAL (desc) = 1;
 
+  if (CONSTANT_CLASS_P (scalar))
+    {
+      tree tmp;
+      tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+      gfc_add_modify (&se->pre, tmp, scalar);
+      scalar = tmp;
+    }
   if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
     scalar = gfc_build_addr_expr (NULL_TREE, scalar);
   gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
@@ -88,6 +95,56 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
 }
 
 
+/* Get the coarray token from the ultimate array or component ref.
+   Returns a NULL_TREE, when the ref object is not allocatable or pointer.  */
+
+tree
+gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
+{
+  gfc_symbol *sym = expr->symtree->n.sym;
+  bool is_coarray = sym->attr.codimension;
+  gfc_expr *caf_expr = gfc_copy_expr (expr);
+  gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
+
+  while (ref)
+    {
+      if (ref->type == REF_COMPONENT
+	  && (ref->u.c.component->attr.allocatable
+	      || ref->u.c.component->attr.pointer)
+	  && (is_coarray || ref->u.c.component->attr.codimension))
+	  last_caf_ref = ref;
+      ref = ref->next;
+    }
+
+  if (last_caf_ref == NULL)
+    return NULL_TREE;
+
+  tree comp = last_caf_ref->u.c.component->caf_token, caf;
+  gfc_se se;
+  bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
+  if (comp == NULL_TREE && comp_ref)
+    return NULL_TREE;
+  gfc_init_se (&se, outerse);
+  gfc_free_ref_list (last_caf_ref->next);
+  last_caf_ref->next = NULL;
+  caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
+  se.want_pointer = comp_ref;
+  gfc_conv_expr (&se, caf_expr);
+  gfc_add_block_to_block (&outerse->pre, &se.pre);
+
+  if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
+    se.expr = TREE_OPERAND (se.expr, 0);
+  gfc_free_expr (caf_expr);
+
+  if (comp_ref)
+    caf = fold_build3_loc (input_location, COMPONENT_REF,
+			   TREE_TYPE (comp), se.expr, comp, NULL_TREE);
+  else
+    caf = gfc_conv_descriptor_token (se.expr);
+  return gfc_build_addr_expr (NULL_TREE, caf);
+}
+
+
 /* This is the seed for an eventual trans-class.c
 
    The following parameters should not be used directly since they might
@@ -101,6 +158,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
 #define VTABLE_DEF_INIT_FIELD 3
 #define VTABLE_COPY_FIELD 4
 #define VTABLE_FINAL_FIELD 5
+#define VTABLE_DEALLOCATE_FIELD 6
 
 
 tree
@@ -141,7 +199,7 @@ gfc_class_vptr_get (tree decl)
   tree vptr;
   /* For class arrays decl may be a temporary descriptor handle, the vptr is
      then available through the saved descriptor.  */
-  if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+  if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
       && GFC_DECL_SAVED_DESCRIPTOR (decl))
     decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
   if (POINTER_TYPE_P (TREE_TYPE (decl)))
@@ -160,7 +218,7 @@ gfc_class_len_get (tree decl)
   tree len;
   /* For class arrays decl may be a temporary descriptor handle, the len is
      then available through the saved descriptor.  */
-  if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+  if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
       && GFC_DECL_SAVED_DESCRIPTOR (decl))
     decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
   if (POINTER_TYPE_P (TREE_TYPE (decl)))
@@ -182,7 +240,7 @@ gfc_class_len_or_zero_get (tree decl)
   tree len;
   /* For class arrays decl may be a temporary descriptor handle, the vptr is
      then available through the saved descriptor.  */
-  if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+  if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
       && GFC_DECL_SAVED_DESCRIPTOR (decl))
     decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
   if (POINTER_TYPE_P (TREE_TYPE (decl)))
@@ -243,6 +301,7 @@ VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
+VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
 
 
 /* The size field is returned as an array index type.  Therefore treat
@@ -293,15 +352,14 @@ 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;
   array_ref = NULL;
   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)
 	array_ref = ref;
 
       if (ref->type == REF_COMPONENT
@@ -310,11 +368,10 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
 	  /* Component to the right of a part reference with nonzero rank
 	     must not have the ALLOCATABLE attribute.  If attempts are
 	     made to reference such a component reference, an error results
-	     followed by anICE.  */
-	  if (array_ref
-	      && CLASS_DATA (ref->u.c.component)->attr.allocatable)
+	     followed by an ICE.  */
+	  if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
 	    return NULL;
-	class_ref = ref;
+	  class_ref = ref;
 	}
 
       if (ref->next == NULL)
@@ -328,7 +385,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;
@@ -342,7 +399,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;
@@ -430,9 +487,16 @@ gfc_get_vptr_from_expr (tree expr)
 	  else
 	    type = NULL_TREE;
 	}
-      if (TREE_CODE (tmp) == VAR_DECL)
+      if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
 	break;
     }
+
+  if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+  if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+    return gfc_class_vptr_get (tmp);
+
   return NULL_TREE;
 }
 
@@ -511,7 +575,14 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
   if (optional)
     cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
 
-  if (parmse->ss && parmse->ss->info->useflags)
+  if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+    {
+      /* If there is a ready made pointer to a derived type, use it
+	 rather than evaluating the expression again.  */
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+    }
+  else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
     {
       /* For an array reference in an elemental procedure call we need
 	 to retain the ss to provide the scalarized array reference.  */
@@ -522,7 +593,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 			  cond_optional, tmp,
 			  fold_convert (TREE_TYPE (tmp), null_pointer_node));
       gfc_add_modify (&parmse->pre, ctree, tmp);
-
     }
   else
     {
@@ -792,7 +862,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
     {
       ctree = gfc_class_len_get (var);
       /* When the actual arg is a char array, then set the _len component of the
-       unlimited polymorphic entity, too.  */
+	 unlimited polymorphic entity to the length of the string.  */
       if (e->ts.type == BT_CHARACTER)
 	{
 	  /* Start with parmse->string_length because this seems to be set to a
@@ -964,8 +1034,13 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     {
       tmp = e->symtree->n.sym->backend_decl;
+
+      if (TREE_CODE (tmp) == FUNCTION_DECL)
+	tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
+
       if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
 	tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+
       slen = integer_zero_node;
     }
   else
@@ -1016,6 +1091,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 	tmp = integer_zero_node;
       gfc_add_modify (&parmse->pre, ctree,
 		      fold_convert (TREE_TYPE (ctree), tmp));
+
+      /* Return the len component, except in the case of scalarized array
+	references, where the dynamic type cannot change.  */
+      if (!elemental && full_array && copyback)
+	  gfc_add_modify (&parmse->post, tmp,
+			  fold_convert (TREE_TYPE (tmp), ctree));
     }
 
   if (optional)
@@ -1166,6 +1247,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
       stmtblock_t body;
       stmtblock_t ifbody;
       gfc_loopinfo loop;
+      tree orig_nelems = nelems; /* Needed for bounds check.  */
 
       gfc_init_block (&body);
       tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1193,6 +1275,31 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
 	}
       vec_safe_push (args, to_ref);
 
+      /* Add bounds check.  */
+      if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
+	{
+	  char *msg;
+	  const char *name = "<<unknown>>";
+	  tree from_len;
+
+	  if (DECL_P (to))
+	    name = (const char *)(DECL_NAME (to)->identifier.id.str);
+
+	  from_len = gfc_conv_descriptor_size (from_data, 1);
+	  tmp = fold_build2_loc (input_location, NE_EXPR,
+				  boolean_type_node, from_len, orig_nelems);
+	  msg = xasprintf ("Array bound mismatch for dimension %d "
+			   "of array '%s' (%%ld/%%ld)",
+			   1, name);
+
+	  gfc_trans_runtime_check (true, false, tmp, &body,
+				   &gfc_current_locus, msg,
+			     fold_convert (long_integer_type_node, orig_nelems),
+			       fold_convert (long_integer_type_node, from_len));
+
+	  free (msg);
+	}
+
       tmp = build_call_vec (fcn_type, fcn, args);
 
       /* Build the body of the loop.  */
@@ -1357,8 +1464,13 @@ gfc_trans_class_init_assign (gfc_code *code)
   rhs->rank = 0;
 
   if (code->expr1->ts.type == BT_CLASS
-	&& CLASS_DATA (code->expr1)->attr.dimension)
-    tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+      && CLASS_DATA (code->expr1)->attr.dimension)
+    {
+      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);
@@ -1403,114 +1515,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  */
 
 
@@ -1813,69 +1817,54 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
 {
   tree caf_decl;
   bool found = false;
-  gfc_ref *ref, *comp_ref = NULL;
+  gfc_ref *ref;
 
   gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
 
   /* Not-implemented diagnostic.  */
+  if (expr->symtree->n.sym->ts.type == BT_CLASS
+      && UNLIMITED_POLY (expr->symtree->n.sym)
+      && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+    gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
+	       "%L is not supported", &expr->where);
+
   for (ref = expr->ref; ref; ref = ref->next)
     if (ref->type == REF_COMPONENT)
       {
-        comp_ref = ref;
-	if ((ref->u.c.component->ts.type == BT_CLASS
-	     && !CLASS_DATA (ref->u.c.component)->attr.codimension
-	     && (CLASS_DATA (ref->u.c.component)->attr.pointer
-		 || CLASS_DATA (ref->u.c.component)->attr.allocatable))
-	    || (ref->u.c.component->ts.type != BT_CLASS
-		&& !ref->u.c.component->attr.codimension
-		&& (ref->u.c.component->attr.pointer
-		    || ref->u.c.component->attr.allocatable)))
-	  gfc_error ("Sorry, coindexed access to a pointer or allocatable "
-		     "component of the coindexed coarray at %L is not yet "
-		     "supported", &expr->where);
+	if (ref->u.c.component->ts.type == BT_CLASS
+	    && UNLIMITED_POLY (ref->u.c.component)
+	    && CLASS_DATA (ref->u.c.component)->attr.codimension)
+	  gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
+		     "component at %L is not supported", &expr->where);
       }
-  if ((!comp_ref
-       && ((expr->symtree->n.sym->ts.type == BT_CLASS
-	    && CLASS_DATA (expr->symtree->n.sym)->attr.alloc_comp)
-	   || (expr->symtree->n.sym->ts.type == BT_DERIVED
-	       && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)))
-      || (comp_ref
-	  && ((comp_ref->u.c.component->ts.type == BT_CLASS
-	       && CLASS_DATA (comp_ref->u.c.component)->attr.alloc_comp)
-	      || (comp_ref->u.c.component->ts.type == BT_DERIVED
-		  && comp_ref->u.c.component->ts.u.derived->attr.alloc_comp))))
-    gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
-	       "not yet supported", &expr->where);
-
-  if (expr->rank)
-    {
-      /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
-	 general not possible as the required stride multiplier might be not
-	 a multiple of c_sizeof(b). In case of noncoindexed access, the
-	 scalarizer often takes care of it - for coarrays, it always fails.  */
-      for (ref = expr->ref; ref; ref = ref->next)
-        if (ref->type == REF_COMPONENT
-	    && ((ref->u.c.component->ts.type == BT_CLASS
-		 && CLASS_DATA (ref->u.c.component)->attr.codimension)
-	        || (ref->u.c.component->ts.type != BT_CLASS
-		    && ref->u.c.component->attr.codimension)))
-	  break;
-      if (ref == NULL)
-	ref = expr->ref;
-      for ( ; ref; ref = ref->next)
-	if (ref->type == REF_ARRAY && ref->u.ar.dimen)
-	  break;
-      for ( ; ref; ref = ref->next)
-	if (ref->type == REF_COMPONENT)
-	  gfc_error ("Sorry, coindexed access at %L to a scalar component "
-		     "with an array partref is not yet supported",
-		     &expr->where);
-    }
 
-  caf_decl = expr->symtree->n.sym->backend_decl;
-  gcc_assert (caf_decl);
+  /* Make sure the backend_decl is present before accessing it.  */
+  caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
+      ? gfc_get_symbol_decl (expr->symtree->n.sym)
+      : expr->symtree->n.sym->backend_decl;
+
   if (expr->symtree->n.sym->ts.type == BT_CLASS)
-    caf_decl = gfc_class_data_get (caf_decl);
+    {
+      if (expr->ref && expr->ref->type == REF_ARRAY)
+	{
+	  caf_decl = gfc_class_data_get (caf_decl);
+	  if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+	    return caf_decl;
+	}
+      for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_COMPONENT
+	      && strcmp (ref->u.c.component->name, "_data") != 0)
+	    {
+	      caf_decl = gfc_class_data_get (caf_decl);
+	      if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+		return caf_decl;
+	      break;
+	    }
+	  else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
+	    break;
+	}
+    }
   if (expr->symtree->n.sym->attr.codimension)
     return caf_decl;
 
@@ -1893,7 +1882,14 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
 				    TREE_TYPE (comp->backend_decl), caf_decl,
 				    comp->backend_decl, NULL_TREE);
 	if (comp->ts.type == BT_CLASS)
-	  caf_decl = gfc_class_data_get (caf_decl);
+	  {
+	    caf_decl = gfc_class_data_get (caf_decl);
+	    if (CLASS_DATA (comp)->attr.codimension)
+	      {
+		found = true;
+		break;
+	      }
+	  }
 	if (comp->attr.codimension)
 	  {
 	    found = true;
@@ -1908,8 +1904,8 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
 /* Obtain the Coarray token - and optionally also the offset.  */
 
 void
-gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr,
-			  gfc_expr *expr)
+gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
+			  tree se_expr, gfc_expr *expr)
 {
   tree tmp;
 
@@ -1964,7 +1960,47 @@ gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr
   *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
 			     *offset, fold_convert (gfc_array_index_type, tmp));
 
-  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
+  if (expr->symtree->n.sym->ts.type == BT_DERIVED
+      && expr->symtree->n.sym->attr.codimension
+      && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+    {
+      gfc_expr *base_expr = gfc_copy_expr (expr);
+      gfc_ref *ref = base_expr->ref;
+      gfc_se base_se;
+
+      // Iterate through the refs until the last one.
+      while (ref->next)
+	  ref = ref->next;
+
+      if (ref->type == REF_ARRAY
+	  && ref->u.ar.type != AR_FULL)
+	{
+	  const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
+	  int i;
+	  for (i = 0; i < ranksum; ++i)
+	    {
+	      ref->u.ar.start[i] = NULL;
+	      ref->u.ar.end[i] = NULL;
+	    }
+	  ref->u.ar.type = AR_FULL;
+	}
+      gfc_init_se (&base_se, NULL);
+      if (gfc_caf_attr (base_expr).dimension)
+	{
+	  gfc_conv_expr_descriptor (&base_se, base_expr);
+	  tmp = gfc_conv_descriptor_data_get (base_se.expr);
+	}
+      else
+	{
+	  gfc_conv_expr (&base_se, base_expr);
+	  tmp = base_se.expr;
+	}
+
+      gfc_free_expr (base_expr);
+      gfc_add_block_to_block (&se->pre, &base_se.pre);
+      gfc_add_block_to_block (&se->post, &base_se.post);
+    }
+  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
     tmp = gfc_conv_descriptor_data_get (caf_decl);
   else
    {
@@ -1995,6 +2031,12 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
       break;
   gcc_assert (ref != NULL);
 
+  if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
+    {
+      return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
+				  integer_zero_node);
+    }
+
   img_idx = integer_zero_node;
   extent = integer_one_node;
   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
@@ -2102,6 +2144,7 @@ flatten_array_ctors_without_strlen (gfc_expr* e)
 	}
 
       /* Otherwise, fall through to handle constructor elements.  */
+      gcc_fallthrough ();
     case EXPR_STRUCTURE:
       for (c = gfc_constructor_first (e->value.constructor);
 	   c; c = gfc_constructor_next (c))
@@ -2127,9 +2170,7 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
 
   gfc_init_se (&se, NULL);
 
-  if (!cl->length
-	&& cl->backend_decl
-	&& TREE_CODE (cl->backend_decl) == VAR_DECL)
+  if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
     return;
 
   /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
@@ -2236,7 +2277,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
 	msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
 			 "is less than one", name);
       else
-	msg = xasprintf ("Substring out of bounds: lower bound (%%ld)"
+	msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
 			 "is less than one");
       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
 			       fold_convert (long_integer_type_node,
@@ -2319,7 +2360,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
      On the other hand, if the context is a UNION or a MAP (a
      RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL.  */
 
-  if (context != TREE_TYPE (decl) 
+  if (context != TREE_TYPE (decl)
       && !(   TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
            || TREE_CODE (context) == UNION_TYPE))         /* Field is map */
     {
@@ -2503,8 +2544,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       if (se_expr)
 	se->expr = se_expr;
 
-      /* Procedure actual arguments.  */
-      else if (sym->attr.flavor == FL_PROCEDURE
+      /* Procedure actual arguments.  Look out for temporary variables
+	 with the same attributes as function values.  */
+      else if (!sym->attr.temporary
+	       && sym->attr.flavor == FL_PROCEDURE
 	       && se->expr != current_function_decl)
 	{
 	  if (!sym->attr.dummy && !sym->attr.proc_pointer)
@@ -2826,9 +2869,9 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
     return 0;
 
   m = wrhs.to_shwi ();
-  /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
-     of the asymmetric range of the integer type.  */
-  n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
+  /* Use the wide_int's routine to reliably get the absolute value on all
+     platforms.  Then convert it to a HOST_WIDE_INT like above.  */
+  n = wi::abs (wrhs).to_shwi ();
 
   type = TREE_TYPE (lhs);
   sgn = tree_int_cst_sgn (rhs);
@@ -3631,7 +3674,7 @@ conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
   gfc_ref *ref;
   tree var;
 
-  if (TREE_CODE (base_object) != VAR_DECL)
+  if (!VAR_P (base_object))
     {
       var = gfc_create_var (TREE_TYPE (base_object), NULL);
       gfc_add_modify (&se->pre, var, base_object);
@@ -3902,6 +3945,10 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   if (sym->attr.flavor == FL_PROCEDURE)
     value = se->expr;
 
+  /* If the argument is a pass-by-value scalar, use the value as is.  */
+  else if (!sym->attr.dimension && sym->attr.value)
+    value = se->expr;
+
   /* If the argument is either a string or a pointer to a string,
      convert it to a boundless character type.  */
   else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
@@ -4074,6 +4121,16 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
       new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
       break;
 
+    case GFC_ISYM_LEN_TRIM:
+      new_expr = gfc_copy_expr (arg1);
+      gfc_apply_interface_mapping_to_expr (mapping, new_expr);
+
+      if (!new_expr)
+	return false;
+
+      gfc_replace_expr (arg1, new_expr);
+      return true;
+
     case GFC_ISYM_SIZE:
       if (!sym->as || sym->as->rank == 0)
 	return false;
@@ -4633,10 +4690,11 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
     {
       gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
 
-      if ((proc_ifc->result->ts.type == BT_CLASS
-	   && proc_ifc->result->ts.u.derived->attr.is_class
-	   && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
-	  || proc_ifc->result->attr.pointer)
+      if (proc_ifc->result != NULL
+	  && ((proc_ifc->result->ts.type == BT_CLASS
+	       && proc_ifc->result->ts.u.derived->attr.is_class
+	       && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
+	      || proc_ifc->result->attr.pointer))
 	return true;
       else
 	return false;
@@ -5165,7 +5223,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			ptr = gfc_class_data_get (ptr);
 
 		      tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
-							       true, e, e->ts);
+							       NULL_TREE, true,
+							       e, e->ts);
 		      gfc_add_expr_to_block (&block, tmp);
 		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
 					     void_type_node, ptr,
@@ -5274,7 +5333,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
 						    NULL_TREE, NULL_TREE,
 						    NULL_TREE, true, e,
-						    false);
+						    GFC_CAF_COARRAY_NOCOARRAY);
 		  gfc_add_expr_to_block (&block, tmp);
 		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
 					 void_type_node, ptr,
@@ -5397,7 +5456,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		{
 		  tmp = build_fold_indirect_ref_loc (input_location,
 						     parmse.expr);
-		  tmp = gfc_trans_dealloc_allocated (tmp, false, e);
+		  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+		    tmp = gfc_conv_descriptor_data_get (tmp);
+		  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+						    NULL_TREE, NULL_TREE, true,
+						    e,
+						    GFC_CAF_COARRAY_NOCOARRAY);
 		  if (fsym->attr.optional
 		      && e->expr_type == EXPR_VARIABLE
 		      && e->symtree->n.sym->attr.optional)
@@ -5509,7 +5573,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    {
 	      tree local_tmp;
 	      local_tmp = gfc_evaluate_now (tmp, &se->pre);
-	      local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
+	      local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
+					       parm_rank, 0);
 	      gfc_add_expr_to_block (&se->post, local_tmp);
 	    }
 
@@ -5525,7 +5590,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	  tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
 
-	  gfc_add_expr_to_block (&se->post, tmp);
+	  gfc_prepend_expr_to_block (&post, tmp);
         }
 
       /* Add argument checking of passing an unallocated/NULL actual to
@@ -5637,8 +5702,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  else
 	    {
 	      tmp = parmse.string_length;
-	      if (TREE_CODE (tmp) != VAR_DECL
-		  && TREE_CODE (tmp) != COMPONENT_REF)
+	      if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
 		tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
 	      parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
 	    }
@@ -5767,8 +5831,10 @@ 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;
+    ts = sym->ts;
 
   if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
     se->string_length = build_int_cst (gfc_charlen_type_node, 1);
@@ -5837,7 +5903,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.
@@ -5941,6 +6007,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  type = gfc_get_character_type (ts.kind, ts.u.cl);
 	  type = build_pointer_type (type);
 
+	  /* Emit a DECL_EXPR for the VLA type.  */
+	  tmp = TREE_TYPE (type);
+	  if (TYPE_SIZE (tmp)
+	      && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
+	    {
+	      tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
+	      DECL_ARTIFICIAL (tmp) = 1;
+	      DECL_IGNORED_P (tmp) = 1;
+	      tmp = fold_build1_loc (input_location, DECL_EXPR,
+				     TREE_TYPE (tmp), tmp);
+	      gfc_add_expr_to_block (&se->pre, tmp);
+	    }
+
 	  /* Return an address to a char[0:len-1]* temporary for
 	     character pointers.  */
 	  if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
@@ -5979,7 +6058,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (ts.type == BT_CHARACTER && ts.deferred)
 	{
 	  tmp = len;
-	  if (TREE_CODE (tmp) != VAR_DECL)
+	  if (!VAR_P (tmp))
 	    tmp = gfc_evaluate_now (len, &se->pre);
 	  TREE_STATIC (tmp) = 1;
 	  gfc_add_modify (&se->pre, tmp,
@@ -6123,19 +6202,41 @@ 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)
     {
       gfc_add_block_to_block (&se->pre, &post);
 
       /* Transformational functions of derived types with allocatable
-         components must have the result allocatable components copied.  */
+	 components must have the result allocatable components copied when the
+	 argument is actually given.  */
       arg = expr->value.function.actual;
       if (result && arg && expr->rank
-	    && expr->value.function.isym
-	    && expr->value.function.isym->transformational
-	    && arg->expr->ts.type == BT_DERIVED
-	    && arg->expr->ts.u.derived->attr.alloc_comp)
+	  && expr->value.function.isym
+	  && expr->value.function.isym->transformational
+	  && arg->expr
+	  && arg->expr->ts.type == BT_DERIVED
+	  && arg->expr->ts.u.derived->attr.alloc_comp)
 	{
 	  tree tmp2;
 	  /* Copy the allocatable components.  We have to use a
@@ -6143,7 +6244,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	     from being corrupted.  */
 	  tmp2 = gfc_evaluate_now (result, &se->pre);
 	  tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
-				     result, tmp2, expr->rank);
+				     result, tmp2, expr->rank, 0);
 	  gfc_add_expr_to_block (&se->pre, tmp);
 	  tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
 				           expr->rank);
@@ -6153,7 +6254,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  tmp = gfc_conv_descriptor_data_get (tmp2);
 	  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
 					    NULL_TREE, NULL_TREE, true,
-					    NULL, false);
+					    NULL, GFC_CAF_COARRAY_NOCOARRAY);
 	  gfc_add_expr_to_block (&se->pre, tmp);
 	}
     }
@@ -6356,33 +6457,19 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
       return;
     }
 
+  /* The string copy algorithm below generates code like
+
+     if (dlen > 0) {
+         memmove (dest, src, min(dlen, slen));
+         if (slen < dlen)
+             memset(&dest[slen], ' ', dlen - slen);
+     }
+  */
+
   /* Do nothing if the destination length is zero.  */
   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
 			  build_int_cst (size_type_node, 0));
 
-  /* The following code was previously in _gfortran_copy_string:
-
-       // The two strings may overlap so we use memmove.
-       void
-       copy_string (GFC_INTEGER_4 destlen, char * dest,
-                    GFC_INTEGER_4 srclen, const char * src)
-       {
-         if (srclen >= destlen)
-           {
-             // This will truncate if too long.
-             memmove (dest, src, destlen);
-           }
-         else
-           {
-             memmove (dest, src, srclen);
-             // Pad with spaces.
-             memset (&dest[srclen], ' ', destlen - srclen);
-           }
-       }
-
-     We're now doing it here for better optimization, but the logic
-     is the same.  */
-
   /* For non-default character kinds, we have to multiply the string
      length by the base type size.  */
   chartype = gfc_get_char_type (dkind);
@@ -6405,31 +6492,42 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
   else
     src = gfc_build_addr_expr (pvoid_type_node, src);
 
-  /* Truncate string if source is too long.  */
-  cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
-			   dlen);
+  /* First do the memmove. */
+  tmp2 = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (dlen), dlen,
+			  slen);
   tmp2 = build_call_expr_loc (input_location,
 			      builtin_decl_explicit (BUILT_IN_MEMMOVE),
-			      3, dest, src, dlen);
+			      3, dest, src, tmp2);
+  stmtblock_t tmpblock2;
+  gfc_init_block (&tmpblock2);
+  gfc_add_expr_to_block (&tmpblock2, tmp2);
 
-  /* Else copy and pad with spaces.  */
-  tmp3 = build_call_expr_loc (input_location,
-			      builtin_decl_explicit (BUILT_IN_MEMMOVE),
-			      3, dest, src, slen);
+  /* If the destination is longer, fill the end with spaces.  */
+  cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, slen,
+			   dlen);
+
+  /* Wstringop-overflow appears at -O3 even though this warning is not
+     explicitly available in fortran nor can it be switched off. If the
+     source length is a constant, its negative appears as a very large
+     postive number and triggers the warning in BUILTIN_MEMSET. Fixing
+     the result of the MINUS_EXPR suppresses this spurious warning.  */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			 TREE_TYPE(dlen), dlen, slen);
+  if (slength && TREE_CONSTANT (slength))
+    tmp = gfc_evaluate_now (tmp, block);
 
   tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
-  tmp4 = fill_with_spaces (tmp4, chartype,
-			   fold_build2_loc (input_location, MINUS_EXPR,
-					    TREE_TYPE(dlen), dlen, slen));
+  tmp4 = fill_with_spaces (tmp4, chartype, tmp);
 
   gfc_init_block (&tempblock);
-  gfc_add_expr_to_block (&tempblock, tmp3);
   gfc_add_expr_to_block (&tempblock, tmp4);
   tmp3 = gfc_finish_block (&tempblock);
 
   /* The whole copy_string function is there.  */
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
-			 tmp2, tmp3);
+			 tmp3, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&tmpblock2, tmp);
+  tmp = gfc_finish_block (&tmpblock2);
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
 			 build_empty_stmt (input_location));
   gfc_add_expr_to_block (block, tmp);
@@ -6868,16 +6966,18 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
   /* Deal with arrays of derived types with allocatable components.  */
   if (gfc_bt_struct (cm->ts.type)
 	&& cm->ts.u.derived->attr.alloc_comp)
+    // TODO: Fix caf_mode
     tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
 			       se.expr, dest,
-			       cm->as->rank);
+			       cm->as->rank, 0);
   else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
 	   && CLASS_DATA(cm)->attr.allocatable)
     {
       if (cm->ts.u.derived->attr.alloc_comp)
+	// TODO: Fix caf_mode
 	tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
 				   se.expr, dest,
-				   expr->rank);
+				   expr->rank, 0);
       else
 	{
 	  tmp = TREE_TYPE (dest);
@@ -7257,7 +7357,30 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 			fold_convert (TREE_TYPE (tmp), se.expr));
       gfc_add_block_to_block (&block, &se.post);
     }
-  else if (gfc_bt_struct (expr->ts.type) && expr->ts.f90_type != BT_VOID)
+  else if (expr->ts.type == BT_UNION)
+    {
+      tree tmp;
+      gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
+      /* We mark that the entire union should be initialized with a contrived
+         EXPR_NULL expression at the beginning.  */
+      if (c != NULL && c->n.component == NULL
+	  && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
+        {
+          tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+		            dest, build_constructor (TREE_TYPE (dest), NULL));
+	  gfc_add_expr_to_block (&block, tmp);
+          c = gfc_constructor_next (c);
+        }
+      /* The following constructor expression, if any, represents a specific
+         map intializer, as given by the user.  */
+      if (c != NULL && c->expr != NULL)
+        {
+          gcc_assert (expr->expr_type == EXPR_STRUCTURE);
+	  tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
+	  gfc_add_expr_to_block (&block, tmp);
+        }
+    }
+  else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
     {
       if (expr->expr_type != EXPR_STRUCTURE)
 	{
@@ -7280,8 +7403,9 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 	  if (cm->ts.u.derived->attr.alloc_comp
 	      && expr->expr_type != EXPR_NULL)
 	    {
+	      // TODO: Fix caf_mode
 	      tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
-					 dest, expr->rank);
+					 dest, expr->rank, 0);
 	      gfc_add_expr_to_block (&block, tmp);
 	      if (dealloc != NULL_TREE)
 		gfc_add_expr_to_block (&block, dealloc);
@@ -7347,13 +7471,14 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 /* Assign a derived type constructor to a variable.  */
 
 tree
-gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
+gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
 {
   gfc_constructor *c;
   gfc_component *cm;
   stmtblock_t block;
   tree field;
   tree tmp;
+  gfc_se se;
 
   gfc_start_block (&block);
   cm = expr->ts.u.derived->components;
@@ -7362,7 +7487,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
       && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
           || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
     {
-      gfc_se se, lse;
+      gfc_se lse;
 
       gfc_init_se (&se, NULL);
       gfc_init_se (&lse, NULL);
@@ -7374,6 +7499,9 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
       return gfc_finish_block (&block);
     }
 
+  if (coarray)
+    gfc_init_se (&se, NULL);
+
   for (c = gfc_constructor_first (expr->value.constructor);
        c; c = gfc_constructor_next (c), cm = cm->next)
     {
@@ -7381,6 +7509,65 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
       if (!c->expr && !cm->attr.allocatable)
 	continue;
 
+      /* Register the component with the caf-lib before it is initialized.
+	 Register only allocatable components, that are not coarray'ed
+	 components (%comp[*]).  Only register when the constructor is not the
+	 null-expression.  */
+      if (coarray && !cm->attr.codimension
+	  && (cm->attr.allocatable || cm->attr.pointer)
+	  && (!c->expr || c->expr->expr_type == EXPR_NULL))
+	{
+	  tree token, desc, size;
+	  bool is_array = cm->ts.type == BT_CLASS
+	      ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
+
+	  field = cm->backend_decl;
+	  field = fold_build3_loc (input_location, COMPONENT_REF,
+				   TREE_TYPE (field), dest, field, NULL_TREE);
+	  if (cm->ts.type == BT_CLASS)
+	    field = gfc_class_data_get (field);
+
+	  token = is_array ? gfc_conv_descriptor_token (field)
+			   : fold_build3_loc (input_location, COMPONENT_REF,
+					      TREE_TYPE (cm->caf_token), dest,
+					      cm->caf_token, NULL_TREE);
+
+	  if (is_array)
+	    {
+	      /* The _caf_register routine looks at the rank of the array
+		 descriptor to decide whether the data registered is an array
+		 or not.  */
+	      int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
+						 : cm->as->rank;
+	      /* When the rank is not known just set a positive rank, which
+		 suffices to recognize the data as array.  */
+	      if (rank < 0)
+		rank = 1;
+	      size = integer_zero_node;
+	      desc = field;
+	      gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
+			      build_int_cst (gfc_array_index_type, rank));
+	    }
+	  else
+	    {
+	      desc = gfc_conv_scalar_to_descriptor (&se, field,
+						    cm->ts.type == BT_CLASS
+						    ? CLASS_DATA (cm)->attr
+						    : cm->attr);
+	      size = TYPE_SIZE_UNIT (TREE_TYPE (field));
+	    }
+	  gfc_add_block_to_block (&block, &se.pre);
+	  tmp =  build_call_expr_loc (input_location, gfor_fndecl_caf_register,
+				      7, size, build_int_cst (
+					integer_type_node,
+					GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
+				      gfc_build_addr_expr (pvoid_type_node,
+							   token),
+				      gfc_build_addr_expr (NULL_TREE, desc),
+				      null_pointer_node, null_pointer_node,
+				      integer_zero_node);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
       field = cm->backend_decl;
       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 			     dest, field, NULL_TREE);
@@ -7399,6 +7586,43 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
   return gfc_finish_block (&block);
 }
 
+void
+gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
+                            gfc_component *un, gfc_expr *init)
+{
+  gfc_constructor *ctor;
+
+  if (un->ts.type != BT_UNION || un == NULL || init == NULL)
+    return;
+
+  ctor = gfc_constructor_first (init->value.constructor);
+
+  if (ctor == NULL || ctor->expr == NULL)
+    return;
+
+  gcc_assert (init->expr_type == EXPR_STRUCTURE);
+
+  /* If we have an 'initialize all' constructor, do it first.  */
+  if (ctor->expr->expr_type == EXPR_NULL)
+    {
+      tree union_type = TREE_TYPE (un->backend_decl);
+      tree val = build_constructor (union_type, NULL);
+      CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
+      ctor = gfc_constructor_next (ctor);
+    }
+
+  /* Add the map initializer on top.  */
+  if (ctor != NULL && ctor->expr != NULL)
+    {
+      gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
+      tree val = gfc_conv_initializer (ctor->expr, &un->ts,
+                                       TREE_TYPE (un->backend_decl),
+                                       un->attr.dimension, un->attr.pointer,
+                                       un->attr.proc_pointer);
+      CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
+    }
+}
+
 /* Build an expression for a constructor. If init is nonzero then
    this is part of a static variable initializer.  */
 
@@ -7422,29 +7646,12 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       se->expr = gfc_create_var (type, expr->ts.u.derived->name);
       /* The symtree in expr is NULL, if the code to generate is for
 	 initializing the static members only.  */
-      tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL);
+      tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
+					se->want_coarray);
       gfc_add_expr_to_block (&se->pre, tmp);
       return;
     }
 
-  /* Though unions appear to have multiple map components, they must only
-     have a single initializer since each map overlaps. TODO: squash map
-     constructors?  */
-  if (expr->ts.type == BT_UNION)
-    {
-      c = gfc_constructor_first (expr->value.constructor);
-      cm = c->n.component;
-      val = gfc_conv_initializer (c->expr, &expr->ts,
-                                  TREE_TYPE (cm->backend_decl),
-                                  cm->attr.dimension, cm->attr.pointer,
-                                  cm->attr.proc_pointer);
-      val = unshare_expr_without_location (val);
-
-      /* Append it to the constructor list.  */
-      CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
-      goto finish;
-    }
-
   cm = expr->ts.u.derived->components;
 
   for (c = gfc_constructor_first (expr->value.constructor);
@@ -7479,6 +7686,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 	CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
 				fold_convert (TREE_TYPE (cm->backend_decl),
 					      integer_zero_node));
+      else if (cm->ts.type == BT_UNION)
+        gfc_conv_union_initializer (v, cm, c->expr);
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -7491,7 +7700,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
 	}
     }
-finish:
+
   se->expr = build_constructor (type, v);
   if (init)
     TREE_CONSTANT (se->expr) = 1;
@@ -7745,6 +7954,247 @@ 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;
+}
+
+
+/* Assign tokens for pointer components.  */
+
+static void
+trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
+			gfc_expr *expr2)
+{
+  symbol_attribute lhs_attr, rhs_attr;
+  tree tmp, lhs_tok, rhs_tok;
+  /* Flag to indicated component refs on the rhs.  */
+  bool rhs_cr;
+
+  lhs_attr = gfc_caf_attr (expr1);
+  if (expr2->expr_type != EXPR_NULL)
+    {
+      rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
+      if (lhs_attr.codimension && rhs_attr.codimension)
+	{
+	  lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
+	  lhs_tok = build_fold_indirect_ref (lhs_tok);
+
+	  if (rhs_cr)
+	    rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
+	  else
+	    {
+	      tree caf_decl;
+	      caf_decl = gfc_get_tree_for_caf_expr (expr2);
+	      gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
+					NULL_TREE, NULL);
+	    }
+	  tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			    lhs_tok,
+			    fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
+	  gfc_prepend_expr_to_block (&lse->post, tmp);
+	}
+    }
+  else if (lhs_attr.codimension)
+    {
+      lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
+      lhs_tok = build_fold_indirect_ref (lhs_tok);
+      tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			lhs_tok, null_pointer_node);
+      gfc_prepend_expr_to_block (&lse->post, tmp);
+    }
+}
+
+/* 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)
 {
@@ -7757,20 +8207,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);
@@ -7779,7 +8231,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
@@ -7796,6 +8248,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,
@@ -7809,27 +8268,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.  */
@@ -7856,12 +8294,14 @@ 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));
 
+      /* Also set the tokens for pointer components in derived typed
+	 coarrays.  */
+      if (flag_coarray == GFC_FCOARRAY_LIB)
+	trans_caf_token_assign (&lse, &rse, expr1, expr2);
+
       gfc_add_block_to_block (&block, &rse.post);
       gfc_add_block_to_block (&block, &lse.post);
     }
@@ -7869,6 +8309,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;
 
@@ -7885,9 +8326,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;
@@ -7913,16 +8351,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);
 		}
@@ -7939,17 +8376,21 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 					       bound, bound, 0,
 					       GFC_ARRAY_POINTER_CONT, false);
 	      tmp = gfc_create_var (tmp, "ptrtemp");
-	      lse.descriptor_only = 0;
-	      lse.expr = tmp;
-	      lse.direct_byref = 1;
-	      gfc_conv_expr_descriptor (&lse, expr2);
-	      strlen_rhs = lse.string_length;
+	      rse.descriptor_only = 0;
+	      rse.expr = tmp;
+	      rse.direct_byref = 1;
+	      gfc_conv_expr_descriptor (&rse, expr2);
+	      strlen_rhs = rse.string_length;
 	      rse.expr = tmp;
 	    }
 	  else
 	    {
 	      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)
@@ -7968,12 +8409,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)
 	{
@@ -7987,16 +8438,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);
@@ -8015,9 +8465,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);
@@ -8245,7 +8692,7 @@ gfc_conv_string_parameter (gfc_se * se)
 
 tree
 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
-			 bool deep_copy, bool dealloc)
+			 bool deep_copy, bool dealloc, bool in_coarray)
 {
   stmtblock_t block;
   tree tmp;
@@ -8267,7 +8714,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;
@@ -8323,7 +8769,10 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	 same as the lhs.  */
       if (deep_copy)
 	{
-	  tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
+	  int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+				       | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
+	  tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
+				     caf_mode);
 	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
 			  tmp);
 	  gfc_add_expr_to_block (&block, tmp);
@@ -9050,7 +9499,25 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
   size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
 				   size_in_bytes, size_one_node);
 
-  if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
+  if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
+    {
+      tree caf_decl, token;
+      gfc_se caf_se;
+      symbol_attribute attr;
+
+      gfc_clear_attr (&attr);
+      gfc_init_se (&caf_se, NULL);
+
+      caf_decl = gfc_get_tree_for_caf_expr (expr1);
+      gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
+				NULL);
+      gfc_add_block_to_block (block, &caf_se.pre);
+      gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
+				gfc_build_addr_expr (NULL_TREE, token),
+				NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
+				expr1, 1);
+    }
+  else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
     {
       tmp = build_call_expr_loc (input_location,
 				 builtin_decl_explicit (BUILT_IN_CALLOC),
@@ -9205,14 +9672,122 @@ 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,
+			bool class_realloc)
+{
+  tree tmp, fcn, stdcopy, to_len, from_len, vptr;
+  vec<tree, va_gc> *args = NULL;
+
+  vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
+					 &from_len);
+
+  /* Generate allocation of the lhs.  */
+  if (class_realloc)
+    {
+      stmtblock_t alloc;
+      tree class_han;
+
+      tmp = gfc_vptr_size_get (vptr);
+      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+	  ? gfc_class_data_get (lse->expr) : lse->expr;
+      gfc_init_block (&alloc);
+      gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
+      tmp = fold_build2_loc (input_location, EQ_EXPR,
+			     boolean_type_node, class_han,
+			     build_int_cst (prvoid_type_node, 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     gfc_unlikely (tmp,
+					   PRED_FORTRAN_FAIL_ALLOC),
+			     gfc_finish_block (&alloc),
+			     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&lse->pre, tmp);
+    }
+
+  fcn = gfc_vptr_copy_get (vptr);
+
+  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;
@@ -9227,7 +9802,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   bool scalar_to_array;
   tree string_length;
   int n;
-  bool maybe_workshare = false;
+  bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
+  symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
+  bool is_poly_assign;
 
   /* Assignment of the form lhs = rhs.  */
   gfc_start_block (&block);
@@ -9248,6 +9825,27 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  || gfc_is_alloc_class_scalar_function (expr2)))
     expr2->must_finalize = 1;
 
+  /* Checking whether a class assignment is desired is quite complicated and
+     needed at two locations, so do it once only before the information is
+     needed.  */
+  lhs_attr = gfc_expr_attr (expr1);
+  is_poly_assign = (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));
+
+
+  /* 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, false, &lhs_refs_comp);
+      rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
+    }
+
   if (lss != gfc_ss_terminator)
     {
       /* The assignment needs scalarization.  */
@@ -9268,6 +9866,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       if (rss == gfc_ss_terminator)
 	/* The rhs is scalar.  Add a ss for the expression.  */
 	rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+      /* When doing a class assign, then the handle to the rhs needs to be a
+	 pointer to allow for polymorphism.  */
+      if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
+	rss->info->type = GFC_SS_REFERENCE;
 
       /* Associate the SS with the loop.  */
       gfc_add_ss_to_loop (&loop, lss);
@@ -9279,7 +9881,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);
 
@@ -9319,6 +9922,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
 
   /* Translate the expression.  */
+  rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
+      && lhs_caf_attr.codimension;
   gfc_conv_expr (&rse, expr2);
 
   /* Deal with the case of a scalar class function assigned to a derived type.  */
@@ -9331,7 +9936,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 
   /* Stabilize a string length for temporaries.  */
   if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
-      && !(TREE_CODE (rse.string_length) == VAR_DECL
+      && !(VAR_P (rse.string_length)
 	   || TREE_CODE (rse.string_length) == PARM_DECL
 	   || TREE_CODE (rse.string_length) == INDIRECT_REF))
     string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
@@ -9358,13 +9963,16 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  tree cond;
 	  const char* msg;
 
+	  tmp = INDIRECT_REF_P (lse.expr)
+	      ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
+
 	  /* We should only get array references here.  */
-	  gcc_assert (TREE_CODE (lse.expr) == POINTER_PLUS_EXPR
-		      || TREE_CODE (lse.expr) == ARRAY_REF);
+	  gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
+		      || TREE_CODE (tmp) == ARRAY_REF);
 
 	  /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
 	     or the array itself(ARRAY_REF).  */
-	  tmp = TREE_OPERAND (lse.expr, 0);
+	  tmp = TREE_OPERAND (tmp, 0);
 
 	  /* Provide the address of the array.  */
 	  if (TREE_CODE (lse.expr) == ARRAY_REF)
@@ -9415,9 +10023,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      nullification occurs before the call to the finalizer. In the case of
      a scalar to array assignment, this is done in gfc_trans_scalar_assign
      as part of the deep copy.  */
-  if (!scalar_to_array && (expr1->ts.type == BT_DERIVED)
-					      && (gfc_is_alloc_class_array_function (expr2)
-						      || gfc_is_alloc_class_scalar_function (expr2)))
+  if (!scalar_to_array && expr1->ts.type == BT_DERIVED
+		       && (gfc_is_alloc_class_array_function (expr2)
+			   || gfc_is_alloc_class_scalar_function (expr2)))
     {
       tmp = rse.expr;
       tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
@@ -9426,16 +10034,54 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	gfc_add_block_to_block (&loop.post, &rse.post);
     }
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
-				 gfc_expr_is_variable (expr2) || scalar_to_array
-				 || expr2->expr_type == EXPR_ARRAY,
-				 !(l_is_temp || init_flag) && dealloc);
+  if (is_poly_assign)
+    tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+				  use_vptr_copy || (lhs_attr.allocatable
+						    && !lhs_attr.dimension),
+				  flag_realloc_lhs && !lhs_attr.pointer);
+  else if (flag_coarray == GFC_FCOARRAY_LIB
+	   && lhs_caf_attr.codimension && rhs_caf_attr.codimension
+	   && ((lhs_caf_attr.allocatable && lhs_refs_comp)
+	       || (rhs_caf_attr.allocatable && rhs_refs_comp)))
+    {
+      /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
+	 allocatable component, because those need to be accessed via the
+	 caf-runtime.  No need to check for coindexes here, because resolve
+	 has rewritten those already.  */
+      gfc_code code;
+      gfc_actual_arglist a1, a2;
+      /* Clear the structures to prevent accessing garbage.  */
+      memset (&code, '\0', sizeof (gfc_code));
+      memset (&a1, '\0', sizeof (gfc_actual_arglist));
+      memset (&a2, '\0', sizeof (gfc_actual_arglist));
+      a1.expr = expr1;
+      a1.next = &a2;
+      a2.expr = expr2;
+      a2.next = NULL;
+      code.ext.actual = &a1;
+      code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
+      tmp = gfc_conv_intrinsic_subroutine (&code);
+    }
+  else
+    tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+				   gfc_expr_is_variable (expr2)
+				   || scalar_to_array
+				   || expr2->expr_type == EXPR_ARRAY,
+				   !(l_is_temp || init_flag) && dealloc,
+				   expr1->symtree->n.sym->attr.codimension);
+  /* 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)
     {
       /* F2003: Add the code for reallocation on assignment.  */
-      if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
+      if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
+	  && !is_poly_assign)
 	alloc_scalar_allocatable_for_assignment (&block, string_length,
 						 expr1, expr2);
 
@@ -9476,11 +10122,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 
       /* F2003: Allocate or reallocate lhs of allocatable array.  */
       if (flag_realloc_lhs
-	    && gfc_is_reallocatable_lhs (expr1)
-	    && !gfc_expr_attr (expr1).codimension
-	    && !gfc_is_coindexed (expr1)
-	    && expr2->rank
-	    && !is_runtime_conformable (expr1, expr2))
+	  && gfc_is_reallocatable_lhs (expr1)
+	  && expr2->rank
+	  && !is_runtime_conformable (expr1, expr2))
 	{
 	  realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
 	  ompws_flags &= ~OMPWS_SCALARIZER_WS;
@@ -9547,7 +10191,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;
 
@@ -9590,13 +10234,14 @@ 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
 gfc_trans_init_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr1, code->expr2, true, false);
+  return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
 }
 
 tree