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

1 files changed, 45 insertions, 13 deletions

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)
 	{