re PR fortran/47051 (Wrong reallocate)

2011-01-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47051
	* trans-array.c (gfc_alloc_allocatable_for_assignment): Change
	to be standard compliant by testing for shape rather than size
	before skipping reallocation. Improve comments.

2011-01-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47051
	* gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be
	standard compliant and comment.

From-SVN: r168650

gcc/fortran/ChangeLog

+2011-01-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47051
+	* trans-array.c (gfc_alloc_allocatable_for_assignment): Change
+	to be standard compliant by testing for shape rather than size
+	before skipping reallocation. Improve comments.
+
 2011-01-09  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/47224

gcc/fortran/trans-array.c

 /* Array translation routines
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -6877,35 +6878,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   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.  */
+  /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
+     deallocated if expr is an array of different shape or any of the
+     corresponding length type parameter values of variable and expr
+     differ."  This assures F95 compatibility.  */
   jump_label1 = gfc_build_label_decl (NULL_TREE);
   jump_label2 = gfc_build_label_decl (NULL_TREE);
 
@@ -6917,12 +6894,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 		  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);
-
+  /* Get arrayspec if expr is a full array.  */
   if (expr2 && expr2->expr_type == EXPR_FUNCTION
 	&& expr2->value.function.isym
 	&& expr2->value.function.isym->conversion)
@@ -6936,59 +6908,76 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   else
     as = NULL;
 
-  /* Reset the lhs bounds if any are different from the rhs.  */ 
-  if (as && expr2->expr_type == EXPR_VARIABLE)
+  /* If the lhs shape is not the same as the rhs jump to setting the
+     bounds and doing the reallocation.......  */ 
+  for (n = 0; n < expr1->rank; n++)
     {
-      for (n = 0; n < expr1->rank; n++)
-	{
-	  /* First check the lbounds.  */
-	  dim = rss->data.info.dim[n];
-	  lbd = get_std_lbound (expr2, desc2, dim,
-				as->type == AS_ASSUMED_SIZE);
-	  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
-	  cond = fold_build2_loc (input_location, NE_EXPR,
-				  boolean_type_node, lbd, lbound);
-	  tmp = build3_v (COND_EXPR, cond,
-			  build1_v (GOTO_EXPR, jump_label1),
-			  build_empty_stmt (input_location));
-	  gfc_add_expr_to_block (&fblock, tmp);
+      /* Check the shape.  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[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, lbound);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type,
+			     tmp, ubound);
+      cond = fold_build2_loc (input_location, NE_EXPR,
+			      boolean_type_node,
+			      tmp, gfc_index_zero_node);
+      tmp = build3_v (COND_EXPR, cond,
+		      build1_v (GOTO_EXPR, jump_label1),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&fblock, tmp);	  
+    }
+
+  /* ....else 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 check the shape.  */
-	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
-				 gfc_array_index_type,
-				 loop->to[n], loop->from[n]);
-	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
-				 gfc_array_index_type,
-				 tmp, lbound);
-	  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
-	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
-				 gfc_array_index_type,
-				 tmp, ubound);
-	  cond = fold_build2_loc (input_location, NE_EXPR,
-				  boolean_type_node,
-				  tmp, gfc_index_zero_node);
-	  tmp = build3_v (COND_EXPR, cond,
-			  build1_v (GOTO_EXPR, jump_label1),
-			  build_empty_stmt (input_location));
-	  gfc_add_expr_to_block (&fblock, tmp);	  
-	}
+  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);
     }
 
-    /* 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);
+  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);
+
 
   /* 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).  */
+     variables. F2003 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)."  
+     Reuse size1 to keep a dimension-by-dimension track of the
+     stride of the new array.  */
   size1 = gfc_index_one_node;
   offset = gfc_index_zero_node;
 

gcc/testsuite/ChangeLog

+2011-01-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47051
+	* gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be
+	standard compliant and comment.
+
 2011-01-10  Jan Hubicka  <jh@suse.cz>
 
 	PR lto/46083

gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03

@@ -3,6 +3,7 @@
 ! reallocation of allocatable arrays on assignment.  The tests
 ! below were generated in the final stages of the development of
 ! this patch.
+! test1 has been corrected for PR47051
 !
 ! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
 !            and Tobias Burnus <burnus@gcc.gnu.org>
@@ -28,14 +29,21 @@ contains
     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
+! 7.4.1.3 "If variable is an allocated allocatable variable, it is
+! deallocated if expr is an array of different shape or any of the
+! corresponding length type parameter values of variable and expr
+! differ." Here the shape is the same so the deallocation does not
+! occur and the bounds are not recalculated. This was corrected
+! for the fix of PR47051. 
+    if (lbound (c, 1) .ne. lbound(a, 1)) call abort
+    if (ubound (c, 1) .ne. ubound(a, 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
+! The other PR47051 correction.
+    if (lbound (d, 1) .ne. lbound(b, 1)) call abort
+    if (ubound (d, 1) .ne. ubound(b, 1)) call abort
   end subroutine
   subroutine test2
 !