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
