diff mbox

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

Message ID 20150529134603.0dc5abf9@vepi2
State New
Headers show

Commit Message

Andre Vehreschild May 29, 2015, 11:46 a.m. UTC
Hi Mikael,

comments inline below:

On Thu, 28 May 2015 20:06:57 +0200
Mikael Morin <mikael.morin@sfr.fr> wrote:

> Le 28/05/2015 17:29, Andre Vehreschild a écrit :
> > *************** resolve_allocate_expr (gfc_expr *e, gfc_
> > *** 7103,7112 ****
> > --- 7103,7123 ----
> >     if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
> >         || (dimension && ref2->u.ar.dimen == 0))
> >       {
> > +       /* 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.  */
> I think we can be a little be more user friendly with the gfc_notify_std
> error message.
> Something like:
> ALLOCATE without array spec at %L
> ALLOCATE with array bounds determined from SOURCE or MOLD at %L

I didn't want to mess with the error messages to prevent issues for
translations. So how is the policy on this? 

> > *************** gfc_array_init_size (tree descriptor, in
> > *** 5044,5053 ****
> >   	 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)
> >   	se.expr = gfc_index_one_node;
> >         else
> > --- 5050,5063 ----
> >   	 lower == NULL    => lbound = 1, ubound = upper[n]
> >   	 upper[n] = NULL  => lbound = 1, ubound = lower[n]
> >   	 upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
> >   
> >         /* Set lower bound.  */
> >         gfc_init_se (&se, NULL);
> > +       if (expr3_desc != NULL_TREE)
> > + 	se.expr = gfc_index_one_node;
> > +       else
> > + 	{
> > + 	  ubound = upper[n];
> >   	  if (lower == NULL)
> >   	    se.expr = gfc_index_one_node;
> >   	  else
> > *************** gfc_array_init_size (tree descriptor, in
> > *** 5064,5069 ****
> > --- 5074,5080 ----
> >   		  ubound = lower[n];
> >   		}
> >   	    }
> > + 	}
> >         gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
> >   				      gfc_rank_cst[n], se.expr);
> >         conv_lbound = se.expr;
> You can avoid reindenting if the ubound = upper[n] statement is kept at
> its original place.

Fixed.

> > *************** gfc_array_init_size (tree descriptor, in
> > *** 5076,5085 ****
> >   
> >         /* 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);
> > ! 
> >         gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
> >   				      gfc_rank_cst[n], se.expr);
> >         conv_ubound = se.expr;
> > --- 5087,5111 ----
> >   
> >         /* Set upper bound.  */
> >         gfc_init_se (&se, NULL);
> > +       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;
> Your one-based-ness problem was here, wasn't it?

Correct.

> I would rather copy directly lbound and ubound from expr3_desc to
> descriptor.

It was that way in the previous version of the patch, which does *not* work any
longer. When gfc_trans_allocate () is responsible for the creating a temporary
variable for the source=-expression, then it does so using zero based
expressions. 

> If the source has non-one-based bounds, the above would produce wrong
> bounds.

Counterexample? Note, the expr3_desc is guaranteed to be an artificial variable
created by conv_expr_descriptor, aka zero-based.

<snipp>

> > *************** gfc_trans_allocate (gfc_code * code)
> > *** 5229,5235 ****
> >   	    }
> >   	  else
> >   	    tmp = se.expr;
> > ! 	  if (!code->expr3->mold)
> >   	    expr3 = tmp;
> >   	  else
> >   	    expr3_tmp = tmp;
> > --- 5240,5248 ----
> >   	    }
> >   	  else
> >   	    tmp = se.expr;
> > ! 	  if (code->ext.alloc.arr_spec_from_expr3)
> > ! 	    expr3_desc = tmp;
> > ! 	  else if (!code->expr3->mold)
> >   	    expr3 = tmp;
> >   	  else
> >   	    expr3_tmp = tmp;
> Couldn't expr3 be reused?
> We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc,
> and (below) inexpr3. :-(

Of course can we use just two variables for all expressions. I have removed the
expr3_tmp, inexpr3 and expr3_desc and introduced a e3_is enumeration, which
stores which kind the expr3 is, aka unset, source, mold, desc. This makes the
code simpler at some places.

Attached is a new version of the patch. This one fails
allocate_with_source_3.f90 on runtime, where I don't see the issue currently.
May be you have some luck and time. If not I will investigate on Monday.

Regards,
	Andre

Comments

Thomas Koenig May 29, 2015, 11:08 p.m. UTC | #1
Hi Andre,

just a couple of remarks.

You are adding significant new code to an existing
test case, allocate_with_source_3.f90.  As discussed
previously, it would be better to put the new code
into an extra test case.

The following test case segfaults with your patch
with an "invalid free":

module foo
contains
  integer function f()
    f = 2
  end function f
end module foo
program main
  use foo
  integer :: n
  n = 42
  block
    real, dimension(0:n) :: a
    real, dimension(:), allocatable :: c
    call random_number(a)
    allocate(c,source=a(:f()))
  end block
end program main

You could also add

    n = n - 1
    allocate(c,source=a)
    if (size(a,1) /= size(c,1)) call abort

to the test case above to make sure that changing a variable
that was used to declare an array bound does not lead to wrong
code.

Regards

	Thomas
Mikael Morin June 2, 2015, 4:50 p.m. UTC | #2
Hello Andre,

comments below (out of order, sorry).

Le 29/05/2015 13:46, Andre Vehreschild a écrit :
> Hi Mikael,
> 
> comments inline below:
> 
> On Thu, 28 May 2015 20:06:57 +0200
> Mikael Morin <mikael.morin@sfr.fr> wrote:
> 
>> Le 28/05/2015 17:29, Andre Vehreschild a écrit :
>>> *************** resolve_allocate_expr (gfc_expr *e, gfc_
>>> *** 7103,7112 ****
>>> --- 7103,7123 ----
>>>     if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
>>>         || (dimension && ref2->u.ar.dimen == 0))
>>>       {
>>> +       /* 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.  */
>> I think we can be a little be more user friendly with the gfc_notify_std
>> error message.
>> Something like:
>> ALLOCATE without array spec at %L
>> ALLOCATE with array bounds determined from SOURCE or MOLD at %L
> 
> I didn't want to mess with the error messages to prevent issues for
> translations. So how is the policy on this? 
> 
I'm not aware of any policy regarding translations.
With a message like:
	fortran 2008: array specification required ...
I don't see how the user can understand that the array specification is
_not_ required with fortran 2008, regardless of translations.
I'm rather in favour of not having misleading diagnostic, even if
correctly translated.

--------

>>> *************** gfc_array_init_size (tree descriptor, in
>>> *** 5076,5085 ****
>>>   
>>>         /* 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);
>>> ! 
>>>         gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
>>>   				      gfc_rank_cst[n], se.expr);
>>>         conv_ubound = se.expr;
>>> --- 5087,5111 ----
>>>   
>>>         /* Set upper bound.  */
>>>         gfc_init_se (&se, NULL);
>>> +       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;
>> Your one-based-ness problem was here, wasn't it?
> 
> Correct.
> 
>> I would rather copy directly lbound and ubound from expr3_desc to
>> descriptor.
> 
> It was that way in the previous version of the patch, which does *not* work any
> longer. When gfc_trans_allocate () is responsible for the creating a temporary
> variable for the source=-expression, then it does so using zero based
> expressions. 
> 
>> If the source has non-one-based bounds, the above would produce wrong
>> bounds.
> 
> Counterexample? Note, the expr3_desc is guaranteed to be an artificial variable
> created by conv_expr_descriptor, aka zero-based.
> 
here is a counterexample.

	  integer, dimension(:), allocatable :: a, b

	  allocate (a(0:3))
	  allocate (b, source = a)
	  print *, lbound(a, 1), ubound(a, 1)
	  print *, lbound(b, 1), ubound(b, 1)
	end

output:
	0	3
	1	4


I think that if you set se.expr with
ubound with gfc_conv_descriptor_ubound_get(...) instead of what you do
above, and se.expr with gfc_conv_descriptor_lbound_get(...) instead of
gfc_index_one_node in the hunk before, it should work.

--------

> <snipp>
> 
>>> *************** gfc_trans_allocate (gfc_code * code)
>>> *** 5229,5235 ****
>>>   	    }
>>>   	  else
>>>   	    tmp = se.expr;
>>> ! 	  if (!code->expr3->mold)
>>>   	    expr3 = tmp;
>>>   	  else
>>>   	    expr3_tmp = tmp;
>>> --- 5240,5248 ----
>>>   	    }
>>>   	  else
>>>   	    tmp = se.expr;
>>> ! 	  if (code->ext.alloc.arr_spec_from_expr3)
>>> ! 	    expr3_desc = tmp;
>>> ! 	  else if (!code->expr3->mold)
>>>   	    expr3 = tmp;
>>>   	  else
>>>   	    expr3_tmp = tmp;
>> Couldn't expr3 be reused?
>> We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc,
>> and (below) inexpr3. :-(
> 
> Of course can we use just two variables for all expressions. I have removed the
> expr3_tmp, inexpr3 and expr3_desc and introduced a e3_is enumeration, which
> stores which kind the expr3 is, aka unset, source, mold, desc. This makes the
> code simpler at some places.
> 
I have thought some more about the code not distinguishing source vs mold.
It seems to me that it makes sense to _not_ distinguish, and what you do
with e3_is == E3_MOLD seems bogus to me.  For example:

> @@ -5391,6 +5398,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)
>      {
You forget about the descriptor you have just created?!?

--------

About e3_is, I'm not very fond of it, and I think it can be replaced
using...
> +      e3_is = expr3 != NULL_TREE ?
> +	    (code->ext.alloc.arr_spec_from_expr3 ?
> +	       E3_DESC
> +	     : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
> +	  : E3_UNSET;
>  
... the conditions defining it above directly.
That is replace e3_is == E3_DESC with
code->ext.alloc.arr_spec_from_expr3, etc.

--------

> @@ -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;
This overrides the rank passed as argument.
Instead of this, calculate the correct rank...

> @@ -5338,10 +5392,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,
... here.  Wasn't it correct already by the way?

--------

> @@ -5174,25 +5174,26 @@ 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)
> +	      /* 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)
Hum, why this change?
Are there cases where arr_spec_from_expr3 is set and code->expr3->rank == 0?
And do you really want to call gfc_conv_expr_descriptor in such a case?

>  		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;
> +	      /* Create a temp variable only for component refs.  */
> +	      temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
Why only component refs?

>  	      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
> +	    se.expr = NULL_TREE;
>  	}
>        else
>  	{

--------

> 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,
You don't change it, so don't touch it.

> Attached is a new version of the patch. This one fails
> allocate_with_source_3.f90 on runtime, where I don't see the issue currently.
> May be you have some luck and time. If not I will investigate on Monday.
> 
I haven't looked at it yet.  Tomorrow maybe.

Thanks for your patience so far.

Mikael
diff mbox

Patch

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..6a31396 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;
@@ -5048,7 +5054,9 @@  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)
+	se.expr = gfc_index_one_node;
+      else if (lower == NULL)
 	se.expr = gfc_index_one_node;
       else
 	{
@@ -5076,10 +5084,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 +5272,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 +5306,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 +5324,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 +5377,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 +5392,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 +7135,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..43bc34a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5105,6 +5105,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;
@@ -5117,6 +5119,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);
@@ -5156,10 +5159,7 @@  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;
@@ -5174,25 +5174,26 @@  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)
+	      /* 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;
+	      /* Create a temp variable only for component refs.  */
+	      temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
 	      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
+	    se.expr = NULL_TREE;
 	}
       else
 	{
@@ -5212,32 +5213,41 @@  gfc_trans_allocate (gfc_code * code)
 				     code->expr3->ts,
 				     false, true,
 				     false, false);
+	  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 (!VAR_P (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), "atmp");
-	      gfc_add_modify_loc (input_location, &block, var, tmp);
-	      tmp = var;
-	    }
-	  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.  */
+	     here, fix it for future use.  */
 	  if (se.string_length)
 	    expr3_len = gfc_evaluate_now (se.string_length, &block);
 	}
+      /* 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), "atmp");
+	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+	    {
+	      gfc_allocate_lang_decl (var);
+	      GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+	    }
+	  gfc_add_modify_loc (input_location, &block, var, tmp);
+	  expr3 = var;
+	}
+      else
+	expr3 = se.expr;
+      /* 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
@@ -5252,10 +5262,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);
@@ -5275,9 +5281,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);
@@ -5338,8 +5342,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
@@ -5391,6 +5398,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)
     {
@@ -5490,7 +5503,9 @@  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))
 	{
 	  /* A scalar or derived type.  First compute the size to
 	     allocate.
@@ -5696,11 +5711,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,
@@ -5734,30 +5753,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)
 		{
@@ -5839,7 +5842,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
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_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.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
+