re PR fortran/44672 ([F08] ALLOCATE with SOURCE and no array-spec)

gcc/testsuite/ChangeLog:

2015-06-15  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/44672
	PR fortran/45440
	PR fortran/57307
	* gfortran.dg/allocate_with_source_3.f90: Removed check for
	unimplemented error.
	* gfortran.dg/allocate_with_source_7.f08: New test.
	* gfortran.dg/allocate_with_source_8.f08: New test.

gcc/fortran/ChangeLog:

2015-06-15  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/44672
	PR fortran/45440
	PR fortran/57307
	* gfortran.h: Extend gfc_code.ext.alloc to carry a
	flag indicating that the array specification has to be
	taken from expr3.
	* resolve.c (resolve_allocate_expr): Add F2008 notify
	and flag indicating source driven array spec.
	(resolve_allocate_deallocate): Check for source driven
	array spec, when array to allocate has no explicit
	array spec.
	* trans-array.c (gfc_array_init_size): Get lower and
	upper bound from a tree array descriptor, except when
	the source expression is an array-constructor which is
	fixed to be one-based.
	(retrieve_last_ref): Extracted from gfc_array_allocate().
	(gfc_array_allocate): Enable allocate(array, source= 
	array_expression) as specified by F2008:C633.
	(gfc_conv_expr_descriptor): Add class tree expression
	into the saved descriptor for class arrays.
	* trans-array.h: Add temporary array descriptor to
	gfc_array_allocate ().
	* trans-expr.c (gfc_conv_procedure_call): Special handling
	for _copy() routine translation, that comes without an
	interface. Third and fourth argument are now passed by value.
	* trans-stmt.c (gfc_trans_allocate): Get expr3 array
	descriptor for temporary arrays to allow allocate(array,
	source = array_expression) for array without array
	specification.

From-SVN: r224477

7 files changed, 272 insertions, 121 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 025214b..5ede14d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,35 @@
+2015-06-15  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/44672
+	PR fortran/45440
+	PR fortran/57307
+	* gfortran.h: Extend gfc_code.ext.alloc to carry a
+	flag indicating that the array specification has to be
+	taken from expr3.
+	* resolve.c (resolve_allocate_expr): Add F2008 notify
+	and flag indicating source driven array spec.
+	(resolve_allocate_deallocate): Check for source driven
+	array spec, when array to allocate has no explicit
+	array spec.
+	* trans-array.c (gfc_array_init_size): Get lower and
+	upper bound from a tree array descriptor, except when
+	the source expression is an array-constructor which is
+	fixed to be one-based.
+	(retrieve_last_ref): Extracted from gfc_array_allocate().
+	(gfc_array_allocate): Enable allocate(array, source= 
+	array_expression) as specified by F2008:C633.
+	(gfc_conv_expr_descriptor): Add class tree expression
+	into the saved descriptor for class arrays.
+	* trans-array.h: Add temporary array descriptor to
+	gfc_array_allocate ().
+	* trans-expr.c (gfc_conv_procedure_call): Special handling
+	for _copy() routine translation, that comes without an
+	interface. Third and fourth argument are now passed by value.
+	* trans-stmt.c (gfc_trans_allocate): Get expr3 array
+	descriptor for temporary arrays to allow allocate(array,
+	source = array_expression) for array without array
+	specification.
+
 2015-06-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	* intrinsic.texi:  Change \leq to < in descrition of imaginary
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8e4ca42..4b07ddb 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2395,6 +2395,9 @@ typedef struct gfc_code
     {
       gfc_typespec ts;
       gfc_alloc *list;
+      /* Take the array specification from expr3 to allocate arrays
+	 without an explicit array specification.  */
+      unsigned arr_spec_from_expr3:1;
     }
     alloc;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 52dc109..f365e8ff 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
    have a trailing array reference that gives the size of the array.  */
 
 static bool
-resolve_allocate_expr (gfc_expr *e, gfc_code *code)
+resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
 {
   int i, pointer, allocatable, dimension, is_abstract;
   int codimension;
@@ -7104,13 +7104,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
       || (dimension && ref2->u.ar.dimen == 0))
     {
-      gfc_error ("Array specification required in ALLOCATE statement "
-		 "at %L", &e->where);
-      goto failure;
+      /* F08:C633.  */
+      if (code->expr3)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
+			       "in ALLOCATE statement at %L", &e->where))
+	    goto failure;
+	  *array_alloc_wo_spec = true;
+	}
+      else
+	{
+	  gfc_error ("Array specification required in ALLOCATE statement "
+		     "at %L", &e->where);
+	  goto failure;
+	}
     }
 
   /* Make sure that the array section reference makes sense in the
-    context of an ALLOCATE specification.  */
+     context of an ALLOCATE specification.  */
 
   ar = &ref2->u.ar;
 
@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
   for (i = 0; i < ar->dimen; i++)
     {
-      if (ref2->u.ar.type == AR_ELEMENT)
+      if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
 	goto check_symbols;
 
       switch (ar->dimen_type[i])
@@ -7202,6 +7213,7 @@ failure:
   return false;
 }
 
+
 static void
 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 {
@@ -7376,8 +7388,16 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 
   if (strcmp (fcn, "ALLOCATE") == 0)
     {
+      bool arr_alloc_wo_spec = false;
       for (a = code->ext.alloc.list; a; a = a->next)
-	resolve_allocate_expr (a->expr, code);
+	resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
+
+      if (arr_alloc_wo_spec && code->expr3)
+	{
+	  /* Mark the allocate to have to take the array specification
+	     from the expr3.  */
+	  code->ext.alloc.arr_spec_from_expr3 = 1;
+	}
     }
   else
     {
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5ea9aec..e9174ae 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4998,7 +4998,8 @@ 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)
+		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
+		     tree expr3_desc, bool e3_is_array_constr)
 {
   tree type;
   tree tmp;
@@ -5041,7 +5042,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
       /* Set lower bound.  */
       gfc_init_se (&se, NULL);
-      if (lower == NULL)
+      if (expr3_desc != NULL_TREE)
+	{
+	  if (e3_is_array_constr)
+	    /* The lbound of a constant array [] starts at zero, but when
+	       allocating it, the standard expects the array to start at
+	       one.  */
+	    se.expr = gfc_index_one_node;
+	  else
+	    se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
+						      gfc_rank_cst[n]);
+	}
+      else if (lower == NULL)
 	se.expr = gfc_index_one_node;
       else
 	{
@@ -5069,10 +5081,35 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
       /* Set upper bound.  */
       gfc_init_se (&se, NULL);
-      gcc_assert (ubound);
-      gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
-      gfc_add_block_to_block (pblock, &se.pre);
-
+      if (expr3_desc != NULL_TREE)
+	{
+	  if (e3_is_array_constr)
+	    {
+	      /* The lbound of a constant array [] starts at zero, but when
+	       allocating it, the standard expects the array to start at
+	       one.  Therefore fix the upper bound to be
+	       (desc.ubound - desc.lbound)+ 1.  */
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type,
+				     gfc_conv_descriptor_ubound_get (
+				       expr3_desc, gfc_rank_cst[n]),
+				     gfc_conv_descriptor_lbound_get (
+				       expr3_desc, gfc_rank_cst[n]));
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type, tmp,
+				     gfc_index_one_node);
+	      se.expr = gfc_evaluate_now (tmp, pblock);
+	    }
+	  else
+	    se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
+						      gfc_rank_cst[n]);
+	}
+      else
+	{
+	  gcc_assert (ubound);
+	  gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	}
       gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
 				      gfc_rank_cst[n], se.expr);
       conv_ubound = se.expr;
@@ -5242,6 +5279,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 }
 
 
+/* Retrieve the last ref from the chain.  This routine is specific to
+   gfc_array_allocate ()'s needs.  */
+
+bool
+retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
+{
+  gfc_ref *ref, *prev_ref;
+
+  ref = *ref_in;
+  /* Prevent warnings for uninitialized variables.  */
+  prev_ref = *prev_ref_in;
+  while (ref && ref->next != NULL)
+    {
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+		  || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
+      prev_ref = ref;
+      ref = ref->next;
+    }
+
+  if (ref == NULL || ref->type != REF_ARRAY)
+    return false;
+
+  *ref_in = ref;
+  *prev_ref_in = prev_ref;
+  return true;
+}
+
 /* Initializes the descriptor and generates a call to _gfor_allocate.  Does
    the work for an ALLOCATE statement.  */
 /*GCC ARRAYS*/
@@ -5249,7 +5313,8 @@ 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)
+		    tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
+		    bool e3_is_array_constr)
 {
   tree tmp;
   tree pointer;
@@ -5267,21 +5332,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   gfc_expr **lower;
   gfc_expr **upper;
   gfc_ref *ref, *prev_ref = NULL;
-  bool allocatable, coarray, dimension;
+  bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
 
   ref = expr->ref;
 
   /* Find the last reference in the chain.  */
-  while (ref && ref->next != NULL)
+  if (!retrieve_last_ref (&ref, &prev_ref))
+    return false;
+
+  if (ref->u.ar.type == AR_FULL && expr3 != NULL)
     {
-      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
-		  || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
-      prev_ref = ref;
-      ref = ref->next;
-    }
+      /* F08:C633: Array shape from expr3.  */
+      ref = expr3->ref;
 
-  if (ref == NULL || ref->type != REF_ARRAY)
-    return false;
+      /* Find the last reference in the chain.  */
+      if (!retrieve_last_ref (&ref, &prev_ref))
+	return false;
+      alloc_w_e3_arr_spec = true;
+    }
 
   if (!prev_ref)
     {
@@ -5317,7 +5385,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
       break;
 
     case AR_FULL:
-      gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
+      gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
+		  || alloc_w_e3_arr_spec);
 
       lower = ref->u.ar.as->lower;
       upper = ref->u.ar.as->upper;
@@ -5331,10 +5400,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   overflow = integer_zero_node;
 
   gfc_init_block (&set_descriptor_block);
-  size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
+  size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
+							   : ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3_elem_size, nelems, expr3);
+			      expr3_elem_size, nelems, expr3, e3_arr_desc,
+			      e3_is_array_constr);
 
   if (dimension)
     {
@@ -7073,6 +7144,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       desc = parm;
     }
 
+  /* For class arrays add the class tree into the saved descriptor to
+     enable getting of _vptr and the like.  */
+  if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
+      && IS_CLASS_ARRAY (expr->symtree->n.sym)
+      && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
+    {
+      gfc_allocate_lang_decl (desc);
+      GFC_DECL_SAVED_DESCRIPTOR (desc) =
+	  GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl);
+    }
   if (!se->direct_byref || se->byref_noassign)
     {
       /* Get a pointer to the new descriptor.  */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2155b58..52f1c9a 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 *);
+			 tree, tree *, gfc_expr *, tree, bool);
 
 /* 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 e3f49f5..77d2cda 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4561,6 +4561,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   int has_alternate_specifier = 0;
   bool need_interface_mapping;
   bool callee_alloc;
+  bool ulim_copy;
   gfc_typespec ts;
   gfc_charlen cl;
   gfc_expr *e;
@@ -4569,6 +4570,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
   gfc_component *comp = NULL;
   int arglen;
+  unsigned int argc;
 
   arglist = NULL;
   retargs = NULL;
@@ -4624,10 +4626,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
     }
 
   base_object = NULL_TREE;
+  /* For _vprt->_copy () routines no formal symbol is present.  Nevertheless
+     is the third and fourth argument to such a function call a value
+     denoting the number of elements to copy (i.e., most of the time the
+     length of a deferred length string).  */
+  ulim_copy = formal == NULL && UNLIMITED_POLY (sym)
+      && strcmp ("_copy", comp->name) == 0;
 
   /* Evaluate the arguments.  */
-  for (arg = args; arg != NULL;
-       arg = arg->next, formal = formal ? formal->next : NULL)
+  for (arg = args, argc = 0; arg != NULL;
+       arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
@@ -4729,7 +4737,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  gfc_init_se (&parmse, se);
 	  parm_kind = ELEMENTAL;
 
-	  if (fsym && fsym->attr.value)
+	  /* When no fsym is present, ulim_copy is set and this is a third or
+	     fourth argument, use call-by-value instead of by reference to
+	     hand the length properties to the copy routine (i.e., most of the
+	     time this will be a call to a __copy_character_* routine where the
+	     third and fourth arguments are the lengths of a deferred length
+	     char array).  */
+	  if ((fsym && fsym->attr.value)
+	      || (ulim_copy && (argc == 2 || argc == 3)))
 	    gfc_conv_expr (&parmse, e);
 	  else
 	    gfc_conv_expr_reference (&parmse, e);
@@ -5322,7 +5337,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
 	    && e->ts.u.derived->attr.alloc_comp
 	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
-	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
+	    && e->expr_type != EXPR_VARIABLE && !e->rank)
         {
 	  int parm_rank;
 	  tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 69750df..6772a3c 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5098,6 +5098,8 @@ gfc_trans_allocate (gfc_code * code)
      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;
+  /* Classify what expr3 stores.  */
+  enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
   stmtblock_t block;
   stmtblock_t post;
   tree nelems;
@@ -5110,6 +5112,7 @@ gfc_trans_allocate (gfc_code * code)
   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;
+  e3_is = E3_UNSET;
 
   gfc_init_block (&block);
   gfc_init_block (&post);
@@ -5149,16 +5152,14 @@ gfc_trans_allocate (gfc_code * code)
      expression.  */
   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;
+      bool vtab_needed = false, temp_var_needed = false;
 
       /* 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);
 
+      gfc_init_se (&se, NULL);
       /* When expr3 is a variable, i.e., a very simple expression,
 	     then convert it once here.  */
       if (code->expr3->expr_type == EXPR_VARIABLE
@@ -5167,31 +5168,25 @@ gfc_trans_allocate (gfc_code * code)
 	{
 	  if (!code->expr3->mold
 	      || code->expr3->ts.type == BT_CHARACTER
-	      || vtab_needed)
+	      || vtab_needed
+	      || code->ext.alloc.arr_spec_from_expr3)
 	    {
-	      /* Convert expr3 to a tree.  */
-	      gfc_init_se (&se, NULL);
-	      /* For all "simple" expression just get the descriptor or the
-		 reference, respectively, depending on the rank of the expr.  */
-	      if (code->expr3->rank != 0)
+	      /* Convert expr3 to a tree.  For all "simple" expression just
+		 get the descriptor or the reference, respectively, depending
+		 on the rank of the expr.  */
+	      if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
 		gfc_conv_expr_descriptor (&se, code->expr3);
 	      else
 		gfc_conv_expr_reference (&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);
+	      /* Create a temp variable only for component refs to prevent
+		 having to go through the full deref-chain each time and to
+		 simplfy computation of array properties.  */
+	      temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
 	    }
-	  /* else expr3 = NULL_TREE set above.  */
 	}
       else
 	{
-	  /* In all other cases evaluate the expr3 and create a
-		 temporary.  */
-	  gfc_init_se (&se, NULL);
+	  /* In all other cases evaluate the expr3.  */
 	  symbol_attribute attr;
 	  /* Get the descriptor for all arrays, that are not allocatable or
 	     pointer, because the latter are descriptors already.  */
@@ -5205,45 +5200,55 @@ gfc_trans_allocate (gfc_code * code)
 				     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))
+	  temp_var_needed = !VAR_P (se.expr);
+	}
+      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 (se.expr != NULL_TREE && temp_var_needed)
+	{
+	  tree var;
+	  tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
+		se.expr
+	      : build_fold_indirect_ref_loc (input_location, se.expr);
+	  /* We need a regular (non-UID) symbol here, therefore give a
+	     prefix.  */
+	  var = gfc_create_var (TREE_TYPE (tmp), "source");
+	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
 	    {
-	      tree var;
-	      tmp = build_fold_indirect_ref_loc (input_location,
-						 se.expr);
-	      /* We need a regular (non-UID) symbol here, therefore give a
-		 prefix.  */
-	      var = gfc_create_var (TREE_TYPE (tmp), "source");
-	      gfc_add_modify_loc (input_location, &block, var, tmp);
-
-	      /* Deallocate any allocatable components after all the allocations
-		 and assignments of expr3 have been completed.  */
-	      if (code->expr3->ts.type == BT_DERIVED
-		  && code->expr3->rank == 0
-		  && code->expr3->ts.u.derived->attr.alloc_comp)
-		{
-		  tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
-						   var, 0);
-		  gfc_add_expr_to_block (&post, tmp);
-		}
+	      gfc_allocate_lang_decl (var);
+	      GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+	    }
+	  gfc_add_modify_loc (input_location, &block, var, tmp);
 
-	      tmp = var;
+	  /* Deallocate any allocatable components after all the allocations
+	     and assignments of expr3 have been completed.  */
+	  if (code->expr3->ts.type == BT_DERIVED
+	      && code->expr3->rank == 0
+	      && code->expr3->ts.u.derived->attr.alloc_comp)
+	    {
+	      tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
+					       var, 0);
+	      gfc_add_expr_to_block (&post, tmp);
 	    }
-	  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.  */
+
+	  expr3 = var;
 	  if (se.string_length)
+	    /* Evaluate it assuming that it also is complicated like expr3.  */
 	    expr3_len = gfc_evaluate_now (se.string_length, &block);
 	}
+      else
+	{
+	  expr3 = se.expr;
+	  expr3_len = se.string_length;
+	}
+      /* Store what the expr3 is to be used for.  */
+      e3_is = expr3 != NULL_TREE ?
+	    (code->ext.alloc.arr_spec_from_expr3 ?
+	       E3_DESC
+	     : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+	  : E3_UNSET;
 
       /* Figure how to get the _vtab entry.  This also obtains the tree
 	 expression for accessing the _len component, because only
@@ -5258,10 +5263,6 @@ gfc_trans_allocate (gfc_code * code)
 	  if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
 	      && (VAR_P (expr3) || !code->expr3->ref))
 	    tmp = gfc_class_vptr_get (expr3);
-	  else if (expr3_tmp != NULL_TREE
-		   && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp))
-		   && (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);
@@ -5281,9 +5282,7 @@ gfc_trans_allocate (gfc_code * code)
 	    {
 	      /* 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);
+		expr3_len = gfc_class_len_get (expr3);
 	      else
 		{
 		  rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5344,8 +5343,11 @@ gfc_trans_allocate (gfc_code * code)
 	     advantage is, that we get scalarizer support for free,
 	     don't have to take care about scalar to array treatment and
 	     will benefit of every enhancements gfc_trans_assignment ()
-	     gets.  */
-	  if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+	     gets.
+	     No need to check whether e3_is is E3_UNSET, because that is
+	     done by expr3 != NULL_TREE.  */
+	  if (e3_is != E3_MOLD && expr3 != NULL_TREE
+	      && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
 	    {
 	      /* Build a temporary symtree and symbol.  Do not add it to
 		 the current namespace to prevent accidently modifying
@@ -5397,6 +5399,12 @@ gfc_trans_allocate (gfc_code * code)
 	}
       gcc_assert (expr3_esize);
       expr3_esize = fold_convert (sizetype, expr3_esize);
+      if (e3_is == E3_MOLD)
+	{
+	  /* The expr3 is no longer valid after this point.  */
+	  expr3 = NULL_TREE;
+	  e3_is = E3_UNSET;
+	}
     }
   else if (code->ext.alloc.ts.type != BT_UNKNOWN)
     {
@@ -5496,7 +5504,11 @@ gfc_trans_allocate (gfc_code * code)
       else
 	tmp = expr3_esize;
       if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
-			       label_finish, tmp, &nelems, code->expr3))
+			       label_finish, tmp, &nelems,
+			       e3rhs ? e3rhs : code->expr3,
+			       e3_is == E3_DESC ? expr3 : NULL_TREE,
+			       code->expr3 != NULL && e3_is == E3_DESC
+			       && code->expr3->expr_type == EXPR_ARRAY))
 	{
 	  /* A scalar or derived type.  First compute the size to
 	     allocate.
@@ -5702,11 +5714,15 @@ gfc_trans_allocate (gfc_code * code)
 	  if (expr3 != NULL_TREE
 	      && ((POINTER_TYPE_P (TREE_TYPE (expr3))
 		   && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
-		  || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+		  || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+			TREE_TYPE (expr3))))
 	      && code->expr3->ts.type == BT_CLASS
 	      && (expr->ts.type == BT_CLASS
 		  || expr->ts.type == BT_DERIVED))
 	    {
+	      /* copy_class_to_class can be used for class arrays, too.
+		 It just needs to be ensured, that the decl_saved_descriptor
+		 has a way to get to the vptr.  */
 	      tree to;
 	      to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
 	      tmp = gfc_copy_class_to_class (expr3, to,
@@ -5740,30 +5756,14 @@ gfc_trans_allocate (gfc_code * code)
 
 	      if (dataref && dataref->u.c.component->as)
 		{
-		  int dim;
-		  gfc_expr *temp;
-		  gfc_ref *ref = dataref->next;
-		  ref->u.ar.type = AR_SECTION;
-		  /* We have to set up the array reference to give ranges
-		     in all dimensions and ensure that the end and stride
-		     are set so that the copy can be scalarized.  */
-		  dim = 0;
-		  for (; dim < dataref->u.c.component->as->rank; dim++)
-		    {
-		      ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
-		      if (ref->u.ar.end[dim] == NULL)
-			{
-			  ref->u.ar.end[dim] = ref->u.ar.start[dim];
-			  temp = gfc_get_int_expr (gfc_default_integer_kind,
-						   &al->expr->where, 1);
-			  ref->u.ar.start[dim] = temp;
-			}
-		      temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
-					   gfc_copy_expr (ref->u.ar.start[dim]));
-		      temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
-							&al->expr->where, 1),
-				      temp);
-		    }
+		  gfc_array_spec *as = dataref->u.c.component->as;
+		  gfc_free_ref_list (dataref->next);
+		  dataref->next = NULL;
+		  gfc_add_full_array_ref (last_arg->expr, as);
+		  gfc_resolve_expr (last_arg->expr);
+		  gcc_assert (last_arg->expr->ts.type == BT_CLASS
+			      || last_arg->expr->ts.type == BT_DERIVED);
+		  last_arg->expr->ts.type = BT_CLASS;
 		}
 	      if (rhs->ts.type == BT_CLASS)
 		{
@@ -5845,7 +5845,7 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_add_expr_to_block (&block, tmp);
 	}
      else if (code->expr3 && code->expr3->mold
-	    && code->expr3->ts.type == BT_CLASS)
+	      && code->expr3->ts.type == BT_CLASS)
 	{
 	  /* Since the _vptr has already been assigned to the allocate
 	     object, we can use gfc_copy_class_to_class in its