[gfortran,patch] PR 27895, compile-time bounds checking for array section

["François-Xavier Coudert" <fxcoudert at gmail dot com>]

:ADDPATCH:

Attached patch corrects the compile-time bounds checking code for
array sections by properly taking care of zero-sized sections. It also
enables the front-end to check not only the first element in the
sequence specified by a given triplet, but also the last one. It does
this by adding a function compute_last_value_for_triplet.

This allows us to emit warnings for out-of-bounds access in cases we
didn't detect before, such as:
     integer a(10)
     print *, a(1:12:3)
while avoiding messages in cases such as
     integer a(10)
     print *, a(1:11:3)

The patch is regtested on i686-linux, and comes with a testcase
covering all the possible situations I could think of. OK for mainline
and 4.1?

FX

Attachment: compiletime_bounds_checking.ChangeLog
Description: Binary data

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 114340)
+++ gcc/fortran/resolve.c	(working copy)
@@ -2100,12 +2100,90 @@
 }
 
 
+/* Compare an integer expression with a mpz_t.  */
+
+static comparison
+compare_bound_mpz_t (gfc_expr * a, mpz_t b)
+{
+  int i;
+
+  if (a == NULL || a->expr_type != EXPR_CONSTANT)
+    return CMP_UNKNOWN;
+
+  if (a->ts.type != BT_INTEGER)
+    gfc_internal_error ("compare_bound_int(): Bad expression");
+
+  i = mpz_cmp (a->value.integer, b);
+
+  if (i < 0)
+    return CMP_LT;
+  if (i > 0)
+    return CMP_GT;
+  return CMP_EQ;
+}
+
+
+/* Compute the last value of a sequence given by a triplet.  
+   Return 0 if it wasn't able to compute the last value, or if the
+   sequence if empty, and 1 otherwise.  */
+
+static int
+compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
+				gfc_expr * stride, mpz_t last)
+{
+  if (start == NULL || start->expr_type != EXPR_CONSTANT
+      || end == NULL || end->expr_type != EXPR_CONSTANT
+      || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
+    return 0;
+
+  if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
+      || (stride != NULL && stride->ts.type != BT_INTEGER))
+    return 0;
+
+  if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
+    {
+      if (compare_bound (start, end) == CMP_GT)
+	return 0;
+      mpz_set (last, end->value.integer);
+      return 1;
+    }
+  
+  mpz_set (last, start->value.integer);
+  if (compare_bound_int (stride, 0) == CMP_GT)
+    {
+      /* Stride is positive */
+
+      if (mpz_cmp (last, end->value.integer) > 0)
+	return 0;
+
+      do
+	mpz_add (last, last, stride->value.integer);
+      while (mpz_cmp (last, end->value.integer) <= 0);
+      mpz_sub (last, last, stride->value.integer);
+    }
+  else
+    {
+      /* Stride is negative */
+
+      if (mpz_cmp (last, end->value.integer) < 0)
+	return 0;
+
+      do
+	mpz_add (last, last, stride->value.integer);
+      while (mpz_cmp (last, end->value.integer) >= 0);
+      mpz_sub (last, last, stride->value.integer);
+    }
+  return 1;
+}
+
+
 /* Compare a single dimension of an array reference to the array
    specification.  */
 
 static try
 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
 {
+  mpz_t last_value;
 
 /* Given start, end and stride values, calculate the minimum and
    maximum referenced indexes.  */
@@ -2130,14 +2208,37 @@
 	  return FAILURE;
 	}
 
-      if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
-	goto bound;
-      if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
-	goto bound;
+#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
+#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
 
-      /* TODO: Possibly, we could warn about end[i] being out-of-bound although
-         it is legal (see 6.2.2.3.1).  */
+      if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
+	    || ar->stride[i] == NULL)
+	   && compare_bound (AR_START, AR_END) != CMP_GT)
+	  || (compare_bound_int (ar->stride[i], 0) == CMP_LT
+	      && compare_bound (AR_START, AR_END) != CMP_LT))
+	{
+	  if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
+	    goto bound;
+	  if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
+	    goto bound;
+	}
 
+      mpz_init (last_value);
+      if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
+					  last_value))
+	{
+	  if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
+	      || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
+	    {
+	      mpz_clear (last_value);
+	      goto bound;
+	    }
+	}
+      mpz_clear (last_value);
+
+#undef AR_START
+#undef AR_END
+
       break;
 
     default:

! { dg-do compile }
  integer,parameter :: n = 5, m = 8
  integer a(10), i

  print *, a(15:14) ! don't warn
  print *, a(14:15) ! { dg-warning "is out of bounds" }
  print *, a(-5:-6) ! don't warn
  print *, a(-6:-5) ! { dg-warning "is out of bounds" }
  print *, a(15:14:1) ! don't warn
  print *, a(14:15:1) ! { dg-warning "is out of bounds" }
  print *, a(-5:-6:1) ! don't warn
  print *, a(-6:-5:1) ! { dg-warning "is out of bounds" }
  print *, a(15:14:-1) ! { dg-warning "is out of bounds" }
  print *, a(14:15:-1) ! don't warn
  print *, a(-5:-6:-1) ! { dg-warning "is out of bounds" }
  print *, a(-6:-5:-1) ! don't warn

  print *, a(15:) ! don't warn
  print *, a(15::-1) ! { dg-warning "is out of bounds" }
  print *, a(-1:) ! { dg-warning "is out of bounds" }
  print *, a(-1::-1) ! don't warn
  print *, a(:-1) ! don't warn
  print *, a(:-1:-1) ! { dg-warning "is out of bounds" }
  print *, a(:11) ! { dg-warning "is out of bounds" }
  print *, a(:11:-1) ! don't warn

  print *, a(1:20:10) ! { dg-warning "is out of bounds" }
  print *, a(1:15:15) ! don't warn
  print *, a(1:16:15) ! { dg-warning "is out of bounds" }
  print *, a(10:15:6) ! don't warn
  print *, a(11:15:6) ! { dg-warning "is out of bounds" }
  print *, a(11:-5:6) ! don't warn

  print *, a(10:-8:-9) ! { dg-warning "is out of bounds" }
  print *, a(10:-7:-9) ! don't warn
  
  print *, a(0:0:-1) ! { dg-warning "is out of bounds" }
  print *, a(0:0:1) ! { dg-warning "is out of bounds" }
  print *, a(0:0) ! { dg-warning "is out of bounds" }

  print *, a(1:15:i) ! don't warn
  print *, a(1:15:n) ! { dg-warning "is out of bounds" }
  print *, a(1:15:m) ! don't warn

  print *, a(1:-5:-m) ! don't warn
  print *, a(1:-5:-n) ! { dg-warning "is out of bounds" }
  print *, a(1:-5:-i) ! don't warn

  end