re PR fortran/23232 ([4.1 only] DATA implied DO variables)

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.

From-SVN: r120485

1 files changed, 35 insertions, 4 deletions

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d8988fd..b2f401f 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;