re PR fortran/35810 ([TR 15581 / F2003] Automatic reallocation on assignment to…

re PR fortran/35810 ([TR 15581 / F2003] Automatic reallocation on assignment to allocatable variables)

2010-11-28  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.
	(gfc_is_reallocatable_lhs): New function.
	(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_string_length): Return if character
	length is a variable and the expression is NULL.
	(gfc_conv_procedure_call): If the call is of the kind x = f(...)
	and the lhs is allocatable and reallocation on assignment 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-28  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.

From-SVN: r167220

gcc/fortran/ChangeLog

+2010-11-28  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.
+	(gfc_is_reallocatable_lhs): New function.
+	(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_string_length): Return if character
+	length is a variable and the expression is NULL.
+	(gfc_conv_procedure_call): If the call is of the kind x = f(...)
+	and the lhs is allocatable and reallocation on assignment 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-27  Tobias Burnus  <burnus@net-b.de>
 	    Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 

gcc/fortran/gfortran.h

@@ -2238,6 +2238,7 @@ typedef struct
   int flag_align_commons;
   int flag_whole_file;
   int flag_protect_parens;
+  int flag_realloc_lhs;
 
   int fpe;
   int rtcheck;

gcc/fortran/invoke.texi

@@ -171,7 +171,7 @@ and warnings}.
 -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}
+-fno-align-commons -fno-protect-parens -frealloc-lhs}
 @end table
 
 @menu
@@ -1458,6 +1458,13 @@ levels such that the compiler does not do any re-association. Using
 @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,

gcc/fortran/lang.opt

@@ -474,6 +474,10 @@ frange-check
 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

gcc/fortran/options.c

@@ -149,6 +149,7 @@ gfc_init_options (unsigned int decoded_options_count,
   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;
@@ -266,6 +267,16 @@ gfc_post_options (const char **pfilename)
   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;
@@ -964,6 +975,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
       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;

gcc/fortran/trans-array.h

@@ -57,6 +57,10 @@ tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
 
 tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
 
+tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
+
+bool gfc_is_reallocatable_lhs (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.  */

gcc/fortran/trans-expr.c

@@ -335,6 +335,11 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
 
   gfc_init_se (&se, NULL);
 
+  if (!cl->length
+	&& cl->backend_decl
+	&& TREE_CODE (cl->backend_decl) == VAR_DECL)
+    return;
+
   /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
      "flatten" array constructors by taking their first element; all elements
      should be the same length or a cl->length should be present.  */
@@ -342,7 +347,6 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
     {
       gfc_expr* expr_flat;
       gcc_assert (expr);
-
       expr_flat = gfc_copy_expr (expr);
       flatten_array_ctors_without_strlen (expr_flat);
       gfc_resolve_expr (expr_flat);
@@ -3355,8 +3359,30 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    se->expr = build_fold_indirect_ref_loc (input_location,
 						se->expr);
 
-	  result = 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)
@@ -3370,6 +3396,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  /* 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.  */
@@ -3394,6 +3431,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  /* 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.  */
@@ -5331,6 +5379,81 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
 }
 
 
+/* 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.  */
@@ -5373,6 +5496,31 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   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.
+     Clearly, this cannot be done for an allocatable function result, since
+     the shape of the result is unknown and, in any case, the function must
+     correctly take care of the reallocation internally. For intrinsic
+     calls, the array data is freed and the library takes care of allocation.
+     TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
+     to the library.  */    
+  if (gfc_option.flag_realloc_lhs
+	&& gfc_is_reallocatable_lhs (expr1)
+	&& !gfc_expr_attr (expr1).codimension
+	&& !gfc_is_coindexed (expr1)
+	&& !(expr2->value.function.esym
+	    && expr2->value.function.esym->result->attr.allocatable))
+    {
+      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);
 
@@ -5603,6 +5751,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 
   /* Walk the lhs.  */
   lss = gfc_walk_expr (expr1);
+  if (gfc_is_reallocatable_lhs (expr1)
+	&& !(expr2->expr_type == EXPR_FUNCTION
+	     && expr2->value.function.isym != NULL))
+    lss->is_alloc_lhs = 1;
   rss = NULL;
   if (lss != gfc_ss_terminator)
     {
@@ -5748,6 +5900,17 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  gfc_add_expr_to_block (&body, tmp);
 	}
 
+      /* Allocate or reallocate lhs of allocatable array.  */
+      if (gfc_option.flag_realloc_lhs
+	    && gfc_is_reallocatable_lhs (expr1)
+	    && !gfc_expr_attr (expr1).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);
 

gcc/fortran/trans-types.c

@@ -1048,7 +1048,12 @@ gfc_typenode_for_spec (gfc_typespec * spec)
       break;
 
     case BT_CHARACTER:
-      basetype = gfc_get_character_type (spec->kind, spec->u.cl);
+#if 0
+      if (spec->deferred)
+	basetype = gfc_get_character_type (spec->kind, NULL);
+      else
+#endif
+	basetype = gfc_get_character_type (spec->kind, spec->u.cl);
       break;
 
     case BT_DERIVED:

gcc/fortran/trans.h

@@ -216,7 +216,7 @@ typedef struct gfc_ss
      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;
+  unsigned useflags:2, where:1, is_alloc_lhs:1;
 }
 gfc_ss;
 #define gfc_get_ss() XCNEW (gfc_ss)

gcc/testsuite/ChangeLog

+2010-11-28  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.
+
 2010-11-27  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/46638

gcc/testsuite/gfortran.dg/cshift_bounds_2.f90

 ! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { 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

gcc/testsuite/gfortran.dg/matmul_bounds_2.f90

 ! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { 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

gcc/testsuite/gfortran.dg/matmul_bounds_3.f90

 ! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { 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

gcc/testsuite/gfortran.dg/matmul_bounds_4.f90

 ! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { 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

gcc/testsuite/gfortran.dg/matmul_bounds_5.f90

 ! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { 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

gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03

+! { 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

gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03

+! { 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
+  call test6
+  call test7
+  call test8
+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
+  subroutine test6
+    character(kind=1, len=100), allocatable, dimension(:) :: str
+    str = [ "abc" ]
+    if (TRIM(str(1)) .ne. "abc") call abort
+    if (len(str) .ne. 100) call abort
+  end subroutine
+  subroutine test7
+    character(kind=4, len=100), allocatable, dimension(:) :: str
+    character(kind=4, len=3) :: test = "abc"
+    str = [ "abc" ]
+    if (TRIM(str(1)) .ne. test) call abort
+    if (len(str) .ne. 100) call abort
+  end subroutine
+  subroutine test8
+    type t
+      integer, allocatable :: a(:)
+    end type t
+    type(t) :: x
+    x%a= [1,2,3]
+    if (any (x%a .ne. [1,2,3])) call abort
+    x%a = [4]
+    if (any (x%a .ne. [4])) call abort
+  end subroutine
+end
+

gcc/testsuite/gfortran.dg/transpose_2.f90

 ! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { 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

gcc/testsuite/gfortran.dg/unpack_bounds_1.f90

 ! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { 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