Hi,

so here is the update on pr 64674. Besides adapting to current trunk nothing
has changed from the previous version. The links for getting the patches this
one depends on are:

PR65548 v5: https://gcc.gnu.org/ml/fortran/2015-05/msg00123.html and
PR44672 v6: https://gcc.gnu.org/ml/fortran/2015-05/msg00124.html

Bootstraps and regtests fine on x86_64-linux-gnu/f21.

Any comments?

- Andre

On Mon, 4 May 2015 16:53:15 +0200
Andre Vehreschild <ve...@gmx.de> wrote:

> Hi all,
> 
> I like to present here a first patch for using class arrays in associate. Upto
> now gfortran crashed, when a class array-section/element was selected in an
> associate. This patch fixes this now for class array sections as well as for
> single elements.
> 
> The story of the patch is told quite shortly: 
> 
> - parse.c::parse_associate() needs to gather more information about what the
>   target is like. Previously the target's rank and array_spec was not
> computed, which disallowed the use of further array refs in the associate
> body: associate (vec => class_matrix(2:3, 2))
>     vec(1) = ... ! <- Unclassifiable statement, because no array_spec was
>   attached to vec. This is fixed by the second hunk of the patch.
> 
> - The third hunk in primary.c prevents setting the dimension attribute on a
>   class object's symbol.
> 
> - The hunks in resolve.c take care about adding dummy full array_refs and in
>   resolve_assoc_var correct the class type, when the target expression's rank
>   is 0. Previously the symbol would have an array valued type, when the
>   target's base type was array valued. But for a scalar target this needed
> some polishing.
> 
> - Additionally a test was added.
> 
> Bootstraps and regtests ok on x86_64-linux-gnu/f21.
> 
> Ok for trunk?
> 
> Note, this patch was diffed from a trunk with my older patches for
> 
> PR65548, v3 https://gcc.gnu.org/ml/fortran/2015-04/msg00123.html and
> PR44672, v5 https://gcc.gnu.org/ml/fortran/2015-04/msg00124.html
> 
> applied.
> 
> Regards,
>       Andre


-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

Attachment: pr64787_v2.clog
Description: Binary data

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 786876c..455aa69 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -234,6 +234,9 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
     }
   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 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      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.  */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f55c691..f4fa9c8 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3168,6 +3168,7 @@ void gfc_add_component_ref (gfc_expr *, const char *);
 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")
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 54f8f4a..697a17a 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4975,8 +4975,7 @@ static tree
 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;
@@ -5002,7 +5001,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
   /* 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;
 
@@ -5156,9 +5155,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 	  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));
 
@@ -5230,7 +5226,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 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;
@@ -5315,7 +5311,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   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)
     {
@@ -8022,7 +8018,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				  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);
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 583000e..8544534 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
 /* 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 *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 0866faf..7d3f3be 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -268,6 +268,61 @@ gfc_vptr_size_get (tree vptr)
 #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
@@ -317,6 +372,22 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
 }
 
 
+/* 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.  */
 
@@ -925,22 +996,25 @@ gfc_get_class_array_ref (tree index, tree class_decl)
    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_class_vtab_copy_get (from);
@@ -950,14 +1024,29 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems)
   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_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,
@@ -989,8 +1078,41 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems)
       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
@@ -998,7 +1120,20 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems)
       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;
@@ -8580,7 +8715,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
   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),
@@ -8597,10 +8732,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
 
       /* 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);
     }
 }
 
@@ -8890,7 +9022,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
     {
       /* 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.  */
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 225b0f3..809f621 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4958,9 +4958,8 @@ tree
 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;
@@ -4969,21 +4968,23 @@ gfc_trans_allocate (gfc_code * code)
   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 and the expression to compute
+     the memsz in expr3_memsz.  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);
@@ -5017,201 +5018,344 @@ gfc_trans_allocate (gfc_code * code)
       TREE_USED (label_finish) = 0;
     }
 
-  expr3 = NULL_TREE;
-  slen3 = NULL_TREE;
+  /* When an expr3 is given, try to evaluate it only once.  In most cases
+     expr3 is invariant for all elements of the allocation list.  Exceptions are
+     only arrays.  Furthermore do(es) the standard(s) prevent a dependency of
+     expr3 on the objects to allocate.  Therefore it is save 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, get
+		 and store it for future reference.  */
+	      if (se.string_length)
+		expr3_len = gfc_evaluate_now (se.string_length, &block);
+	    }
+	}
+
+      /* Figure how to get the _vtab entry.  This also retrieves the tree 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_build_addr_expr (NULL_TREE,
+						gfc_get_symbol_decl (vtab));
+	    }
+	  /* _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 computed to be _len * (elem_size = kind_size).
+	     For all other get the element size in the common 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 = TYPE_SIZE_UNIT (gfc_get_char_type (code->ext.alloc.ts.kind));
+	  expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
+					 TREE_TYPE (se_sz.expr),
+					 fold_convert (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_init_se (&se, NULL);
+	{
+	  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;
 
       se.want_pointer = 1;
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
-
-      /* 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_class_vtab_size_get (classexpr);
-	  memsize = fold_convert (sizetype, memsize);
-	}
-
-      memsz = memsize;
-      class_expr = classexpr;
-
+      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;
+
+      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 (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,
-			       memsz, &nelems, code->expr3, &code->ext.alloc.ts))
+			       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)
-	    {
-	      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;
-		}
-	      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)
+	  /* expr3_len is set when expr3 is unlimited polymorphic object or
+	     a deferred length string.  */
+	  if (expr3_len != NULL_TREE)
 	    {
-	      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;
-		    }
-		}
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     TREE_TYPE (expr3_esize), expr3_esize,
+				     fold_convert (TREE_TYPE (expr3_esize),
+						   expr3_len));
+	      if (code->expr3->ts.type != BT_CLASS)
+		/* expr3 is a deferred length string, i.e., we are done.  */
+		memsz = tmp;
 	      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));
+		  /* For unlimited polymorphic enties build
+			  (len > 0) ? element_size * len : element_size
+		     to compute the number of bytes to allocate.  This allows
+		     allocating of unlimited polymorphic objects from an expr3
+		     that is unlimited polymorphic, too, 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);
 		}
-
-	      /* 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 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)
@@ -5228,6 +5372,19 @@ gfc_trans_allocate (gfc_code * code)
 	      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);
 
@@ -5244,124 +5401,106 @@ gfc_trans_allocate (gfc_code * code)
 	  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;
-	    }
-	  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);
-	    }
+	  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
 	    {
 	      /* 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;
-
-	      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));
-		}
+		/* Prepare for setting the vtab as declared.  */
+		ts = &expr->ts;
+
+	      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)
+	    {
+	      /* The length of the string in characters is needed.  expr3_esize
+		 contains the number of bytes needed for the string to pass
+		 to gfc_array_allocate (), therefore can not be resused
+		 here.  */
+	      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;
@@ -5371,15 +5510,15 @@ gfc_trans_allocate (gfc_code * code)
 	      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;
@@ -5413,7 +5552,10 @@ gfc_trans_allocate (gfc_code * code)
 		}
 	      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
@@ -5422,6 +5564,7 @@ gfc_trans_allocate (gfc_code * code)
 
 	      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;
@@ -5430,15 +5573,49 @@ gfc_trans_allocate (gfc_code * code)
 	      /* 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 length's 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
@@ -5459,12 +5636,13 @@ gfc_trans_allocate (gfc_code * code)
 	     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)
@@ -5642,7 +5820,14 @@ gfc_trans_deallocate (gfc_code *code)
 	    }
 
 	  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
 	{
@@ -5657,7 +5842,14 @@ gfc_trans_deallocate (gfc_code *code)
 	  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)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index d7e5bb0..2eeffa3 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -350,6 +350,7 @@ 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);
@@ -366,9 +367,10 @@ 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 *);
+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);
 
diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90
index 462b121..f9e199c 100644
--- a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_13.f90
@@ -12,6 +12,9 @@ class(t), pointer :: b, d(:)
 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())
 
diff --git a/gcc/testsuite/gfortran.dg/allocate_class_4.f90 b/gcc/testsuite/gfortran.dg/allocate_class_4.f90
new file mode 100644
index 0000000..23c9d53
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_class_4.f90
@@ -0,0 +1,36 @@
+! { dg-do compile }
+!
+! Part of PR 51946, but breaks easily, therefore introduce its own test
+! Authors: Damian Rouson  <dam...@sourceryinstitute.org>,
+!          Dominique Pelletier  <dominique.pellet...@polymtl.ca>
+! Contributed by: Andre Vehreschild  <ve...@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" } }
+ 
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
index c6c6d29..49d35c8 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
@@ -23,12 +23,14 @@ program test
     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)
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90
index 0753fe0..d0ef663 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90
@@ -5,52 +5,211 @@
 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
+
+    str = "string for test"
+    str4 = 4_"string for test"
+
+    allocate(character(string_len)::P1)
+
+    select type(P1)
+        type is (character(*))
+            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
+
+    allocate(A1, source = P1)
 
-    allocate(character(string_len)::P)
+    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(P)
+    select type(A2)
         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
+            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
 
-    deallocate(P)
+    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
             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

Reply via email to