2007-01-05 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/23232
	* decl.c (gfc_in_match_data, gfc_set_in_match_data): New
	functions to signal that a DATA statement is being matched.
	(gfc_match_data): Call gfc_set_in_match_data on entry and on
	exit.
	* gfortran.h : Add prototypes for above.
	* expr.c (check_init_expr): Avoid check on parameter or
	variable if gfc_in_match_data is true.
	(gfc_match_init_expr): Do not call error on non-reduction of
	expression if gfc_in_match_data is true.

	PR fortran/27996
	PR fortran/27998
	* decl.c (gfc_set_constant_character_len): Add boolean arg to
	flag array constructor resolution.  Warn if string is being
	truncated.  Standard dependent error if string is padded. Set
	new arg to false for all three calls to
	gfc_set_constant_character_len.
	* match.h : Add boolean arg to prototype for
	gfc_set_constant_character_len.
	* gfortran.h : Add warn_character_truncation to gfc_options.
	* options.c (set_Wall): Set warn_character_truncation if -Wall
	is set.
	* resolve.c (resolve_code): Warn if rhs string in character
	assignment has to be truncated.
	* array.c (gfc_resolve_character_array_constructor): Set new
	argument to true for call to gfc_set_constant_character_len.

2007-01-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/23232
	* gfortran.dg/data_implied_do_1.f90: New test.

	PR fortran/27996
	PR fortran/27998
	* gfortran.dg/char_length_1.f90: New test.




git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@120485 138bc75d-0d04-0410-961f-82ee72b054a4

11 files changed, 193 insertions, 25 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index be3a9b5ebd6..0d9ade0da9d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,33 @@
+2007-01-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/23232
+	* decl.c (gfc_in_match_data, gfc_set_in_match_data): New
+	functions to signal that a DATA statement is being matched.
+	(gfc_match_data): Call gfc_set_in_match_data on entry and on
+	exit.
+	* gfortran.h : Add prototypes for above.
+	* expr.c (check_init_expr): Avoid check on parameter or
+	variable if gfc_in_match_data is true.
+	(gfc_match_init_expr): Do not call error on non-reduction of
+	expression if gfc_in_match_data is true.
+
+	PR fortran/27996
+	PR fortran/27998
+	* decl.c (gfc_set_constant_character_len): Add boolean arg to
+	flag array constructor resolution.  Warn if string is being
+	truncated.  Standard dependent error if string is padded. Set
+	new arg to false for all three calls to
+	gfc_set_constant_character_len.
+	* match.h : Add boolean arg to prototype for
+	gfc_set_constant_character_len.
+	* gfortran.h : Add warn_character_truncation to gfc_options.
+	* options.c (set_Wall): Set warn_character_truncation if -Wall
+	is set.
+	* resolve.c (resolve_code): Warn if rhs string in character
+	assignment has to be truncated.
+	* array.c (gfc_resolve_character_array_constructor): Set new
+	argument to true for call to gfc_set_constant_character_len.
+
 2007-01-05  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/29624
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 479e60bdc7b..d3606f52d81 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1587,7 +1587,7 @@ got_charlen:
 	  /* Update the element constructors.  */
 	  for (p = expr->value.constructor; p; p = p->next)
 	    if (p->expr->expr_type == EXPR_CONSTANT)
-	      gfc_set_constant_character_len (max_length, p->expr);
+	      gfc_set_constant_character_len (max_length, p->expr, true);
 	}
     }
 }
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d8988fd2015..b2f401f6efb 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -74,6 +74,20 @@ gfc_symbol *gfc_new_block;
 
 /********************* DATA statement subroutines *********************/
 
+static bool in_match_data = false;
+
+bool
+gfc_in_match_data (void)
+{
+  return in_match_data;
+}
+
+void
+gfc_set_in_match_data (bool set_value)
+{
+  in_match_data = set_value;
+}
+
 /* Free a gfc_data_variable structure and everything beneath it.  */
 
 static void
@@ -455,6 +469,8 @@ gfc_match_data (void)
   gfc_data *new;
   match m;
 
+  gfc_set_in_match_data (true);
+
   for (;;)
     {
       new = gfc_get_data ();
@@ -477,6 +493,8 @@ gfc_match_data (void)
       gfc_match_char (',');	/* Optional comma */
     }
 
+  gfc_set_in_match_data (false);
+
   if (gfc_pure (NULL))
     {
       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
@@ -486,6 +504,7 @@ gfc_match_data (void)
   return MATCH_YES;
 
 cleanup:
+  gfc_set_in_match_data (false);
   gfc_free_data (new);
   return MATCH_ERROR;
 }
@@ -743,7 +762,7 @@ build_sym (const char *name, gfc_charlen * cl,
    truncated.  */
 
 void
-gfc_set_constant_character_len (int len, gfc_expr * expr)
+gfc_set_constant_character_len (int len, gfc_expr * expr, bool array)
 {
   char * s;
   int slen;
@@ -758,6 +777,18 @@ gfc_set_constant_character_len (int len, gfc_expr * expr)
       memcpy (s, expr->value.character.string, MIN (len, slen));
       if (len > slen)
 	memset (&s[slen], ' ', len - slen);
+
+      if (gfc_option.warn_character_truncation && slen > len)
+	gfc_warning_now ("CHARACTER expression at %L is being truncated "
+			 "(%d/%d)", &expr->where, slen, len);
+
+      /* Apply the standard by 'hand' otherwise it gets cleared for
+	 initializers.  */
+      if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
+	gfc_error_now ("The CHARACTER elements of the array constructor "
+		       "at %L must have the same length (%d/%d)",
+		        &expr->where, slen, len);
+
       s[len] = '\0';
       gfc_free (expr->value.character.string);
       expr->value.character.string = s;
@@ -909,13 +940,13 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
 	      gfc_constructor * p;
 
 	      if (init->expr_type == EXPR_CONSTANT)
-		gfc_set_constant_character_len (len, init);
+		gfc_set_constant_character_len (len, init, false);
 	      else if (init->expr_type == EXPR_ARRAY)
 		{
 		  gfc_free_expr (init->ts.cl->length);
 		  init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
 		  for (p = init->value.constructor; p; p = p->next)
-		    gfc_set_constant_character_len (len, p->expr);
+		    gfc_set_constant_character_len (len, p->expr, false);
 		}
 	    }
 	}
@@ -4025,7 +4056,7 @@ do_parm (void)
       && init->ts.type == BT_CHARACTER
       && init->ts.kind == 1)
     gfc_set_constant_character_len (
-      mpz_get_si (sym->ts.cl->length->value.integer), init);
+      mpz_get_si (sym->ts.cl->length->value.integer), init, false);
 
   sym->value = init;
   return MATCH_YES;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 7c2069c340b..1146bd11796 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1829,6 +1829,9 @@ check_init_expr (gfc_expr * e)
 	  break;
 	}
 
+      if (gfc_in_match_data ())
+	break;
+
       gfc_error ("Parameter '%s' at %L has not been declared or is "
 		 "a variable, which does not reduce to a constant "
 		 "expression", e->symtree->n.sym->name, &e->where);
@@ -1912,7 +1915,8 @@ gfc_match_init_expr (gfc_expr ** result)
   /* Not all inquiry functions are simplified to constant expressions
      so it is necessary to call check_inquiry again.  */ 
   if (!gfc_is_constant_expr (expr)
-	&& check_inquiry (expr, 1) == FAILURE)
+	&& check_inquiry (expr, 1) == FAILURE
+	&& !gfc_in_match_data ())
     {
       gfc_error ("Initialization expression didn't reduce %C");
       return MATCH_ERROR;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 62862977eeb..695d26d817d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1637,6 +1637,7 @@ typedef struct
   int warn_surprising;
   int warn_tabs;
   int warn_underflow;
+  int warn_character_truncation;
   int max_errors;
 
   int flag_all_intrinsics;
@@ -1713,6 +1714,10 @@ void gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t);
 void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
 void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
 
+/* decl.c */
+bool gfc_in_match_data (void);
+void gfc_set_in_match_data (bool);
+
 /* scanner.c */
 void gfc_scanner_done_1 (void);
 void gfc_scanner_init_1 (void);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 2209c0ded6d..3c8089af566 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -130,7 +130,7 @@ match gfc_match_derived_decl (void);
 match gfc_match_implicit_none (void);
 match gfc_match_implicit (void);
 
-void gfc_set_constant_character_len (int, gfc_expr *);
+void gfc_set_constant_character_len (int, gfc_expr *, bool);
 
 /* Matchers for attribute declarations */
 match gfc_match_allocatable (void);
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 8819b6037c6..da8db65dbb1 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -309,6 +309,7 @@ set_Wall (void)
   gfc_option.warn_surprising = 1;
   gfc_option.warn_tabs = 0;
   gfc_option.warn_underflow = 1;
+  gfc_option.warn_character_truncation = 1;
 
   set_Wunused (1);
   warn_return_type = 1;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3c28d452ee4..44236e576b6 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5084,6 +5084,28 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
 	      goto call;
 	    }
 
+	  if (code->expr->ts.type == BT_CHARACTER
+		&& gfc_option.warn_character_truncation)
+	    {
+	      int llen = 0, rlen = 0;
+	      gfc_symbol *sym;
+	      sym = code->expr->symtree->n.sym;
+	      if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+		llen = mpz_get_si (sym->ts.cl->length->value.integer);
+
+	      if (code->expr2->expr_type == EXPR_CONSTANT)
+		rlen = code->expr2->value.character.length;
+
+	      else if (code->expr2->ts.cl != NULL
+		    && code->expr2->ts.cl->length != NULL
+		    && code->expr2->ts.cl->length->expr_type == EXPR_CONSTANT)
+		rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
+
+	      if (rlen && llen && rlen > llen)
+		gfc_warning_now ("rhs of CHARACTER assignment at %L will "
+				 "be truncated (%d/%d)", &code->loc, rlen, llen);
+	    }
+
 	  if (gfc_pure (NULL))
 	    {
 	      if (gfc_impure_variable (code->expr->symtree->n.sym))
@@ -6435,17 +6457,47 @@ traverse_data_list (gfc_data_variable * var, locus * where)
 {
   mpz_t trip;
   iterator_stack frame;
-  gfc_expr *e;
+  gfc_expr *e, *start, *end, *step;
+  try retval = SUCCESS;
 
   mpz_init (frame.value);
 
-  mpz_init_set (trip, var->iter.end->value.integer);
-  mpz_sub (trip, trip, var->iter.start->value.integer);
-  mpz_add (trip, trip, var->iter.step->value.integer);
+  start = gfc_copy_expr (var->iter.start);
+  end = gfc_copy_expr (var->iter.end);
+  step = gfc_copy_expr (var->iter.step);
+
+  if (gfc_simplify_expr (start, 1) == FAILURE
+	|| start->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("iterator start at %L does not simplify",
+		 &start->where);
+      retval = FAILURE;
+      goto cleanup;
+    }
+  if (gfc_simplify_expr (end, 1) == FAILURE
+	||  end->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("iterator end at %L does not simplify",
+		 &end->where);
+      retval = FAILURE;
+      goto cleanup;
+    }
+  if (gfc_simplify_expr (step, 1) == FAILURE
+	||  step->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("iterator step at %L does not simplify",
+		 &step->where);
+      retval = FAILURE;
+      goto cleanup;
+    }
+
+  mpz_init_set (trip, end->value.integer);
+  mpz_sub (trip, trip, start->value.integer);
+  mpz_add (trip, trip, step->value.integer);
 
-  mpz_div (trip, trip, var->iter.step->value.integer);
+  mpz_div (trip, trip, step->value.integer);
 
-  mpz_set (frame.value, var->iter.start->value.integer);
+  mpz_set (frame.value, start->value.integer);
 
   frame.prev = iter_stack;
   frame.variable = var->iter.var->symtree;
@@ -6456,26 +6508,34 @@ traverse_data_list (gfc_data_variable * var, locus * where)
       if (traverse_data_var (var->list, where) == FAILURE)
 	{
 	  mpz_clear (trip);
-	  return FAILURE;
+	  retval = FAILURE;
+	  goto cleanup;
 	}
 
       e = gfc_copy_expr (var->expr);
       if (gfc_simplify_expr (e, 1) == FAILURE)
-        {
-          gfc_free_expr (e);
-          return FAILURE;
-        }
+	{
+	  gfc_free_expr (e);
+	  mpz_clear (trip);
+	  retval = FAILURE;
+	  goto cleanup;
+	}
 
-      mpz_add (frame.value, frame.value, var->iter.step->value.integer);
+      mpz_add (frame.value, frame.value, step->value.integer);
 
       mpz_sub_ui (trip, trip, 1);
     }
 
   mpz_clear (trip);
+cleanup:
   mpz_clear (frame.value);
 
+  gfc_free_expr (start);
+  gfc_free_expr (end);
+  gfc_free_expr (step);
+
   iter_stack = frame.prev;
-  return SUCCESS;
+  return retval;
 }
 
 
@@ -6520,11 +6580,6 @@ resolve_data_variables (gfc_data_variable * d)
 	  if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
 	    return FAILURE;
 
-	  if (d->iter.start->expr_type != EXPR_CONSTANT
-	      || d->iter.end->expr_type != EXPR_CONSTANT
-	      || d->iter.step->expr_type != EXPR_CONSTANT)
-	    gfc_internal_error ("resolve_data_variables(): Bad iterator");
-
 	  if (resolve_data_variables (d->list) == FAILURE)
 	    return FAILURE;
 	}
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3a5224a84f8..49786c58ecc 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2007-01-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/23232
+	* gfortran.dg/data_implied_do_1.f90: New test.
+
+	PR fortran/27996
+	PR fortran/27998
+	* gfortran.dg/char_length_1.f90: New test.
+
 2007-01-05  Richard Guenther  <rguenther@suse.de>
 
 	PR middle-end/28116
diff --git a/gcc/testsuite/gfortran.dg/char_length_1.f90 b/gcc/testsuite/gfortran.dg/char_length_1.f90
index e69de29bb2d..e372343d0b2 100644
--- a/gcc/testsuite/gfortran.dg/char_length_1.f90
+++ b/gcc/testsuite/gfortran.dg/char_length_1.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! { dg-options "-Wall -std=f2003" }
+! Tests the patch for PR27996 and PR27998, in which warnings
+! or errors were not emitted when the length of character
+! constants was changed silently.
+!
+! Contributed by Tobias Burnus <tobias.burnus@physik.fu-berlin.de> 
+!
+program test
+  character(10) :: a(3)
+  character(10) :: b(3)= &
+       (/ 'Takata ', 'Tanaka', 'Hayashi' /) ! { dg-error "same length" }
+  character(4) :: c = "abcde"  ! { dg-warning "being truncated" }
+  a =  (/ 'Takata', 'Tanaka ', 'Hayashi' /) ! { dg-error "same length" }
+  a =  (/ 'Takata ', 'Tanaka ', 'Hayashi' /)
+  b = "abc"
+  c = "abcdefg"   ! { dg-warning "will be truncated" }
+end program test
diff --git a/gcc/testsuite/gfortran.dg/data_implied_do_1.f90 b/gcc/testsuite/gfortran.dg/data_implied_do_1.f90
new file mode 100644
index 00000000000..1cc977c343a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_implied_do_1.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! Test of the patch for PR23232, in which implied do loop
+! variables were not permitted in DATA statements.
+! 
+! Contributed by Roger Ferrer Ibáñez <rofi@ya.com> 
+!
+PROGRAM p
+  REAL :: TWO_ARRAY (3, 3)
+  INTEGER :: K, J
+  DATA ((TWO_ARRAY (K, J), K = 1, J-1), J = 1, 3) /3 * 1.0/
+  DATA ((TWO_ARRAY (K, J), K = J, 3), J = 1, 3) /6 * 2.0/
+  if (any (reshape (two_array, (/9/)) &
+      .ne. (/2.0,2.0,2.0,1.0,2.0,2.0,1.0,1.0,2.0/))) call abort ()
+END PROGRAM
+