Patchwork (Re)allocation of allocatable arrays on assignment - F2003

login
register
mail settings
Submitter Paul Richard Thomas
Date Oct. 31, 2010, 6:01 p.m.
Message ID <AANLkTi=mxWu9dUeBrvgGeVeTMuB4DD=pEJnnsKxVMaKZ@mail.gmail.com>
Download mbox | patch
Permalink /patch/69728/
State New
Headers show

Comments

Paul Richard Thomas - Oct. 31, 2010, 6:01 p.m.
This patch has been some weeks arriving at state where it could be
submitted.  It was seen in an advanced state before the end of stage 1
and it was felt then that it could be included in 4.6.0 if this
version followed rapidly.

In the end, it turned out to be straightforward, although some of the
scalarizer wrinkles were difficult to sort out.  The testcase has
evolved to include tests on bounds.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk?

Now for allocatable scalars, via Steve and Tobias's patch.

Cheers

Paul

2010-10-31  Paul Thomas  <pault@gcc.gnu.org>

        * trans-array.c (gfc_trans_array_constructor): If the loop->to
	is a VAR_DECL, assume this is dynamic. In this case, use the
	counter to obtain the value and set loop->to appropriately.
	(gfc_conv_ss_descriptor): Always save the offset of a variable
	in info.saved_offset.
	(gfc_conv_ss_startstride): Do not attempt bound checking of the
	lhs of an assignment, if allocatable and f2003 is allowed.
	(gfc_conv_loop_setup): If possible, do not use an allocatable
	lhs variable for the loopspec.
	(get_std_lbound): New function.
	(gfc_alloc_allocatable_for_assignment): New function.
	* trans-array.h : Add primitive for previous.
	* trans-expr.c (): Call gfc_alloc_allocatable_for_assignment.
	* trans.h : Add is_alloc_lhs bitfield to gfc_ss structure.

2010-10-31  Paul Thomas  <pault@gcc.gnu.org

        * gfortran.dg/realloc_on_assign_1.f03: New test.
        * gfortran.dg/transpose_2.f90: Set -std=f95.
Dominique Dhumieres - Oct. 31, 2010, 9:50 p.m.
Paul,

The patch fixes all the problem I know, but for the bounds when
the size has not changed:

[macbook] f90/bug% cat realloc_bnd.f90
real :: a(10)=1, b(51:60)=2
real, allocatable :: c(:), d(:)
c=a
print *, lbound(c), ubound(c)
c=b
print *, lbound(c), ubound(c)
d=b
print *, lbound(d), ubound(d)
d=a
print *, lbound(d), ubound(d)
if (any(lbound(d)/=1).or.any(ubound(d)/=10)) call abort()
end
[macbook] f90/bug% a.out
           1          10
           1          10
          51          60
          51          60
Abort

BTW I think the patch should not be delayed by this
last problem.

Thanks,

Dominique
Paul Richard Thomas - Nov. 1, 2010, 6:48 a.m.
Dear Dominique,

You are absolutely right about this remaining bug.  I think that it
can be fixed quite easily. Let me do so before committing the patch.

Many thanks

Paul

On Sun, Oct 31, 2010 at 10:50 PM, Dominique Dhumieres
<dominiq@lps.ens.fr> wrote:
> Paul,
>
> The patch fixes all the problem I know, but for the bounds when
> the size has not changed:
>
> [macbook] f90/bug% cat realloc_bnd.f90
> real :: a(10)=1, b(51:60)=2
> real, allocatable :: c(:), d(:)
> c=a
> print *, lbound(c), ubound(c)
> c=b
> print *, lbound(c), ubound(c)
> d=b
> print *, lbound(d), ubound(d)
> d=a
> print *, lbound(d), ubound(d)
> if (any(lbound(d)/=1).or.any(ubound(d)/=10)) call abort()
> end
> [macbook] f90/bug% a.out
>           1          10
>           1          10
>          51          60
>          51          60
> Abort
>
> BTW I think the patch should not be delayed by this
> last problem.
>
> Thanks,
>
> Dominique
>
Dominique Dhumieres - Nov. 1, 2010, 10:18 a.m.
Paul,

I think I have found another problem with bounds:

[macbook] f90/bug% cat bounds_sec_a_8_red.f90
integer, parameter :: ik=8
   integer(4), allocatable :: ib(:)
integer, parameter :: from=-1, to=2
integer(ik), allocatable :: ia(:)
allocate(ia(from:to))
ib=ia
print *, 'bounds, full array           ', lbound(ib), ubound(ib)
deallocate(ia)
end
[macbook] f90/bug% gfc bounds_sec_a_8_red.f90
[macbook] f90/bug% a.out 
 bounds, full array                      1           4

Should not the answer be -1:2?

Dominique
Paul Richard Thomas - Nov. 2, 2010, 9:26 p.m.
Dominique,

I think that you are right but Intel gives the same result - ***sigh**

I have put that on the list to investigate.  The more fundamental
issues are now resolved; eg bounds changing with same size and
function result assignments.

Thanks for your continuing support on this.

Paul

On Mon, Nov 1, 2010 at 11:18 AM, Dominique Dhumieres <dominiq@lps.ens.fr> wrote:
> Paul,
>
> I think I have found another problem with bounds:
>
> [macbook] f90/bug% cat bounds_sec_a_8_red.f90
> integer, parameter :: ik=8
>   integer(4), allocatable :: ib(:)
> integer, parameter :: from=-1, to=2
> integer(ik), allocatable :: ia(:)
> allocate(ia(from:to))
> ib=ia
> print *, 'bounds, full array           ', lbound(ib), ubound(ib)
> deallocate(ia)
> end
> [macbook] f90/bug% gfc bounds_sec_a_8_red.f90
> [macbook] f90/bug% a.out
>  bounds, full array                      1           4
>
> Should not the answer be -1:2?
>
> Dominique
>
Paul Richard Thomas - Nov. 2, 2010, 9:28 p.m.
Dominique,

This one is now fixed (in the version of the patch to come).

Thanks

Paul

On Sun, Oct 31, 2010 at 10:50 PM, Dominique Dhumieres
<dominiq@lps.ens.fr> wrote:
> Paul,
>
> The patch fixes all the problem I know, but for the bounds when
> the size has not changed:
>
> [macbook] f90/bug% cat realloc_bnd.f90
> real :: a(10)=1, b(51:60)=2
> real, allocatable :: c(:), d(:)
> c=a
> print *, lbound(c), ubound(c)
> c=b
> print *, lbound(c), ubound(c)
> d=b
> print *, lbound(d), ubound(d)
> d=a
> print *, lbound(d), ubound(d)
> if (any(lbound(d)/=1).or.any(ubound(d)/=10)) call abort()
> end
> [macbook] f90/bug% a.out
>           1          10
>           1          10
>          51          60
>          51          60
> Abort
>
> BTW I think the patch should not be delayed by this
> last problem.
>
> Thanks,
>
> Dominique
>
Dominique Dhumieres - Nov. 2, 2010, 10:22 p.m.
Paul,

If it may help, the bounds are correct (-1:2) if the kinds of ia and ib
are the same, but wrong (1:4) if the kinds are different (I have checked
2 vs. 4, and 8 vs. 4).

If it rings some bell for you, these codelets were leftover of experiments
with bounds for derived types (there is probably at least one pr closed
for it).

Hoping for the patch!-)

Dominique
Dominique Dhumieres - Nov. 2, 2010, 10:30 p.m.
It was pr38324, a sequel of pr34143.

Cheers,

Dominique

Patch

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 164755)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1830,1835 ****
--- 1830,1836 ----
    tree offsetvar;
    tree desc;
    tree type;
+   tree tmp;
    bool dynamic;
    bool old_first_len, old_typespec_chararray_ctor;
    tree old_first_len_val;
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1942,1947 ****
--- 1943,1951 ----
  	}
      }
  
+   if (TREE_CODE (loop->to[0]) == VAR_DECL)
+     dynamic = true;
+ 
    gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
  			       type, NULL_TREE, dynamic, true, false, where);
  
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1956,1967 ****
    /* If the array grows dynamically, the upper bound of the loop variable
       is determined by the array's final upper bound.  */
    if (dynamic)
!     loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
  
    if (TREE_USED (offsetvar))
      pushdecl (offsetvar);
    else
      gcc_assert (INTEGER_CST_P (offset));
  #if 0
    /* Disable bound checking for now because it's probably broken.  */
    if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
--- 1960,1982 ----
    /* If the array grows dynamically, the upper bound of the loop variable
       is determined by the array's final upper bound.  */
    if (dynamic)
!     {
!       tmp = fold_build2_loc (input_location, MINUS_EXPR,
! 			     gfc_array_index_type,
! 			     offsetvar, gfc_index_one_node);
!       tmp = gfc_evaluate_now (tmp, &loop->pre);
!       gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
!       if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
! 	gfc_add_modify (&loop->pre, loop->to[0], tmp);
!       else
! 	loop->to[0] = tmp;
!     }
  
    if (TREE_USED (offsetvar))
      pushdecl (offsetvar);
    else
      gcc_assert (INTEGER_CST_P (offset));
+ 
  #if 0
    /* Disable bound checking for now because it's probably broken.  */
    if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
*************** gfc_conv_ss_descriptor (stmtblock_t * bl
*** 2174,2179 ****
--- 2189,2199 ----
  
        tmp = gfc_conv_array_offset (se.expr);
        ss->data.info.offset = gfc_evaluate_now (tmp, block);
+ 
+       /* Make absolutely sure that the saved_offset is indeed saved
+ 	 so that the variable is still accessible after the loops
+ 	 are translated.  */
+       ss->data.info.saved_offset = ss->data.info.offset;
      }
  }
  
*************** gfc_conv_ss_startstride (gfc_loopinfo * 
*** 3201,3206 ****
--- 3221,3231 ----
  	  if (ss->type != GFC_SS_SECTION)
  	    continue;
  
+ 	  /* Catch allocatable lhs in f2003.  */
+ 	  if (gfc_option.allow_std & GFC_STD_F2003
+ 		&& ss->is_alloc_lhs)
+ 	    continue;
+ 
  	  gfc_start_block (&inner);
  
  	  /* TODO: range checking for mapped dimensions.  */
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 3668,3673 ****
--- 3693,3703 ----
  	      continue;
  	    }
  
+ 	  /* Avoid using an allocatable lhs in an assignment, since
+ 	     there might be a reallocation coming.  */
+ 	  if (loopspec[n] && ss->is_alloc_lhs)
+ 	    continue;
+ 
  	  if (ss->type != GFC_SS_SECTION)
  	    continue;
  
*************** gfc_copy_only_alloc_comp (gfc_symbol * d
*** 6449,6454 ****
--- 6479,6775 ----
  }
  
  
+ /* Returns the value of LBOUND for an expression.  This could be broken out
+    from gfc_conv_intrinsic_bound but this seemed to be simpler.  This is
+    called by gfc_alloc_allocatable_for_assignment.  */
+ static tree
+ get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
+ {
+   tree lbound;
+   tree ubound;
+   tree stride;
+   tree cond, cond1, cond3, cond4;
+   tree tmp;
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+     {
+       tmp = gfc_rank_cst[dim];
+       lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
+       ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
+       stride = gfc_conv_descriptor_stride_get (desc, tmp);
+       cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ 			       ubound, lbound);
+       cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ 			       stride, gfc_index_zero_node);
+       cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ 			       boolean_type_node, cond3, cond1);
+       cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ 			       stride, gfc_index_zero_node);
+       if (assumed_size)
+ 	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ 				tmp, build_int_cst (gfc_array_index_type,
+ 						    expr->rank - 1));
+       else
+ 	cond = boolean_false_node;
+ 
+       cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ 			       boolean_type_node, cond3, cond4);
+       cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ 			      boolean_type_node, cond, cond1);
+ 
+       return fold_build3_loc (input_location, COND_EXPR,
+ 			      gfc_array_index_type, cond,
+ 			      lbound, gfc_index_one_node);
+     }
+   else if (expr->expr_type == EXPR_VARIABLE)
+     {
+       tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+       return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
+     }
+ 
+   return gfc_index_one_node;
+ }
+ 
+ /* Allocate the lhs of an assignment to an allocatable array, otherwise
+    reallocate it.  */
+ 
+ void
+ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
+ 				      gfc_expr *expr1,
+ 				      gfc_expr *expr2)
+ {
+   stmtblock_t realloc_block;
+   stmtblock_t alloc_block;
+   stmtblock_t fblock;
+   gfc_ss *rss;
+   gfc_ss *lss;
+   tree realloc_expr;
+   tree alloc_expr;
+   tree size1;
+   tree size2;
+   tree array1;
+   tree cond;
+   tree tmp;
+   tree tmp2;
+   tree lbound;
+   tree ubound;
+   tree desc;
+   tree desc2;
+   tree offset;
+   tree jump_label;
+   tree lbd;
+   int n;
+   int dim;
+   gfc_array_spec * as;
+ 
+   /* Bail out if this is not a valid allocate on assignment.  */
+   if (!expr1->symtree->n.sym->attr.allocatable
+ 	|| (expr1->ref && expr1->ref->type == REF_ARRAY
+ 	      && expr1->ref->u.ar.type != AR_FULL)
+ 	|| !expr2->rank)
+     return;
+ 
+   /* Find the ss for the lhs.  */
+   lss = loop->ss;
+   for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+     if (lss->expr == expr1)
+       break;
+ 
+   if (lss == gfc_ss_terminator)
+     return;
+ 
+   /* Find an ss for the rhs. For operator expressions, we see the
+      ss's for the operands. Any one of these will do.  */
+   rss = loop->ss;
+   for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
+     if (rss->expr != expr1)
+       break;
+ 
+   if (rss == gfc_ss_terminator)
+     return;
+ 
+   gfc_start_block (&fblock);
+ 
+   /* Since the lhs is allocatable, this must be a descriptor type.
+      Get the data and array size.  */
+   desc = lss->data.info.descriptor;
+   gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+   array1 = gfc_conv_descriptor_data_get (desc);
+   size1 = gfc_conv_descriptor_size (desc, expr1->rank);
+ 
+   /* Get the rhs size.  Fix both sizes.  */
+   desc2 = rss->data.info.descriptor;
+   size2 = gfc_index_one_node;
+   for (n = 0; n < expr2->rank; n++)
+     {
+       tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     loop->to[n], loop->from[n]);
+       tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     tmp, gfc_index_one_node);
+       size2 = fold_build2_loc (input_location, MULT_EXPR,
+ 			       gfc_array_index_type,
+ 			       tmp, size2);
+     }
+   size1 = gfc_evaluate_now (size1, &fblock);
+   size2 = gfc_evaluate_now (size2, &fblock);
+ 
+   /* If the lhs is allocated and the lhs and rhs are equal length, jump
+      past the realloc/malloc.  This allows F95 compliant expressions
+      to escape allocation on assignment.  */
+   jump_label = gfc_build_label_decl (NULL_TREE);
+   tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ 			 array1, build_int_cst (TREE_TYPE (array1), 0));
+   tmp2 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ 			  size1, size2);
+   cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ 			  boolean_type_node, tmp, tmp2);
+   tmp = build3_v (COND_EXPR, cond,
+ 		  build1_v (GOTO_EXPR, jump_label),
+ 		  build_empty_stmt (input_location));
+ 
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   /* Now modify the lhs descriptor and the associated scalarizer
+      variables.
+      7.4.1.3: If variable is or becomes an unallocated allocatable
+      variable, then it is allocated with each deferred type parameter
+      equal to the corresponding type parameters of expr , with the
+      shape of expr , and with each lower bound equal to the
+      corresponding element of LBOUND(expr).  */
+   size1 = gfc_index_one_node;
+   offset = gfc_index_zero_node;
+   as = gfc_get_full_arrayspec_from_expr (expr2);
+ 
+   for (n = 0; n < expr2->rank; n++)
+     {
+       tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     loop->to[n], loop->from[n]);
+       tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     tmp, gfc_index_one_node);
+ 
+       lbound = gfc_index_one_node;
+       ubound = tmp;
+ 
+       if (as)
+ 	{
+ 	  lbd = get_std_lbound (expr2, desc2, n,
+ 				as->type == AS_ASSUMED_SIZE);
+ 	  ubound = fold_build2_loc (input_location,
+ 				    MINUS_EXPR,
+ 				    gfc_array_index_type,
+ 				    ubound, lbound);
+ 	  ubound = fold_build2_loc (input_location,
+ 				    PLUS_EXPR,
+ 				    gfc_array_index_type,
+ 				    ubound, lbd);
+ 	  lbound = lbd;
+ 	}
+ 
+       gfc_conv_descriptor_lbound_set (&fblock, desc,
+ 				      gfc_rank_cst[n],
+ 				      lbound);
+       gfc_conv_descriptor_ubound_set (&fblock, desc,
+ 				      gfc_rank_cst[n],
+ 				      ubound);
+       gfc_conv_descriptor_stride_set (&fblock, desc,
+ 				      gfc_rank_cst[n],
+ 				      size1);
+       lbound = gfc_conv_descriptor_lbound_get (desc,
+ 					       gfc_rank_cst[n]);
+       tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+ 			      gfc_array_index_type,
+ 			      lbound, size1);
+       offset = fold_build2_loc (input_location, MINUS_EXPR,
+ 				gfc_array_index_type,
+ 				offset, tmp2);
+       size1 = fold_build2_loc (input_location, MULT_EXPR,
+ 			       gfc_array_index_type,
+ 			       tmp, size1);
+     }
+ 
+   /* Set the lhs descriptor and scalarizer offsets.  For rank > 1,
+      the array offset is saved and the info.offset is used for a
+      running offset.  Use the saved_offset instead.  */
+   tmp = gfc_conv_descriptor_offset (desc);
+   gfc_add_modify (&fblock, tmp, offset);
+   if (lss->data.info.saved_offset
+ 	&& TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
+       gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
+ 
+   /* Now set the deltas for the lhs.  */
+   for (n = 0; n < expr2->rank; n++)
+     {
+       tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+       dim = lss->data.info.dim[n];
+       tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			     gfc_array_index_type, tmp,
+ 			     loop->from[dim]);
+       if (lss->data.info.delta[dim]
+ 	    && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
+ 	gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
+     }
+ 
+   /* Get the new lhs size in bytes.  */
+   if (expr2->ts.type == BT_CHARACTER && expr2->ts.u.cl->backend_decl)
+     tmp = expr2->ts.u.cl->backend_decl;
+   else
+     tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+   tmp = fold_convert (gfc_array_index_type, tmp);
+   size2 = fold_build2_loc (input_location, MULT_EXPR,
+ 			   gfc_array_index_type,
+ 			   tmp, size2);
+   size2 = fold_convert (size_type_node, size2);
+   size2 = gfc_evaluate_now (size2, &fblock);
+ 
+   /* Realloc expression.  Note that the scalarizer uses desc.data
+      in the array reference - (*desc.data)[<element>]. */
+   gfc_init_block (&realloc_block);
+   tmp = build_call_expr_loc (input_location,
+ 			     built_in_decls[BUILT_IN_REALLOC], 2,
+ 			     fold_convert (pvoid_type_node, array1),
+ 			     size2);
+   gfc_conv_descriptor_data_set (&realloc_block,
+ 				desc, tmp);
+   realloc_expr = gfc_finish_block (&realloc_block);
+ 
+   /* Malloc expression.  */
+   gfc_init_block (&alloc_block);
+   tmp = build_call_expr_loc (input_location,
+ 			     built_in_decls[BUILT_IN_MALLOC], 1,
+ 			     size2);
+   gfc_conv_descriptor_data_set (&alloc_block,
+ 				desc, tmp);
+   tmp = gfc_conv_descriptor_dtype (desc);
+   gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+   alloc_expr = gfc_finish_block (&alloc_block);
+ 
+   /* Malloc if not allocated; realloc otherwise.  */
+   tmp = build_int_cst (TREE_TYPE (array1), 0);
+   cond = fold_build2_loc (input_location, EQ_EXPR,
+ 			  boolean_type_node,
+ 			  array1, tmp);
+   tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   if (lss->data.info.data
+ 	&& TREE_CODE (lss->data.info.data) == VAR_DECL)
+     {
+       tmp = gfc_conv_descriptor_data_get (desc);
+       gfc_add_modify (&fblock, lss->data.info.data, tmp);
+     }
+ 
+   /* Add the exit label.  */
+   tmp = build1_v (LABEL_EXPR, jump_label);
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   tmp = gfc_finish_block (&fblock);
+   gfc_add_expr_to_block (&loop->pre, tmp);
+ }
+ 
+ 
  /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
     Do likewise, recursively if necessary, with the allocatable components of
     derived types.  */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 164755)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5597,5602 ****
--- 5597,5604 ----
  
    /* Walk the lhs.  */
    lss = gfc_walk_expr (expr1);
+   if (expr1->symtree->n.sym->attr.allocatable)
+     lss->is_alloc_lhs = 1;
    rss = NULL;
    if (lss != gfc_ss_terminator)
      {
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5744,5749 ****
--- 5746,5755 ----
  	  gfc_add_expr_to_block (&body, tmp);
  	}
  
+       /* Allocate or reallocate lhs of allocatable array.  */
+       if (gfc_option.allow_std & GFC_STD_F2003)
+ 	gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+ 
        /* Generate the copying loops.  */
        gfc_trans_scalarizing_loops (&loop, &body);
  
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 164755)
--- gcc/fortran/trans-array.h	(working copy)
*************** tree gfc_copy_alloc_comp (gfc_symbol *, 
*** 57,62 ****
--- 57,64 ----
  
  tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
  
+ void gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
+ 
  /* Add initialization for deferred arrays.  */
  void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *);
  /* Generate an initializer for a static pointer or allocatable array.  */
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 164755)
--- gcc/fortran/trans.h	(working copy)
*************** typedef struct gfc_ss
*** 216,222 ****
       loops the terms appear in.  This will be 1 for the RHS expressions,
       2 for the LHS expressions, and 3(=1|2) for the temporary.  The bit
       'where' suppresses precalculation of scalars in WHERE assignments.  */
!   unsigned useflags:2, where:1;
  }
  gfc_ss;
  #define gfc_get_ss() XCNEW (gfc_ss)
--- 216,222 ----
       loops the terms appear in.  This will be 1 for the RHS expressions,
       2 for the LHS expressions, and 3(=1|2) for the temporary.  The bit
       'where' suppresses precalculation of scalars in WHERE assignments.  */
!   unsigned useflags:2, where:1, is_alloc_lhs:1;
  }
  gfc_ss;
  #define gfc_get_ss() XCNEW (gfc_ss)
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03	(revision 0)
***************
*** 0 ****
--- 1,80 ----
+ ! { dg-do run }
+ ! Tests the patch that implements F2003 automatic allocation and
+ ! reallocation of allocatable arrays on assignment.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+   integer(4), allocatable :: a(:), b(:), c(:,:)
+   integer(4) :: j
+   integer(4) :: src(2:5) = [11,12,13,14]
+   integer(4) :: mat(2:3,5:6)
+   character(4), allocatable :: chr1(:)
+   character(4) :: chr2(2) = ["abcd", "wxyz"]
+ 
+   allocate(a(1))
+   mat = reshape (src, [2,2])
+ 
+   a = [4,3,2,1]
+   if (size(a, 1) .ne. 4) call abort
+   if (any (a .ne. [4,3,2,1])) call abort
+ 
+   a = [((42 - i), i = 1, 10)]
+   if (size(a, 1) .ne. 10) call abort
+   if (any (a .ne. [((42 - i), i = 1, 10)])) call abort
+ 
+   b = a
+   if (size(b, 1) .ne. 10) call abort
+   if (any (b .ne. a)) call abort
+ 
+   a = [4,3,2,1]
+   if (size(a, 1) .ne. 4) call abort
+   if (any (a .ne. [4,3,2,1])) call abort
+ 
+   a = b
+   if (size(a, 1) .ne. 10) call abort
+   if (any (a .ne. [((42 - i), i = 1, 10)])) call abort
+ 
+   j = 20
+   a = [(i, i = 1, j)]
+   if (size(a, 1) .ne. j) call abort
+   if (any (a .ne. [(i, i = 1, j)])) call abort
+ 
+   a = foo (15)
+   if (size(a, 1) .ne. 15) call abort
+   if (any (a .ne. [((i + 15), i = 1, 15)])) call abort
+ 
+   a = src
+   if (lbound(a, 1) .ne. lbound(src, 1)) call abort
+   if (ubound(a, 1) .ne. ubound(src, 1)) call abort
+   if (any (a .ne. [11,12,13,14])) call abort
+ 
+   k = 7
+   a = b(k:8)
+   if (lbound(a, 1) .ne. lbound (b(k:8), 1)) call abort
+   if (ubound(a, 1) .ne. ubound (b(k:8), 1)) call abort
+   if (any (a .ne. [35,34])) call abort
+ 
+   c = mat
+   if (any (lbound (c) .ne. lbound (mat))) call abort
+   if (any (ubound (c) .ne. ubound (mat))) call abort
+   if (any (c .ne. mat)) call abort
+ 
+   deallocate (c)
+   c = mat(2:,:)
+   if (any (lbound (c) .ne. lbound (mat(2:,:)))) call abort
+ 
+   chr1 = chr2(2:1:-1)
+   if (lbound(chr1, 1) .ne. 1) call abort
+   if (any (chr1 .ne. chr2(2:1:-1))) call abort
+ 
+   b = c(1, :) + c(2, :)
+   if (lbound(b, 1) .ne. lbound (c(1, :) + c(2, :), 1)) call abort
+   if (any (b .ne. c(1, :) + c(2, :))) call abort
+ contains
+   function foo (n) result(res)
+     integer(4), allocatable, dimension(:) :: res
+     integer(4) :: n
+     allocate (res(n))
+     res = [((i + 15), i = 1, n)]
+   end function foo
+ end
Index: gcc/testsuite/gfortran.dg/transpose_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transpose_2.f90	(revision 164755)
--- gcc/testsuite/gfortran.dg/transpose_2.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" }
  program main
    implicit none
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -std=f95" }
  ! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" }
  program main
    implicit none