(Re)allocation of allocatable arrays on assignment - F2003

(Re)allocation of allocatable arrays on assignment - F2003

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 1495 bytes --]

This patch has been some weeks arriving at state where it could be
submitted.  It was seen in an advanced state before the end of stage 1
and it was felt then that it could be included in 4.6.0 if this
version followed rapidly.

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

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

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

Cheers

Paul

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

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

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

        * gfortran.dg/realloc_on_assign_1.f03: New test.
        * gfortran.dg/transpose_2.f90: Set -std=f95.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-diff, Size: 19547 bytes --]

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

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

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 899 bytes --]

On 10/31/2010 07:01 PM, Paul Richard Thomas wrote:
> This patch has been some weeks arriving at state where it could be
> submitted.  It was seen in an advanced state before the end of stage 1
> and it was felt then that it could be included in 4.6.0 if this
> version followed rapidly.
Well, to my knowledge, we are still in Stage 1 as there was no 
announcement stating otherwise. However, I think the end of Stage 1 is 
imminent.

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

I will try to test and review your patch this evening. However, as 
written before I like to have the option to disable the new feature to 
allow to use -std=gnu with the old speed and old bound checks. I do not 
expect that many users will use it; however, for some programs/users it 
might make a difference.

How about something like the attached patch? (Relative to your patch and 
untested.)

Tobias

[-- Attachment #2: realloc-opt.diff --]
[-- Type: text/x-patch, Size: 3707 bytes --]

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 2d0d4eb..126d20d 100644
--- a/gcc/fortran/gfortran.h
+++ b/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;
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index bacab6b..fbbd8d2 100644
--- a/gcc/fortran/invoke.texi
+++ b/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,
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 6088730..2462a8e 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -478,6 +478,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
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 36dd9c8..a564f59 100644
--- a/gcc/fortran/options.c
+++ b/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;
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 966d83b..7fc44b2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3230,8 +3230,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	    continue;
 
 	  /* Catch allocatable lhs in f2003.  */
-	  if (gfc_option.allow_std & GFC_STD_F2003
-		&& ss->is_alloc_lhs)
+	  if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
 	    continue;
 
 	  gfc_start_block (&inner);

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

[Paul Richard Thomas]

Dear Dominique,

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

Many thanks

Paul

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



-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy

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

[Dominique Dhumieres]

Paul,

I think I have found another problem with bounds:

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

Should not the answer be -1:2?

Dominique

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

[Paul Richard Thomas]

Dominique,

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

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

Thanks for your continuing support on this.

Paul

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



-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy

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

[Dominique Dhumieres]

Paul,

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

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

Hoping for the patch!-)

Dominique

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 3431 bytes --]

Dear All,

I believe that this one is finally it!  The bugs fixed are reflected
in the second testcase.  In particular, the bounds of the lhs are
consistently calculated and even seem to be correct; which is more
than can be said for other products.

In addition to correcting bugs, the main addition to the patch is the
option -f(no-)realloc_lhs.  Default behaviour for -std > f95 is to
reallocate on assignment.  The option allows one to improve
performance a bit for f200x and to benefit from the feature for f95.
Tobias Burnus prepared this part of the patch.

Please note that allocatable assignments of the kind:
       x = transformational_array_intrinisic (...)
now produce a temporary unless -fno-realloc_lhs or -std=f95 are
deployed.  This could be fixed relatively easily by detecting the
option in the library and repeating the logic of
gfc_alloc_allocatable_for_assignment there.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk?
(Richard, Jakub - please note the discussion on the gfortran list
about the slightly late submission of this patch relative to the end
of stage 1.  A mostly cooked version was seen a week ago.)

Many thanks to Tobias and Dominique for their help with this patch.
Their testcases went places that no other cleaner goes :-)

Cheers

Paul

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

        * trans-array.c (gfc_trans_array_constructor): If the loop->to
	is a VAR_DECL, assume this is dynamic. In this case, use the
	counter to obtain the value and set loop->to appropriately.
	(gfc_conv_ss_descriptor): Always save the offset of a variable
	in info.saved_offset.
	(gfc_conv_ss_startstride): Do not attempt bound checking of the
	lhs of an assignment, if allocatable and f2003 is allowed.
	(gfc_conv_loop_setup): If possible, do not use an allocatable
	lhs variable for the loopspec.
	(get_std_lbound): New function.
	(gfc_alloc_allocatable_for_assignment): New function.
	* 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.
	(arrayfunc_assign_needs_temporary): Reallocation assignments
	where the lhs is an intrinsic need a temporary.
	(gfc_trans_arrayfunc_assign): Reallocation assignments need
	a loopinfo and for the loop bounds to be set.
	(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-04  Paul Thomas  <pault@gcc.gnu.org

        * 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.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-diff, Size: 36964 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 166125)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3353,3360 ****
  	    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)
--- 3353,3382 ----
  	    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)
*************** arrayfunc_assign_needs_temporary (gfc_ex
*** 5220,5225 ****
--- 5242,5254 ----
    bool c = false;
    gfc_symbol *sym = expr1->symtree->n.sym;
  
+   /* Except for constant masks, the shape of an intrinsic function
+      result is unknown. TODO: make use of the masks to fix this.  */
+   if (gfc_option.flag_realloc_lhs
+ 	&& expr1->symtree->n.sym->attr.allocatable
+ 	&& expr2->value.function.isym != NULL)
+     return true;
+ 
    /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
    if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
      return true;
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 5339,5344 ****
--- 5368,5374 ----
    gfc_se se;
    gfc_ss *ss;
    gfc_component *comp = NULL;
+   gfc_loopinfo loop;
  
    if (arrayfunc_assign_needs_temporary (expr1, expr2))
      return NULL;
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 5371,5376 ****
--- 5401,5422 ----
    se.direct_byref = 1;
    se.ss = gfc_walk_expr (expr2);
    gcc_assert (se.ss != gfc_ss_terminator);
+ 
+   /* Reallocate on assignment needs the loopinfo. This is
+      signalled to gfc_conv_procedure_call by setting the
+      is_alloc_lhs.  */
+   if (gfc_option.flag_realloc_lhs
+ 	&& expr1->symtree->n.sym->attr.allocatable)
+     {
+       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, &expr1->where);
+       gfc_copy_loopinfo_to_se (&se, &loop);
+       ss->is_alloc_lhs = 1;
+     }
+ 
    gfc_conv_function_expr (&se, expr2);
    gfc_add_block_to_block (&se.pre, &se.post);
  
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5601,5606 ****
--- 5647,5654 ----
  
    /* 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
*** 5746,5751 ****
--- 5794,5808 ----
  	  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)
+ 	{
+ 	  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.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 166125)
--- 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,6863 ----
  }
  
  
+ /* 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++)
+ 	{
+ 	  dim = rss->data.info.dim[n];
+ 	  lbd = get_std_lbound (expr2, desc2, dim,
+ 				as->type == AS_ASSUMED_SIZE);
+ 	  tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+ 	  cond = fold_build2_loc (input_location, NE_EXPR,
+ 				  boolean_type_node, lbd, tmp);
+ 	  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-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 166125)
--- 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 166125)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 2237,2242 ****
--- 2237,2243 ----
    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 166125)
--- gcc/fortran/lang.opt	(working copy)
*************** frange-check
*** 478,483 ****
--- 478,487 ----
  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 166125)
--- 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 166125)
--- 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 166125)
--- 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 166125)
--- 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 166125)
--- 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 166125)
--- 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 166125)
--- 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 166125)
--- 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 166125)
--- 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 166125)
--- 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,84 ----
+ ! { 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>
+ !
+   call test1
+   call test2
+   call test3
+   call test4
+ 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
+ end

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

[Tobias Burnus]

Dear Paul,

thanks for the patch.

On 11/04/2010 07:18 AM, Paul Richard Thomas wrote:
> In addition to correcting bugs, the main addition to the patch is the
> option -f(no-)realloc_lhs.  Default behaviour for -std>  f95 is to
> reallocate on assignment.

I think a '-' instead of a '_' is more in line with most GCC and 
gfortran options; essentially only Darwin and SH use some '_' in the 
flags. While most of the patch uses realloc_lhs, there is at least one 
place where realloc-lhs is used. (As Intel uses "-assume realloc_lhs", 
the '_' has also some merits.) Thus, please make the use of '-' vs. '_' 
consistent and consider using a hyphen instead of an underscore.

Additionally, the gfortran manpage (as the gcc one) states:

        In some cases, options have positive and negative forms; the 
negative
        form of -ffoo would be -fno-foo.  This manual documents only one of
        these two forms, whichever one is not the default.

As -std=gnu is the default, which implies -frealloc-lhs/-frealloc_lhs, 
we should document
-fno-realloc-lhs/-fno-realloc_lhs instead. Sorry for missing this when I 
wrote the patch.

> Please note that allocatable assignments of the kind:
>         x = transformational_array_intrinisic (...)
> now produce a temporary unless -fno-realloc_lhs or -std=f95 are
> deployed.  This could be fixed relatively easily by detecting the
> option in the library and repeating the logic of
> gfc_alloc_allocatable_for_assignment there.

I think that would be useful - also for cases such as
   a = abs(a)
where the RHS is a elemental* function as one knows that the LHS and RHS 
must have the same shape. However, such a patch can be deferred.

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

The patch looks OK.

@@ -3676,6 +3700,11 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * 
where)
               continue;
             }

+         /* Avoid using an allocatable lhs in an assignment, since
+            there might be a reallocation coming.  */
+         if (loopspec[n] && ss->is_alloc_lhs)
+           continue;
+

I was wondering whether one should also add a 
"gfc_option.flag_realloc_lhs &&" to the if.


+}
+
+/* Allocate the lhs of an assignment to an allocatable array, otherwise

Add another empty line before the comment.

Tobias

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

[Tobias Burnus]

On 11/04/2010 09:50 AM, Tobias Burnus wrote:
>> Bootstrapped and regtested on FC9/x86_64 - OK for trunk?
>
> The patch looks OK.

Before you commit, can you add a
     PR fortran/35810
to the ChangeLog entry?

Thanks,

Tobias

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

[Tobias Burnus]

On 11/04/2010 09:56 AM, Tobias Burnus wrote:
> On 11/04/2010 09:50 AM, Tobias Burnus wrote:
>>> Bootstrapped and regtested on FC9/x86_64 - OK for trunk?
>>>
> Before you commit, can you add [...]

Another post script: Can you add a condition that no reallocation 
happens for coarrays/coindexed variables? That's not a correctness issue 
(the RHS must have the same size as the LHS -- otherwise the program is 
invalid) but a performance issue. [Actually, in terms of array bounds, 
it might also be a correctness issue.]

Example:

subroutine sub
   integer, allocatable :: a(:)[:]
   a = [8] ! Right-most partref of LHS is a coarray (attr.codimension != 0)
end

type t
    integer, allocatable :: alloc_comp(:)
end type t
contains
subroutine sub2(a)
   type(t) :: a[*]
   a[1]%alloc_comp = [8] ! LHS is coindexed
end

Cf. F2008, "7.2.1.2 Intrinsic assignment statement":

"In an intrinsic assignment statement, [...] (3) the variable and expr shall be
conformable unless the variable is an allocatable array that has the same rank
as expr and is neither a coarray nor a coindexed object,"


The attr.codimension check can be added at the same place as the 
attr.allocatable check as both is with regards to the right most 
partref. The coindexed check can be done by calling gfc_is_coindexed (expr).

Tobias

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

[Paul Richard Thomas]

Dear Tobias,

On Thu, Nov 4, 2010 at 10:09 AM, Tobias Burnus <burnus@net-b.de> wrote:
> On 11/04/2010 09:56 AM, Tobias Burnus wrote:
>>
>> On 11/04/2010 09:50 AM, Tobias Burnus wrote:
>>>>
>>>> Bootstrapped and regtested on FC9/x86_64 - OK for trunk?
>>>>
>> Before you commit, can you add [...]
>
> Another post script: Can you add a condition that no reallocation happens
> for coarrays/coindexed variables? That's not a correctness issue (the RHS
> must have the same size as the LHS -- otherwise the program is invalid) but
> a performance issue. [Actually, in terms of array bounds, it might also be a
> correctness issue.]

OK

>
> The attr.codimension check can be added at the same place as the
> attr.allocatable check as both is with regards to the right most partref.
> The coindexed check can be done by calling gfc_is_coindexed (expr).

Thanks for the pointer and for the review.  I had thought to change
the underscore in the option but sheer laziness won out :-)  I'll
implement all the other bits and pieces and will try to do the commit
tonight.

BTW Did you want the attribution for your part of the patch?

Cheers

Paul

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

[Tobias Burnus]

Dear Paul,

On 11/04/2010 11:07 AM, Paul Richard Thomas wrote:
>>> Before you commit, can you add [...]
[...]
> I'll implement all the other bits and pieces and will try
> to do the commit tonight.

Thanks!

> BTW Did you want the attribution for your part of the patch?

As my part was really minor, I think it is not needed ;-)

Tobias

PS: I assume as follow up support for allocatable scalars will be added.

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

[Dominique Dhumieres]

Paul,

First the good news:
(1) regstrapped without regression,
(2) the reported problems have been fixed.

Now the bad news:
(1) the last patch woke up one bug of my collection (pr28849)
with another bound problem:

[macbook] f90/bug% cat pr28849_db.f90
program gfc_bounds_check
  implicit none

  real, parameter   :: v(2) = (/ 1., 2. /)
  real, allocatable :: a(:,:), b(:,:)

  allocate (a(1,2), b(2,1))

  print *, "Assignments with correct shapes after RESHAPE..."
  a(:,:) = reshape (v(:), (/ 1, 2 /) )
  b(:,:) = reshape (v(:), (/ 2, 1 /) )
  ! Verify correctness of assignments
  print *, lbound(a), ubound(a)
  print *, "a(:,1) =", a(:,1)
  print *, lbound(b), ubound(b)
  print *, "b(:,1) =", b(:,1)

  print *, "...and with wrong shape (should fail with bounds checking on)"
  a(:,:) = reshape (v(:), (/ 2, 1 /) )
  b(:,:) = reshape (v(:), (/ 1, 2 /) )
  print *, "a(:,1) =", a(:,1)
  print *, lbound(a), ubound(a)
  print *, "b(:,1) =", b(:,1)
  print *, lbound(b), ubound(b)

  print *, "Must have missed an array bound violation after RESHAPE..."

end program gfc_bounds_check
[macbook] f90/bug% gfc -fcheck=all pr28849_db.f90
[macbook] f90/bug% a.out
 Assignments with correct shapes after RESHAPE...
           1           1           1           2
 a(:,1) =   1.0000000    
           1           1           2           1
 b(:,1) =   1.0000000       2.0000000    
 ...and with wrong shape (should fail with bounds checking on)
 a(:,1) =   1.0000000    
           1           1           1           2
 b(:,1) =   1.0000000       2.0000000    
           1           1           2           1
 Must have missed an array bound violation after RESHAPE...

So either a is relocated as a(2,1) (b as b(1,2)) and the bounds
are inconsistent, or it is not and there should be a run time
error as when compiled with -std=f95.

(2) More serious rnflow is miscompiled (again in evlrnf).
When compiled with -OO, I get

  0: 0: 0.001 -> Read sequence
  0: 0: 0.466 -> extract extrema
  0: 0: 0.479 -> Generate raw transitions counts
  0: 0: 0.499 -> Compute Markov matrix
  0: 0: 0.500 -> Calculate theoretical rainflow
a.out(47494) malloc: *** mmap(size=562941464334336) failed (error code=12)
*** error: can't allocate region
*** set a breakpoint in malloc_error_break to debug

When compiled with optimization strting at -O1, the test run, but the final
output is obviously wrong (a regression from the previous patch).

Cheers,

Dominique

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

[Paul Richard Thomas]

Dominique,

Thanks a lot - I'll get onto it.

Paul

On Thu, Nov 4, 2010 at 3:19 PM, Dominique Dhumieres <dominiq@lps.ens.fr> wrote:
> Paul,
>
> First the good news:
> (1) regstrapped without regression,
> (2) the reported problems have been fixed.
>
> Now the bad news:
> (1) the last patch woke up one bug of my collection (pr28849)
> with another bound problem:
>
> [macbook] f90/bug% cat pr28849_db.f90
> program gfc_bounds_check
>  implicit none
>
>  real, parameter   :: v(2) = (/ 1., 2. /)
>  real, allocatable :: a(:,:), b(:,:)
>
>  allocate (a(1,2), b(2,1))
>
>  print *, "Assignments with correct shapes after RESHAPE..."
>  a(:,:) = reshape (v(:), (/ 1, 2 /) )
>  b(:,:) = reshape (v(:), (/ 2, 1 /) )
>  ! Verify correctness of assignments
>  print *, lbound(a), ubound(a)
>  print *, "a(:,1) =", a(:,1)
>  print *, lbound(b), ubound(b)
>  print *, "b(:,1) =", b(:,1)
>
>  print *, "...and with wrong shape (should fail with bounds checking on)"
>  a(:,:) = reshape (v(:), (/ 2, 1 /) )
>  b(:,:) = reshape (v(:), (/ 1, 2 /) )
>  print *, "a(:,1) =", a(:,1)
>  print *, lbound(a), ubound(a)
>  print *, "b(:,1) =", b(:,1)
>  print *, lbound(b), ubound(b)
>
>  print *, "Must have missed an array bound violation after RESHAPE..."
>
> end program gfc_bounds_check
> [macbook] f90/bug% gfc -fcheck=all pr28849_db.f90
> [macbook] f90/bug% a.out
>  Assignments with correct shapes after RESHAPE...
>           1           1           1           2
>  a(:,1) =   1.0000000
>           1           1           2           1
>  b(:,1) =   1.0000000       2.0000000
>  ...and with wrong shape (should fail with bounds checking on)
>  a(:,1) =   1.0000000
>           1           1           1           2
>  b(:,1) =   1.0000000       2.0000000
>           1           1           2           1
>  Must have missed an array bound violation after RESHAPE...
>
> So either a is relocated as a(2,1) (b as b(1,2)) and the bounds
> are inconsistent, or it is not and there should be a run time
> error as when compiled with -std=f95.
>
> (2) More serious rnflow is miscompiled (again in evlrnf).
> When compiled with -OO, I get
>
>  0: 0: 0.001 -> Read sequence
>  0: 0: 0.466 -> extract extrema
>  0: 0: 0.479 -> Generate raw transitions counts
>  0: 0: 0.499 -> Compute Markov matrix
>  0: 0: 0.500 -> Calculate theoretical rainflow
> a.out(47494) malloc: *** mmap(size=562941464334336) failed (error code=12)
> *** error: can't allocate region
> *** set a breakpoint in malloc_error_break to debug
>
> When compiled with optimization strting at -O1, the test run, but the final
> output is obviously wrong (a regression from the previous patch).
>
> Cheers,
>
> Dominique
>



-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy

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

[Tobias Burnus]

On 11/04/2010 03:19 PM, Dominique Dhumieres wrote:
> First the good news:
> (1) the last patch woke up one bug of my collection (pr28849)
> with another bound problem:
>
> [macbook] f90/bug% cat pr28849_db.f90
[...]
>    print *, "...and with wrong shape (should fail with bounds checking on)"
>    a(:,:) = reshape (v(:), (/ 2, 1 /) )
>    b(:,:) = reshape (v(:), (/ 1, 2 /) )

Without bound checks (and realloc-lhs) I get the same result as with 
ifort and crayftn. However, for the last line shown above (line 20) I 
get with gfortran a segfault which valgrind diagnoses as:

==25067== Invalid write of size 4
==25067==    at 0x40188D: MAIN__ (pr28849_db.f90:20)


> So either a is relocated as a(2,1) (b as b(1,2)) and the bounds
> are inconsistent, or it is not and there should be a run time
> error as when compiled with -std=f95.

I think the program is valid Fortran 2003 and thus no bound check error 
should be printed. Despite ifort and crayftn showing the same bounds, I 
think you are right that the bounds are wrong.

Some other results:

a) I immediately get a segfault if I comments out the allocate statement.

b) If I comment out the first part of the example ("correct bounds", 
i.e. not reallocation), I get the result:

  ...and with wrong shape (should fail with bounds checking on)
  a(:,1) =   1.0000000
            1           1           1           2
  b(:,1) =   1.0000000     -1.33410292E-32
            1           1           2           1

Note the uninitialized value for b(2,1).


Tobias

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

[Dominique Dhumieres]

It was pr38324, a sequel of pr34143.

Cheers,

Dominique

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

[Paul Richard Thomas]

Dominique,

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

Thanks

Paul

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



-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy