Patchwork [fortran] PR35810 - [TR 15581 / F2003] Automatic reallocation on assignment to allocatable variables

login
register
mail settings
Submitter Paul Richard Thomas
Date Nov. 20, 2010, 8:28 p.m.
Message ID <AANLkTim7ChiQB+Hzf-Pit4GSRh7idofZA5doH5-nxhj9@mail.gmail.com>
Download mbox | patch
Permalink /patch/72362/
State New
Headers show

Comments

Paul Richard Thomas - Nov. 20, 2010, 8:28 p.m.
Dear All,

The attached deals with all the problems that Tobias and Dominique
have found.... so far!  The main difference from the last version
concerns the handling of allocatable_lhs = f(....).  See
gfc_conv_procedure_call and gfc_trans_arrayfunc_assign for the
details.

Not only does the patch bootstrap and regtest but it runs Polyhedron
correctly this time!  OK for trunk?

Cheers

Paul

2010-11-20  Paul Thomas  <pault@gcc.gnu.org>

	 PR fortran/35810
	* 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.
	* gfortran.h : Add flag_realloc_lhs to the options structure.
	* lang.opt : Add option f(no-)realloc-lhs.
	* invoke.texi : Document option f(no-)realloc-lhs.
	* options.c (gfc_init_options, gfc_post_options,
	gfc_handle_option): Incorporate f(no-)realloc-lhs with default
	to frealloc_lhs for -std > f95.
	* trans-array.h : Add primitive for previous.
	* trans-expr.c (gfc_conv_procedure_call): If the call is of
	the kind x = f(...) and the lhs is allocatable and reallocation
	on assignment is OK, call gfc_alloc_allocatable_for_assignment.
	Do not generate the function call unless direct by reference.
	(realloc_lhs_loop_for_fcn_call): New function.
	(realloc_lhs_bounds_for_intrinsic_call): New function.
	(gfc_trans_arrayfunc_assign): Reallocation assignments need
	a loopinfo and for the loop bounds to be set.  With intrinsic
	functions, free the lhs data and let the library allocate the
	data array. Done by the new functions above.
	(gfc_trans_assignment_1): If the lhs is allocatable and
	reallocation on assignment is allowed, mark the lhs and use
	gfc_alloc_allocatable_for_assignment to make the reallocation.
	* trans.h : Add is_alloc_lhs bitfield to gfc_ss structure.

2010-11-20  Paul Thomas  <pault@gcc.gnu.org

	PR fortran/35810
	* gfortran.dg/realloc_on_assign_1.f03: New test.
	* gfortran.dg/realloc_on_assign_2.f03: New test.
	* gfortran.dg/transpose_2.f90: dg-option -fno-realloc-lhs.
	* gfortran.dg/unpack_bounds_1.f90: The same.
	* gfortran.dg/cshift_bounds_2.f90: The same.
	* gfortran.dg/matmul_bounds_2.f90: The same.
	* gfortran.dg/matmul_bounds_3.f90: The same.
	* gfortran.dg/matmul_bounds_4.f90: The same.
	* gfortran.dg/matmul_bounds_5.f90: The same.
Tobias Burnus - Nov. 21, 2010, 8:15 a.m.
Dear Paul,

Paul Richard Thomas wrote:
> Not only does the patch bootstrap and regtest but it runs Polyhedron
> correctly this time!  OK for trunk?

Reading the code I think you mishandle kind=4 characters as you seem to 
allocate only (char-length) bytes instead of (storage size of an 
element)*(char length). However, when I tries it, I already get a 
segfault with kind=1 characters:

character(kind=1, len=100), allocatable, dimension(:) :: str
str = [ "abc" ]
end

Ditto for character kind=4.


Additionally, you have lots of checks of the form:
+   if (!expr1->symtree->n.sym->attr.allocatable
+       || (expr1->ref && expr1->ref->type == REF_ARRAY

Those fail if you work with derived types such as:

type t
   integer, allocatable :: a(:)
end type t
type(t) :: x

x%a= [1,2,3]
print *, x%a
x%a = [1]
print * ,x%a
end

As "x" is not allocatable, only "x%a" is. For the attribute, you should 
could use gfc_expr_attr (), for the last component ref, you need to use 
a manual for loop, unless I missed a helper function.

Otherwise, the patch looks good.

Tobias
Paul Richard Thomas - Nov. 21, 2010, 10:05 a.m.
Dear Tobias,

Thanks for taking yet another look and, as I anticipated, finding more
problems :-)


> Reading the code I think you mishandle kind=4 characters as you seem to
> allocate only (char-length) bytes instead of (storage size of an
> element)*(char length). However, when I tries it, I already get a segfault
> with kind=1 characters:
>
> character(kind=1, len=100), allocatable, dimension(:) :: str
> str = [ "abc" ]
> end
>
> Ditto for character kind=4.

This I have fixed and, as a side effect, I nearly have deferred length
characters working too.  I should have been using expr1 as the source
of the character length, not expr2.

>
>
> Additionally, you have lots of checks of the form:
> +   if (!expr1->symtree->n.sym->attr.allocatable
> +       || (expr1->ref && expr1->ref->type == REF_ARRAY
>
> Those fail if you work with derived types such as:
>
> type t
>  integer, allocatable :: a(:)
> end type t
> type(t) :: x
>
> x%a= [1,2,3]
> print *, x%a
> x%a = [1]
> print * ,x%a
> end
>

I did not touch this because I thought that it was already working.
However, I have now remembered that the automatic allocation only
works when it is the derived type itself on the lhs.  I will make it
so!

Thanks again

Paul
Dominique Dhumieres - Nov. 21, 2010, 11 a.m.
Paul,
On my side I have found that the test in pr42112 gives an ICE:

[macbook] f90/bug% gfc pr42112.f90
pr42112.f90: In function 'f':
pr42112.f90:16:0: internal compiler error: in fold_binary_loc, at fold-const.c:9415

However I don't think it should delay a commit.

Cheers,

Dominique
Paul Richard Thomas - Nov. 21, 2010, 11:43 a.m.
Dear Dominique,

Thanks to you too!

On Sun, Nov 21, 2010 at 12:00 PM, Dominique Dhumieres
<dominiq@lps.ens.fr> wrote:
> Paul,
> On my side I have found that the test in pr42112 gives an ICE:
>
> [macbook] f90/bug% gfc pr42112.f90
> pr42112.f90: In function 'f':
> pr42112.f90:16:0: internal compiler error: in fold_binary_loc, at fold-const.c:9415
>
> However I don't think it should delay a commit.

I disagree.  The correct version of the testcase in this PR (ie.
without the first ALLOCATE) fails with my patch.  I will fix it.

Cheers

Paul

Patch

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 166976)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1837,1842 ****
--- 1837,1843 ----
    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
*** 1949,1954 ****
--- 1950,1958 ----
  	}
      }
  
+   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
*** 1963,1974 ****
    /* 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)
--- 1967,1989 ----
    /* 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
*** 2181,2186 ****
--- 2196,2206 ----
  
        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 * 
*** 3209,3214 ****
--- 3229,3238 ----
  	  if (ss->type != GFC_SS_SECTION)
  	    continue;
  
+ 	  /* Catch allocatable lhs in f2003.  */
+ 	  if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
+ 	    continue;
+ 
  	  gfc_start_block (&inner);
  
  	  /* TODO: range checking for mapped dimensions.  */
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 3676,3681 ****
--- 3700,3710 ----
  	      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
*** 6457,6462 ****
--- 6486,6883 ----
  }
  
  
+ /* 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);
+     }
+   else if (expr->expr_type == EXPR_FUNCTION)
+     {
+       /* A conversion function, so use the argument.  */
+       expr = expr->value.function.actual->expr;
+       if (expr->expr_type != EXPR_VARIABLE)
+ 	return gfc_index_one_node;
+       desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+       return get_std_lbound (expr, desc, dim, assumed_size);
+     }
+ 
+   return gfc_index_one_node;
+ }
+ 
+ /* Allocate the lhs of an assignment to an allocatable array, otherwise
+    reallocate it.  */
+ 
+ tree
+ 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_label1;
+   tree jump_label2;
+   tree neq_size;
+   tree lbd;
+   int n;
+   int dim;
+   gfc_array_spec * as;
+ 
+   /* x = f(...) with x allocatable.  In this case, expr1 is the rhs.
+      Find the lhs expression in the loop chain and set expr1 and
+      expr2 accordingly.  */
+   if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
+     {
+       expr2 = expr1;
+       /* Find the ss for the lhs.  */
+       lss = loop->ss;
+       for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+ 	if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
+ 	  break;
+       if (lss == gfc_ss_terminator)
+ 	return NULL_TREE;
+       expr1 = lss->expr;
+     }
+ 
+   /* 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 && !expr2->rank))
+     return NULL_TREE;
+ 
+   /* 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 NULL_TREE;
+ 
+   /* 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 && rss != loop->temp_ss)
+       break;
+ 
+   if (expr2 && rss == gfc_ss_terminator)
+     return NULL_TREE;
+ 
+   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.  */
+   if (expr2)
+     desc2 = rss->data.info.descriptor;
+   else
+     desc2 = NULL_TREE;
+   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);
+   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ 			  size1, size2);
+   neq_size = gfc_evaluate_now (cond, &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_label1 = gfc_build_label_decl (NULL_TREE);
+   jump_label2 = gfc_build_label_decl (NULL_TREE);
+ 
+   /* Allocate if data is NULL.  */
+   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ 			 array1, build_int_cst (TREE_TYPE (array1), 0));
+   tmp = build3_v (COND_EXPR, cond,
+ 		  build1_v (GOTO_EXPR, jump_label1),
+ 		  build_empty_stmt (input_location));
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   /* Reallocate if sizes are different.  */
+   tmp = build3_v (COND_EXPR, neq_size,
+ 		  build1_v (GOTO_EXPR, jump_label1),
+ 		  build_empty_stmt (input_location));
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   if (expr2 && expr2->expr_type == EXPR_FUNCTION
+ 	&& expr2->value.function.isym
+ 	&& expr2->value.function.isym->conversion)
+     {
+       /* For conversion functions, take the arg.  */
+       gfc_expr *arg = expr2->value.function.actual->expr;
+       as = gfc_get_full_arrayspec_from_expr (arg);
+     }
+   else if (expr2)
+     as = gfc_get_full_arrayspec_from_expr (expr2);
+   else
+     as = NULL;
+ 
+   /* Reset the lhs bounds if any are different from the rhs.  */ 
+   if (as && expr2->expr_type == EXPR_VARIABLE)
+     {
+       for (n = 0; n < expr1->rank; n++)
+ 	{
+ 	  /* First check the lbounds.  */
+ 	  dim = rss->data.info.dim[n];
+ 	  lbd = get_std_lbound (expr2, desc2, dim,
+ 				as->type == AS_ASSUMED_SIZE);
+ 	  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+ 	  cond = fold_build2_loc (input_location, NE_EXPR,
+ 				  boolean_type_node, lbd, lbound);
+ 	  tmp = build3_v (COND_EXPR, cond,
+ 			  build1_v (GOTO_EXPR, jump_label1),
+ 			  build_empty_stmt (input_location));
+ 	  gfc_add_expr_to_block (&fblock, tmp);
+ 
+ 	  /* Now check the shape.  */
+ 	  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, lbound);
+ 	  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ 	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 				 gfc_array_index_type,
+ 				 tmp, ubound);
+ 	  cond = fold_build2_loc (input_location, NE_EXPR,
+ 				  boolean_type_node,
+ 				  tmp, gfc_index_zero_node);
+ 	  tmp = build3_v (COND_EXPR, cond,
+ 			  build1_v (GOTO_EXPR, jump_label1),
+ 			  build_empty_stmt (input_location));
+ 	  gfc_add_expr_to_block (&fblock, tmp);	  
+ 	}
+     }
+ 
+     /* Otherwise jump past the (re)alloc code.  */
+     tmp = build1_v (GOTO_EXPR, jump_label2);
+     gfc_add_expr_to_block (&fblock, tmp);
+     
+     /* Add the label to start automatic (re)allocation.  */
+     tmp = build1_v (LABEL_EXPR, jump_label1);
+     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;
+ 
+   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 < expr1->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);
+ 
+   /* Only reallocate if sizes are different.  */
+   tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
+ 		  build_empty_stmt (input_location));
+   realloc_expr = tmp;
+ 
+ 
+   /* 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);
+ 
+   /* Make sure that the scalarizer data pointer is updated.  */
+   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_label2);
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   return gfc_finish_block (&fblock);
+ }
+ 
+ 
  /* 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 166976)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3355,3362 ****
  	    se->expr = build_fold_indirect_ref_loc (input_location,
  						se->expr);
  
! 	  result = build_fold_indirect_ref_loc (input_location,
! 						se->expr);
  	  VEC_safe_push (tree, gc, retargs, se->expr);
  	}
        else if (comp && comp->attr.dimension)
--- 3355,3384 ----
  	    se->expr = build_fold_indirect_ref_loc (input_location,
  						se->expr);
  
! 	  /* If the lhs of an assignment x = f(..) is allocatable and
! 	     f2003 is allowed, we must do the automatic reallocation.
! 	     TODO - deal with instrinsics, without using a temporary.  */
! 	  if (gfc_option.flag_realloc_lhs
! 		&& se->ss && se->ss->loop_chain
! 		&& se->ss->loop_chain->is_alloc_lhs
! 		&& !expr->value.function.isym
! 		&& sym->result->as != NULL)
! 	    {
! 	      /* Evaluate the bounds of the result, if known.  */
! 	      gfc_set_loop_bounds_from_array_spec (&mapping, se,
! 						   sym->result->as);
! 
! 	      /* Perform the automatic reallocation.  */
! 	      tmp = gfc_alloc_allocatable_for_assignment (se->loop,
! 							  expr, NULL);
! 	      gfc_add_expr_to_block (&se->pre, tmp);
! 
! 	      /* Pass the temporary as the first argument.  */
! 	      result = info->descriptor;
! 	    }
! 	  else
! 	    result = build_fold_indirect_ref_loc (input_location,
! 						  se->expr);
  	  VEC_safe_push (tree, gc, retargs, se->expr);
  	}
        else if (comp && comp->attr.dimension)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3370,3375 ****
--- 3392,3408 ----
  	  /* Evaluate the bounds of the result, if known.  */
  	  gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
  
+ 	  /* If the lhs of an assignment x = f(..) is allocatable and
+ 	     f2003 is allowed, we must not generate the function call
+ 	     here but should just send back the results of the mapping.
+ 	     This is signalled by the function ss being flagged.  */
+ 	  if (gfc_option.flag_realloc_lhs
+ 		&& se->ss && se->ss->is_alloc_lhs)
+ 	    {
+ 	      gfc_free_interface_mapping (&mapping);
+ 	      return has_alternate_specifier;
+ 	    }
+ 
  	  /* Create a temporary to store the result.  In case the function
  	     returns a pointer, the temporary will be a shallow copy and
  	     mustn't be deallocated.  */
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3394,3399 ****
--- 3427,3443 ----
  	  /* Evaluate the bounds of the result, if known.  */
  	  gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
  
+ 	  /* If the lhs of an assignment x = f(..) is allocatable and
+ 	     f2003 is allowed, we must not generate the function call
+ 	     here but should just send back the results of the mapping.
+ 	     This is signalled by the function ss being flagged.  */
+ 	  if (gfc_option.flag_realloc_lhs
+ 		&& se->ss && se->ss->is_alloc_lhs)
+ 	    {
+ 	      gfc_free_interface_mapping (&mapping);
+ 	      return has_alternate_specifier;
+ 	    }
+ 
  	  /* Create a temporary to store the result.  In case the function
  	     returns a pointer, the temporary will be a shallow copy and
  	     mustn't be deallocated.  */
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 4899,4905 ****
  	  /* Assign to a temporary descriptor and then copy that
  	     temporary to the pointer.  */
  	  tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
- 
  	  lse.expr = tmp;
  	  lse.direct_byref = 1;
  	  gfc_conv_expr_descriptor (&lse, expr2, rss);
--- 4943,4948 ----
*************** arrayfunc_assign_needs_temporary (gfc_ex
*** 5331,5336 ****
--- 5374,5454 ----
  }
  
  
+ /* Provide the loop info so that the lhs descriptor can be built for
+    reallocatable assignments from extrinsic function calls.  */
+ 
+ static void
+ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
+ {
+   gfc_loopinfo loop;
+   /* Signal that the function call should not be made by
+      gfc_conv_loop_setup. */
+   se->ss->is_alloc_lhs = 1;
+   gfc_init_loopinfo (&loop);
+   gfc_add_ss_to_loop (&loop, *ss);
+   gfc_add_ss_to_loop (&loop, se->ss);
+   gfc_conv_ss_startstride (&loop);
+   gfc_conv_loop_setup (&loop, where);
+   gfc_copy_loopinfo_to_se (se, &loop);
+   gfc_add_block_to_block (&se->pre, &loop.pre);
+   gfc_add_block_to_block (&se->pre, &loop.post);
+   se->ss->is_alloc_lhs = 0;
+ }
+ 
+ 
+ static void
+ realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+ {
+   tree desc;
+   tree tmp;
+   tree offset;
+   int n;
+ 
+   /* Use the allocation done by the library.  */
+   desc = build_fold_indirect_ref_loc (input_location, se->expr);
+   tmp = gfc_conv_descriptor_data_get (desc);
+   tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+   gfc_add_expr_to_block (&se->pre, tmp);
+   gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
+   /* Unallocated, the descriptor does not have a dtype.  */
+   tmp = gfc_conv_descriptor_dtype (desc);
+   gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ 
+   offset = gfc_index_zero_node;
+   tmp = gfc_index_one_node;
+   /* Now reset the bounds from zero based to unity based.  */
+   for (n = 0 ; n < rank; n++)
+     {
+       /* Accumulate the offset.  */
+       offset = fold_build2_loc (input_location, MINUS_EXPR,
+ 				gfc_array_index_type,
+ 				offset, tmp);
+       /* Now do the bounds.  */
+       gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
+       tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+       tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     tmp, gfc_index_one_node);
+       gfc_conv_descriptor_lbound_set (&se->post, desc,
+ 				      gfc_rank_cst[n],
+ 				      gfc_index_one_node);
+       gfc_conv_descriptor_ubound_set (&se->post, desc,
+ 				      gfc_rank_cst[n], tmp);
+ 
+       /* The extent for the next contribution to offset.  */
+       tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
+ 			     gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+       tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ 			     gfc_array_index_type,
+ 			     tmp, gfc_index_one_node);
+     }
+   gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+ }
+ 
+ 
+ 
  /* Try to translate array(:) = func (...), where func is a transformational
     array function, without using a temporary.  Returns NULL if this isn't the
     case.  */
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 5373,5378 ****
--- 5491,5516 ----
    se.direct_byref = 1;
    se.ss = gfc_walk_expr (expr2);
    gcc_assert (se.ss != gfc_ss_terminator);
+ 
+   /* Reallocate on assignment needs the loopinfo for extrinsic functions.
+      This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
+      For intrinsic calls, the array data is freed and the library takes care
+      of allocation.  TODO: Add the logic of trans-array.c: 
+      gfc_alloc_allocatable_for_assignment to the library.  */    
+   if (gfc_option.flag_realloc_lhs
+ 	&& expr1->symtree->n.sym->attr.allocatable
+ 	&& !expr1->symtree->n.sym->attr.codimension
+ 	&& !gfc_is_coindexed (expr1))
+     {
+       if (!expr2->value.function.isym)
+ 	{
+ 	  realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
+ 	  ss->is_alloc_lhs = 1;
+ 	}
+       else
+ 	realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
+     }
+ 
    gfc_conv_function_expr (&se, expr2);
    gfc_add_block_to_block (&se.pre, &se.post);
  
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5603,5608 ****
--- 5741,5750 ----
  
    /* Walk the lhs.  */
    lss = gfc_walk_expr (expr1);
+   if (expr1->symtree->n.sym->attr.allocatable
+ 	&& !(expr2->expr_type == EXPR_FUNCTION
+ 	     && expr2->value.function.isym != NULL))
+     lss->is_alloc_lhs = 1;
    rss = NULL;
    if (lss != gfc_ss_terminator)
      {
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5748,5753 ****
--- 5890,5906 ----
  	  gfc_add_expr_to_block (&body, tmp);
  	}
  
+       /* Allocate or reallocate lhs of allocatable array.  */
+       if (gfc_option.flag_realloc_lhs
+ 	    && expr1->symtree->n.sym->attr.allocatable
+ 	    && !expr1->symtree->n.sym->attr.codimension
+ 	    && !gfc_is_coindexed (expr1))
+ 	{
+ 	  tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+ 	  if (tmp != NULL_TREE)
+ 	    gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
+ 	}
+ 
        /* Generate the copying loops.  */
        gfc_trans_scalarizing_loops (&loop, &body);
  
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 166976)
--- 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);
  
+ tree 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/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 166976)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 2238,2243 ****
--- 2238,2244 ----
    int flag_align_commons;
    int flag_whole_file;
    int flag_protect_parens;
+   int flag_realloc_lhs;
  
    int fpe;
    int rtcheck;
Index: gcc/fortran/lang.opt
===================================================================
*** gcc/fortran/lang.opt	(revision 166976)
--- gcc/fortran/lang.opt	(working copy)
*************** frange-check
*** 474,479 ****
--- 474,483 ----
  Fortran
  Enable range checking during compilation
  
+ frealloc-lhs
+ Fortran
+ Reallocate the LHS in assignments
+ 
  frecord-marker=4
  Fortran RejectNegative
  Use a 4-byte record marker for unformatted files
Index: gcc/fortran/invoke.texi
===================================================================
*** gcc/fortran/invoke.texi	(revision 166976)
--- gcc/fortran/invoke.texi	(working copy)
*************** and warnings}.
*** 171,177 ****
  -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
  -finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan|snan>} @gol
  -finit-logical=@var{<true|false>} -finit-character=@var{n} @gol
! -fno-align-commons -fno-protect-parens}
  @end table
  
  @menu
--- 171,177 ----
  -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
  -finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan|snan>} @gol
  -finit-logical=@var{<true|false>} -finit-character=@var{n} @gol
! -fno-align-commons -fno-protect-parens -frealloc-lhs}
  @end table
  
  @menu
*************** levels such that the compiler does not d
*** 1458,1463 ****
--- 1458,1470 ----
  @code{COMPLEX} expressions to produce faster code. Note that for the re-association
  optimization @option{-fno-signed-zeros} and @option{-fno-trapping-math}
  need to be in effect.
+ 
+ @item -frealloc-lhs
+ @opindex @code{frealloc-lhs}
+ @cindex Reallocate the LHS in assignments
+ An allocatable left-hand side of an intrinsic assignment is automatically
+ (re)allocated if it is either unallocated or has a different shape. The
+ option is enabled by default except when @option{-std=f95} is given.
  @end table
  
  @xref{Code Gen Options,,Options for Code Generation Conventions,
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 166976)
--- 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/fortran/options.c
===================================================================
*** gcc/fortran/options.c	(revision 166976)
--- gcc/fortran/options.c	(working copy)
*************** gfc_init_options (unsigned int decoded_o
*** 149,154 ****
--- 149,155 ----
    gfc_option.flag_init_character_value = (char)0;
    gfc_option.flag_align_commons = 1;
    gfc_option.flag_protect_parens = 1;
+   gfc_option.flag_realloc_lhs = -1;
    
    gfc_option.fpe = 0;
    gfc_option.rtcheck = 0;
*************** gfc_post_options (const char **pfilename
*** 266,271 ****
--- 267,282 ----
    if (flag_associative_math == -1)
      flag_associative_math = (!flag_trapping_math && !flag_signed_zeros);
  
+   /* By default, disable (re)allocation during assignment for -std=f95,
+      and enable it for F2003/F2008/GNU/Legacy. */
+   if (gfc_option.flag_realloc_lhs == -1)
+     {
+       if (gfc_option.allow_std & GFC_STD_F2003)
+ 	gfc_option.flag_realloc_lhs = 1;
+       else
+ 	gfc_option.flag_realloc_lhs = 0;
+     }
+ 
    /* -fbounds-check is equivalent to -fcheck=bounds */
    if (flag_bounds_check)
      gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS;
*************** gfc_handle_option (size_t scode, const c
*** 964,969 ****
--- 975,984 ----
        gfc_option.flag_protect_parens = value;
        break;
  
+     case OPT_frealloc_lhs:
+       gfc_option.flag_realloc_lhs = value;
+       break;
+ 
      case OPT_fcheck_:
        gfc_handle_runtime_check_option (arg);
        break;
Index: gcc/testsuite/gfortran.dg/transpose_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transpose_2.f90	(revision 166976)
--- 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 -fno-realloc-lhs" }
  ! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" }
  program main
    implicit none
Index: gcc/testsuite/gfortran.dg/unpack_bounds_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unpack_bounds_1.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/unpack_bounds_1.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" }
  program main
    integer, allocatable, dimension(:) :: vector
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" }
  program main
    integer, allocatable, dimension(:) :: vector
Index: gcc/testsuite/gfortran.dg/cshift_bounds_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/cshift_bounds_2.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/cshift_bounds_2.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" }
  program main
    integer, dimension(:,:), allocatable :: a, b
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" }
  program main
    integer, dimension(:,:), allocatable :: a, b
Index: gcc/testsuite/gfortran.dg/matmul_bounds_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/matmul_bounds_3.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/matmul_bounds_3.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" }
  program main
    real, dimension(3,2) :: a
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" }
  program main
    real, dimension(3,2) :: a
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/matmul_bounds_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/matmul_bounds_5.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/matmul_bounds_5.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
  program main
    real, dimension(2,3) :: a
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
  program main
    real, dimension(2,3) :: a
Index: gcc/testsuite/gfortran.dg/matmul_bounds_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/matmul_bounds_2.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/matmul_bounds_2.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" }
  program main
    real, dimension(3,2) :: a
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" }
  program main
    real, dimension(3,2) :: a
Index: gcc/testsuite/gfortran.dg/matmul_bounds_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/matmul_bounds_4.f90	(revision 166976)
--- gcc/testsuite/gfortran.dg/matmul_bounds_4.f90	(working copy)
***************
*** 1,5 ****
  ! { dg-do run }
! ! { dg-options "-fbounds-check" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
  program main
    real, dimension(3) :: a
--- 1,5 ----
  ! { dg-do run }
! ! { dg-options "-fbounds-check -fno-realloc-lhs" }
  ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
  program main
    real, dimension(3) :: a
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03	(revision 0)
***************
*** 0 ****
--- 1,118 ----
+ ! { dg-do run }
+ ! Tests the patch that implements F2003 automatic allocation and
+ ! reallocation of allocatable arrays on assignment.  The tests
+ ! below were generated in the final stages of the development of
+ ! this patch.
+ !
+ ! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
+ !            and Tobias Burnus <burnus@gcc.gnu.org>
+ !
+   integer :: nglobal
+   call test1
+   call test2
+   call test3
+   call test4
+   call test5
+ contains
+   subroutine test1
+ !
+ ! Check that the bounds are set correctly, when assigning
+ ! to an array that already has the correct shape.
+ !
+     real :: a(10) = 1, b(51:60) = 2
+     real, allocatable :: c(:), d(:)
+     c=a
+     if (lbound (c, 1) .ne. lbound(a, 1)) call abort
+     if (ubound (c, 1) .ne. ubound(a, 1)) call abort
+     c=b
+     if (lbound (c, 1) .ne. lbound(b, 1)) call abort
+     if (ubound (c, 1) .ne. ubound(b, 1)) call abort
+     d=b
+     if (lbound (d, 1) .ne. lbound(b, 1)) call abort
+     if (ubound (d, 1) .ne. ubound(b, 1)) call abort
+     d=a
+     if (lbound (d, 1) .ne. lbound(a, 1)) call abort
+     if (ubound (d, 1) .ne. ubound(a, 1)) call abort
+   end subroutine
+   subroutine test2
+ !
+ ! Check that the bounds are set correctly, when making an
+ ! assignment with an implicit conversion.  First with a
+ ! non-descriptor variable....
+ !
+     integer(4), allocatable :: a(:)
+     integer(8) :: b(5:6)
+     a = b
+     if (lbound (a, 1) .ne. lbound(b, 1)) call abort
+     if (ubound (a, 1) .ne. ubound(b, 1)) call abort
+   end subroutine
+   subroutine test3
+ !
+ ! ...and now a descriptor variable.
+ !
+     integer(4), allocatable :: a(:)
+     integer(8), allocatable :: b(:)
+     allocate (b(7:11))
+     a = b
+     if (lbound (a, 1) .ne. lbound(b, 1)) call abort
+     if (ubound (a, 1) .ne. ubound(b, 1)) call abort
+   end subroutine
+   subroutine test4
+ !
+ ! Check assignments of the kind a = f(...)
+ !
+     integer, allocatable :: a(:)
+     integer, allocatable :: c(:)
+     a = f()
+     if (any (a .ne. [1, 2, 3, 4])) call abort
+     c = a + 8
+     a = f (c)
+     if (any ((a - 8) .ne. [1, 2, 3, 4])) call abort
+     deallocate (c)
+     a = f (c)
+     if (any ((a - 4) .ne. [1, 2, 3, 4])) call abort
+   end subroutine
+   function f(b)
+     integer, allocatable, optional :: b(:)
+     integer :: f(4)
+     if (.not.present (b)) then
+       f = [1,2,3,4]
+     elseif (.not.allocated (b)) then
+       f = [5,6,7,8]
+     else
+       f = b
+     end if
+   end function f
+   
+   subroutine test5
+ !
+ ! Extracted from rnflow.f90, Polyhedron benchmark suite,
+ ! http://www.polyhedron.com
+ !
+     integer, parameter :: ncls = 233, ival = 16, ipic = 17
+     real, allocatable, dimension (:,:) :: utrsft
+     real, allocatable, dimension (:,:) :: dtrsft
+     real, allocatable, dimension (:,:) :: xwrkt
+     allocate (utrsft(ncls, ncls), dtrsft(ncls, ncls))
+     nglobal = 0
+     xwrkt = trs2a2 (ival, ipic, ncls)
+     if (any (shape (xwrkt) .ne. [ncls, ncls])) call abort
+     xwrkt = invima (xwrkt, ival, ipic, ncls)
+     if (nglobal .ne. 1) call abort
+     if (sum(xwrkt) .ne. xwrkt(ival, ival)) call abort
+   end subroutine
+   function trs2a2 (j, k, m)
+     real, dimension (1:m,1:m) :: trs2a2
+     integer, intent (in)      :: j, k, m
+     nglobal = nglobal + 1
+     trs2a2 = 0.0
+   end function trs2a2
+   function invima (a, j, k, m)
+     real, dimension (1:m,1:m)              :: invima
+     real, dimension (1:m,1:m), intent (in) :: a
+     integer, intent (in)            :: j, k
+     invima (j, j) = 1.0 / (1.0 - a (j, j))
+   end function invima
+ 
+ end
+