re PR fortran/49540 (Memory-hog with large DATA stmt)

	PR fortran/49540
	* gfortran.h (gfc_constructor): Add repeat field.
	* trans-array.c (gfc_conv_array_initializer): Handle repeat > 1.
	* array.c (current_expand): Add repeat field.
	(expand_constructor): Copy repeat.
	* constructor.c (node_free, node_copy, gfc_constructor_get,
	gfc_constructor_lookup): Handle repeat field.
	(gfc_constructor_lookup_next, gfc_constructor_remove): New functions.
	* data.h (gfc_assign_data_value): Add mpz_t * argument.
	(gfc_assign_data_value_range): Removed.
	* constructor.h (gfc_constructor_advance): Removed.
	(gfc_constructor_lookup_next, gfc_constructor_remove): New prototypes.
	* data.c (gfc_assign_data_value): Add REPEAT argument, handle it and
	also handle overwriting a range with a single entry.
	(gfc_assign_data_value_range): Removed.
	* resolve.c (check_data_variable): Adjust gfc_assign_data_value
	call.  Use gfc_assign_data_value instead of
	gfc_assign_data_value_expr.

	* gfortran.dg/pr49540-1.f90: New test.
	* gfortran.dg/pr49540-2.f90: New test.

From-SVN: r175693

1 files changed, 127 insertions, 33 deletions

diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 137a939..67da371 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -1,5 +1,5 @@
 /* Supporting functions for resolving DATA statement.
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
    Free Software Foundation, Inc.
    Contributed by Lifang Zeng <zlf605@hotmail.com>
 
@@ -189,10 +189,13 @@ create_character_initializer (gfc_expr *init, gfc_typespec *ts,
 
 /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
    LVALUE already has an initialization, we extend this, otherwise we
-   create a new one.  */
+   create a new one.  If REPEAT is non-NULL, initialize *REPEAT
+   consecutive values in LVALUE the same value in RVALUE.  In that case,
+   LVALUE must refer to a full array, not an array section.  */
 
 gfc_try
-gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
+gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
+		       mpz_t *repeat)
 {
   gfc_ref *ref;
   gfc_expr *init;
@@ -269,6 +272,100 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
 			 &lvalue->where);
 	      goto abort;
 	    }
+	  else if (repeat != NULL
+		   && ref->u.ar.type != AR_ELEMENT)
+	    {
+	      mpz_t size, end;
+	      gcc_assert (ref->u.ar.type == AR_FULL
+			  && ref->next == NULL);
+	      mpz_init_set (end, offset);
+	      mpz_add (end, end, *repeat);
+	      if (spec_size (ref->u.ar.as, &size) == SUCCESS)
+		{
+		  if (mpz_cmp (end, size) > 0)
+		    {
+		      mpz_clear (size);
+		      gfc_error ("Data element above array upper bound at %L",
+				 &lvalue->where);
+		      goto abort;
+		    }
+		  mpz_clear (size);
+		}
+
+	      con = gfc_constructor_lookup (expr->value.constructor,
+					    mpz_get_si (offset));
+	      if (!con)
+		{
+		  con = gfc_constructor_lookup_next (expr->value.constructor,
+						     mpz_get_si (offset));
+		  if (con != NULL && mpz_cmp (con->offset, end) >= 0)
+		    con = NULL;
+		}
+
+	      /* Overwriting an existing initializer is non-standard but
+		 usually only provokes a warning from other compilers.  */
+	      if (con != NULL && con->expr != NULL)
+		{
+		  /* Order in which the expressions arrive here depends on
+		     whether they are from data statements or F95 style
+		     declarations.  Therefore, check which is the most
+		     recent.  */
+		  gfc_expr *exprd;
+		  exprd = (LOCATION_LINE (con->expr->where.lb->location)
+			   > LOCATION_LINE (rvalue->where.lb->location))
+			  ? con->expr : rvalue;
+		  if (gfc_notify_std (GFC_STD_GNU,"Extension: "
+				      "re-initialization of '%s' at %L",
+				      symbol->name, &exprd->where) == FAILURE)
+		    return FAILURE;
+		}
+
+	      while (con != NULL)
+		{
+		  gfc_constructor *next_con = gfc_constructor_next (con);
+
+		  if (mpz_cmp (con->offset, end) >= 0)
+		    break;
+		  if (mpz_cmp (con->offset, offset) < 0)
+		    {
+		      gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
+		      mpz_sub (con->repeat, offset, con->offset);
+		    }
+		  else if (mpz_cmp_si (con->repeat, 1) > 0
+			   && mpz_get_si (con->offset)
+			      + mpz_get_si (con->repeat) > mpz_get_si (end))
+		    {
+		      int endi;
+		      splay_tree_node node
+			= splay_tree_lookup (con->base,
+					     mpz_get_si (con->offset));
+		      gcc_assert (node
+				  && con == (gfc_constructor *) node->value
+				  && node->key == (splay_tree_key)
+						  mpz_get_si (con->offset));
+		      endi = mpz_get_si (con->offset)
+			     + mpz_get_si (con->repeat);
+		      if (endi > mpz_get_si (end) + 1)
+			mpz_set_si (con->repeat, endi - mpz_get_si (end));
+		      else
+			mpz_set_si (con->repeat, 1);
+		      mpz_set (con->offset, end);
+		      node->key = (splay_tree_key) mpz_get_si (end);
+		      break;
+		    }
+		  else
+		    gfc_constructor_remove (con);
+		  con = next_con;
+		}
+
+	      con = gfc_constructor_insert_expr (&expr->value.constructor,
+						 NULL, &rvalue->where,
+						 mpz_get_si (offset));
+	      mpz_set (con->repeat, *repeat);
+	      repeat = NULL;
+	      mpz_clear (end);
+	      break;
+	    }
 	  else
 	    {
 	      mpz_t size;
@@ -293,6 +390,32 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
 						 NULL, &rvalue->where,
 						 mpz_get_si (offset));
 	    }
+	  else if (mpz_cmp_si (con->repeat, 1) > 0)
+	    {
+	      /* Need to split a range.  */
+	      if (mpz_cmp (con->offset, offset) < 0)
+		{
+		  gfc_constructor *pred_con = con;
+		  con = gfc_constructor_insert_expr (&expr->value.constructor,
+						     NULL, &con->where,
+						     mpz_get_si (offset));
+		  con->expr = gfc_copy_expr (pred_con->expr);
+		  mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
+		  mpz_sub (con->repeat, con->repeat, offset);
+		  mpz_sub (pred_con->repeat, offset, pred_con->offset);
+		}
+	      if (mpz_cmp_si (con->repeat, 1) > 0)
+		{
+		  gfc_constructor *succ_con;
+		  succ_con
+		    = gfc_constructor_insert_expr (&expr->value.constructor,
+						   NULL, &con->where,
+						   mpz_get_si (offset) + 1);
+		  succ_con->expr = gfc_copy_expr (con->expr);
+		  mpz_sub_ui (succ_con->repeat, con->repeat, 1);
+		  mpz_set_si (con->repeat, 1);
+		}
+	    }
 	  break;
 
 	case REF_COMPONENT:
@@ -337,6 +460,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
     }
 
   mpz_clear (offset);
+  gcc_assert (repeat == NULL);
 
   if (ref || last_ts->type == BT_CHARACTER)
     {
@@ -380,36 +504,6 @@ abort:
 }
 
 
-/* Similarly, but initialize REPEAT consecutive values in LVALUE the same
-   value in RVALUE.  */
-
-gfc_try
-gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
-			     mpz_t index, mpz_t repeat)
-{
-  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;
-      }
-
-  mpz_clear (offset);
-  mpz_clear (last_offset);
-
-  return t;
-}
-
-
 /* Modify the index of array section and re-calculate the array offset.  */
 
 void