PR fortran/36517, fortran/36492

2008-06-18  Daniel Kraft  <d@domob.eu>

	PR fortran/36517, fortran/36492
	* gfortran.dg/array_constructor_25.f03:  New test.
	* gfortran.dg/array_constructor_26.f03:  New test.
	* gfortran.dg/array_constructor_27.f03:  New test.
	* gfortran.dg/array_constructor_28.f03:  New test.
	* gfortran.dg/array_constructor_29.f03:  New test.
	* gfortran.dg/array_constructor_30.f03:  New test.
	* gfortran.dg/array_constructor_type_19.f03:  New test.
	* gfortran.dg/array_constructor_type_20.f03:  New test.
	* gfortran.dg/array_constructor_type_21.f03:  New test.

2008-06-18  Daniel Kraft  <d@domob.eu>

	PR fortran/36517, fortran/36492
	* array.c (gfc_resolve_character_array_constructor):  Call
	gfc_set_constant_character_len with changed length-chec argument.
	* decl.c (gfc_set_constant_character_len):  Changed array argument to
	be a generic length-checking argument that can be used for correct
	checking with typespec and in special cases where the should-be length
	is different from the target length.
	(build_struct):  Call gfc_set_constant_character_len with changed length
	checking argument and introduced additional checks for exceptional
	conditions on invalid code.
	(add_init_expr_to_sym), (do_parm):  Call gfc_set_constant_character_len
	with changed argument.
	* match.h (gfc_set_constant_character_len):  Changed third argument to
	int for the should-be length rather than bool.

From-SVN: r136894

4 files changed, 86 insertions, 33 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e83c3cb..6362039 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2008-06-18  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/36517, fortran/36492
+	* array.c (gfc_resolve_character_array_constructor):  Call
+	gfc_set_constant_character_len with changed length-chec argument.
+	* decl.c (gfc_set_constant_character_len):  Changed array argument to
+	be a generic length-checking argument that can be used for correct
+	checking with typespec and in special cases where the should-be length
+	is different from the target length.
+	(build_struct):  Call gfc_set_constant_character_len with changed length
+	checking argument and introduced additional checks for exceptional
+	conditions on invalid code.
+	(add_init_expr_to_sym), (do_parm):  Call gfc_set_constant_character_len
+	with changed argument.
+	* match.h (gfc_set_constant_character_len):  Changed third argument to
+	int for the should-be length rather than bool.
+
 2008-06-17  Daniel Kraft  <d@domob.eu>
 
 	PR fortran/36112
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 73b78c3..a34695e 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1680,25 +1680,29 @@ got_charlen:
 	 (without typespec) all elements are verified to have the same length
 	 anyway.  */
       if (found_length != -1)
-        for (p = expr->value.constructor; p; p = p->next)
-          if (p->expr->expr_type == EXPR_CONSTANT)
-            {
-              gfc_expr *cl = NULL;
-              int current_length = -1;
-
-              if (p->expr->ts.cl && p->expr->ts.cl->length)
-              {
-                cl = p->expr->ts.cl->length;
-                gfc_extract_int (cl, &current_length);
-              }
-
-              /* If gfc_extract_int above set current_length, we implicitly
-                 know the type is BT_INTEGER and it's EXPR_CONSTANT.  */
-
-              if (! cl
-                  || (current_length != -1 && current_length < found_length))
-                gfc_set_constant_character_len (found_length, p->expr, true);
-            }
+	for (p = expr->value.constructor; p; p = p->next)
+	  if (p->expr->expr_type == EXPR_CONSTANT)
+	    {
+	      gfc_expr *cl = NULL;
+	      int current_length = -1;
+	      bool has_ts;
+
+	      if (p->expr->ts.cl && p->expr->ts.cl->length)
+	      {
+		cl = p->expr->ts.cl->length;
+		gfc_extract_int (cl, &current_length);
+	      }
+
+	      /* If gfc_extract_int above set current_length, we implicitly
+		 know the type is BT_INTEGER and it's EXPR_CONSTANT.  */
+
+	      has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec);
+
+	      if (! cl
+		  || (current_length != -1 && current_length < found_length))
+		gfc_set_constant_character_len (found_length, p->expr,
+						has_ts ? -1 : found_length);
+	    }
     }
 
   return SUCCESS;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index a1c7d5a..57db93f 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1084,10 +1084,12 @@ build_sym (const char *name, gfc_charlen *cl,
 
 
 /* Set character constant to the given length. The constant will be padded or
-   truncated.  */
+   truncated.  If we're inside an array constructor without a typespec, we
+   additionally check that all elements have the same length; check_len -1
+   means no checking.  */
 
 void
-gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
+gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
 {
   gfc_char_t *s;
   int slen;
@@ -1110,10 +1112,11 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
 
       /* Apply the standard by 'hand' otherwise it gets cleared for
 	 initializers.  */
-      if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
+      if (check_len != -1 && slen != check_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);
+			&expr->where, slen, check_len);
 
       s[len] = '\0';
       gfc_free (expr->value.character.string);
@@ -1269,7 +1272,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
 	      gfc_constructor * p;
 
 	      if (init->expr_type == EXPR_CONSTANT)
-		gfc_set_constant_character_len (len, init, false);
+		gfc_set_constant_character_len (len, init, -1);
 	      else if (init->expr_type == EXPR_ARRAY)
 		{
 		  /* Build a new charlen to prevent simplification from
@@ -1280,7 +1283,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
 		  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, false);
+		    gfc_set_constant_character_len (len, p->expr, -1);
 		}
 	    }
 	}
@@ -1402,19 +1405,48 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 
   /* Should this ever get more complicated, combine with similar section
      in add_init_expr_to_sym into a separate function.  */
-  if (c->ts.type == BT_CHARACTER && !c->pointer && c->initializer)
+  if (c->ts.type == BT_CHARACTER && !c->pointer && c->initializer && c->ts.cl
+      && c->ts.cl->length && c->ts.cl->length->expr_type == EXPR_CONSTANT)
     {
-      int len = mpz_get_si (c->ts.cl->length->value.integer);
+      int len;
+
+      gcc_assert (c->ts.cl && c->ts.cl->length);
+      gcc_assert (c->ts.cl->length->expr_type == EXPR_CONSTANT);
+      gcc_assert (c->ts.cl->length->ts.type == BT_INTEGER);
+
+      len = mpz_get_si (c->ts.cl->length->value.integer);
 
       if (c->initializer->expr_type == EXPR_CONSTANT)
-	gfc_set_constant_character_len (len, c->initializer, false);
+	gfc_set_constant_character_len (len, c->initializer, -1);
       else if (mpz_cmp (c->ts.cl->length->value.integer,
 			c->initializer->ts.cl->length->value.integer))
 	{
+	  bool has_ts;
 	  gfc_constructor *ctor = c->initializer->value.constructor;
-	  for (;ctor ; ctor = ctor->next)
-	    if (ctor->expr->expr_type == EXPR_CONSTANT)
-	      gfc_set_constant_character_len (len, ctor->expr, true);
+
+	  bool first = true;
+	  int first_len;
+
+	  has_ts = (c->initializer->ts.cl
+		    && c->initializer->ts.cl->length_from_typespec);
+
+	  for (; ctor; ctor = ctor->next)
+	    {
+	      /* Remember the length of the first element for checking that
+		 all elements *in the constructor* have the same length.  This
+		 need not be the length of the LHS!  */
+	      if (first)
+		{
+		  gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
+		  gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
+		  first_len = ctor->expr->value.character.length;
+		  first = false;
+		}
+
+	      if (ctor->expr->expr_type == EXPR_CONSTANT)
+		gfc_set_constant_character_len (len, ctor->expr,
+						has_ts ? -1 : first_len);
+	    }
 	}
     }
 
@@ -5822,7 +5854,7 @@ do_parm (void)
       && init->expr_type == EXPR_CONSTANT
       && init->ts.type == BT_CHARACTER)
     gfc_set_constant_character_len (
-      mpz_get_si (sym->ts.cl->length->value.integer), init, false);
+      mpz_get_si (sym->ts.cl->length->value.integer), init, -1);
   else if (sym->ts.type == BT_CHARACTER && sym->ts.cl != NULL
 	   && sym->ts.cl->length == NULL)
 	{
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 5ee91fb..cf30b27 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -147,7 +147,7 @@ match gfc_match_final_decl (void);
 match gfc_match_implicit_none (void);
 match gfc_match_implicit (void);
 
-void gfc_set_constant_character_len (int, gfc_expr *, bool);
+void gfc_set_constant_character_len (int, gfc_expr *, int);
 
 /* Matchers for attribute declarations.  */
 match gfc_match_allocatable (void);