re PR fortran/36319 (Segfault with wide characters in DATA)

	PR fortran/36319

	* intrinsic.c (gfc_convert_chartype): Don't mark conversion
	function as pure.
	* trans-array.c (gfc_trans_array_ctor_element): Divide element
	size by the size of one character to obtain length.
	* iresolve.c (gfc_resolve_cshift): Call the _char4 variant when
	appropriate.
	(gfc_resolve_eoshift): Likewise.
	* trans-intrinsic.c (gfc_conv_intrinsic_ctime): Minor beautification.
	(gfc_conv_intrinsic_fdate): Minor beautification.
	(gfc_conv_intrinsic_ttynam): Minor beautification.
	(gfc_conv_intrinsic_minmax_char): Allow all character kinds.
	(size_of_string_in_bytes): New function.
	(gfc_conv_intrinsic_size): Call size_of_string_in_bytes for
	character expressions.
	(gfc_conv_intrinsic_sizeof): Likewise.
	(gfc_conv_intrinsic_array_transfer): Likewise.
	(gfc_conv_intrinsic_trim): Allow all character kinds. Minor
	beautification.
	(gfc_conv_intrinsic_repeat): Fix comment typo.
	* simplify.c (gfc_convert_char_constant): Take care of conversion
	of array constructors.

	* intrinsics/string_intrinsics_inc.c (string_index): Return
	correct value for zero-length substring.
	* intrinsics/cshift0.c: Add _char4 variant.
	* intrinsics/eoshift0.c (eoshift0): Allow filler to be a pattern
	wider than a single byte. Add _char4 variant and use above
	functionality.
	* intrinsics/eoshift2.c (eoshift2): Likewise.
	* m4/eoshift1.m4: Likewise.
	* m4/eoshift3.m4: Likewise.
	* m4/cshift1.m4: Add _char4 variants.
	* gfortran.map (GFORTRAN_1.1): Add _gfortran_cshift0_1_char4,
	_gfortran_cshift0_2_char4, _gfortran_cshift0_4_char4,
	_gfortran_cshift0_8_char4, _gfortran_cshift1_16_char4,
	_gfortran_cshift1_4_char4, _gfortran_cshift1_8_char4,
	_gfortran_eoshift0_1_char4, _gfortran_eoshift0_2_char4,
	_gfortran_eoshift0_4_char4, _gfortran_eoshift0_8_char4,
	_gfortran_eoshift1_16_char4, _gfortran_eoshift1_4_char4,
	_gfortran_eoshift1_8_char4, _gfortran_eoshift2_1_char4,
	_gfortran_eoshift2_2_char4, _gfortran_eoshift2_4_char4,
	_gfortran_eoshift2_8_char4, _gfortran_eoshift3_16_char4,
	_gfortran_eoshift3_4_char4 and _gfortran_eoshift3_8_char4.
	* generated/eoshift3_4.c: Regenerate.
	* generated/eoshift1_8.c: Regenerate.
	* generated/eoshift1_16.c: Regenerate.
	* generated/cshift1_4.c: Regenerate.
	* generated/eoshift1_4.c: Regenerate.
	* generated/eoshift3_8.c: Regenerate.
	* generated/eoshift3_16.c: Regenerate.
	* generated/cshift1_8.c: Regenerate.
	* generated/cshift1_16.c: Regenerate.

	* gfortran.dg/widechar_5.f90: New file.
	* gfortran.dg/widechar_6.f90: New file.
	* gfortran.dg/widechar_7.f90: New file.
	* gfortran.dg/widechar_intrinsics_5.f90: Uncomment the lines
	testing the SPREAD intrinsic.
	* gfortran.dg/widechar_intrinsics_6.f90: New file.
	* gfortran.dg/widechar_intrinsics_7.f90: New file.
	* gfortran.dg/widechar_intrinsics_8.f90: New file.
	* gfortran.dg/widechar_intrinsics_9.f90: New file.
	* gfortran.dg/widechar_intrinsics_10.f90: New file.

From-SVN: r136129

6 files changed, 165 insertions, 60 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d879a4c..1995f6a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,28 @@
+2008-05-28  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36319
+	* intrinsic.c (gfc_convert_chartype): Don't mark conversion
+	function as pure.
+	* trans-array.c (gfc_trans_array_ctor_element): Divide element
+	size by the size of one character to obtain length.
+	* iresolve.c (gfc_resolve_cshift): Call the _char4 variant when
+	appropriate.
+	(gfc_resolve_eoshift): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_ctime): Minor beautification.
+	(gfc_conv_intrinsic_fdate): Minor beautification.
+	(gfc_conv_intrinsic_ttynam): Minor beautification.
+	(gfc_conv_intrinsic_minmax_char): Allow all character kinds.
+	(size_of_string_in_bytes): New function.
+	(gfc_conv_intrinsic_size): Call size_of_string_in_bytes for
+	character expressions.
+	(gfc_conv_intrinsic_sizeof): Likewise.
+	(gfc_conv_intrinsic_array_transfer): Likewise.
+	(gfc_conv_intrinsic_trim): Allow all character kinds. Minor
+	beautification.
+	(gfc_conv_intrinsic_repeat): Fix comment typo.
+	* simplify.c (gfc_convert_char_constant): Take care of conversion
+	of array constructors.
+
 2008-05-27  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/36316
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index e902f69..62ee442 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3807,7 +3807,6 @@ gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
   new->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   new->symtree->n.sym->attr.function = 1;
   new->symtree->n.sym->attr.elemental = 1;
-  new->symtree->n.sym->attr.pure = 1;
   new->symtree->n.sym->attr.referenced = 1;
   gfc_intrinsic_symbol(new->symtree->n.sym);
   gfc_commit_symbol (new->symtree->n.sym);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 94ed4a6..acbf5be 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -627,9 +627,19 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
         }
     }
 
-  f->value.function.name
-    = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
-		      array->ts.type == BT_CHARACTER ? "_char" : "");
+  if (array->ts.type == BT_CHARACTER)
+    {
+      if (array->ts.kind == gfc_default_character_kind)
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
+      else
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
+			    array->ts.kind);
+    }
+  else
+    f->value.function.name
+	= gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
 }
 
 
@@ -768,9 +778,19 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
         }
     }
 
-  f->value.function.name
-    = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
-		      array->ts.type == BT_CHARACTER ? "_char" : "");
+  if (array->ts.type == BT_CHARACTER)
+    {
+      if (array->ts.kind == gfc_default_character_kind)
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
+      else
+	f->value.function.name
+	  = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
+			    array->ts.kind);
+    }
+  else
+    f->value.function.name
+	= gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
 }
 
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 8c1c6b3..59b425f 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -4811,26 +4811,75 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
   if (!gfc_is_constant_expr (e))
     return NULL;
 
-  result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
-  if (result == NULL)
-    return &gfc_bad_expr;
-
-  result->value.character.length = e->value.character.length;
-  result->value.character.string
-    = gfc_get_wide_string (e->value.character.length + 1);
-  memcpy (result->value.character.string, e->value.character.string,
-	  (e->value.character.length + 1) * sizeof (gfc_char_t));
-
-  /* Check we only have values representable in the destination kind.  */
-  for (i = 0; i < result->value.character.length; i++)
-    if (!gfc_check_character_range (result->value.character.string[i], kind))
-      {
-	gfc_error ("Character '%s' in string at %L cannot be converted into "
-		   "character kind %d",
-		   gfc_print_wide_char (result->value.character.string[i]),
-		   &e->where, kind);
+  if (e->expr_type == EXPR_CONSTANT)
+    {
+      /* Simple case of a scalar.  */
+      result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+      if (result == NULL)
 	return &gfc_bad_expr;
-      }
 
-  return result;
+      result->value.character.length = e->value.character.length;
+      result->value.character.string
+	= gfc_get_wide_string (e->value.character.length + 1);
+      memcpy (result->value.character.string, e->value.character.string,
+	      (e->value.character.length + 1) * sizeof (gfc_char_t));
+
+      /* Check we only have values representable in the destination kind.  */
+      for (i = 0; i < result->value.character.length; i++)
+	if (!gfc_check_character_range (result->value.character.string[i],
+					kind))
+	  {
+	    gfc_error ("Character '%s' in string at %L cannot be converted "
+		       "into character kind %d",
+		       gfc_print_wide_char (result->value.character.string[i]),
+		       &e->where, kind);
+	    return &gfc_bad_expr;
+	  }
+
+      return result;
+    }
+  else if (e->expr_type == EXPR_ARRAY)
+    {
+      /* For an array constructor, we convert each constructor element.  */
+      gfc_constructor *head = NULL, *tail = NULL, *c;
+
+      for (c = e->value.constructor; c; c = c->next)
+	{
+	  if (head == NULL)
+	    head = tail = gfc_get_constructor ();
+	  else
+	    {
+	      tail->next = gfc_get_constructor ();
+	      tail = tail->next;
+	    }
+
+	  tail->where = c->where;
+	  tail->expr = gfc_convert_char_constant (c->expr, type, kind);
+	  if (tail->expr == &gfc_bad_expr)
+	    {
+	      tail->expr = NULL;
+	      return &gfc_bad_expr;
+	    }
+
+	  if (tail->expr == NULL)
+	    {
+	      gfc_free_constructor (head);
+	      return NULL;
+	    }
+	}
+
+      result = gfc_get_expr ();
+      result->ts.type = type;
+      result->ts.kind = kind;
+      result->expr_type = EXPR_ARRAY;
+      result->value.constructor = head;
+      result->shape = gfc_copy_shape (e->shape, e->rank);
+      result->where = e->where;
+      result->rank = e->rank;
+      result->ts.cl = e->ts.cl;
+
+      return result;
+    }
+  else
+    return NULL;
 }
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index bc6d13a..7df192c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -969,7 +969,6 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
 			      tree offset, gfc_se * se, gfc_expr * expr)
 {
   tree tmp;
-  tree esize;
 
   gfc_conv_expr (se, expr);
 
@@ -977,11 +976,17 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
   tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
   tmp = gfc_build_array_ref (tmp, offset, NULL);
 
-  esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
-  esize = fold_convert (gfc_charlen_type_node, esize);
-
   if (expr->ts.type == BT_CHARACTER)
     {
+      int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+      tree esize;
+
+      esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
+      esize = fold_convert (gfc_charlen_type_node, esize);
+      esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
+			   build_int_cst (gfc_charlen_type_node,
+					  gfc_character_kinds[i].bit_size / 8));
+
       gfc_conv_string_parameter (se);
       if (POINTER_TYPE_P (TREE_TYPE (tmp)))
 	{
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 990a127..73e14a3 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1327,9 +1327,7 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
   tree var;
   tree len;
   tree tmp;
-  tree type;
   tree cond;
-  tree gfc_int8_type_node = gfc_get_int_type (8);
   tree fndecl;
   tree *args;
   unsigned int num_args;
@@ -1337,9 +1335,8 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
   args = alloca (sizeof (tree) * num_args);
 
-  type = build_pointer_type (gfc_character1_type_node);
-  var = gfc_create_var (type, "pstr");
-  len = gfc_create_var (gfc_int8_type_node, "len");
+  var = gfc_create_var (pchar_type_node, "pstr");
+  len = gfc_create_var (gfc_get_int_type (8), "len");
 
   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
   args[0] = build_fold_addr_expr (var);
@@ -1368,9 +1365,7 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
   tree var;
   tree len;
   tree tmp;
-  tree type;
   tree cond;
-  tree gfc_int4_type_node = gfc_get_int_type (4);
   tree fndecl;
   tree *args;
   unsigned int num_args;
@@ -1378,9 +1373,8 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
   args = alloca (sizeof (tree) * num_args);
 
-  type = build_pointer_type (gfc_character1_type_node);
-  var = gfc_create_var (type, "pstr");
-  len = gfc_create_var (gfc_int4_type_node, "len");
+  var = gfc_create_var (pchar_type_node, "pstr");
+  len = gfc_create_var (gfc_get_int_type (4), "len");
 
   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
   args[0] = build_fold_addr_expr (var);
@@ -1411,19 +1405,16 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
   tree var;
   tree len;
   tree tmp;
-  tree type;
   tree cond;
   tree fndecl;
-  tree gfc_int4_type_node = gfc_get_int_type (4);
   tree *args;
   unsigned int num_args;
 
   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
   args = alloca (sizeof (tree) * num_args);
 
-  type = build_pointer_type (gfc_character1_type_node);
-  var = gfc_create_var (type, "pstr");
-  len = gfc_create_var (gfc_int4_type_node, "len");
+  var = gfc_create_var (pchar_type_node, "pstr");
+  len = gfc_create_var (gfc_get_int_type (4), "len");
 
   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
   args[0] = build_fold_addr_expr (var);
@@ -1551,7 +1542,7 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
   /* Create the result variables.  */
   len = gfc_create_var (gfc_charlen_type_node, "len");
   args[0] = build_fold_addr_expr (len);
-  var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr");
+  var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
   args[2] = build_int_cst (NULL_TREE, op);
   args[3] = build_int_cst (NULL_TREE, nargs / 2);
@@ -3237,6 +3228,24 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
 }
 
 
+/* Helper function to compute the size of a character variable,
+   excluding the terminating null characters.  The result has
+   gfc_array_index_type type.  */
+
+static tree
+size_of_string_in_bytes (int kind, tree string_length)
+{
+  tree bytesize;
+  int i = gfc_validate_kind (BT_CHARACTER, kind, false);
+ 
+  bytesize = build_int_cst (gfc_array_index_type,
+			    gfc_character_kinds[i].bit_size / 8);
+
+  return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
+		      fold_convert (gfc_array_index_type, string_length));
+}
+
+
 static void
 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
 {
@@ -3249,7 +3258,6 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
   tree tmp;
   tree lower;
   tree upper;
-  /*tree stride;*/
   int n;
 
   arg = expr->value.function.actual->expr;
@@ -3268,8 +3276,8 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
 
       /* Obtain the source word length.  */
       if (arg->ts.type == BT_CHARACTER)
-	source_bytes = fold_convert (gfc_array_index_type,
-				     argse.string_length);
+	source_bytes = size_of_string_in_bytes (arg->ts.kind,
+						argse.string_length);
       else
 	source_bytes = fold_convert (gfc_array_index_type,
 				     size_in_bytes (type)); 
@@ -3283,7 +3291,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
 
       /* Obtain the argument's word length.  */
       if (arg->ts.type == BT_CHARACTER)
-	tmp = fold_convert (gfc_array_index_type, argse.string_length);
+	tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
       else
 	tmp = fold_convert (gfc_array_index_type,
 			    size_in_bytes (type)); 
@@ -3404,7 +3412,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
 
       /* Obtain the source word length.  */
       if (arg->expr->ts.type == BT_CHARACTER)
-	tmp = fold_convert (gfc_array_index_type, argse.string_length);
+	tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+				       argse.string_length);
       else
 	tmp = fold_convert (gfc_array_index_type,
 			    size_in_bytes (source_type)); 
@@ -3443,7 +3452,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
 
       /* Obtain the source word length.  */
       if (arg->expr->ts.type == BT_CHARACTER)
-	tmp = fold_convert (gfc_array_index_type, argse.string_length);
+	tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+				       argse.string_length);
       else
 	tmp = fold_convert (gfc_array_index_type,
 			    size_in_bytes (source_type)); 
@@ -3495,7 +3505,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
 
   if (arg->expr->ts.type == BT_CHARACTER)
     {
-      tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
     }
   else
@@ -3869,12 +3879,10 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
 static void
 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
 {
-  tree gfc_int4_type_node = gfc_get_int_type (4);
   tree var;
   tree len;
   tree addr;
   tree tmp;
-  tree type;
   tree cond;
   tree fndecl;
   tree function;
@@ -3884,10 +3892,9 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
   args = alloca (sizeof (tree) * num_args);
 
-  type = build_pointer_type (gfc_character1_type_node);
-  var = gfc_create_var (type, "pstr");
+  var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
   addr = gfc_build_addr_expr (ppvoid_type_node, var);
-  len = gfc_create_var (gfc_int4_type_node, "len");
+  len = gfc_create_var (gfc_get_int_type (4), "len");
 
   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
   args[0] = build_fold_addr_expr (len);
@@ -3928,7 +3935,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
   stmtblock_t block, body;
   int i;
 
-  /* We store in charsize the size of an character.  */
+  /* We store in charsize the size of a character.  */
   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);