1 files changed, 64 insertions, 51 deletions

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 5593289..73b78c3 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1576,23 +1576,20 @@ resolve_array_list (gfc_constructor *p)
   return t;
 }
 
-/* Resolve character array constructor. If it is a constant character array and
-   not specified character length, update character length to the maximum of
-   its element constructors' length.  For arrays with fixed length, pad the
-   elements as necessary with needed_length.  */
+/* Resolve character array constructor. If it has a specified constant character
+   length, pad/trunkate the elements here; if the length is not specified and
+   all elements are of compile-time known length, emit an error as this is
+   invalid.  */
 
-void
+try
 gfc_resolve_character_array_constructor (gfc_expr *expr)
 {
   gfc_constructor *p;
-  int max_length;
-  bool generated_length;
+  int found_length;
 
   gcc_assert (expr->expr_type == EXPR_ARRAY);
   gcc_assert (expr->ts.type == BT_CHARACTER);
 
-  max_length = -1;
-
   if (expr->ts.cl == NULL)
     {
       for (p = expr->value.constructor; p; p = p->next)
@@ -1611,15 +1608,16 @@ gfc_resolve_character_array_constructor (gfc_expr *expr)
 
 got_charlen:
 
-  generated_length = false;
+  found_length = -1;
+
   if (expr->ts.cl->length == NULL)
     {
-      /* Find the maximum length of the elements. Do nothing for variable
-	 array constructor, unless the character length is constant or
-	 there is a constant substring reference.  */
+      /* Check that all constant string elements have the same length until
+	 we reach the end or find a variable-length one.  */
 
       for (p = expr->value.constructor; p; p = p->next)
 	{
+	  int current_length = -1;
 	  gfc_ref *ref;
 	  for (ref = p->expr->ref; ref; ref = ref->next)
 	    if (ref->type == REF_SUBSTRING
@@ -1628,32 +1626,43 @@ got_charlen:
 	      break;
 
 	  if (p->expr->expr_type == EXPR_CONSTANT)
-	    max_length = MAX (p->expr->value.character.length, max_length);
+	    current_length = p->expr->value.character.length;
 	  else if (ref)
 	    {
 	      long j;
 	      j = mpz_get_ui (ref->u.ss.end->value.integer)
 		- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
-	      max_length = MAX ((int) j, max_length);
+	      current_length = (int) j;
 	    }
 	  else if (p->expr->ts.cl && p->expr->ts.cl->length
 		   && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
 	    {
 	      long j;
 	      j = mpz_get_si (p->expr->ts.cl->length->value.integer);
-	      max_length = MAX ((int) j, max_length);
+	      current_length = (int) j;
 	    }
 	  else
-	    return;
-	}
+	    return SUCCESS;
 
-      if (max_length != -1)
-	{
-	  /* Update the character length of the array constructor.  */
-	  expr->ts.cl->length = gfc_int_expr (max_length);
-	  generated_length = true;
-	  /* Real update follows below.  */
+	  gcc_assert (current_length != -1);
+
+	  if (found_length == -1)
+	    found_length = current_length;
+	  else if (found_length != current_length)
+	    {
+	      gfc_error ("Different CHARACTER lengths (%d/%d) in array"
+			 " constructor at %L", found_length, current_length,
+			 &p->expr->where);
+	      return FAILURE;
+	    }
+
+	  gcc_assert (found_length == current_length);
 	}
+
+      gcc_assert (found_length != -1);
+
+      /* Update the character length of the array constructor.  */
+      expr->ts.cl->length = gfc_int_expr (found_length);
     }
   else 
     {
@@ -1664,33 +1673,35 @@ got_charlen:
       /* If we've got a constant character length, pad according to this.
 	 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
 	 max_length only if they pass.  */
-      gfc_extract_int (expr->ts.cl->length, &max_length);
+      gfc_extract_int (expr->ts.cl->length, &found_length);
+
+      /* Now pad/trunkate the elements accordingly to the specified character
+	 length.  This is ok inside this conditional, as in the case above
+	 (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);
+            }
     }
 
-  /* Found a length to update to, do it for all element strings shorter than
-     the target length.  */
-  if (max_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 (generated_length || ! cl
-		|| (current_length != -1 && current_length < max_length))
-	      gfc_set_constant_character_len (max_length, p->expr, true);
-	  }
-    }
+  return SUCCESS;
 }
 
 
@@ -1704,8 +1715,10 @@ gfc_resolve_array_constructor (gfc_expr *expr)
   t = resolve_array_list (expr->value.constructor);
   if (t == SUCCESS)
     t = gfc_check_constructor_type (expr);
-  if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
-    gfc_resolve_character_array_constructor (expr);
+
+  /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
+     the call to this function, so we don't need to call it here; if it was
+     called twice, an error message there would be duplicated.  */
 
   return t;
 }