Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec

[Andre Vehreschild <vehre at gmx dot de>]

Hi Mikael,

thanks for the comments so far.

> I don't understand why one of your previous patches was factoring the
> source expression evaluation to a temporary in gfc_trans_allocate, and
> now with this patch you do the same thing in gfc_resolve_allocate, not
> reusing the part in gfc_trans_allocate.

When I remember correctly, then at the time of writing this patch the one
factoring out the temporary in gfc_trans_allocate() was not doing that yet. At
least it was not doing it always as needed. Therefore we are looking at a kind
of history here already. 

> 
> > *************** failure:
> > *** 7201,7212 ****
> > --- 7212,7229 ----
> >     return false;
> >   }
> >   
> > + 
> >   static void
> >   resolve_allocate_deallocate (gfc_code *code, const char *fcn)
> >   {
> >     gfc_expr *stat, *errmsg, *pe, *qe;
> >     gfc_alloc *a, *p, *q;
> >   
> > +   /* When this flag is set already, then this allocate has already been
> > +      resolved.  Doing so again, would result in an endless loop.  */
> > +   if (code->ext.alloc.arr_spec_from_expr3)
> > +     return;
> > + 
> I expect you'll miss some error messages by doing this.
> Where is the endless loop?

This has been removed. The endless loop was triggered by gfc_resolve_code () in
line 179 of the patch, which is now in chunk that is mostly removed.

> > *************** resolve_allocate_deallocate (gfc_code *c
> > *** 7375,7382 ****
> > --- 7392,7500 ----
> >   
> >     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, &arr_alloc_wo_spec);
> > ! 
> > !       if (arr_alloc_wo_spec && code->expr3)
> > ! 	{
> 	[...]
> > ! 
> > ! 	      ass = gfc_get_code (EXEC_ASSIGN);
> This memory is not freed as far as I know.
> I think you can use a local variable for it.

Complete block removed. Therefore fixed.

> *** /tmp/PRaWHc_trans-expr.c	2015-05-25 19:54:35.056309429 +0200
> --- /tmp/7e82nd_trans-expr.c	2015-05-25 19:54:35.058309429 +0200
> *************** gfc_conv_procedure_call (gfc_se * se, gf
> *** 5328,5334 ****
>         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))
>           {
>   	  int parm_rank;
>   	  tmp = build_fold_indirect_ref_loc (input_location,
> --- 5328,5335 ----
>         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_STRUCTURE)
>           {
>   	  int parm_rank;
>   	  tmp = build_fold_indirect_ref_loc (input_location,
> 
> Can't you remove this? It's undone by the PR58586 patch.

Removed, looks like an artefact of a long forgotten need.

> > *************** gfc_trans_allocate (gfc_code * code)
> > *** 5733,5746 ****
> >   
> >   	      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;
> > --- 5758,5815 ----
> >   
> >   	      if (dataref && dataref->u.c.component->as)
> >   		{
> > ! 		  int dim = 0;
> >   		  gfc_expr *temp;
> >   		  gfc_ref *ref = dataref->next;
> >   		  ref->u.ar.type = AR_SECTION;
> > + 		  if (code->ext.alloc.arr_spec_from_expr3)
> > + 		    {
> > + 		      /* Take the array dimensions from the
> > + 			 source=-expression.  */
> > + 		      gfc_array_ref *source_ref =
> > + 			  gfc_find_array_ref (code->expr3);
> Does this work?  code->expr3 is not always a variable.

The block removed from resolve_allocate() ensured, that this was always a
variable. Therefore, yes, it had to work then. Now, we of course have far more
trouble.

> 
> > + 		      if (source_ref->type == AR_FULL)
> > + 			{
> > + 			  /* For full array refs copy the bounds.  */
> > + 			  for (; dim < dataref->u.c.component->as->rank;
> > dim++)
> > + 			    {
> > + 			      ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
> > + 			      ref->u.ar.start[dim] =
> > + 				  gfc_copy_expr
> > (source_ref->as->lower[dim]);
> > + 			      ref->u.ar.end[dim] =
> > + 				  gfc_copy_expr
> > (source_ref->as->upper[dim]);
> > + 			    }
> This won't work.  Consider this:
> 	block
> 	  integer :: a(n)
> 	  n = n+1
> 	  allocate(b, source=a)
> 	end block
> 
> You have to use a full array ref.  In fact you can use a full array ref
> everywhere, I think.

I don't get you there. Using a full array ref produces numerous regressions.
Have a look at the current patch. The full array ref is in the
#if-#else-#endif's #else block. Any ideas?

Bootstraps and regtests fine on x86_64-linux-gnu.

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

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 905d47c..211c781 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2396,6 +2396,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 e615cc6..315170a 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 c8fab45..014ee53 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5005,7 +5005,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)
 {
   tree type;
   tree tmp;
@@ -5020,7 +5021,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
   tree var;
   stmtblock_t thenblock;
   stmtblock_t elseblock;
-  gfc_expr *ubound;
+  gfc_expr *ubound = NULL;
   gfc_se se;
   int n;
 
@@ -5035,6 +5036,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
   or_expr = boolean_false_node;
 
+  /* When expr3_desc is set, use its rank, because we want to allocate an
+     array with the array_spec coming from source=.  */
+  if (expr3_desc != NULL_TREE)
+    rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc));
+
   for (n = 0; n < rank; n++)
     {
       tree conv_lbound;
@@ -5044,24 +5050,29 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 	 lower == NULL    => lbound = 1, ubound = upper[n]
 	 upper[n] = NULL  => lbound = 1, ubound = lower[n]
 	 upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
-      ubound = upper[n];
 
       /* Set lower bound.  */
       gfc_init_se (&se, NULL);
-      if (lower == NULL)
+      if (expr3_desc != NULL_TREE)
 	se.expr = gfc_index_one_node;
       else
 	{
-	  gcc_assert (lower[n]);
-	  if (ubound)
-	    {
-	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
-	      gfc_add_block_to_block (pblock, &se.pre);
-	    }
+	  ubound = upper[n];
+	  if (lower == NULL)
+	    se.expr = gfc_index_one_node;
 	  else
 	    {
-	      se.expr = gfc_index_one_node;
-	      ubound = lower[n];
+	      gcc_assert (lower[n]);
+	      if (ubound)
+		{
+		  gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+		  gfc_add_block_to_block (pblock, &se.pre);
+		}
+	      else
+		{
+		  se.expr = gfc_index_one_node;
+		  ubound = lower[n];
+		}
 	    }
 	}
       gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5076,10 +5087,25 @@ 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)
+	{
+	  /* Set 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]));
+	  se.expr = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type, tmp,
+				     gfc_index_one_node);
+	}
+      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;
@@ -5249,6 +5275,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*/
@@ -5256,7 +5309,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)
+		    tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
 {
   tree tmp;
   tree pointer;
@@ -5274,21 +5327,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)
     {
@@ -5324,7 +5380,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;
@@ -5338,10 +5395,11 @@ 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);
 
   if (dimension)
     {
@@ -7080,6 +7138,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..6e5378f 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);
 
 /* 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 9be8a42..3916836 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5328,7 +5328,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 81943b0..c9c112f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5104,7 +5104,7 @@ gfc_trans_allocate (gfc_code * code)
      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;
+  tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
   stmtblock_t block;
   stmtblock_t post;
   tree nelems;
@@ -5117,6 +5117,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;
+  expr3_desc = NULL_TREE;
 
   gfc_init_block (&block);
   gfc_init_block (&post);
@@ -5174,21 +5175,31 @@ 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)
-		gfc_conv_expr_descriptor (&se, code->expr3);
-	      else
-		gfc_conv_expr_reference (&se, code->expr3);
-	      if (!code->expr3->mold)
-		expr3 = se.expr;
+	      if (code->ext.alloc.arr_spec_from_expr3)
+		{
+		  gfc_conv_expr_descriptor (&se, code->expr3);
+		  expr3_desc = se.expr;
+		}
 	      else
-		expr3_tmp = se.expr;
-	      expr3_len = se.string_length;
+		{
+		  /* For all "simple" expression just get the descriptor
+		     or the reference, respectively, depending on the
+		     rank of the expr.  */
+		  if (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);
 	    }
@@ -5215,7 +5226,7 @@ gfc_trans_allocate (gfc_code * code)
 	  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.  */
+	     variable declaration.  */
 	  if (!VAR_P (se.expr))
 	    {
 	      tree var;
@@ -5229,7 +5240,9 @@ gfc_trans_allocate (gfc_code * code)
 	    }
 	  else
 	    tmp = se.expr;
-	  if (!code->expr3->mold)
+	  if (code->ext.alloc.arr_spec_from_expr3)
+	    expr3_desc = tmp;
+	  else if (!code->expr3->mold)
 	    expr3 = tmp;
 	  else
 	    expr3_tmp = tmp;
@@ -5291,6 +5304,7 @@ gfc_trans_allocate (gfc_code * code)
 	}
       else
 	{
+	  tree inexpr3;
 	  /* 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.  */
@@ -5339,7 +5353,9 @@ gfc_trans_allocate (gfc_code * code)
 	     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))
+	  inexpr3 = expr3_desc ? expr3_desc : expr3;
+	  if (inexpr3 != NULL_TREE && DECL_P (inexpr3)
+	      && DECL_ARTIFICIAL (inexpr3))
 	    {
 	      /* Build a temporary symtree and symbol.  Do not add it to
 		 the current namespace to prevent accidently modifying
@@ -5349,11 +5365,11 @@ gfc_trans_allocate (gfc_code * code)
 		 gfc_create_var () took care about generating the
 		 identifier.  */
 	      newsym->name = gfc_get_string (IDENTIFIER_POINTER (
-					       DECL_NAME (expr3)));
+					       DECL_NAME (inexpr3)));
 	      newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
 	      /* The backend_decl is known.  It is expr3, which is inserted
 		 here.  */
-	      newsym->n.sym->backend_decl = expr3;
+	      newsym->n.sym->backend_decl = inexpr3;
 	      e3rhs = gfc_get_expr ();
 	      e3rhs->ts = code->expr3->ts;
 	      e3rhs->rank = code->expr3->rank;
@@ -5379,7 +5395,7 @@ gfc_trans_allocate (gfc_code * code)
 		  newsym->n.sym->as = arr;
 		  gfc_add_full_array_ref (e3rhs, arr);
 		}
-	      else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+	      else if (POINTER_TYPE_P (TREE_TYPE (inexpr3)))
 		newsym->n.sym->attr.pointer = 1;
 	      /* The string length is known to.  Set it for char arrays.  */
 	      if (e3rhs->ts.type == BT_CHARACTER)
@@ -5490,7 +5506,8 @@ 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, expr3_desc))
 	{
 	  /* A scalar or derived type.  First compute the size to
 	     allocate.
@@ -5693,17 +5710,26 @@ gfc_trans_allocate (gfc_code * code)
 	{
 	  /* Initialization via SOURCE block (or static default initializer).
 	     Classes need some special handling, so catch them first.  */
-	  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))))
+	  if ((expr3_desc != NULL_TREE
+	       || (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))))))
 	      && code->expr3->ts.type == BT_CLASS
 	      && (expr->ts.type == BT_CLASS
 		  || expr->ts.type == BT_DERIVED))
 	    {
-	      tree to;
+	      /* 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, from;
 	      to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
-	      tmp = gfc_copy_class_to_class (expr3, to,
+	      /* Only use the array descriptor in expr3_desc, when it is
+		 set and not in a mold= expression.  */
+	      from = expr3_desc == NULL_TREE || code->expr3->mold ?
+		       expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+	      tmp = gfc_copy_class_to_class (from, to,
 					     nelems, upoly_expr);
 	    }
 	  else if (al->expr->ts.type == BT_CLASS)
@@ -5734,30 +5760,86 @@ gfc_trans_allocate (gfc_code * code)
 
 	      if (dataref && dataref->u.c.component->as)
 		{
-		  int dim;
+#if 1
+		  int dim = 0;
 		  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++)
+		  if (code->ext.alloc.arr_spec_from_expr3)
+		    {
+		      /* Take the array dimensions from the
+			 source=-expression.  */
+		      gfc_array_ref *source_ref =
+			  gfc_find_array_ref (e3rhs ? e3rhs : code->expr3);
+		      if (source_ref->type == AR_FULL)
+			{
+			  /* For full array refs copy the bounds.  */
+			  for (; dim < dataref->u.c.component->as->rank; dim++)
+			    {
+			      ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+			      ref->u.ar.start[dim] =
+				  gfc_copy_expr (source_ref->as->lower[dim]);
+			      ref->u.ar.end[dim] =
+				  gfc_copy_expr (source_ref->as->upper[dim]);
+			    }
+			}
+		      else
+			{
+			  int sdim = 0;
+			  /* For partial array refs, the partials.  */
+			  for (; dim < dataref->u.c.component->as->rank;
+			       dim++, sdim++)
+			    {
+			      ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+			      ref->u.ar.start[dim] =
+				  gfc_get_int_expr (gfc_default_integer_kind,
+						    &al->expr->where, 1);
+			      /* Skip over element dimensions.  */
+			      while (source_ref->dimen_type[sdim]
+				     == DIMEN_ELEMENT)
+				++sdim;
+			      temp = gfc_subtract (gfc_copy_expr (
+						     source_ref->end[sdim]),
+						   gfc_copy_expr (
+						     source_ref->start[sdim]));
+			      ref->u.ar.end[dim] = gfc_add (temp,
+				    gfc_get_int_expr (gfc_default_integer_kind,
+						      &al->expr->where, 1));
+			    }
+			}
+		    }
+		  else
 		    {
-		      ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
-		      if (ref->u.ar.end[dim] == NULL)
+		      /* 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.  */
+		      for (; dim < dataref->u.c.component->as->rank; dim++)
 			{
-			  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;
+			  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);
 			}
-		      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);
 		    }
+#else
+		  gfc_free_ref_list (dataref->next);
+		  dataref->next = NULL;
+		  gfc_add_full_array_ref (last_arg->expr,
+				gfc_get_full_arrayspec_from_expr (e3rhs ? e3rhs
+								: code->expr3));
+#endif
 		}
 	      if (rhs->ts.type == BT_CLASS)
 		{
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
 !
 ! Contributed by Reinhold Bader
 !
 program assumed_shape_01
-  use, intrinsic :: iso_c_binding
   implicit none
-  type, bind(c) :: cstruct
-     integer(c_int) :: i
-     real(c_float) :: r(2)
+  type :: cstruct
+     integer :: i
+     real :: r(2)
   end type cstruct
-  interface
-     subroutine psub(this, that) bind(c, name='Psub')
-       import :: c_float, cstruct
-       real(c_float) :: this(:,:)
-       type(cstruct) :: that(:)
-     end subroutine psub
-  end interface
-
-  real(c_float) :: t(3,7)
+
   type(cstruct), pointer :: u(:)
+  integer, allocatable :: iv(:), iv2(:)
+  integer, allocatable :: im(:,:)
+  integer, parameter :: cim(2,3) = reshape([1,2,3, 2,3,4], [2,3])
+  integer :: i
+  integer, parameter :: lcim(2,10) = reshape([(i, i=1,10),(i,i=1,10)], [2,10])
+
+  allocate(iv, source= [ 1, 2, 3, 4])
+  if (any(iv /= [ 1, 2, 3, 4])) call abort()
+  deallocate(iv)
+
+  allocate(iv, source=(/(i, i=1,10)/))
+  if (any(iv /= (/(i, i=1,10)/))) call abort()
+
+  ! Now 2D
+  allocate(im, source= cim)
+  if (any(im /= cim)) call abort()
+  deallocate(im)
+
+  allocate(im, source= reshape([iv, iv], [2, size(iv, 1)]))
+  if (any(im /= lcim)) call abort()
+  deallocate(im)
+  deallocate(iv)
+
+  allocate(u, source=[cstruct( 4, [1.1,2.2] )] )
+  if (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+  deallocate (u)
 
-! The following is VALID Fortran 2008 but NOT YET supported 
-  allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) ! { dg-error "Array specification required in ALLOCATE statement" }
-  call psub(t, u)
+  allocate(iv, source= arrval())
+  if (any(iv /= [ 1, 2, 4, 5, 6])) call abort()
+  ! Check simple array assign
+  allocate(iv2, source=iv)
+  if (any(iv2 /= [ 1, 2, 4, 5, 6])) call abort()
+  deallocate(iv, iv2)
+
+  ! Now check for mold=
+  allocate(iv, mold= [ 1, 2, 3, 4])
+  if (any(shape(iv) /= [4])) call abort()
+  deallocate(iv)
+
+  allocate(iv, mold=(/(i, i=1,10)/))
+  if (any(shape(iv) /= [10])) call abort()
+
+  ! Now 2D
+  allocate(im, mold= cim)
+  if (any(shape(im) /= shape(cim))) call abort()
+  deallocate(im)
+
+  allocate(im, mold= reshape([iv, iv], [2, size(iv, 1)]))
+  if (any(shape(im) /= shape(lcim))) call abort()
+  deallocate(im)
+  deallocate(iv)
+
+  allocate(u, mold=[cstruct( 4, [1.1,2.2] )] )
+  if (any(shape(u(1)%r(:)) /= 2)) call abort()
   deallocate (u)
 
+  allocate(iv, mold= arrval())
+  if (any(shape(iv) /= [5])) call abort()
+  ! Check simple array assign
+  allocate(iv2, mold=iv)
+  if (any(shape(iv2) /= [5])) call abort()
+  deallocate(iv, iv2)
+
+  call addData([4, 5])
+  call addData(["foo", "bar"])
+contains
+  function arrval()
+    integer, dimension(5) :: arrval
+    arrval = [ 1, 2, 4, 5, 6]
+  end function
+
+  subroutine addData(P)
+    class(*), intent(in) :: P(:)
+    class(*), allocatable :: cP(:)
+    allocate (cP, source= P)
+    select type (cP)
+      type is (integer)
+        if (any(cP /= [4,5])) call abort()
+      type is (character(*))
+        if (len(cP) /= 3) call abort()
+        if (any(cP /= ["foo", "bar"])) call abort()
+      class default
+        call abort()
+    end select
+    deallocate (cP)
+    allocate (cP, mold= P)
+    select type (cP)
+      type is (integer)
+        if (any(size(cP) /= [2])) call abort()
+      type is (character(*))
+        if (len(cP) /= 3) call abort()
+        if (any(size(cP) /= [2])) call abort()
+      class default
+        call abort()
+    end select
+    deallocate (cP)
+  end subroutine
 end program assumed_shape_01
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
@@ -0,0 +1,79 @@
+! { dg-do run }
+!
+! Check that allocate with source for arrays without array-spec
+! works.
+! PR fortran/44672
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!                Antony Lewis  <antony@cosmologist.info>
+!                Andre Vehreschild  <vehre@gcc.gnu.org>
+!
+
+program allocate_with_source_6
+
+  type P
+    class(*), allocatable :: X(:,:)
+  end type
+
+  type t
+  end type t
+
+  type(t), allocatable :: a(:), b, c(:)
+  integer :: num_params_used = 6
+  integer, allocatable :: m(:)
+
+  allocate(b,c(5))
+  allocate(a(5), source=b)
+  deallocate(a)
+  allocate(a, source=c)
+  allocate(m, source=[(I, I=1, num_params_used)])
+  if (any(m /= [(I, I=1, num_params_used)])) call abort()
+  deallocate(a,b,m)
+  call testArrays()
+
+contains
+  subroutine testArrays()
+    type L
+      class(*), allocatable :: v(:)
+    end type
+    Type(P) Y
+    type(L) o
+    real arr(3,5)
+    real, allocatable :: v(:)
+
+    arr = 5
+    allocate(Y%X, source=arr)
+    select type (R => Y%X)
+      type is (real)
+        if (any(reshape(R, [15]) /= [5,5,5,5,5, 5,5,5,5,5, 5,5,5,5,5])) &
+          call abort()
+      class default
+        call abort()
+    end select
+    deallocate(Y%X)
+
+    allocate(Y%X, source=arr(2:3,3:4))
+    select type (R => Y%X)
+      type is (real)
+        if (any(reshape(R, [4]) /= [5,5,5,5])) &
+          call abort()
+      class default
+        call abort()
+    end select
+    deallocate(Y%X)
+
+    allocate(o%v, source=arr(2,3:4))
+    select type (R => o%v)
+      type is (real)
+        if (any(R /= [5,5])) &
+          call abort()
+      class default
+        call abort()
+    end select
+    deallocate(o%v)
+
+    allocate(v, source=arr(2,1:5))
+    if (any(v /= [5,5,5,5,5])) call abort()
+    deallocate(v)
+  end subroutine testArrays
+end
+