re PR fortran/29630 ("Unclassifiable statement" with vector subscripts in initialization)

fortran/
2006-11-06  Erik Edelmann  <eedelman@gcc.gnu.org>

        PR fortran/29630
        PR fortran/29679
        * expr.c (find_array_section): Support vector subscripts.  Don't
        add sizes for dimen_type == DIMEN_ELEMENT to the shape array.


testsuite/
2006-11-06  Erik Edelmann  <eedelman@gcc.gnu.org>

        PR fortran/29630
        PR fortran/29679
        * gfortran.dg/initialization_2.f90: Test PRs 29630 and 29679 too.
        * gfortran.dg/initialization_3.f90: New.

From-SVN: r118528

gcc/fortran/ChangeLog

+2006-11-06  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/29630
+	PR fortran/29679
+	* expr.c (find_array_section): Support vector subscripts.  Don't
+	  add sizes for dimen_type == DIMEN_ELEMENT to the shape array.
+
 2006-11-05  Bernhard Fischer  <aldot@gcc.gnu.org>
 
 	PR fortran/21061

gcc/fortran/expr.c

@@ -1013,7 +1013,9 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
   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_ref *ref)
   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_ref *ref)
   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_ref *ref)
       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,64 +1073,95 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
       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;
-	}
-
-      /* Obtain the stride.  */
-      if (step)
-	mpz_set (stride[d], step->value.integer);
+      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]);
+
+	  /* 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);
+	  /* Obtain the end value for the index.  */
+	  if (finish)
+	    mpz_set (end[d], finish->value.integer);
+	  else
+	    mpz_set (end[d], upper->value.integer);
+
+	  /* 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;
+	    }
 
-      /* 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;
+	  /* Calculate the number of elements and the shape.  */
+	  mpz_abs (tmp_mpz, stride[d]);
+	  mpz_div (tmp_mpz, stride[d], tmp_mpz);
+	  mpz_add (tmp_mpz, end[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 number of elements and the shape.  */
-      mpz_abs (tmp_mpz, stride[d]);
-      mpz_div (tmp_mpz, stride[d], tmp_mpz);
-      mpz_add (tmp_mpz, end[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);
-
-      mpz_set (expr->shape[d], tmp_mpz);
-
       /* Calculate the 'stride' (=delta) for conversion of the
 	 counter values into the index along the constructor.  */
       mpz_set (delta[d], delta_mpz);
@@ -1137,7 +1172,6 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
 
   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_ref *ref)
       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_ref *ref)
 	  mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
 	  mpz_add (ptr, ptr, tmp_mpz);
 
-	  mpz_mul (tmp_mpz, stride[d], stop);
-	  mpz_add (ctr[d], ctr[d], tmp_mpz); 
+	  if (!incr_ctr) continue;
+
+	  if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
+	    {
+	      gcc_assert(vecsub[d]);
 
-	  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 (!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);
+	    {
+	      mpz_add (ctr[d], ctr[d], stride[d]); 
+
+	      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_ref *ref)
 
   mpz_clear (ptr);
   mpz_clear (index);
-  mpz_clear (stop);
 
 cleanup:
 

gcc/testsuite/ChangeLog

+2006-11-06  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/29630
+	PR fortran/29679
+	* gfortran.dg/initialization_2.f90: Test PRs 29630 and 29679 too.
+	* gfortran.dg/initialization_3.f90: New.
+
 2006-11-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/25545

gcc/testsuite/gfortran.dg/initialization_2.f90

-! { 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

gcc/testsuite/gfortran.dg/initialization_3.f90

+! { 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