re PR fortran/24978 (ICE in gfc_assign_data_value_range)

gcc/fortran/:
2010-05-05  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/24978
	* gfortran.h: Removed repeat count from constructor, removed
	all usages.
	* data.h (gfc_assign_data_value_range): Changed return value from
	void to gfc_try.
	* data.c (gfc_assign_data_value): Add location to constructor element.
	(gfc_assign_data_value_range): Call gfc_assign_data_value()
	for each element in range. Return early if an error was generated.
	* resolve.c (check_data_variable): Stop early if range assignment
	generated an error.

gcc/testsuite/:
2010-05-05  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/24978
	* gfortran.dg/data_invalid.f90: New.

From-SVN: r159076

10 files changed, 176 insertions, 205 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0641cbf..090a431 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2010-05-05  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/24978
+	* gfortran.h: Removed repeat count from constructor, removed
+	all usages.
+	* data.h (gfc_assign_data_value_range): Changed return value from
+	void to gfc_try.
+	* data.c (gfc_assign_data_value): Add location to constructor element.
+	(gfc_assign_data_value_range): Call gfc_assign_data_value()
+	for each element in range. Return early if an error was generated.
+	* resolve.c (check_data_variable): Stop early if range assignment
+	generated an error.
+
 2010-05-05  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/43696
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 5487be7..3ffc397 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1266,7 +1266,6 @@ typedef struct
 
   mpz_t *offset;
   gfc_component *component;
-  mpz_t *repeat;
 
   gfc_try (*expand_work_function) (gfc_expr *);
 }
@@ -1501,7 +1500,6 @@ expand_constructor (gfc_constructor_base base)
 	  return FAILURE;
 	}
       current_expand.offset = &c->offset;
-      current_expand.repeat = &c->repeat;
       current_expand.component = c->n.component;
       if (current_expand.expand_work_function (e) == FAILURE)
 	return FAILURE;
diff --git a/gcc/fortran/constructor.c b/gcc/fortran/constructor.c
index 12bbdc4..45228b0 100644
--- a/gcc/fortran/constructor.c
+++ b/gcc/fortran/constructor.c
@@ -36,7 +36,6 @@ node_free (splay_tree_value value)
     gfc_free_iterator (c->iterator, 1);
 
   mpz_clear (c->offset);
-  mpz_clear (c->repeat);
 
   gfc_free (c);
 }
@@ -55,7 +54,6 @@ node_copy (splay_tree_node node, void *base)
   c->n.component = src->n.component;
 
   mpz_init_set (c->offset, src->offset);
-  mpz_init_set (c->repeat, src->repeat);
 
   return c;
 }
@@ -80,7 +78,6 @@ gfc_constructor_get (void)
   c->iterator = NULL;
 
   mpz_init_set_si (c->offset, 0);
-  mpz_init_set_si (c->repeat, 0);
 
   return c;
 }
@@ -172,7 +169,6 @@ gfc_constructor_insert_expr (gfc_constructor_base *base,
 gfc_constructor *
 gfc_constructor_lookup (gfc_constructor_base base, int offset)
 {
-  gfc_constructor *c;
   splay_tree_node node;
 
   if (!base)
@@ -182,22 +178,7 @@ gfc_constructor_lookup (gfc_constructor_base base, int offset)
   if (node)
     return (gfc_constructor*) node->value;
 
-  /* Check if the previous node has a repeat count big enough to
-     cover the offset looked for.  */
-  node = splay_tree_predecessor (base, offset);
-  if (!node)
-    return NULL;
-
-  c = (gfc_constructor*) node->value;
-  if (mpz_cmp_si (c->repeat, 1) > 0)
-    {
-      if (mpz_get_si (c->offset) + mpz_get_si (c->repeat) <= offset)
-	c = NULL;
-    }
-  else
-    c = NULL;
-
-  return c;
+  return NULL;
 }
 
 
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index fca251c..c217e1c 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -288,7 +288,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
 	  if (!con)
 	    {
 	      con = gfc_constructor_insert_expr (&expr->value.constructor,
-						 NULL, NULL,
+						 NULL, &rvalue->where,
 						 mpz_get_si (offset));
 	    }
 	  break;
@@ -352,8 +352,10 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
 	  expr = (LOCATION_LINE (init->where.lb->location)
 		  > LOCATION_LINE (rvalue->where.lb->location))
 	       ? init : rvalue;
-	  gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
-			  "of '%s' at %L", symbol->name, &expr->where);
+	  if (gfc_notify_std (GFC_STD_GNU,"Extension: "
+			      "re-initialization of '%s' at %L",
+			      symbol->name, &expr->where) == FAILURE)
+	    return FAILURE;
 	}
 
       expr = gfc_copy_expr (rvalue);
@@ -371,149 +373,35 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
 
 
 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
-   value in RVALUE.  For the nonce, LVALUE must refer to a full array, not
-   an array section.  */
+   value in RVALUE.  */
 
-void
+gfc_try
 gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
 			     mpz_t index, mpz_t repeat)
 {
-  gfc_ref *ref;
-  gfc_expr *init, *expr;
-  gfc_constructor *con, *last_con;
-  gfc_symbol *symbol;
-  gfc_typespec *last_ts;
-  mpz_t offset;
-
-  symbol = lvalue->symtree->n.sym;
-  init = symbol->value;
-  last_ts = &symbol->ts;
-  last_con = NULL;
-  mpz_init_set_si (offset, 0);
-
-  /* Find/create the parent expressions for subobject references.  */
-  for (ref = lvalue->ref; ref; ref = ref->next)
-    {
-      /* Use the existing initializer expression if it exists.
-	 Otherwise create a new one.  */
-      if (init == NULL)
-	expr = gfc_get_expr ();
-      else
-	expr = init;
-
-      /* Find or create this element.  */
-      switch (ref->type)
-	{
-	case REF_ARRAY:
-	  if (init == NULL)
-	    {
-	      /* The element typespec will be the same as the array
-		 typespec.  */
-	      expr->ts = *last_ts;
-	      /* Setup the expression to hold the constructor.  */
-	      expr->expr_type = EXPR_ARRAY;
-	      expr->rank = ref->u.ar.as->rank;
-	    }
-	  else
-	    gcc_assert (expr->expr_type == EXPR_ARRAY);
-
-	  if (ref->u.ar.type == AR_ELEMENT)
-	    {
-	      get_array_index (&ref->u.ar, &offset);
-
-	      /* This had better not be the bottom of the reference.
-		 We can still get to a full array via a component.  */
-	      gcc_assert (ref->next != NULL);
-	    }
-	  else
-	    {
-	      mpz_set (offset, index);
-
-	      /* We're at a full array or an array section.  This means
-		 that we've better have found a full array, and that we're
-		 at the bottom of the reference.  */
-	      gcc_assert (ref->u.ar.type == AR_FULL);
-	      gcc_assert (ref->next == NULL);
-	    }
-
-	  con = gfc_constructor_lookup (expr->value.constructor,
-					mpz_get_si (offset));
-	  if (con == NULL)
-	    {
-	      con = gfc_constructor_insert_expr (&expr->value.constructor,
-						 NULL, NULL,
-						 mpz_get_si (offset));
-	      if (ref->next == NULL)
-		mpz_set (con->repeat, repeat);
-	    }
-	  else
-	    gcc_assert (ref->next != NULL);
-	  break;
-
-	case REF_COMPONENT:
-	  if (init == NULL)
-	    {
-	      /* Setup the expression to hold the constructor.  */
-	      expr->expr_type = EXPR_STRUCTURE;
-	      expr->ts.type = BT_DERIVED;
-	      expr->ts.u.derived = ref->u.c.sym;
-	    }
-	  else
-	    gcc_assert (expr->expr_type == EXPR_STRUCTURE);
-	  last_ts = &ref->u.c.component->ts;
-
-  	  /* Find the same element in the existing constructor.  */
-	  con = find_con_by_component (ref->u.c.component,
-				       expr->value.constructor);
-
-	  if (con == NULL)
-	    {
-	      /* Create a new constructor.  */
-	      con = gfc_constructor_append_expr (&expr->value.constructor,
-						 NULL, NULL);
-	      con->n.component = ref->u.c.component;
-	    }
-
-	  /* Since we're only intending to initialize arrays here,
-	     there better be an inner reference.  */
-	  gcc_assert (ref->next != NULL);
-	  break;
-
-	case REF_SUBSTRING:
-	default:
-	  gcc_unreachable ();
-	}
-
-      if (init == NULL)
-	{
-	  /* Point the container at the new expression.  */
-	  if (last_con == NULL)
-	    symbol->value = expr;
-	  else
-	    last_con->expr = expr;
-	}
-      init = con->expr;
-      last_con = con;
-    }
+  mpz_t offset, last_offset;
+  gfc_try t;
+
+  mpz_init (offset);
+  mpz_init (last_offset);
+  mpz_add (last_offset, index, repeat);
+
+  t = SUCCESS;
+  for (mpz_set(offset, index) ; mpz_cmp(offset, last_offset) < 0;
+		   mpz_add_ui (offset, offset, 1))
+    if (gfc_assign_data_value (lvalue, rvalue, offset) == FAILURE)
+      {
+	t = FAILURE;
+	break;
+      }
 
-  if (last_ts->type == BT_CHARACTER)
-    expr = create_character_intializer (init, last_ts, NULL, rvalue);
-  else
-    {
-      /* We should never be overwriting an existing initializer.  */
-      gcc_assert (!init);
+  mpz_clear (offset);
+  mpz_clear (last_offset);
 
-      expr = gfc_copy_expr (rvalue);
-      if (!gfc_compare_types (&lvalue->ts, &expr->ts))
-	gfc_convert_type (expr, &lvalue->ts, 0);
-    }
-
-  if (last_con == NULL)
-    symbol->value = expr;
-  else
-    last_con->expr = expr;
+  return t;
 }
 
+
 /* Modify the index of array section and re-calculate the array offset.  */
 
 void 
diff --git a/gcc/fortran/data.h b/gcc/fortran/data.h
index 0d31a92..c54c75d 100644
--- a/gcc/fortran/data.h
+++ b/gcc/fortran/data.h
@@ -20,5 +20,5 @@ along with GCC; see the file COPYING3.  If not see
 void gfc_formalize_init_value (gfc_symbol *);
 void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *);
 gfc_try gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t);
-void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
+gfc_try gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
 void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 11ce974..827a13f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2187,8 +2187,6 @@ typedef struct gfc_constructor
      gfc_component *component; /* Record the component being initialized.  */
   }
   n;
-  mpz_t repeat; /* Record the repeat number of initial values in data
-                  statement like "data a/5*10/".  */
 }
 gfc_constructor;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d92c69c..2c79863 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11781,11 +11781,14 @@ check_data_variable (gfc_data_variable *var, locus *where)
 	      mpz_set_ui (size, 0);
 	    }
 
-	  gfc_assign_data_value_range (var->expr, values.vnode->expr,
-				       offset, range);
+	  t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
+					   offset, range);
 
 	  mpz_add (offset, offset, range);
 	  mpz_clear (range);
+
+	  if (t == FAILURE)
+	    break;
 	}
 
       /* Assign initial value to symbol.  */
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index e20406c..8ece643 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4133,11 +4133,10 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
 {
   gfc_constructor *c;
   tree tmp;
-  mpz_t maxval;
   gfc_se se;
   HOST_WIDE_INT hi;
   unsigned HOST_WIDE_INT lo;
-  tree index, range;
+  tree index;
   VEC(constructor_elt,gc) *v = NULL;
 
   switch (expr->expr_type)
@@ -4190,42 +4189,13 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
             index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
           else
             index = NULL_TREE;
-	  mpz_init (maxval);
-          if (mpz_cmp_si (c->repeat, 0) != 0)
-            {
-              tree tmp1, tmp2;
-
-              mpz_set (maxval, c->repeat);
-              mpz_add (maxval, c->offset, maxval);
-              mpz_sub_ui (maxval, maxval, 1);
-              tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
-              if (mpz_cmp_si (c->offset, 0) != 0)
-                {
-                  mpz_add_ui (maxval, c->offset, 1);
-                  tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
-                }
-              else
-                tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
-
-              range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
-            }
-          else
-            range = NULL;
-	  mpz_clear (maxval);
 
           gfc_init_se (&se, NULL);
 	  switch (c->expr->expr_type)
 	    {
 	    case EXPR_CONSTANT:
 	      gfc_conv_constant (&se, c->expr);
-              if (range == NULL_TREE)
-		CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
-              else
-                {
-                  if (index != NULL_TREE)
-		    CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
-		  CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
-                }
+	      CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
 	      break;
 
 	    case EXPR_STRUCTURE:
@@ -4239,14 +4209,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
 		 for one reason or another, assuming that if they are
 		 standard defying the frontend will catch them.  */
 	      gfc_conv_expr (&se, c->expr);
-	      if (range == NULL_TREE)
-		CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
-	      else
-		{
-		  if (index != NULL_TREE)
-		  CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
-		  CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
-		}
+	      CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
 	      break;
 	    }
         }
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9cee690..3ff3220 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-05-05  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/24978
+	* gfortran.dg/data_invalid.f90: New.
+
 2010-05-05  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/lto2.adb: New test.
diff --git a/gcc/testsuite/gfortran.dg/data_invalid.f90 b/gcc/testsuite/gfortran.dg/data_invalid.f90
new file mode 100644
index 0000000..10ea7e5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_invalid.f90
@@ -0,0 +1,122 @@
+! { dg-do "compile" }
+! { dg-options "-std=f95 -fmax-errors=0" }
+!
+! Testcases from PR fortran/24978
+!
+
+SUBROUTINE data_init_scalar_invalid()
+  integer :: a
+  data       a / 1 /
+  data       a / 1 /                             ! { dg-error "re-initialization" }
+
+  integer :: b = 0
+  data       b / 1 /                             ! { dg-error "re-initialization" }
+END SUBROUTINE
+
+SUBROUTINE data_init_array_invalid()
+  ! initialize (at least) one element, re-initialize full array
+  integer :: a(3)
+  data       a(2) / 2 /
+  data       a    / 3*1 /                        ! { dg-error "re-initialization" }
+
+  ! initialize (at least) one element, re-initialize subsection including the element
+  integer :: b(3)
+  data       b(2)   / 2 /
+  data       b(1:2) / 2*1 /                      ! { dg-error "re-initialization" }
+
+  ! initialize subsection, re-initialize (intersecting) subsection
+  integer :: c(3)
+  data       c(1:2) / 2*1 /
+  data       c(2:3) / 1,1 /                      ! { dg-error "re-initialization" }
+
+  ! initialize subsection, re-initialize full array
+  integer :: d(3)
+  data       d(2:3) / 2*1 /
+  data       d      / 2*2, 3 /                   ! { dg-error "re-initialization" }
+
+  ! full array initializer, re-initialize (at least) one element
+  integer :: e(3)
+  data       e    / 3*1 /
+  data       e(2) / 2 /                          ! { dg-error "re-initialization" }
+
+  integer :: f(3) = 0                            ! { dg-error "already is initialized" }
+  data       f(2) / 1 /
+
+  ! full array initializer, re-initialize subsection
+  integer :: g(3)
+  data       g      / 3*1 /
+  data       g(1:2) / 2*2 /                      ! { dg-error "re-initialization" }
+
+  integer :: h(3) = 1                            ! { dg-error "already is initialized" }
+  data       h(2:3) / 2*2 /
+
+  ! full array initializer, re-initialize full array
+  integer :: i(3)
+  data       i   / 3*1 /
+  data       i   / 2,2,2 /                       ! { dg-error "re-initialization" }
+
+  integer :: j(3) = 1                            ! { dg-error "already is initialized" }
+  data       j   / 3*2 /
+END SUBROUTINE
+
+SUBROUTINE data_init_matrix_invalid()
+  ! initialize (at least) one element, re-initialize full matrix
+  integer :: a(3,3)
+  data       a(2,2) / 1 /
+  data       a      / 9*2 /                      ! { dg-error "re-initialization" }
+
+  ! initialize (at least) one element, re-initialize subsection
+  integer :: b(3,3)
+  data       b(2,2) / 1 /
+  data       b(2,:) / 3*2 /                      ! { dg-error "re-initialization" }
+
+  ! initialize subsection, re-initialize (intersecting) subsection
+  integer :: c(3,3)
+  data       c(3,:) / 3*1 /, c(:,3) / 3*2 /      ! { dg-error "re-initialization" }
+
+  ! initialize subsection, re-initialize full array
+  integer :: d(3,3)
+  data       d(2,:) / 1,2,3 /
+  data       d      / 9*4 /                      ! { dg-error "re-initialization" }
+
+  ! full array initializer, re-initialize (at least) one element
+  integer :: e(3,3)
+  data       e      / 9*1 /
+  data       e(2,3) / 2 /                        ! { dg-error "re-initialization" }
+
+  integer :: f(3,3) = 1                          ! { dg-error "already is initialized" }
+  data       f(3,2) / 2 /
+
+  ! full array initializer, re-initialize subsection
+  integer :: g(3,3)
+  data       g          / 9 * 1 /
+  data       g(2:3,2:3) / 2, 2*3, 4 /            ! { dg-error "re-initialization" }
+
+  integer :: h(3,3) = 1                          ! { dg-error "already is initialized" }
+  data       h(2:3,2:3) / 2, 2*3, 4 /
+
+  ! full array initializer, re-initialize full array
+  integer :: i(3,3)
+  data       i   / 3*1, 3*2, 3*3 /
+  data       i   / 9 * 1 /                       ! { dg-error "re-initialization" }
+
+  integer :: j(3,3) = 0                          ! { dg-error "already is initialized" }
+  data       j   / 9 * 1 /
+END SUBROUTINE
+
+SUBROUTINE data_init_misc_invalid()
+  ! wrong number of dimensions
+  integer :: a(3)
+  data       a(1,1) / 1 /                        ! { dg-error "Rank mismatch" }
+
+  ! index out-of-bounds, direct access
+  integer :: b(3)
+  data       b(-2) / 1 /                         ! { dg-error "below array lower bound" }
+
+  ! index out-of-bounds, implied do-loop (PR32315)
+  integer :: i
+  character(len=20), dimension(4) :: string
+  data (string(i), i = 1, 5) / 'A', 'B', 'C', 'D', 'E' /   ! { dg-error "above array upper bound" }
+END SUBROUTINE
+
+! { dg-excess-errors "" }