[commited,Fortran,pr64787,a.o.,v1] Invalid code on sourced allocation of class(*) character string

Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog	(Revision 221620)
+++ gcc/fortran/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,62 @@ 
+2015-03-24  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/64787
+	PR fortran/57456
+	PR fortran/63230
+	* class.c (gfc_add_component_ref):  Free no longer needed
+	ref-chains to prevent memory loss.
+	(find_intrinsic_vtab): For deferred length char arrays or
+	unlimited polymorphic objects, store the size in bytes of one
+	character in the size component of the vtab.
+	* gfortran.h: Added gfc_add_len_component () define.
+	* trans-array.c (gfc_trans_create_temp_array): Switched to new
+	function name for getting a class' vtab's field.
+	(build_class_array_ref): Likewise.
+	(gfc_array_init_size): Using the size information from allocate
+	more consequently now, i.e., the typespec of the entity to
+	allocate is no longer needed.  This is to address the last open
+	comment in PR fortran/57456.
+	(gfc_array_allocate): Likewise.
+	(structure_alloc_comps): gfc_copy_class_to_class () needs to
+	know whether the class is unlimited polymorphic.
+	* trans-array.h: Changed interface of gfc_array_allocate () to
+	reflect the no longer needed typespec.
+	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): New.
+	(gfc_reset_len): New.
+	(gfc_get_class_array_ref): Switch to new function name for
+	getting a class' vtab's field.
+	(gfc_copy_class_to_class):  Added flag to know whether the class
+	to copy is unlimited polymorphic.  Adding _len dependent code
+	then, which calls ->vptr->copy () with four arguments adding
+	the length information ->vptr->copy(from, to, from_len, to_cap).
+	(gfc_conv_procedure_call): Switch to new function name for
+	getting a class' vtab's field. 
+	(alloc_scalar_allocatable_for_assignment): Use the string_length
+	as computed by gfc_conv_expr and not the statically backend_decl
+	which may be incorrect when ref-ing.
+	(gfc_trans_assignment_1): Use the string_length variable and
+	not the rse.string_length.  The former has been computed more
+	generally.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Switch to new
+	function name for getting a class' vtab's field.
+	(gfc_conv_intrinsic_storage_size): Likewise.
+	(gfc_conv_intrinsic_transfer): Likewise.
+	* trans-stmt.c (gfc_trans_allocate): Restructured to evaluate
+	source=expr3 only once before the loop over the objects to
+	allocate, when the objects are not arrays. Doing correct _len
+	initialization and calling of vptr->copy () fixing PR 64787.
+	(gfc_trans_deallocate): Reseting _len to 0, preventing future
+	errors.
+	* trans.c (gfc_build_array_ref): Switch to new function name
+	for getting a class' vtab's field.
+	(gfc_add_comp_finalizer_call): Likewise.
+	* trans.h: Define the prototypes for the gfc_class_vtab_*_get ()
+	and gfc_vptr_*_get () functions.
+	Added gfc_find_and_cut_at_last_class_ref () and
+	gfc_reset_len () routine prototype.  Added flag to
+	gfc_copy_class_to_class () prototype to signal an unlimited
+	polymorphic entity to copy.    
+
 2015-03-24  Iain Sandoe  <iain@codesourcery.com>
 	    Tobias Burnus  <burnus@net-b.de>
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 221620)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -3175,6 +3175,7 @@ 
 void gfc_add_class_array_ref (gfc_expr *);
 #define gfc_add_data_component(e)     gfc_add_component_ref(e,"_data")
 #define gfc_add_vptr_component(e)     gfc_add_component_ref(e,"_vptr")
+#define gfc_add_len_component(e)      gfc_add_component_ref(e,"_len")
 #define gfc_add_hash_component(e)     gfc_add_component_ref(e,"_hash")
 #define gfc_add_size_component(e)     gfc_add_component_ref(e,"_size")
 #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(Revision 221620)
+++ gcc/fortran/class.c	(Arbeitskopie)
@@ -234,6 +234,9 @@ 
     }
   if (*tail != NULL && strcmp (name, "_data") == 0)
     next = *tail;
+  else
+    /* Avoid losing memory.  */
+    gfc_free_ref_list (*tail);
   (*tail) = gfc_get_ref();
   (*tail)->next = next;
   (*tail)->type = REF_COMPONENT;
@@ -2562,13 +2565,19 @@ 
 	      c->attr.access = ACCESS_PRIVATE;
 
 	      /* Build a minimal expression to make use of
-		 target-memory.c/gfc_element_size for 'size'.  */
+		 target-memory.c/gfc_element_size for 'size'.  Special handling
+		 for character arrays, that are not constant sized: to support
+		 len (str) * kind, only the kind information is stored in the
+		 vtab.  */
 	      e = gfc_get_expr ();
 	      e->ts = *ts;
 	      e->expr_type = EXPR_VARIABLE;
 	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 						 NULL,
-						 (int)gfc_element_size (e));
+						 ts->type == BT_CHARACTER
+						 && charlen == 0 ?
+						   ts->kind :
+						   (int)gfc_element_size (e));
 	      gfc_free_expr (e);
 
 	      /* Add component _extends.  */
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 221620)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -166,7 +166,7 @@ 
   if (POINTER_TYPE_P (TREE_TYPE (decl)))
     decl = build_fold_indirect_ref_loc (input_location, decl);
   len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
-			    CLASS_LEN_FIELD);
+			   CLASS_LEN_FIELD);
   return fold_build3_loc (input_location, COMPONENT_REF,
 			  TREE_TYPE (len), decl, len,
 			  NULL_TREE);
@@ -173,65 +173,78 @@ 
 }
 
 
+/* Get the specified FIELD from the VPTR.  */
+
 static tree
-gfc_vtable_field_get (tree decl, int field)
+vptr_field_get (tree vptr, int fieldno)
 {
-  tree size;
-  tree vptr;
-  vptr = gfc_class_vptr_get (decl);
+  tree field;
   vptr = build_fold_indirect_ref_loc (input_location, vptr);
-  size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
-			    field);
-  size = fold_build3_loc (input_location, COMPONENT_REF,
-			  TREE_TYPE (size), vptr, size,
-			  NULL_TREE);
-  /* Always return size as an array index type.  */
-  if (field == VTABLE_SIZE_FIELD)
-    size = fold_convert (gfc_array_index_type, size);
-  gcc_assert (size);
-  return size;
+  field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
+			     fieldno);
+  field = fold_build3_loc (input_location, COMPONENT_REF,
+			   TREE_TYPE (field), vptr, field,
+			   NULL_TREE);
+  gcc_assert (field);
+  return field;
 }
 
 
-tree
-gfc_vtable_hash_get (tree decl)
-{
-  return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
-}
+/* Get the field from the class' vptr.  */
 
-
-tree
-gfc_vtable_size_get (tree decl)
+static tree
+class_vtab_field_get (tree decl, int fieldno)
 {
-  return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
+  tree vptr;
+  vptr = gfc_class_vptr_get (decl);
+  return vptr_field_get (vptr, fieldno);
 }
 
 
-tree
-gfc_vtable_extends_get (tree decl)
-{
-  return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
+/* Define a macro for creating the class_vtab_* and vptr_* accessors in
+   unison.  */
+#define VTAB_GET_FIELD_GEN(name, field) tree \
+gfc_class_vtab_## name ##_get (tree cl) \
+{ \
+  return class_vtab_field_get (cl, field); \
+} \
+ \
+tree \
+gfc_vptr_## name ##_get (tree vptr) \
+{ \
+  return vptr_field_get (vptr, field); \
 }
 
+VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
+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)
 
-tree
-gfc_vtable_def_init_get (tree decl)
-{
-  return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
-}
 
+/* The size field is returned as an array index type.  Therefore treat
+   it and only it specially.  */
 
 tree
-gfc_vtable_copy_get (tree decl)
+gfc_class_vtab_size_get (tree cl)
 {
-  return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
+  tree size;
+  size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
+  /* Always return size as an array index type.  */
+  size = fold_convert (gfc_array_index_type, size);
+  gcc_assert (size);
+  return size;
 }
 
-
 tree
-gfc_vtable_final_get (tree decl)
+gfc_vptr_size_get (tree vptr)
 {
-  return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD);
+  tree size;
+  size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
+  /* Always return size as an array index type.  */
+  size = fold_convert (gfc_array_index_type, size);
+  gcc_assert (size);
+  return size;
 }
 
 
@@ -245,6 +258,61 @@ 
 #undef VTABLE_FINAL_FIELD
 
 
+/* Search for the last _class ref in the chain of references of this
+   expression and cut the chain there.  Albeit this routine is similiar
+   to class.c::gfc_add_component_ref (), is there a significant
+   difference: gfc_add_component_ref () concentrates on an array ref to
+   be the last ref in the chain.  This routine is oblivious to the kind
+   of refs following.  */
+
+gfc_expr *
+gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
+{
+  gfc_expr *base_expr;
+  gfc_ref *ref, *class_ref, *tail;
+
+  /* Find the last class reference.  */
+  class_ref = NULL;
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	  && ref->u.c.component->ts.type == BT_CLASS)
+	class_ref = ref;
+
+      if (ref->next == NULL)
+	break;
+    }
+
+  /* Remove and store all subsequent references after the
+     CLASS reference.  */
+  if (class_ref)
+    {
+      tail = class_ref->next;
+      class_ref->next = NULL;
+    }
+  else
+    {
+      tail = e->ref;
+      e->ref = NULL;
+    }
+
+  base_expr = gfc_expr_to_initialize (e);
+
+  /* Restore the original tail expression.  */
+  if (class_ref)
+    {
+      gfc_free_ref_list (class_ref->next);
+      class_ref->next = tail;
+    }
+  else
+    {
+      gfc_free_ref_list (e->ref);
+      e->ref = tail;
+    }
+  return base_expr;
+}
+
+
 /* Reset the vptr to the declared type, e.g. after deallocation.  */
 
 void
@@ -294,6 +362,23 @@ 
 }
 
 
+/* Reset the len for unlimited polymorphic objects.  */
+
+void
+gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
+{
+  gfc_expr *e;
+  gfc_se se_len;
+  e = gfc_find_and_cut_at_last_class_ref (expr);
+  gfc_add_len_component (e);
+  gfc_init_se (&se_len, NULL);
+  gfc_conv_expr (&se_len, e);
+  gfc_add_modify (block, se_len.expr,
+		  fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
+  gfc_free_expr (e);
+}
+
+
 /* Obtain the vptr of the last class reference in an expression.
    Return NULL_TREE if no class reference is found.  */
 
@@ -873,7 +958,7 @@ 
 gfc_get_class_array_ref (tree index, tree class_decl)
 {
   tree data = gfc_class_data_get (class_decl);
-  tree size = gfc_vtable_size_get (class_decl);
+  tree size = gfc_class_vtab_size_get (class_decl);
   tree offset = fold_build2_loc (input_location, MULT_EXPR,
 				 gfc_array_index_type,
 				 index, size);
@@ -891,39 +976,57 @@ 
    that the _vptr is set.  */
 
 tree
-gfc_copy_class_to_class (tree from, tree to, tree nelems)
+gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
 {
   tree fcn;
   tree fcn_type;
   tree from_data;
+  tree from_len;
   tree to_data;
+  tree to_len;
   tree to_ref;
   tree from_ref;
   vec<tree, va_gc> *args;
   tree tmp;
+  tree stdcopy;
+  tree extcopy;
   tree index;
-  stmtblock_t loopbody;
-  stmtblock_t body;
-  gfc_loopinfo loop;
 
   args = NULL;
+  /* To prevent warnings on uninitialized variables.  */
+  from_len = to_len = NULL_TREE;
 
   if (from != NULL_TREE)
-    fcn = gfc_vtable_copy_get (from);
+    fcn = gfc_class_vtab_copy_get (from);
   else
-    fcn = gfc_vtable_copy_get (to);
+    fcn = gfc_class_vtab_copy_get (to);
 
   fcn_type = TREE_TYPE (TREE_TYPE (fcn));
 
   if (from != NULL_TREE)
-    from_data = gfc_class_data_get (from);
+      from_data = gfc_class_data_get (from);
   else
-    from_data = gfc_vtable_def_init_get (to);
+    from_data = gfc_class_vtab_def_init_get (to);
 
+  if (unlimited)
+    {
+      if (from != NULL_TREE && unlimited)
+	from_len = gfc_class_len_get (from);
+      else
+	from_len = integer_zero_node;
+    }
+
   to_data = gfc_class_data_get (to);
+  if (unlimited)
+    to_len = gfc_class_len_get (to);
 
   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
     {
+      stmtblock_t loopbody;
+      stmtblock_t body;
+      stmtblock_t ifbody;
+      gfc_loopinfo loop;
+
       gfc_init_block (&body);
       tmp = fold_build2_loc (input_location, MINUS_EXPR,
 			     gfc_array_index_type, nelems,
@@ -955,8 +1058,42 @@ 
       loop.loopvar[0] = index;
       loop.to[0] = nelems;
       gfc_trans_scalarizing_loops (&loop, &loopbody);
-      gfc_add_block_to_block (&body, &loop.pre);
-      tmp = gfc_finish_block (&body);
+      gfc_init_block (&ifbody);
+      gfc_add_block_to_block (&ifbody, &loop.pre);
+      stdcopy = gfc_finish_block (&ifbody);
+      if (unlimited)
+	{
+	  vec_safe_push (args, from_len);
+	  vec_safe_push (args, to_len);
+	  tmp = build_call_vec (fcn_type, fcn, args);
+	  /* Build the body of the loop.  */
+	  gfc_init_block (&loopbody);
+	  gfc_add_expr_to_block (&loopbody, tmp);
+
+	  /* Build the loop and return.  */
+	  gfc_init_loopinfo (&loop);
+	  loop.dimen = 1;
+	  loop.from[0] = gfc_index_zero_node;
+	  loop.loopvar[0] = index;
+	  loop.to[0] = nelems;
+	  gfc_trans_scalarizing_loops (&loop, &loopbody);
+	  gfc_init_block (&ifbody);
+	  gfc_add_block_to_block (&ifbody, &loop.pre);
+	  extcopy = gfc_finish_block (&ifbody);
+
+	  tmp = fold_build2_loc (input_location, GT_EXPR,
+				 boolean_type_node, from_len,
+				 integer_zero_node);
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 void_type_node, tmp, extcopy, stdcopy);
+	  gfc_add_expr_to_block (&body, tmp);
+	  tmp = gfc_finish_block (&body);
+	}
+      else
+	{
+	  gfc_add_expr_to_block (&body, stdcopy);
+	  tmp = gfc_finish_block (&body);
+	}
       gfc_cleanup_loop (&loop);
     }
   else
@@ -964,12 +1101,27 @@ 
       gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
       vec_safe_push (args, from_data);
       vec_safe_push (args, to_data);
-      tmp = build_call_vec (fcn_type, fcn, args);
+      stdcopy = build_call_vec (fcn_type, fcn, args);
+
+      if (unlimited)
+	{
+	  vec_safe_push (args, from_len);
+	  vec_safe_push (args, to_len);
+	  extcopy = build_call_vec (fcn_type, fcn, args);
+	  tmp = fold_build2_loc (input_location, GT_EXPR,
+				 boolean_type_node, from_len,
+				 integer_zero_node);
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 void_type_node, tmp, extcopy, stdcopy);
+	}
+      else
+	tmp = stdcopy;
     }
 
   return tmp;
 }
 
+
 static tree
 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
 {
@@ -5693,7 +5845,7 @@ 
 			CLASS_DATA (expr->value.function.esym->result)->attr);
 	    }
 
-	  final_fndecl = gfc_vtable_final_get (se->expr);
+	  final_fndecl = gfc_class_vtab_final_get (se->expr);
 	  is_final = fold_build2_loc (input_location, NE_EXPR,
 				      boolean_type_node,
  			    	      final_fndecl,
@@ -5704,7 +5856,7 @@ 
  	  tmp = build_call_expr_loc (input_location,
 				     final_fndecl, 3,
 				     gfc_build_addr_expr (NULL, tmp),
-				     gfc_vtable_size_get (se->expr),
+				     gfc_class_vtab_size_get (se->expr),
 				     boolean_false_node);
  	  tmp = fold_build3_loc (input_location, COND_EXPR,
 				 void_type_node, is_final, tmp,
@@ -8529,7 +8681,7 @@ 
   if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
     {
       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
-			      expr1->ts.u.cl->backend_decl, size);
+			      lse.string_length, size);
       /* Jump past the realloc if the lengths are the same.  */
       tmp = build3_v (COND_EXPR, cond,
 		      build1_v (GOTO_EXPR, jump_label2),
@@ -8546,10 +8698,7 @@ 
 
       /* Update the lhs character length.  */
       size = string_length;
-      if (TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
-	gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
-      else
-	gfc_add_modify (block, lse.string_length, size);
+      gfc_add_modify (block, lse.string_length, size);
     }
 }
 
@@ -8839,7 +8988,7 @@ 
     {
       /* F2003: Add the code for reallocation on assignment.  */
       if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
-	alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
+	alloc_scalar_allocatable_for_assignment (&block, string_length,
 						 expr1, expr2);
 
       /* Use the scalar assignment as is.  */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(Revision 221620)
+++ gcc/fortran/trans-intrinsic.c	(Arbeitskopie)
@@ -2755,7 +2755,7 @@ 
 	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
 	       : null_pointer_node;
       }
-  
+
     if (least == 2)
       {
 	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
@@ -5922,9 +5922,9 @@ 
   else if (arg->ts.type == BT_CLASS)
     {
       if (arg->rank)
-	byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+	byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
       else
-	byte_size = gfc_vtable_size_get (argse.expr);
+	byte_size = gfc_class_vtab_size_get (argse.expr);
     }
   else
     {
@@ -6053,7 +6053,7 @@ 
       gfc_conv_expr_descriptor (&argse, arg);
       if (arg->ts.type == BT_CLASS)
 	{
-	  tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+	  tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
 	  tmp = fold_convert (result_type, tmp);
 	  goto done;
 	}
@@ -6198,7 +6198,7 @@ 
 					 argse.string_length);
 	  break;
 	case BT_CLASS:
-	  tmp = gfc_vtable_size_get (argse.expr);
+	  tmp = gfc_class_vtab_size_get (argse.expr);
 	  break;
 	default:
 	  source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
@@ -6322,7 +6322,7 @@ 
       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
       break;
     case BT_CLASS:
-      tmp = gfc_vtable_size_get (argse.expr);
+      tmp = gfc_class_vtab_size_get (argse.expr);
       break;
     default:
       tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(Revision 221620)
+++ gcc/fortran/trans.c	(Arbeitskopie)
@@ -373,7 +373,7 @@ 
 	    return build4_loc (input_location, ARRAY_REF, type, base,
 			       offset, NULL_TREE, NULL_TREE);
 
-	  span = gfc_vtable_size_get (decl);
+	  span = gfc_class_vtab_size_get (decl);
 	}
       else if (GFC_DECL_SUBREF_ARRAY_P (decl))
 	span = GFC_DECL_SPAN(decl);
@@ -1015,8 +1015,8 @@ 
 	return false;
 
       gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
-      final_fndecl = gfc_vtable_final_get (decl);
-      size = gfc_vtable_size_get (decl);
+      final_fndecl = gfc_class_vtab_final_get (decl);
+      size = gfc_class_vtab_size_get (decl);
       array = gfc_class_data_get (decl);
     }
 
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(Revision 221620)
+++ gcc/fortran/trans.h	(Arbeitskopie)
@@ -350,20 +350,31 @@ 
 gfc_wrapped_block;
 
 /* Class API functions.  */
+tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
 tree gfc_class_len_get (tree);
+gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *);
+/* Get an accessor to the class' vtab's * field, when a class handle is
+   available.  */
+tree gfc_class_vtab_hash_get (tree);
+tree gfc_class_vtab_size_get (tree);
+tree gfc_class_vtab_extends_get (tree);
+tree gfc_class_vtab_def_init_get (tree);
+tree gfc_class_vtab_copy_get (tree);
+tree gfc_class_vtab_final_get (tree);
+/* Get an accessor to the vtab's * field, when a vptr handle is present.  */
+tree gfc_vtpr_hash_get (tree);
+tree gfc_vptr_size_get (tree);
+tree gfc_vptr_extends_get (tree);
+tree gfc_vptr_def_init_get (tree);
+tree gfc_vptr_copy_get (tree);
+tree gfc_vptr_final_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
-tree gfc_class_set_static_fields (tree, tree, tree);
-tree gfc_vtable_hash_get (tree);
-tree gfc_vtable_size_get (tree);
-tree gfc_vtable_extends_get (tree);
-tree gfc_vtable_def_init_get (tree);
-tree gfc_vtable_copy_get (tree);
-tree gfc_vtable_final_get (tree);
+void gfc_reset_len (stmtblock_t *, gfc_expr *);
 tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
-tree gfc_copy_class_to_class (tree, tree, tree);
+tree gfc_copy_class_to_class (tree, tree, tree, bool);
 bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
 bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
 
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(Revision 221620)
+++ gcc/fortran/trans-array.c	(Arbeitskopie)
@@ -1196,7 +1196,7 @@ 
 	elemsize = fold_convert (gfc_array_index_type,
 			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
       else
-	elemsize = gfc_vtable_size_get (class_expr);
+	elemsize = gfc_class_vtab_size_get (class_expr);
 
       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			      size, elemsize);
@@ -3066,7 +3066,7 @@ 
   if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
     return false;
 
-  size = gfc_vtable_size_get (decl);
+  size = gfc_class_vtab_size_get (decl);
 
   /* Build the address of the element.  */
   type = TREE_TYPE (TREE_TYPE (base));
@@ -4956,8 +4956,7 @@ 
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
 		     stmtblock_t * descriptor_block, tree * overflow,
-		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
-		     gfc_typespec *ts)
+		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
 {
   tree type;
   tree tmp;
@@ -4983,7 +4982,7 @@ 
 
   /* Set the dtype.  */
   tmp = gfc_conv_descriptor_dtype (descriptor);
-  gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+  gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type));
 
   or_expr = boolean_false_node;
 
@@ -5137,9 +5136,6 @@ 
 	  tmp = TYPE_SIZE_UNIT (tmp);
 	}
     }
-  else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
-    /* FIXME: Properly handle characters.  See PR 57456.  */
-    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
   else
     tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
 
@@ -5211,7 +5207,7 @@ 
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 		    tree errlen, tree label_finish, tree expr3_elem_size,
-		    tree *nelems, gfc_expr *expr3, gfc_typespec *ts)
+		    tree *nelems, gfc_expr *expr3)
 {
   tree tmp;
   tree pointer;
@@ -5296,7 +5292,7 @@ 
   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3_elem_size, nelems, expr3, ts);
+			      expr3_elem_size, nelems, expr3);
 
   if (dimension)
     {
@@ -7942,7 +7938,8 @@ 
 
 	      dst_data = gfc_class_data_get (dcmp);
 	      src_data = gfc_class_data_get (comp);
-	      size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
+	      size = fold_convert (size_type_node,
+				   gfc_class_vtab_size_get (comp));
 
 	      if (CLASS_DATA (c)->attr.dimension)
 		{
@@ -7977,7 +7974,8 @@ 
 				  fold_convert (TREE_TYPE (dst_data), tmp));
 		}
 
-	      tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
+	      tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
+					     UNLIMITED_POLY (c));
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	      tmp = gfc_finish_block (&tmpblock);
 
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h	(Revision 221620)
+++ gcc/fortran/trans-array.h	(Arbeitskopie)
@@ -24,7 +24,7 @@ 
 /* Generate code to initialize and allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
 bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
-			 tree, tree *, gfc_expr *, gfc_typespec *);
+			 tree, tree *, gfc_expr *);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(Revision 221620)
+++ gcc/fortran/trans-stmt.c	(Arbeitskopie)
@@ -4932,9 +4932,8 @@ 
 gfc_trans_allocate (gfc_code * code)
 {
   gfc_alloc *al;
-  gfc_expr *e;
   gfc_expr *expr;
-  gfc_se se;
+  gfc_se se, se_sz;
   tree tmp;
   tree parm;
   tree stat;
@@ -4943,21 +4942,23 @@ 
   tree label_errmsg;
   tree label_finish;
   tree memsz;
-  tree expr3;
-  tree slen3;
+  tree al_vptr, al_len;
+  /* If an expr3 is present, then store the tree for accessing its
+     _vptr, and _len components in the variables, respectively.  The
+     element size, i.e. _vptr%size, is stored in expr3_esize.  Any of
+     the trees may be the NULL_TREE indicating that this is not
+     available for expr3's type.  */
+  tree expr3, expr3_vptr, expr3_len, expr3_esize;
   stmtblock_t block;
   stmtblock_t post;
-  gfc_expr *sz;
-  gfc_se se_sz;
-  tree class_expr;
   tree nelems;
-  tree memsize = NULL_TREE;
-  tree classexpr = NULL_TREE;
+  bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
 
-  stat = tmp = memsz = NULL_TREE;
+  stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
+  expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
   label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
 
   gfc_init_block (&block);
@@ -4991,206 +4992,364 @@ 
       TREE_USED (label_finish) = 0;
     }
 
-  expr3 = NULL_TREE;
-  slen3 = NULL_TREE;
+  /* When an expr3 is present, try to evaluate it only once.  In most
+     cases expr3 is invariant for all elements of the allocation list.
+     Only exceptions are arrays.  Furthermore the standards prevent a
+     dependency of expr3 on the objects in the allocate list.  Therefore
+     it is safe to pre-evaluate expr3 for complicated expressions, i.e.
+     everything not a variable or constant.  When an array allocation
+     is wanted, then the following block nevertheless evaluates the
+     _vptr, _len and element_size for expr3.  */
+  if (code->expr3)
+    {
+      bool vtab_needed = false;
+      /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
+	 the expression is only needed to get the _vptr, _len a.s.o.  */
+      tree expr3_tmp = NULL_TREE;
 
+      /* Figure whether we need the vtab from expr3.  */
+      for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
+	   al = al->next)
+	vtab_needed = (al->expr->ts.type == BT_CLASS);
+
+      /* A array expr3 needs the scalarizer, therefore do not process it
+	 here.  */
+      if (code->expr3->expr_type != EXPR_ARRAY
+	  && (code->expr3->rank == 0
+	      || code->expr3->expr_type == EXPR_FUNCTION)
+	  && (!code->expr3->symtree
+	      || !code->expr3->symtree->n.sym->as)
+	  && !gfc_is_class_array_ref (code->expr3, NULL))
+	{
+	  /* When expr3 is a variable, i.e., a very simple expression,
+	     then convert it once here.  */
+	  if ((code->expr3->expr_type == EXPR_VARIABLE)
+	      || code->expr3->expr_type == EXPR_CONSTANT)
+	    {
+	      if (!code->expr3->mold
+		  || code->expr3->ts.type == BT_CHARACTER
+		  || vtab_needed)
+		{
+		  /* Convert expr3 to a tree.  */
+		  gfc_init_se (&se, NULL);
+		  se.want_pointer = 1;
+		  gfc_conv_expr (&se, code->expr3);
+		  if (!code->expr3->mold)
+		    expr3 = se.expr;
+		  else
+		    expr3_tmp = se.expr;
+		  expr3_len = se.string_length;
+		  gfc_add_block_to_block (&block, &se.pre);
+		  gfc_add_block_to_block (&post, &se.post);
+		}
+	      /* else expr3 = NULL_TREE set above.  */
+	    }
+	  else
+	    {
+	      /* In all other cases evaluate the expr3 and create a
+		 temporary.  */
+	      gfc_init_se (&se, NULL);
+	      gfc_conv_expr_reference (&se, code->expr3);
+	      if (code->expr3->ts.type == BT_CLASS)
+		gfc_conv_class_to_class (&se, code->expr3,
+					 code->expr3->ts,
+					 false, true,
+					  false,false);
+	      gfc_add_block_to_block (&block, &se.pre);
+	      gfc_add_block_to_block (&post, &se.post);
+	      /* Prevent aliasing, i.e., se.expr may be already a
+		 variable declaration.  */
+	      if (!VAR_P (se.expr))
+		{
+		  tmp = build_fold_indirect_ref_loc (input_location,
+						     se.expr);
+		  tmp = gfc_evaluate_now (tmp, &block);
+		}
+	      else
+		tmp = se.expr;
+	      if (!code->expr3->mold)
+		expr3 = tmp;
+	      else
+		expr3_tmp = tmp;
+	      /* When he length of a char array is easily available
+		 here, fix it for future use.  */
+	      if (se.string_length)
+		expr3_len = gfc_evaluate_now (se.string_length, &block);
+	    }
+	}
+
+      /* Figure how to get the _vtab entry.  This also obtains the tree
+	 expression for accessing the _len component, because only
+	 unlimited polymorphic objects, which are a subcategory of class
+	 types, have a _len component.  */
+      if (code->expr3->ts.type == BT_CLASS)
+	{
+	  gfc_expr *rhs;
+	  /* Polymorphic SOURCE: VPTR must be determined at run time.  */
+	  if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref))
+	    tmp = gfc_class_vptr_get (expr3);
+	  else if (expr3_tmp != NULL_TREE
+		   && (VAR_P (expr3_tmp) ||!code->expr3->ref))
+	    tmp = gfc_class_vptr_get (expr3_tmp);
+	  else
+	    {
+	      rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
+	      gfc_add_vptr_component (rhs);
+	      gfc_init_se (&se, NULL);
+	      se.want_pointer = 1;
+	      gfc_conv_expr (&se, rhs);
+	      tmp = se.expr;
+	      gfc_free_expr (rhs);
+	    }
+	  /* Set the element size.  */
+	  expr3_esize = gfc_vptr_size_get (tmp);
+	  if (vtab_needed)
+	    expr3_vptr = tmp;
+	  /* Initialize the ref to the _len component.  */
+	  if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3))
+	    {
+	      /* Same like for retrieving the _vptr.  */
+	      if (expr3 != NULL_TREE && !code->expr3->ref)
+		expr3_len  = gfc_class_len_get (expr3);
+	      else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
+		expr3_len  = gfc_class_len_get (expr3_tmp);
+	      else
+		{
+		  rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
+		  gfc_add_len_component (rhs);
+		  gfc_init_se (&se, NULL);
+		  gfc_conv_expr (&se, rhs);
+		  expr3_len = se.expr;
+		  gfc_free_expr (rhs);
+		}
+	    }
+	}
+      else
+	{
+	  /* When the object to allocate is polymorphic type, then it
+	     needs its vtab set correctly, so deduce the required _vtab
+	     and _len from the source expression.  */
+	  if (vtab_needed)
+	    {
+	      /* VPTR is fixed at compile time.  */
+	      gfc_symbol *vtab;
+
+	      vtab = gfc_find_vtab (&code->expr3->ts);
+	      gcc_assert (vtab);
+	      expr3_vptr = gfc_get_symbol_decl (vtab);
+	      expr3_vptr = gfc_build_addr_expr (NULL_TREE,
+						expr3_vptr);
+	    }
+	  /* _len component needs to be set, when ts is a character
+	     array.  */
+	  if (expr3_len == NULL_TREE
+	      && code->expr3->ts.type == BT_CHARACTER)
+	    {
+	      if (code->expr3->ts.u.cl
+		  && code->expr3->ts.u.cl->length)
+		{
+		  gfc_init_se (&se, NULL);
+		  gfc_conv_expr (&se, code->expr3->ts.u.cl->length);
+		  gfc_add_block_to_block (&block, &se.pre);
+		  expr3_len = gfc_evaluate_now (se.expr, &block);
+		}
+	      gcc_assert (expr3_len);
+	    }
+	  /* For character arrays only the kind's size is needed, because
+	     the array mem_size is _len * (elem_size = kind_size).
+	     For all other get the element size in the normal way.  */
+	  if (code->expr3->ts.type == BT_CHARACTER)
+	    expr3_esize = TYPE_SIZE_UNIT (
+		  gfc_get_char_type (code->expr3->ts.kind));
+	  else
+	    expr3_esize = TYPE_SIZE_UNIT (
+		  gfc_typenode_for_spec (&code->expr3->ts));
+	}
+      gcc_assert (expr3_esize);
+      expr3_esize = fold_convert (sizetype, expr3_esize);
+    }
+  else if (code->ext.alloc.ts.type != BT_UNKNOWN)
+    {
+      /* Compute the explicit typespec given only once for all objects
+	 to allocate.  */
+      if (code->ext.alloc.ts.type != BT_CHARACTER)
+	expr3_esize = TYPE_SIZE_UNIT (
+	      gfc_typenode_for_spec (&code->ext.alloc.ts));
+      else
+	{
+	  gfc_expr *sz;
+	  gcc_assert (code->ext.alloc.ts.u.cl->length != NULL);
+	  sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
+	  gfc_init_se (&se_sz, NULL);
+	  gfc_conv_expr (&se_sz, sz);
+	  gfc_free_expr (sz);
+	  tmp = gfc_get_char_type (code->ext.alloc.ts.kind);
+	  tmp = TYPE_SIZE_UNIT (tmp);
+	  tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
+	  expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
+					 TREE_TYPE (se_sz.expr),
+					 tmp, se_sz.expr);
+	}
+    }
+
+  /* Loop over all objects to allocate.  */
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
     {
       expr = gfc_copy_expr (al->expr);
+      /* UNLIMITED_POLY () needs the _data component to be set, when
+	 expr is a unlimited polymorphic object.  But the _data component
+	 has not been set yet, so check the derived type's attr for the
+	 unlimited polymorphic flag to be safe.  */
+      upoly_expr = UNLIMITED_POLY (expr)
+		    || (expr->ts.type == BT_DERIVED
+			&& expr->ts.u.derived->attr.unlimited_polymorphic);
+      gfc_init_se (&se, NULL);
 
+      /* For class types prepare the expressions to ref the _vptr
+	 and the _len component.  The latter for unlimited polymorphic
+	 types only.  */
       if (expr->ts.type == BT_CLASS)
-	gfc_add_data_component (expr);
+	{
+	  gfc_expr *expr_ref_vptr, *expr_ref_len;
+	  gfc_add_data_component (expr);
+	  /* Prep the vptr handle.  */
+	  expr_ref_vptr = gfc_copy_expr (al->expr);
+	  gfc_add_vptr_component (expr_ref_vptr);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, expr_ref_vptr);
+	  al_vptr = se.expr;
+	  se.want_pointer = 0;
+	  gfc_free_expr (expr_ref_vptr);
+	  /* Allocated unlimited polymorphic objects always have a _len
+	     component.  */
+	  if (upoly_expr)
+	    {
+	      expr_ref_len = gfc_copy_expr (al->expr);
+	      gfc_add_len_component (expr_ref_len);
+	      gfc_conv_expr (&se, expr_ref_len);
+	      al_len = se.expr;
+	      gfc_free_expr (expr_ref_len);
+	    }
+	  else
+	    /* In a loop ensure that all loop variable dependent variables
+	       are initialized at the same spot in all execution paths.  */
+	    al_len = NULL_TREE;
+	}
+      else
+	al_vptr = al_len = NULL_TREE;
 
-      gfc_init_se (&se, NULL);
-
       se.want_pointer = 1;
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
+      if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
+	/* se.string_length now stores the .string_length variable of expr
+	   needed to allocate character(len=:) arrays.  */
+	al_len = se.string_length;
 
-      /* Evaluate expr3 just once if not a variable.  */
-      if (al == code->ext.alloc.list
-	    && al->expr->ts.type == BT_CLASS
-	    && code->expr3
-	    && code->expr3->ts.type == BT_CLASS
-	    && code->expr3->expr_type != EXPR_VARIABLE)
-	{
-	  gfc_init_se (&se_sz, NULL);
-	  gfc_conv_expr_reference (&se_sz, code->expr3);
-	  gfc_conv_class_to_class (&se_sz, code->expr3,
-				   code->expr3->ts, false, true, false, false);
-	  gfc_add_block_to_block (&se.pre, &se_sz.pre);
-	  gfc_add_block_to_block (&se.post, &se_sz.post);
-	  classexpr = build_fold_indirect_ref_loc (input_location,
-						   se_sz.expr);
-	  classexpr = gfc_evaluate_now (classexpr, &se.pre);
-	  memsize = gfc_vtable_size_get (classexpr);
-	  memsize = fold_convert (sizetype, memsize);
-	}
-
-      memsz = memsize;
-      class_expr = classexpr;
-
+      al_len_needs_set = al_len != NULL_TREE;
+      /* When allocating an array one can not use much of the
+	 pre-evaluated expr3 expressions, because for most of them the
+	 scalarizer is needed which is not available in the pre-evaluation
+	 step.  Therefore gfc_array_allocate () is responsible (and able)
+	 to handle the complete array allocation.  Only the element size
+	 needs to be provided, which is done most of the time by the
+	 pre-evaluation step.  */
       nelems = NULL_TREE;
-      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
-			       memsz, &nelems, code->expr3, &code->ext.alloc.ts))
+      if (expr3_len && code->expr3->ts.type == BT_CHARACTER)
+	/* When al is an array, then the element size for each element
+	   in the array is needed, which is the product of the len and
+	   esize for char arrays.  */
+	tmp = fold_build2_loc (input_location, MULT_EXPR,
+			       TREE_TYPE (expr3_esize), expr3_esize,
+			       fold_convert (TREE_TYPE (expr3_esize),
+					     expr3_len));
+      else
+	tmp = expr3_esize;
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
+			       label_finish, tmp, &nelems, code->expr3))
 	{
-	  bool unlimited_char;
+	  /* A scalar or derived type.  First compute the size to
+	     allocate.
 
-	  unlimited_char = UNLIMITED_POLY (al->expr)
-			   && ((code->expr3 && code->expr3->ts.type == BT_CHARACTER)
-			      || (code->ext.alloc.ts.type == BT_CHARACTER
-				  && code->ext.alloc.ts.u.cl
-				  && code->ext.alloc.ts.u.cl->length));
-
-	  /* A scalar or derived type.  */
-
-	  /* Determine allocate size.  */
-	  if (al->expr->ts.type == BT_CLASS
-		&& !unlimited_char
-		&& code->expr3
-		&& memsz == NULL_TREE)
+	     expr3_len is set when expr3 is an unlimited polymorphic
+	     object or a deferred length string.  */
+	  if (expr3_len != NULL_TREE)
 	    {
-	      if (code->expr3->ts.type == BT_CLASS)
-		{
-		  sz = gfc_copy_expr (code->expr3);
-		  gfc_add_vptr_component (sz);
-		  gfc_add_size_component (sz);
-		  gfc_init_se (&se_sz, NULL);
-		  gfc_conv_expr (&se_sz, sz);
-		  gfc_free_expr (sz);
-		  memsz = se_sz.expr;
-		}
+	      tmp = fold_convert (TREE_TYPE (expr3_esize), expr3_len);
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     TREE_TYPE (expr3_esize),
+				      expr3_esize, tmp);
+	      if (code->expr3->ts.type != BT_CLASS)
+		/* expr3 is a deferred length string, i.e., we are
+		   done.  */
+		memsz = tmp;
 	      else
-		memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
-	    }
-	  else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
-		   || unlimited_char) && code->expr3)
-	    {
-	      if (!code->expr3->ts.u.cl->backend_decl)
 		{
-		  /* Convert and use the length expression.  */
-		  gfc_init_se (&se_sz, NULL);
-		  if (code->expr3->expr_type == EXPR_VARIABLE
-			|| code->expr3->expr_type == EXPR_CONSTANT)
-		    {
-		      gfc_conv_expr (&se_sz, code->expr3);
-		      gfc_add_block_to_block (&se.pre, &se_sz.pre);
-		      se_sz.string_length
-			= gfc_evaluate_now (se_sz.string_length, &se.pre);
-		      gfc_add_block_to_block (&se.pre, &se_sz.post);
-		      memsz = se_sz.string_length;
-		    }
-		  else if (code->expr3->mold
-			     && code->expr3->ts.u.cl
-			     && code->expr3->ts.u.cl->length)
-		    {
-		      gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
-		      gfc_add_block_to_block (&se.pre, &se_sz.pre);
-		      se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
-		      gfc_add_block_to_block (&se.pre, &se_sz.post);
-		      memsz = se_sz.expr;
-		    }
-		  else
-		    {
-		      /* This is would be inefficient and possibly could
-			 generate wrong code if the result were not stored
-			 in expr3/slen3.  */
-		      if (slen3 == NULL_TREE)
-			{
-			  gfc_conv_expr (&se_sz, code->expr3);
-			  gfc_add_block_to_block (&se.pre, &se_sz.pre);
-			  expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
-			  gfc_add_block_to_block (&post, &se_sz.post);
-			  slen3 = gfc_evaluate_now (se_sz.string_length,
-						    &se.pre);
-			}
-		      memsz = slen3;
-		    }
+		  /* For unlimited polymorphic enties build
+			  (len > 0) ? element_size * len : element_size
+		     to compute the number of bytes to allocate.
+		     This allows the allocation of unlimited polymorphic
+		     objects from an expr3 that is also unlimited
+		     polymorphic and stores a _len dependent object,
+		     e.g., a string.  */
+		  memsz = fold_build2_loc (input_location, GT_EXPR,
+					   boolean_type_node, expr3_len,
+					   integer_zero_node);
+		  memsz = fold_build3_loc (input_location, COND_EXPR,
+					 TREE_TYPE (expr3_esize),
+					 memsz, tmp, expr3_esize);
 		}
-	      else
-		/* Otherwise use the stored string length.  */
-		memsz = code->expr3->ts.u.cl->backend_decl;
-	      tmp = al->expr->ts.u.cl->backend_decl;
-
-	      /* Store the string length.  */
-	      if (tmp && TREE_CODE (tmp) == VAR_DECL)
-		gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
-				memsz));
-	      else if (al->expr->ts.type == BT_CHARACTER
-		       && al->expr->ts.deferred && se.string_length)
-		gfc_add_modify (&se.pre, se.string_length,
-				fold_convert (TREE_TYPE (se.string_length),
-				memsz));
-	      else if ((al->expr->ts.type == BT_DERIVED
-			|| al->expr->ts.type == BT_CLASS)
-		       && expr->ts.u.derived->attr.unlimited_polymorphic)
-		{
-		  tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl);
-		  gfc_add_modify (&se.pre, tmp,
-				  fold_convert (TREE_TYPE (tmp),
-						memsz));
-		}
-
-	      /* Convert to size in bytes, using the character KIND.  */
-	      if (unlimited_char)
-		tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
-	      else
-		tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
-	      tmp = TYPE_SIZE_UNIT (tmp);
-	      memsz = fold_build2_loc (input_location, MULT_EXPR,
-				       TREE_TYPE (tmp), tmp,
-				       fold_convert (TREE_TYPE (tmp), memsz));
 	    }
-          else if ((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
-		    || unlimited_char)
+	  else if (expr3_esize != NULL_TREE)
+	    /* Any other object in expr3 just needs element size in
+	       bytes.  */
+	    memsz = expr3_esize;
+	  else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred)
+		   || (upoly_expr
+		       && code->ext.alloc.ts.type == BT_CHARACTER))
 	    {
-	      gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
+	      /* Allocating deferred length char arrays need the length
+		 to allocate in the alloc_type_spec.  But also unlimited
+		 polymorphic objects may be allocated as char arrays.
+		 Both are handled here.  */
 	      gfc_init_se (&se_sz, NULL);
 	      gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
 	      gfc_add_block_to_block (&se.pre, &se_sz.pre);
 	      se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
 	      gfc_add_block_to_block (&se.pre, &se_sz.post);
-	      /* Store the string length.  */
-	      if ((expr->symtree->n.sym->ts.type == BT_CLASS
-		  || expr->symtree->n.sym->ts.type == BT_DERIVED)
-		  && expr->ts.u.derived->attr.unlimited_polymorphic)
-		/* For unlimited polymorphic entities get the backend_decl of
-		   the _len component for that.  */
-		tmp = gfc_class_len_get (gfc_get_symbol_decl (
-					   expr->symtree->n.sym));
-	      else
-		/* Else use what is stored in the charlen->backend_decl.  */
-		tmp = al->expr->ts.u.cl->backend_decl;
-	      gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
-			      se_sz.expr));
-              tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
-              tmp = TYPE_SIZE_UNIT (tmp);
+	      expr3_len = se_sz.expr;
+	      tmp_expr3_len_flag = true;
+	      tmp = TYPE_SIZE_UNIT (
+		    gfc_get_char_type (code->ext.alloc.ts.kind));
 	      memsz = fold_build2_loc (input_location, MULT_EXPR,
-				       TREE_TYPE (tmp), tmp,
-				       fold_convert (TREE_TYPE (se_sz.expr),
-						     se_sz.expr));
+				       TREE_TYPE (tmp),
+				       fold_convert (TREE_TYPE (tmp),
+						     expr3_len),
+				       tmp);
 	    }
-	  else if (code->ext.alloc.ts.type != BT_UNKNOWN)
-	    memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
-	  else if (memsz == NULL_TREE)
-	    memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
-
-	  if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
+	  else if (expr->ts.type == BT_CHARACTER)
 	    {
-	      memsz = se.string_length;
-
-	      /* Convert to size in bytes, using the character KIND.  */
-	      tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
-	      tmp = TYPE_SIZE_UNIT (tmp);
+	      /* Compute the number of bytes needed to allocate a fixed
+		 length char array.  */
+	      gcc_assert (se.string_length != NULL_TREE);
+	      tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind));
 	      memsz = fold_build2_loc (input_location, MULT_EXPR,
 				       TREE_TYPE (tmp), tmp,
-				       fold_convert (TREE_TYPE (tmp), memsz));
+				       fold_convert (TREE_TYPE (tmp),
+						     se.string_length));
 	    }
+	  else if (code->ext.alloc.ts.type != BT_UNKNOWN)
+	    /* Handle all types, where the alloc_type_spec is set.  */
+	    memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
+	  else
+	    /* Handle size computation of the type declared to alloc.  */
+	    memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));;
 
 	  /* Allocate - for non-pointers with re-alloc checking.  */
 	  if (gfc_expr_attr (expr).allocatable)
 	    gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
-				      stat, errmsg, errlen, label_finish, expr);
+				      stat, errmsg, errlen, label_finish,
+				      expr);
 	  else
 	    gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
 
@@ -5202,6 +5361,19 @@ 
 	      gfc_add_expr_to_block (&se.pre, tmp);
 	    }
 	}
+      else
+	{
+	  if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
+	      && expr3_len != NULL_TREE)
+	    {
+	      /* Arrays need to have a _len set before the array
+		 descriptor is filled.  */
+	      gfc_add_modify (&block, al_len,
+			      fold_convert (TREE_TYPE (al_len), expr3_len));
+	      /* Prevent setting the length twice.  */
+	      al_len_needs_set = false;
+	    }
+	}
 
       gfc_add_block_to_block (&block, &se.pre);
 
@@ -5218,124 +5390,114 @@ 
 	  gfc_add_expr_to_block (&block, tmp);
 	}
 
-      /* We need the vptr of CLASS objects to be initialized.  */
-      e = gfc_copy_expr (al->expr);
-      if (e->ts.type == BT_CLASS)
+      /* Set the vptr.  */
+      if (al_vptr != NULL_TREE)
 	{
-	  gfc_expr *lhs, *rhs;
-	  gfc_se lse;
-	  gfc_ref *ref, *class_ref, *tail;
-
-	  /* Find the last class reference.  */
-	  class_ref = NULL;
-	  for (ref = e->ref; ref; ref = ref->next)
-	    {
-	      if (ref->type == REF_COMPONENT
-		  && ref->u.c.component->ts.type == BT_CLASS)
-		class_ref = ref;
-
-	      if (ref->next == NULL)
-		break;
-	    }
-
-	  /* Remove and store all subsequent references after the
-	     CLASS reference.  */
-	  if (class_ref)
-	    {
-	      tail = class_ref->next;
-	      class_ref->next = NULL;
-	    }
+	  if (expr3_vptr != NULL_TREE)
+	    /* The vtab is already known, so just assign it.  */
+	    gfc_add_modify (&block, al_vptr,
+			    fold_convert (TREE_TYPE (al_vptr), expr3_vptr));
 	  else
 	    {
-	      tail = e->ref;
-	      e->ref = NULL;
-	    }
-
-	  lhs = gfc_expr_to_initialize (e);
-	  gfc_add_vptr_component (lhs);
-
-	  /* Remove the _vptr component and restore the original tail
-	     references.  */
-	  if (class_ref)
-	    {
-	      gfc_free_ref_list (class_ref->next);
-	      class_ref->next = tail;
-	    }
-	  else
-	    {
-	      gfc_free_ref_list (e->ref);
-	      e->ref = tail;
-	    }
-
-	  if (class_expr != NULL_TREE)
-	    {
-	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
-	      gfc_init_se (&lse, NULL);
-	      lse.want_pointer = 1;
-	      gfc_conv_expr (&lse, lhs);
-	      tmp = gfc_class_vptr_get (class_expr);
-	      gfc_add_modify (&block, lse.expr,
-			fold_convert (TREE_TYPE (lse.expr), tmp));
-	    }
-	  else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
-	    {
-	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
-	      rhs = gfc_copy_expr (code->expr3);
-	      gfc_add_vptr_component (rhs);
-	      tmp = gfc_trans_pointer_assignment (lhs, rhs);
-	      gfc_add_expr_to_block (&block, tmp);
-	      gfc_free_expr (rhs);
-	      rhs = gfc_expr_to_initialize (e);
-	    }
-	  else
-	    {
 	      /* VPTR is fixed at compile time.  */
 	      gfc_symbol *vtab;
 	      gfc_typespec *ts;
+
 	      if (code->expr3)
+		/* Although expr3 is pre-evaluated above, it may happen,
+		   that for arrays or in mold= cases the pre-evaluation
+		   was not successful.  In these rare cases take the vtab
+		   from the typespec of expr3 here.  */
 		ts = &code->expr3->ts;
-	      else if (e->ts.type == BT_DERIVED)
-		ts = &e->ts;
-	      else if (code->ext.alloc.ts.type == BT_DERIVED || UNLIMITED_POLY (al->expr))
+	      else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr)
+		/* The alloc_type_spec gives the type to allocate or the
+		   al is unlimited polymorphic, which enforces the use of
+		   an alloc_type_spec that is not necessarily a BT_DERIVED.  */
 		ts = &code->ext.alloc.ts;
-	      else if (e->ts.type == BT_CLASS)
-		ts = &CLASS_DATA (e)->ts;
 	      else
-		ts = &e->ts;
+		/* Prepare for setting the vtab as declared.  */
+		ts = &expr->ts;
 
-	      if (ts->type == BT_DERIVED || UNLIMITED_POLY (e))
-		{
-		  vtab = gfc_find_vtab (ts);
-		  gcc_assert (vtab);
-		  gfc_init_se (&lse, NULL);
-		  lse.want_pointer = 1;
-		  gfc_conv_expr (&lse, lhs);
-		  tmp = gfc_build_addr_expr (NULL_TREE,
-					     gfc_get_symbol_decl (vtab));
-		  gfc_add_modify (&block, lse.expr,
-			fold_convert (TREE_TYPE (lse.expr), tmp));
-		}
+	      vtab = gfc_find_vtab (ts);
+	      gcc_assert (vtab);
+	      tmp = gfc_build_addr_expr (NULL_TREE,
+					 gfc_get_symbol_decl (vtab));
+	      gfc_add_modify (&block, al_vptr,
+			      fold_convert (TREE_TYPE (al_vptr), tmp));
 	    }
-	  gfc_free_expr (lhs);
 	}
 
-      gfc_free_expr (e);
-
+      /* Add assignment for string length.  */
+      if (al_len != NULL_TREE && al_len_needs_set)
+	{
+	  if (expr3_len != NULL_TREE)
+	    {
+	      gfc_add_modify (&block, al_len,
+			      fold_convert (TREE_TYPE (al_len),
+					    expr3_len));
+	      /* When tmp_expr3_len_flag is set, then expr3_len is
+		 abused to carry the length information from the
+		 alloc_type.  Clear it to prevent setting incorrect len
+		 information in future loop iterations.  */
+	      if (tmp_expr3_len_flag)
+		/* No need to reset tmp_expr3_len_flag, because the
+		   presence of an expr3 can not change within in the
+		   loop.  */
+		expr3_len = NULL_TREE;
+	    }
+	  else if (code->ext.alloc.ts.type == BT_CHARACTER
+		   && code->ext.alloc.ts.u.cl->length)
+	    {
+	      /* Cover the cases where a string length is explicitly
+		 specified by a type spec for deferred length character
+		 arrays or unlimited polymorphic objects without a
+		 source= or mold= expression.  */
+	      gfc_init_se (&se_sz, NULL);
+	      gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+	      gfc_add_modify (&block, al_len,
+			      fold_convert (TREE_TYPE (al_len),
+					    se_sz.expr));
+	    }
+	  else
+	    /* No length information needed, because type to allocate
+	       has no length.  Set _len to 0.  */
+	    gfc_add_modify (&block, al_len,
+			    fold_convert (TREE_TYPE (al_len),
+					  integer_zero_node));
+	}
       if (code->expr3 && !code->expr3->mold)
 	{
 	  /* Initialization via SOURCE block
 	     (or static default initializer).  */
 	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
-	  if (class_expr != NULL_TREE)
+	  if (expr3 != NULL_TREE
+	      && ((POINTER_TYPE_P (TREE_TYPE (expr3))
+		   && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+		  || VAR_P (expr3))
+	      && code->expr3->ts.type == BT_CLASS
+	      && (expr->ts.type == BT_CLASS
+		  || expr->ts.type == BT_DERIVED))
 	    {
 	      tree to;
-	      to = TREE_OPERAND (se.expr, 0);
-
-	      tmp = gfc_copy_class_to_class (class_expr, to, nelems);
+	      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 (code->expr3->ts.type == BT_CHARACTER)
+	    {
+	      tmp = INDIRECT_REF_P (se.expr) ?
+			se.expr :
+			build_fold_indirect_ref_loc (input_location,
+						     se.expr);
+	      gfc_trans_string_copy (&block, al_len, tmp,
+				     code->expr3->ts.kind,
+				     expr3_len, expr3,
+				     code->expr3->ts.kind);
+	      tmp = NULL_TREE;
+	    }
 	  else if (al->expr->ts.type == BT_CLASS)
 	    {
-	      gfc_actual_arglist *actual;
+	      gfc_actual_arglist *actual, *last_arg;
 	      gfc_expr *ppc;
 	      gfc_code *ppc_code;
 	      gfc_ref *ref, *dataref;
@@ -5345,15 +5507,15 @@ 
 	      actual->expr = gfc_copy_expr (rhs);
 	      if (rhs->ts.type == BT_CLASS)
 		gfc_add_data_component (actual->expr);
-	      actual->next = gfc_get_actual_arglist ();
-	      actual->next->expr = gfc_copy_expr (al->expr);
-	      actual->next->expr->ts.type = BT_CLASS;
-	      gfc_add_data_component (actual->next->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 = actual->next->expr->ref; ref; ref = ref->next)
+	      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;
@@ -5387,7 +5549,10 @@ 
 		}
 	      if (rhs->ts.type == BT_CLASS)
 		{
-		  ppc = gfc_copy_expr (rhs);
+		  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
@@ -5396,6 +5561,7 @@ 
 
 	      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;
@@ -5404,19 +5570,53 @@ 
 	      /* 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);
 	    }
-	  else if (expr3 != NULL_TREE)
-	    {
-	      tmp = build_fold_indirect_ref_loc (input_location, se.expr);
-	      gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
-				     slen3, expr3, code->expr3->ts.kind);
-	      tmp = NULL_TREE;
-	    }
 	  else
 	    {
-	      /* Switch off automatic reallocation since we have just done
-		 the ALLOCATE.  */
+	      /* Switch off automatic reallocation since we have just
+		 done the ALLOCATE.  */
 	      int realloc_lhs = flag_realloc_lhs;
 	      flag_realloc_lhs = 0;
 	      tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
@@ -5433,12 +5633,13 @@ 
 	     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);
+	  tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems,
+					 upoly_expr);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
 
        gfc_free_expr (expr);
-    }
+    } // for-loop
 
   /* STAT.  */
   if (code->expr1)
@@ -5463,17 +5664,20 @@ 
 
       slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
       dlen = gfc_get_expr_charlen (code->expr2);
-      slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
-			      slen);
+      slen = fold_build2_loc (input_location, MIN_EXPR,
+			      TREE_TYPE (slen), dlen, slen);
 
-      gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
-			     slen, errmsg_str, gfc_default_character_kind);
+      gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
+			     code->expr2->ts.kind,
+			     slen, errmsg_str,
+			     gfc_default_character_kind);
       dlen = gfc_finish_block (&errmsg_block);
 
-      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
-			     build_int_cst (TREE_TYPE (stat), 0));
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     stat, build_int_cst (TREE_TYPE (stat), 0));
 
-      tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
+      tmp = build3_v (COND_EXPR, tmp,
+		      dlen, build_empty_stmt (input_location));
 
       gfc_add_expr_to_block (&block, tmp);
     }
@@ -5571,7 +5775,7 @@ 
 		  last = ref;
 
 	      /* Do not deallocate the components of a derived type
-		ultimate pointer component.  */
+		 ultimate pointer component.  */
 	      if (!(last && last->u.c.component->attr.pointer)
 		    && !(!last && expr->symtree->n.sym->attr.pointer))
 		{
@@ -5616,7 +5820,14 @@ 
 	    }
 
 	  if (al->expr->ts.type == BT_CLASS)
-	    gfc_reset_vptr (&se.pre, al->expr);
+	    {
+	      gfc_reset_vptr (&se.pre, al->expr);
+	      if (UNLIMITED_POLY (al->expr)
+		  || (al->expr->ts.type == BT_DERIVED
+		      && al->expr->ts.u.derived->attr.unlimited_polymorphic))
+		/* Clear _len, too.  */
+		gfc_reset_len (&se.pre, al->expr);
+	    }
 	}
       else
 	{
@@ -5631,7 +5842,14 @@ 
 	  gfc_add_expr_to_block (&se.pre, tmp);
 
 	  if (al->expr->ts.type == BT_CLASS)
-	    gfc_reset_vptr (&se.pre, al->expr);
+	    {
+	      gfc_reset_vptr (&se.pre, al->expr);
+	      if (UNLIMITED_POLY (al->expr)
+		  || (al->expr->ts.type == BT_DERIVED
+		      && al->expr->ts.u.derived->attr.unlimited_polymorphic))
+		/* Clear _len, too.  */
+		gfc_reset_len (&se.pre, al->expr);
+	    }
 	}
 
       if (code->expr1)
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90	(Revision 221620)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90	(Arbeitskopie)
@@ -5,45 +5,106 @@ 
 program test
     implicit none
 
-    class(*), pointer :: P
+    class(*), pointer :: P1, P2, P3
+    class(*), pointer, dimension(:) :: PA1
+    class(*), allocatable :: A1, A2
     integer :: string_len = 10 *2
+    character(len=:), allocatable, target :: str
+    character(len=:,kind=4), allocatable :: str4
+    type T
+        class(*), pointer :: content
+    end type
+    type(T) :: o1, o2
 
-    allocate(character(string_len)::P)
+    str = "string for test"
+    str4 = 4_"string for test"
 
-    select type(P)
+    allocate(character(string_len)::P1)
+
+    select type(P1)
         type is (character(*))
-            P ="some test string"
-            if (P .ne. "some test string") then
-                call abort ()
-            end if
-            if (len(P) .ne. 20) then
-                call abort ()
-            end if
-            if (len(P) .eq. len("some test string")) then
-                call abort ()
-            end if
+            P1 ="some test string"
+            if (P1 .ne. "some test string") call abort ()
+            if (len(P1) .ne. 20) call abort ()
+            if (len(P1) .eq. len("some test string")) call abort ()
         class default
             call abort ()
     end select
 
-    deallocate(P)
+    allocate(A1, source = P1)
 
+    select type(A1)
+        type is (character(*))
+            if (A1 .ne. "some test string") call abort ()
+            if (len(A1) .ne. 20) call abort ()
+            if (len(A1) .eq. len("some test string")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(A2, source = convertType(P1))
+
+    select type(A2)
+        type is (character(*))
+            if (A2 .ne. "some test string") call abort ()
+            if (len(A2) .ne. 20) call abort ()
+            if (len(A2) .eq. len("some test string")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(P2, source = str)
+
+    select type(P2)
+        type is (character(*))
+            if (P2 .ne. "string for test") call abort ()
+            if (len(P2) .eq. 20) call abort ()
+            if (len(P2) .ne. len("string for test")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(P3, source = "string for test")
+
+    select type(P3)
+        type is (character(*))
+            if (P3 .ne. "string for test") call abort ()
+            if (len(P3) .eq. 20) call abort ()
+            if (len(P3) .ne. len("string for test")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(character(len=10)::PA1(3))
+
+    select type(PA1)
+        type is (character(*))
+            PA1(1) = "string 10 "
+            if (PA1(1) .ne. "string 10 ") call abort ()
+            if (any(len(PA1(:)) .ne. [10,10,10])) call abort ()
+        class default
+            call abort ()
+    end select
+
+    deallocate(PA1)
+    deallocate(P3)
+!   if (len(P3) .ne. 0) call abort() ! Can't check, because select
+!     type would be needed, which needs the vptr, which is 0 now.
+    deallocate(P2)
+    deallocate(A2)
+    deallocate(A1)
+    deallocate(P1)
+
     ! Now for kind=4 chars.
 
-    allocate(character(len=20,kind=4)::P)
+    allocate(character(len=20,kind=4)::P1)
 
-    select type(P)
+    select type(P1)
         type is (character(len=*,kind=4))
-            P ="some test string"
-            if (P .ne. 4_"some test string") then
-                call abort ()
-            end if
-            if (len(P) .ne. 20) then
-                call abort ()
-            end if
-            if (len(P) .eq. len("some test string")) then
-                call abort ()
-            end if
+            P1 ="some test string"
+            if (P1 .ne. 4_"some test string") call abort ()
+            if (len(P1) .ne. 20) call abort ()
+            if (len(P1) .eq. len("some test string")) call abort ()
         type is (character(len=*,kind=1))
             call abort ()
         class default
@@ -50,7 +111,105 @@ 
             call abort ()
     end select
 
-    deallocate(P)
+    allocate(A1, source=P1)
 
+    select type(A1)
+        type is (character(len=*,kind=4))
+            if (A1 .ne. 4_"some test string") call abort ()
+            if (len(A1) .ne. 20) call abort ()
+            if (len(A1) .eq. len("some test string")) call abort ()
+        type is (character(len=*,kind=1))
+            call abort ()
+        class default
+            call abort ()
+    end select
 
+    allocate(A2, source = convertType(P1))
+
+    select type(A2)
+        type is (character(len=*, kind=4))
+            if (A2 .ne. 4_"some test string") call abort ()
+            if (len(A2) .ne. 20) call abort ()
+            if (len(A2) .eq. len("some test string")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(P2, source = str4)
+
+    select type(P2)
+        type is (character(len=*,kind=4))
+            if (P2 .ne. 4_"string for test") call abort ()
+            if (len(P2) .eq. 20) call abort ()
+            if (len(P2) .ne. len("string for test")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(P3, source = convertType(P2))
+
+    select type(P3)
+        type is (character(len=*, kind=4))
+            if (P3 .ne. 4_"string for test") call abort ()
+            if (len(P3) .eq. 20) call abort ()
+            if (len(P3) .ne. len("string for test")) call abort ()
+        class default
+            call abort ()
+    end select
+
+    allocate(character(kind=4, len=10)::PA1(3))
+
+    select type(PA1)
+        type is (character(len=*, kind=4))
+            PA1(1) = 4_"string 10 "
+            if (PA1(1) .ne. 4_"string 10 ") call abort ()
+            if (any(len(PA1(:)) .ne. [10,10,10])) call abort ()
+        class default
+            call abort ()
+    end select
+
+    deallocate(PA1)
+    deallocate(P3)
+    deallocate(P2)
+    deallocate(A2)
+    deallocate(P1)
+    deallocate(A1)
+
+    allocate(o1%content, source='test string')
+    allocate(o2%content, source=o1%content)
+    select type (c => o1%content)
+      type is (character(*))
+        if (c /= 'test string') call abort ()
+      class default
+        call abort()
+    end select
+    select type (d => o2%content)
+      type is (character(*))
+        if (d /= 'test string') call abort ()
+      class default
+    end select
+
+    call AddCopy ('test string')
+
+contains
+
+  function convertType(in)
+    class(*), pointer, intent(in) :: in
+    class(*), pointer :: convertType
+
+    convertType => in
+  end function
+
+  subroutine AddCopy(C)
+    class(*), intent(in) :: C
+    class(*), pointer :: P
+    allocate(P, source=C)
+    select type (P)
+      type is (character(*))
+        if (P /= 'test string') call abort()
+      class default
+        call abort()
+    end select
+  end subroutine
+
 end program test
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90	(Revision 221620)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90	(Arbeitskopie)
@@ -12,6 +12,9 @@ 
 allocate (a, b, source=c(1))
 allocate (c(4), d(6), source=e)
 
+allocate (a, b, mold=f())
+allocate (c(1), d(6), mold=g())
+
 allocate (a, b, source=f())
 allocate (c(1), d(6), source=g())
 
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90	(Revision 221620)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90	(Arbeitskopie)
@@ -23,12 +23,14 @@ 
     implicit none
     character(LEN=:), allocatable, target :: S
     character(LEN=100) :: res
-    class(*), pointer :: ucp
+    class(*), pointer :: ucp, ucp2
     call sub1 ("long test string", 16)
     call sub2 ()
     S = "test"
     ucp => S
     call sub3 (ucp)
+    allocate (ucp2, source=ucp)
+    call sub3 (ucp2)
     call sub4 (S, 4)
     call sub4 ("This is a longer string.", 24)
     call bar (S, res)
Index: gcc/testsuite/gfortran.dg/allocate_class_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_class_4.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_class_4.f90	(Revision 221621)
@@ -0,0 +1,36 @@ 
+! { dg-do compile }
+!
+! Part of PR 51946, but breaks easily, therefore introduce its own test
+! Authors: Damian Rouson  <damian@sourceryinstitute.org>,
+!          Dominique Pelletier  <dominique.pelletier@polymtl.ca>
+! Contributed by: Andre Vehreschild  <vehre@gcc.gnu.org>
+
+module integrable_model_module
+
+   implicit none
+
+   type, abstract, public :: integrable_model
+      contains
+         procedure(default_constructor), deferred :: empty_instance
+   end type
+
+   abstract interface
+      function default_constructor(this) result(blank_slate)
+         import :: integrable_model
+         class(integrable_model), intent(in)  :: this
+         class(integrable_model), allocatable :: blank_slate
+      end function
+   end interface
+
+   contains
+
+      subroutine integrate(this)
+         class(integrable_model), intent(inout) :: this
+         class(integrable_model), allocatable   :: residual
+         allocate(residual, source=this%empty_instance())
+      end subroutine
+
+end module integrable_model_module
+
+! { dg-final { cleanup-modules "integrable_model_module" } }
+ 
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03	(Revision 0)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03	(Revision 221621)
@@ -0,0 +1,215 @@ 
+! { dg-do run }
+!
+! Test case for unlimited polymorphism that is derived from the article
+! by Mark Leair, in the 'PGI Insider':
+! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm
+! Note that 'getValue' has been removed from the generic 'add' becuse
+! gfortran asserts that this is ambiguous. See
+! https://gcc.gnu.org/ml/fortran/2015-03/msg00002.html for a discussion.
+!
+module link_mod
+  private
+  public :: link, output, index
+  character(6) :: output (14)
+  integer :: index = 0
+  type link
+     private
+     class(*), pointer :: value => null() ! value stored in link
+     type(link), pointer :: next => null()! next link in list
+     contains
+     procedure :: getValue    ! return value pointer
+     procedure :: printLinks  ! print linked list starting with this link
+     procedure :: nextLink    ! return next pointer
+     procedure :: setNextLink ! set next pointer
+  end type link
+
+  interface link
+   procedure constructor ! construct/initialize a link
+  end interface
+
+contains
+
+  function nextLink(this)
+  class(link) :: this
+  class(link), pointer :: nextLink
+    nextLink => this%next
+  end function nextLink
+
+  subroutine setNextLink(this,next)
+  class(link) :: this
+  class(link), pointer :: next
+     this%next => next
+  end subroutine setNextLink
+
+  function getValue(this)
+  class(link) :: this
+  class(*), pointer :: getValue
+  getValue => this%value
+  end function getValue
+
+  subroutine printLink(this)
+  class(link) :: this
+
+  index = index + 1
+
+  select type(v => this%value)
+  type is (integer)
+    write (output(index), '(i6)') v
+  type is (character(*))
+    write (output(index), '(a6)') v
+  type is (real)
+    write (output(index), '(f6.2)') v
+  class default
+    stop 'printLink: unexepected type for link'
+  end select
+
+  end subroutine printLink
+
+  subroutine printLinks(this)
+  class(link) :: this
+  class(link), pointer :: curr
+
+  call printLink(this)
+  curr => this%next
+  do while(associated(curr))
+    call printLink(curr)
+    curr => curr%next
+  end do
+
+  end subroutine
+
+  function constructor(value, next)
+    class(link),pointer :: constructor
+    class(*) :: value
+    class(link), pointer :: next
+    allocate(constructor)
+    constructor%next => next
+    allocate(constructor%value, source=value)
+  end function constructor
+
+end module link_mod
+
+module list_mod
+  use link_mod
+  private
+  public :: list
+  type list
+     private
+     class(link),pointer :: firstLink => null() ! first link in list
+     class(link),pointer :: lastLink => null()  ! last link in list
+   contains
+     procedure :: printValues ! print linked list
+     procedure :: addInteger  ! add integer to linked list
+     procedure :: addChar     ! add character to linked list
+     procedure :: addReal     ! add real to linked list
+     procedure :: addValue    ! add class(*) to linked list
+     procedure :: firstValue  ! return value associated with firstLink
+     procedure :: isEmpty     ! return true if list is empty
+     generic :: add => addInteger, addChar, addReal
+  end type list
+
+contains
+
+  subroutine printValues(this)
+    class(list) :: this
+
+    if (.not.this%isEmpty()) then
+       call this%firstLink%printLinks()
+    endif
+  end subroutine printValues
+
+  subroutine addValue(this, value)
+    class(list) :: this
+    class(*) :: value
+    class(link), pointer :: newLink
+
+    if (.not. associated(this%firstLink)) then
+       this%firstLink => link(value, this%firstLink)
+       this%lastLink => this%firstLink
+    else
+       newLink => link(value, this%lastLink%nextLink())
+       call this%lastLink%setNextLink(newLink)
+       this%lastLink => newLink
+    end if
+
+  end subroutine addValue
+
+  subroutine addInteger(this, value)
+   class(list) :: this
+    integer value
+    class(*), allocatable :: v
+    allocate(v,source=value)
+    call this%addValue(v)
+  end subroutine addInteger
+
+  subroutine addChar(this, value)
+    class(list) :: this
+    character(*) :: value
+    class(*), allocatable :: v
+
+    allocate(v,source=value)
+    call this%addValue(v)
+  end subroutine addChar
+
+  subroutine addReal(this, value)
+    class(list) :: this
+    real value
+    class(*), allocatable :: v
+
+    allocate(v,source=value)
+    call this%addValue(v)
+  end subroutine addReal
+
+  function firstValue(this)
+    class(list) :: this
+    class(*), pointer :: firstValue
+
+    firstValue => this%firstLink%getValue()
+
+  end function firstValue
+
+  function isEmpty(this)
+    class(list) :: this
+    logical isEmpty
+
+    if (associated(this%firstLink)) then
+       isEmpty = .false.
+    else
+       isEmpty = .true.
+    endif
+  end function isEmpty
+
+end module list_mod
+
+program main
+  use link_mod, only : output
+  use list_mod
+  implicit none
+  integer i, j
+  type(list) :: my_list
+
+  do i=1, 10
+     call my_list%add(i)
+  enddo
+  call my_list%add(1.23)
+  call my_list%add('A')
+  call my_list%add('BC')
+  call my_list%add('DEF')
+  call my_list%printvalues()
+  do i = 1, 14
+    select case (i)
+      case (1:10)
+        read (output(i), '(i6)') j
+        if (j .ne. i) call abort
+      case (11)
+        if (output(i) .ne. "  1.23") call abort
+      case (12)
+        if (output(i) .ne. "     A") call abort
+      case (13)
+        if (output(i) .ne. "    BC") call abort
+      case (14)
+        if (output(i) .ne. "   DEF") call abort
+    end select
+  end do
+end program main
+
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog	(Revision 221620)
+++ gcc/testsuite/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,18 @@ 
+2015-03-24  Andre Vehreschild  <vehre@gmx.de>
+
+	* gfortran.dg/allocate_alloc_opt_13.f90: Added tests for
+	source= and mold= expressions functionality.
+	* gfortran.dg/allocate_class_4.f90: New test.
+	* gfortran.dg/unlimited_polymorphic_20.f90: Added test whether
+	copying an unlimited polymorhpic object containing a char array
+	to another unlimited polymorphic object respects the _len
+	component.
+	* gfortran.dg/unlimited_polymorphic_22.f90: Extended to check
+	whether deferred length char array allocate works, unlimited
+	polymorphic object allocation from a string works and if
+	allocating an array of deferred length strings works.
+	* gfortran.dg/unlimited_polymorphic_24.f03: New test.
+
 2015-03-24  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/65513