re PR fortran/30003 ([4.1 only] Expressions with side effects in array references)

2006-12-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30003
	* trans-array.c (gfc_trans_create_temp_array): Set the section
	ends to zero.
	(gfc_conv_array_transpose): Likewise.
	(gfc_conv_section_startstride): Declare an expression for end,
	set it from a the array reference and evaluate it for the info
	structure. Zero the ends in the ss structure and set end, used
	in the bounds check, from the info structure.
	trans.h: Add and end array to the gfc_ss_info structure.

2006-12-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30003
	* gfortran.dg/allocatable_function_1.f90: Increase the number
	of expected calls of free to 10; the lhs section reference is
	now evaluated so there is another call to bar.  Change the
	comment appropriately.
	* gfortran.dg/array_section_1.f90: New test.

From-SVN: r119556

6 files changed, 90 insertions, 5 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a65b4a7..34ea1e5 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,17 @@
 2006-12-05  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/30003
+	* trans-array.c (gfc_trans_create_temp_array): Set the section
+	ends to zero.
+	(gfc_conv_array_transpose): Likewise.
+	(gfc_conv_section_startstride): Declare an expression for end,
+	set it from a the array reference and evaluate it for the info
+	structure. Zero the ends in the ss structure and set end, used
+	in the bounds check, from the info structure.
+	trans.h: Add and end array to the gfc_ss_info structure.
+
+2006-12-05  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/29912
 	* trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL if the
 	lhs and rhs character lengths are not constant and equal for
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0049ad5..bfd0600 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -618,6 +618,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
 
       info->delta[dim] = gfc_index_zero_node;
       info->start[dim] = gfc_index_zero_node;
+      info->end[dim] = gfc_index_zero_node;
       info->stride[dim] = gfc_index_one_node;
       info->dim[dim] = dim;
     }
@@ -783,6 +784,7 @@ gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
     {
       dest_info->delta[n] = gfc_index_zero_node;
       dest_info->start[n] = gfc_index_zero_node;
+      dest_info->end[n] = gfc_index_zero_node;
       dest_info->stride[n] = gfc_index_one_node;
       dest_info->dim[n] = n;
 
@@ -2449,6 +2451,7 @@ static void
 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
 {
   gfc_expr *start;
+  gfc_expr *end;
   gfc_expr *stride;
   tree desc;
   gfc_se se;
@@ -2464,6 +2467,7 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
     {
       /* We use a zero-based index to access the vector.  */
       info->start[n] = gfc_index_zero_node;
+      info->end[n] = gfc_index_zero_node;
       info->stride[n] = gfc_index_one_node;
       return;
     }
@@ -2471,6 +2475,7 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
   gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
   desc = info->descriptor;
   start = info->ref->u.ar.start[dim];
+  end = info->ref->u.ar.end[dim];
   stride = info->ref->u.ar.stride[dim];
 
   /* Calculate the start of the range.  For vector subscripts this will
@@ -2490,6 +2495,24 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
     }
   info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
 
+  /* Similarly calculate the end.  Although this is not used in the
+     scalarizer, it is needed when checking bounds and where the end
+     is an expression with side-effects.  */
+  if (end)
+    {
+      /* Specified section start.  */
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_type (&se, end, gfc_array_index_type);
+      gfc_add_block_to_block (&loop->pre, &se.pre);
+      info->end[n] = se.expr;
+    }
+  else
+    {
+      /* No upper bound specified so use the bound of the array.  */
+      info->end[n] = gfc_conv_array_ubound (desc, dim);
+    }
+  info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
+
   /* Calculate the stride.  */
   if (stride == NULL)
     info->stride[n] = gfc_index_one_node;
@@ -2582,6 +2605,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	  for (n = 0; n < ss->data.info.dimen; n++)
 	    {
 	      ss->data.info.start[n] = gfc_index_zero_node;
+	      ss->data.info.end[n] = gfc_index_zero_node;
 	      ss->data.info.stride[n] = gfc_index_one_node;
 	    }
 	  break;
@@ -2635,7 +2659,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	         than it is here, with all the trees.  */
 	      lbound = gfc_conv_array_lbound (desc, dim);
 	      ubound = gfc_conv_array_ubound (desc, dim);
-	      end = gfc_conv_section_upper_bound (ss, n, &block);
+	      end = info->end[n];
 
 	      /* Zero stride is not allowed.  */
 	      tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ed96838..d16a5df 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -107,6 +107,7 @@ typedef struct gfc_ss_info
      start is used in the calculation of these.  Indexed by scalarizer
      dimension.  */
   tree start[GFC_MAX_DIMENSIONS];
+  tree end[GFC_MAX_DIMENSIONS];
   tree stride[GFC_MAX_DIMENSIONS];
   tree delta[GFC_MAX_DIMENSIONS];
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 363e298..dc199b6 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,14 @@
 2006-12-05  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/30003
+	* gfortran.dg/allocatable_function_1.f90: Increase the number
+	of expected calls of free to 10; the lhs section reference is
+	now evaluated so there is another call to bar.  Change the
+	comment appropriately.
+	* gfortran.dg/array_section_1.f90: New test.
+
+2006-12-05  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/29912
 	* gfortran.dg/char_result_12.f90: New test.
 
diff --git a/gcc/testsuite/gfortran.dg/allocatable_function_1.f90 b/gcc/testsuite/gfortran.dg/allocatable_function_1.f90
index b20ff3d..fc3b983 100644
--- a/gcc/testsuite/gfortran.dg/allocatable_function_1.f90
+++ b/gcc/testsuite/gfortran.dg/allocatable_function_1.f90
@@ -65,9 +65,9 @@ program alloc_fun
 ! 1 _gfortran_internal_free
     if (.not.all(2*bar(size(a)) + 5 == [ 7, 9, 11 ])) call abort()
 
-! The first reference never happens because the rhs determines the loop size.
-! Thus there is no subsequent _gfortran_internal_free.
-! 2 _gfortran_internal_free's
+! Although the rhs determines the loop size, the lhs reference is
+! evaluated, in case it has side-effects or is needed for bounds checking.
+! 3 _gfortran_internal_free's
     a(1:size (bar (3))) = 2*bar(size(a)) + 2 + a(size (bar (3)))
     if (.not.all(a == [ 7, 9, 11 ])) call abort()
 
@@ -107,6 +107,6 @@ contains
     end function bar
 
 end program alloc_fun
-! { dg-final { scan-tree-dump-times "free" 9 "original" } }
+! { dg-final { scan-tree-dump-times "free" 10 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 ! { dg-final { cleanup-modules "m" } }
diff --git a/gcc/testsuite/gfortran.dg/array_section_1.f90 b/gcc/testsuite/gfortran.dg/array_section_1.f90
new file mode 100644
index 0000000..4d5eedf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_section_1.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! Tests the fix for PR30003, in which the 'end' of an array section
+! would not be evaluated at all if it was on the lhs of an assignment
+! or would be evaluated many times if bound checking were on.
+!
+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
+!
+    implicit none
+    integer :: a(5), b(3), cnt
+
+    b = [ 1, 2, 3 ]
+! Check the lhs references
+    cnt = 0
+    a(bar(1):3) = b
+    if (cnt /= 1) call abort ()
+    cnt = 0
+    a(1:bar(3)) = b
+    if (cnt /= 1) call abort ()
+    cnt = 0
+    a(1:3:bar(1)) = b
+    if (cnt /= 1) call abort ()
+! Check the rhs references
+    cnt = 0
+    a(1:3) = b(bar(1):3)
+    if (cnt /= 1) call abort ()
+    cnt = 0
+    a(1:3) = b(1:bar(3))
+    if (cnt /= 1) call abort ()
+    cnt = 0
+    a(1:3) = b(1:3:bar(1))
+    if (cnt /= 1) call abort ()
+contains
+    integer function bar(n)
+        integer, intent(in) :: n
+        cnt = cnt + 1
+        bar = n
+    end function bar
+end