re PR fortran/15959 (ICE and assertion failure in trans-decl.c with character initialization)

2005-04-05  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/15959
	PR fortran/20713

	* array.c (resolve_character_array_constructor): New function. Set
	constant character array's character length.
	(gfc_resolve_array_constructor): Use it.
	* decl.c (add_init_expr_to_sym): Set symbol and initializer character
	length.
	(gfc_set_constant_character_len): New function. Set constant character
	expression according the given length.
	* match.h (gfc_set_constant_character_len): Add prototype.

2005-04-05  Feng Wang  <fengwang@nudt.edu.cn>

	* gfortran.dg/pr15959.f90: New test.
	* gfortran.dg/string_pad_trunc.f90: New test.

From-SVN: r97613

gcc/fortran/array.c

@@ -1499,9 +1499,45 @@ 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.  */
 
-/* Resolve all of the expressions in an array list.
-   TODO: String lengths.  */
+static void
+resolve_character_array_constructor (gfc_expr * expr)
+{
+  gfc_constructor * p;
+  int max_length;
+
+  gcc_assert (expr->expr_type == EXPR_ARRAY);
+  gcc_assert (expr->ts.type == BT_CHARACTER);
+
+  max_length = -1;
+
+  if (expr->ts.cl == NULL || expr->ts.cl->length == NULL)
+    {
+      /* Find the maximum length of the elements. Do nothing for variable array
+	 constructor.  */
+      for (p = expr->value.constructor; p; p = p->next)
+	if (p->expr->expr_type == EXPR_CONSTANT)
+	  max_length = MAX (p->expr->value.character.length, max_length);
+	else
+	  return;
+
+      if (max_length != -1)
+	{
+	  /* Update the character length of the array constructor.  */
+	  if (expr->ts.cl == NULL)
+	    expr->ts.cl = gfc_get_charlen ();
+	  expr->ts.cl->length = gfc_int_expr (max_length);
+	  /* Update the element constructors.  */
+	  for (p = expr->value.constructor; p; p = p->next)
+	    gfc_set_constant_character_len (max_length, p->expr);
+	}
+    }
+}
+
+/* Resolve all of the expressions in an array list.  */
 
 try
 gfc_resolve_array_constructor (gfc_expr * expr)
@@ -1511,6 +1547,8 @@ 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)
+    resolve_character_array_constructor (expr);
 
   return t;
 }

gcc/fortran/decl.c

@@ -646,6 +646,30 @@ build_sym (const char *name, gfc_charlen * cl,
   return SUCCESS;
 }
 
+/* Set character constant to the given length. The constant will be padded or
+   truncated.  */
+
+void
+gfc_set_constant_character_len (int len, gfc_expr * expr)
+{
+  char * s;
+  int slen;
+
+  gcc_assert (expr->expr_type == EXPR_CONSTANT);
+  gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
+
+  slen = expr->value.character.length;
+  if (len != slen)
+    {
+      s = gfc_getmem (len);
+      memcpy (s, expr->value.character.string, MIN (len, slen));
+      if (len > slen)
+	memset (&s[slen], ' ', len - slen);
+      gfc_free (expr->value.character.string);
+      expr->value.character.string = s;
+      expr->value.character.length = len;
+    }
+}
 
 /* Function called by variable_decl() that adds an initialization
    expression to a symbol.  */
@@ -711,6 +735,35 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
 	  && gfc_check_assign_symbol (sym, init) == FAILURE)
 	return FAILURE;
 
+      if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
+	{
+	  /* Update symbol character length according initializer.  */
+	  if (sym->ts.cl->length == NULL)
+	    {
+	      if (init->expr_type == EXPR_CONSTANT)
+		sym->ts.cl->length =
+			gfc_int_expr (init->value.character.length);
+	      else if (init->expr_type == EXPR_ARRAY)
+		sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
+	    }
+	  /* Update initializer character length according symbol.  */
+	  else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+	    {
+	      int len = mpz_get_si (sym->ts.cl->length->value.integer);
+	      gfc_constructor * p;
+
+	      if (init->expr_type == EXPR_CONSTANT)
+		gfc_set_constant_character_len (len, init);
+	      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);
+		}
+	    }
+	}
+
       /* Add initializer.  Make sure we keep the ranks sane.  */
       if (sym->attr.dimension && init->rank == 0)
 	init->rank = sym->as->rank;

gcc/fortran/match.h

@@ -108,6 +108,8 @@ 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 *);
+
 /* Matchers for attribute declarations */
 match gfc_match_allocatable (void);
 match gfc_match_dimension (void);

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2005-04-05  Feng Wang  <fengwang@nudt.edu.cn>
+
+	* gfortran.dg/pr15959.f90: New test.
+	* gfortran.dg/string_pad_trunc.f90: New test.
+
 2005-04-05  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	* gfortran.dg/backspace.f, gfortran.dg/g77_intrinsics_funcs.f,

gcc/testsuite/gfortran.dg/pr15959.f90

@@ -0,0 +1,5 @@
+! { dg-do run }
+! Test initializer of character array. PR15959
+character (*), parameter :: a (1:2) = (/'ab', 'abc'/)
+if (a(2) .ne. 'abc') call abort()
+end

gcc/testsuite/gfortran.dg/string_pad_trunc.f90

@@ -0,0 +1,20 @@
+! { dg-do run }
+! PR20713. Pad and truncate string.
+
+character(len = 6),parameter:: a = 'hello'
+character(len = 6),parameter:: b = 'hello *'
+character(len = 6),parameter:: c (1:1) = 'hello'
+character(len = 11) line
+
+write (line, '(6A)') a, 'world'
+if (line .ne. 'hello world') call abort
+
+write (line, '(6A)') b, 'world'
+if (line .ne. 'hello world') call abort
+
+write (line, '(6A)') c, 'world'
+if (line .ne. 'hello world') call abort
+
+write (line, '(6A)') c(1), 'world'
+if (line .ne. 'hello world') call abort
+end