# [patch,fortran] PRs 29630 & 29679: Vector subscripts and shapes in initialization expressions

Erik Edelmann erik.edelmann@iki.fi
Sat Nov 4 14:12:00 GMT 2006

```On Sat, Nov 04, 2006 at 07:32:45AM +0100, Paul Thomas wrote:
> Erik Edelmann wrote:
> I don't think that you did.......

Oh, sorry!  Here it comes.

Erik
-------------- next part --------------
Index: gcc/testsuite/gfortran.dg/initialization_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/initialization_2.f90	(revision 118464)
+++ gcc/testsuite/gfortran.dg/initialization_2.f90	(working copy)
@@ -1,7 +1,22 @@
-! { dg-do compile }
-! PR 29393: Ranks of PARAMETER-lhs in initializations
-    integer, parameter ::   A(-3:7,2)=0
-    integer, parameter, dimension(3) :: V = (/ 2, 4, 6 /)
-    integer, parameter, dimension(3) :: B = A(V,1)
-    integer, parameter, dimension(3) :: C = A(0:2,1)
-end
+! {dg-do run }
+! Vector subscripts, ranks and shapes of initialization expressions (PRs 29393,
+! 29630 and 29679)
+program test
+
+    implicit none
+    integer :: i, j
+    integer, parameter :: a(4,4,4) = reshape([ (i,i=1,64) ], [4,4,4])
+    integer, parameter :: v(4) = [4, 1, 3, 2]
+
+    integer :: b1(3,3) = a(1:3, 2, 2:4)
+    integer :: b2(1,3) = a(2:2, 4, [1,4,3])
+    integer :: b2b(3) = a([1,4,3], 2, 4)
+    integer :: b3(4) = a(1, v, 3)
+    integer :: b4(3,3) = a(v([2,4,3]), 2, [2,3,4])
+
+    if (any(b1 /= reshape([21,22,23, 37,38,39, 53,54,55], [3,3]))) call abort()
+    if (any(b2 /= reshape([14, 62, 46], [1,3]))) call abort()
+    if (any(b2b /= [53, 56, 55])) call abort()
+    if (any(b3 /= [45, 33, 41, 37])) call abort()
+    if (any(b4 /= reshape([21,22,23, 37,38,39, 53,54,55], [3,3]))) call abort()
+end program test
Index: gcc/testsuite/gfortran.dg/initialization_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/initialization_3.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/initialization_3.f90	(revision 0)
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! Check that bounds are checked when using vector subscripts in initialization
+! expressions. (PR 29630)
+program test
+
+    implicit none
+    integer :: i, j
+    integer, parameter :: a(4,4,4) = reshape([ (i,i=1,64) ], [4,4,4])
+    integer, parameter :: v(4) = [5, 1, -4, 2]
+
+    integer :: b2(3) = a(2, 4, [1,7,3]) ! { dg-error "out of bounds" }
+    integer :: b3(4) = a(1, v, 3) ! { dg-error "out of bounds" }
+end program test
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 118464)
+++ gcc/fortran/expr.c	(working copy)
@@ -1013,7 +1013,9 @@ find_array_section (gfc_expr *expr, gfc_
int idx;
int rank;
int d;
+  int shape_i;
long unsigned one = 1;
+  bool incr_ctr;
mpz_t start[GFC_MAX_DIMENSIONS];
mpz_t end[GFC_MAX_DIMENSIONS];
mpz_t stride[GFC_MAX_DIMENSIONS];
@@ -1023,7 +1025,6 @@ find_array_section (gfc_expr *expr, gfc_
mpz_t tmp_mpz;
mpz_t nelts;
mpz_t ptr;
-  mpz_t stop;
mpz_t index;
gfc_constructor *cons;
gfc_constructor *base;
@@ -1032,6 +1033,7 @@ find_array_section (gfc_expr *expr, gfc_
gfc_expr *step;
gfc_expr *upper;
gfc_expr *lower;
+  gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
try t;

t = SUCCESS;
@@ -1057,9 +1059,11 @@ find_array_section (gfc_expr *expr, gfc_
mpz_init (end[d]);
mpz_init (ctr[d]);
mpz_init (stride[d]);
+      vecsub[d] = NULL;
}

/* Build the counters to clock through the array reference.  */
+  shape_i = 0;
for (d = 0; d < rank; d++)
{
/* Make this stretch of code easier on the eye!  */
@@ -1069,63 +1073,94 @@ find_array_section (gfc_expr *expr, gfc_
lower = ref->u.ar.as->lower[d];
upper = ref->u.ar.as->upper[d];

-      if ((begin && begin->expr_type != EXPR_CONSTANT)
-	    || (finish && finish->expr_type != EXPR_CONSTANT)
-	    || (step && step->expr_type != EXPR_CONSTANT))
-	{
-	  t = FAILURE;
-	  goto cleanup;
-	}
+      if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
+        {
+          gcc_assert(begin);
+	  gcc_assert(begin->expr_type == EXPR_ARRAY);
+	  gcc_assert(begin->rank == 1);
+	  gcc_assert(begin->shape);
+
+	  vecsub[d] = begin->value.constructor;
+	  mpz_set (ctr[d], vecsub[d]->expr->value.integer);
+	  mpz_mul (nelts, nelts, begin->shape[0]);
+	  mpz_set (expr->shape[shape_i++], begin->shape[0]);

-      /* Obtain the stride.  */
-      if (step)
-	mpz_set (stride[d], step->value.integer);
+	  /* Check bounds.  */
+	  for (c = vecsub[d]; c; c = c->next)
+	    {
+	      if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
+	          || mpz_cmp (c->expr->value.integer, lower->value.integer) < 0)
+		{
+		  gfc_error ("index in dimension %d is out of bounds "
+			     "at %L", d + 1, &ref->u.ar.c_where[d]);
+		  t = FAILURE;
+		  goto cleanup;
+		}
+	    }
+        }
else
-	mpz_set_ui (stride[d], one);
+        {
+	  if ((begin && begin->expr_type != EXPR_CONSTANT)
+		|| (finish && finish->expr_type != EXPR_CONSTANT)
+		|| (step && step->expr_type != EXPR_CONSTANT))
+	    {
+	      t = FAILURE;
+	      goto cleanup;
+	    }

-      if (mpz_cmp_ui (stride[d], 0) == 0)
-	mpz_set_ui (stride[d], one);
+	  /* Obtain the stride.  */
+	  if (step)
+	    mpz_set (stride[d], step->value.integer);
+	  else
+	    mpz_set_ui (stride[d], one);

-      /* Obtain the start value for the index.  */
-      if (begin)
-	  mpz_set (start[d], begin->value.integer);
-      else
-	mpz_set (start[d], lower->value.integer);
+	  if (mpz_cmp_ui (stride[d], 0) == 0)
+	    mpz_set_ui (stride[d], one);

-      mpz_set (ctr[d], start[d]);
+	  /* Obtain the start value for the index.  */
+	  if (begin)
+	    mpz_set (start[d], begin->value.integer);
+	  else
+	    mpz_set (start[d], lower->value.integer);

-      /* Obtain the end value for the index.  */
-      if (finish)
-        mpz_set (end[d], finish->value.integer);
-      else
-	mpz_set (end[d], upper->value.integer);
+	  mpz_set (ctr[d], start[d]);

-      /* Separate 'if' because elements sometimes arrive with
-	 non-null end.  */
-      if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
-	mpz_set (end [d], begin->value.integer);
-
-      /* Check the bounds.  */
-      if (mpz_cmp (ctr[d], upper->value.integer) > 0
-	    || mpz_cmp (end[d], upper->value.integer) > 0
-	    || mpz_cmp (ctr[d], lower->value.integer) < 0
-	    || mpz_cmp (end[d], lower->value.integer) < 0)
-	{
-	  gfc_error ("index in dimension %d is out of bounds "
-		     "at %L", d + 1, &ref->u.ar.c_where[d]);
-	  t = FAILURE;
-	  goto cleanup;
-	}
+	  /* Obtain the end value for the index.  */
+	  if (finish)
+	    mpz_set (end[d], finish->value.integer);
+	  else
+	    mpz_set (end[d], upper->value.integer);

-      /* Calculate the number of elements and the shape.  */
-      mpz_abs (tmp_mpz, stride[d]);
-      mpz_div (tmp_mpz, stride[d], tmp_mpz);
-      mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
-      mpz_div (tmp_mpz, tmp_mpz, stride[d]);
-      mpz_mul (nelts, nelts, tmp_mpz);
+	  /* Separate 'if' because elements sometimes arrive with
+	     non-null end.  */
+	  if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
+	    mpz_set (end [d], begin->value.integer);
+
+	  /* Check the bounds.  */
+	  if (mpz_cmp (ctr[d], upper->value.integer) > 0
+	      || mpz_cmp (end[d], upper->value.integer) > 0
+	      || mpz_cmp (ctr[d], lower->value.integer) < 0
+	      || mpz_cmp (end[d], lower->value.integer) < 0)
+	    {
+	      gfc_error ("index in dimension %d is out of bounds "
+			 "at %L", d + 1, &ref->u.ar.c_where[d]);
+	      t = FAILURE;
+	      goto cleanup;
+	    }

-      mpz_set (expr->shape[d], tmp_mpz);
+	  /* Calculate the number of elements and the shape.  */
+	  mpz_abs (tmp_mpz, stride[d]);
+	  mpz_div (tmp_mpz, stride[d], tmp_mpz);
+	  mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
+	  mpz_div (tmp_mpz, tmp_mpz, stride[d]);
+	  mpz_mul (nelts, nelts, tmp_mpz);
+
+	  /* An element reference reduces the rank of the expression; don't add
+	     anything to the shape array.  */
+	  if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
+	    mpz_set (expr->shape[shape_i++], tmp_mpz);
+	}

/* Calculate the 'stride' (=delta) for conversion of the
counter values into the index along the constructor.  */
@@ -1137,7 +1172,6 @@ find_array_section (gfc_expr *expr, gfc_

mpz_init (index);
mpz_init (ptr);
-  mpz_init (stop);
cons = base;

/* Now clock through the array reference, calculating the index in
@@ -1150,7 +1184,7 @@ find_array_section (gfc_expr *expr, gfc_
else
mpz_init_set_ui (ptr, 0);

-      mpz_set_ui (stop, one);
+      incr_ctr = true;
for (d = 0; d < rank; d++)
{
mpz_set (tmp_mpz, ctr[d]);
@@ -1158,16 +1192,32 @@ find_array_section (gfc_expr *expr, gfc_
mpz_mul (tmp_mpz, tmp_mpz, delta[d]);

-	  mpz_mul (tmp_mpz, stride[d], stop);
+	  if (!incr_ctr) continue;

-	  mpz_set (tmp_mpz, end[d]);
-	  if (mpz_cmp_ui (stride[d], 0) > 0 ?
-		mpz_cmp (ctr[d], tmp_mpz) > 0 :
-		mpz_cmp (ctr[d], tmp_mpz) < 0)
-	    mpz_set (ctr[d], start[d]);
+	  if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
+	    {
+	      gcc_assert(vecsub[d]);
+
+	      if (!vecsub[d]->next)
+		vecsub[d] = ref->u.ar.start[d]->value.constructor;
+	      else
+		{
+		  vecsub[d] = vecsub[d]->next;
+		  incr_ctr = false;
+		}
+	      mpz_set (ctr[d], vecsub[d]->expr->value.integer);
+	    }
else
-	    mpz_set_ui (stop, 0);
+	    {
+
+	      if (mpz_cmp_ui (stride[d], 0) > 0 ?
+		    mpz_cmp (ctr[d], end[d]) > 0 :
+		    mpz_cmp (ctr[d], end[d]) < 0)
+		mpz_set (ctr[d], start[d]);
+	      else
+		incr_ctr = false;
+	    }
}

/* There must be a better way of dealing with negative strides
@@ -1189,7 +1239,6 @@ find_array_section (gfc_expr *expr, gfc_

mpz_clear (ptr);
mpz_clear (index);
-  mpz_clear (stop);

cleanup:

```