intrinsic.c (char_conversions, ncharconv): New static variables.

	* intrinsic.c (char_conversions, ncharconv): New static variables.
	(find_char_conv): New function.
	(add_functions): Add simplification functions for ADJUSTL and
	ADJUSTR. Don't check the kind of their argument. Add checking for
	LGE, LLE, LGT and LLT.
	(add_subroutines): Fix argument type for SLEEP. Fix argument name
	for SYSTEM.
	(add_char_conversions): New function.
	(gfc_intrinsic_init_1): Call add_char_conversions.
	(gfc_intrinsic_done_1): Free char_conversions.
	(check_arglist): Use kind == 0 as a signal that we don't want
	the kind value to be checked.
	(do_simplify): Also simplify character functions.
	(gfc_convert_chartype): New function
	* trans-array.c (gfc_trans_array_ctor_element): Don't force the
	use of default character type.
	(gfc_trans_array_constructor_value): Likewise.
	(get_array_ctor_var_strlen): Use integer kind to build an integer
	instead of a character kind!
	(gfc_build_constant_array_constructor): Don't force the use of
	default character type.
	(gfc_conv_loop_setup): Likewise.
	* trans-expr.c (gfc_conv_string_tmp): Don't force the use of
	default character type. Allocate enough memory for wide strings.
	(gfc_conv_concat_op): Make sure operand kind are the same.
	(string_to_single_character): Remove gfc_ prefix. Reindent.
	Don't force the use of default character type.
	(gfc_conv_scalar_char_value): Likewise.
	(gfc_build_compare_string): Call string_to_single_character.
	(fill_with_spaces): New function
	(gfc_trans_string_copy): Add kind arguments. Use them to deal
	with wide character kinds.
	(gfc_conv_statement_function): Whitespace fix. Call
	gfc_trans_string_copy with new kind arguments.
	(gfc_conv_substring_expr): Call gfc_build_wide_string_const
	instead of using gfc_widechar_to_char.
	(gfc_conv_string_parameter): Don't force the use of default
	character type.
	(gfc_trans_scalar_assign): Pass kind args to gfc_trans_string_copy.
	* intrinsic.h (gfc_check_lge_lgt_lle_llt, gfc_convert_char_constant,
	gfc_resolve_adjustl, gfc_resolve_adjustr): New prototypes.
	* decl.c (gfc_set_constant_character_len): Don't assert the
	existence of a single character kind.
	* trans-array.h (gfc_trans_string_copy): New prototype.
	* gfortran.h (gfc_check_character_range, gfc_convert_chartype):
	New prototypes.
	* error.c (print_wide_char_into_buffer): New function lifting
	code from gfc_print_wide_char. Fix order to output '\x??' instead
	of 'x\??'.
	(gfc_print_wide_char): Call print_wide_char_into_buffer.
	(show_locus): Call print_wide_char_into_buffer with buffer local
	to this function.
	* trans-const.c (gfc_build_wide_string_const): New function.
	(gfc_conv_string_init): Deal with wide characters strings
	constructors.
	(gfc_conv_constant_to_tree): Call gfc_build_wide_string_const.
	* trans-stmt.c (gfc_trans_label_assign): Likewise.
	(gfc_trans_character_select): Deal with wide strings.
	* expr.c (gfc_check_assign): Allow conversion between character
	kinds on assignment.
	* trans-const.h (gfc_build_wide_string_const): New prototype.
	* trans-types.c (gfc_get_character_type_len_for_eltype,
	gfc_get_character_type_len): Create too variants of the old
	gfc_get_character_type_len, one getting kind argument and the
	other one directly taking a type tree.
	* trans.h (gfor_fndecl_select_string_char4,
	gfor_fndecl_convert_char1_to_char4,
	gfor_fndecl_convert_char4_to_char1): New prototypes.
	* trans-types.h (gfc_get_character_type_len_for_eltype): New
	prototype.
	* resolve.c (resolve_operator): Exit early when kind mismatches
	are detected, because that makes us issue an error message later.
	(validate_case_label_expr): Fix wording of error message.
	* iresolve.c (gfc_resolve_adjustl, gfc_resolve_adjustr): New
	functions.
	(gfc_resolve_pack): Call _char4 variants of library function
	when dealing with wide characters.
	(gfc_resolve_reshape): Likewise.
	(gfc_resolve_spread): Likewise.
	(gfc_resolve_transpose): Likewise.
	(gfc_resolve_unpack): Likewise.
	* target-memory.c (size_character): Take character kind bit size
	correctly into account (not that it changes anything for now, but
	it's more generic).
	(gfc_encode_character): Added gfc_ prefix. Encoding each
	character of a string by calling native_encode_expr for the
	corresponding unsigned integer.
	(gfc_target_encode_expr): Add gfc_ prefix to encode_character.
	* trans-decl.c (gfc_build_intrinsic_function_decls): Build
	gfor_fndecl_select_string_char4, gfor_fndecl_convert_char1_to_char4
	and gfor_fndecl_convert_char4_to_char1.
	* target-memory.h (gfc_encode_character): New prototype.
	* arith.c (gfc_check_character_range): New function.
	(eval_intrinsic): Allow non-default character kinds.
	* check.c (gfc_check_access_func): Only allow default
	character kind arguments.
	(gfc_check_chdir): Likewise.
	(gfc_check_chdir_sub): Likewise.
	(gfc_check_chmod): Likewise.
	(gfc_check_chmod_sub): Likewise.
	(gfc_check_lge_lgt_lle_llt): New function.
	(gfc_check_link): Likewise.
	(gfc_check_link_sub): Likewise.
	(gfc_check_symlnk): Likewise.
	(gfc_check_symlnk_sub): Likewise.
	(gfc_check_rename): Likewise.
	(gfc_check_rename_sub): Likewise.
	(gfc_check_fgetputc_sub): Likewise.
	(gfc_check_fgetput_sub): Likewise.
	(gfc_check_stat): Likewise.
	(gfc_check_stat_sub): Likewise.
	(gfc_check_date_and_time): Likewise.
	(gfc_check_ctime_sub): Likewise.
	(gfc_check_fdate_sub): Likewise.
	(gfc_check_gerror): Likewise.
	(gfc_check_getcwd_sub): Likewise.
	(gfc_check_getarg): Likewise.
	(gfc_check_getlog): Likewise.
	(gfc_check_hostnm): Likewise.
	(gfc_check_hostnm_sub): Likewise.
	(gfc_check_ttynam_sub): Likewise.
	(gfc_check_perror): Likewise.
	(gfc_check_unlink): Likewise.
	(gfc_check_unlink_sub): Likewise.
	(gfc_check_system_sub): Likewise.
	* primary.c (got_delim): Perform correct character range checking
	for all kinds.
	* trans-intrinsic.c (gfc_conv_intrinsic_conversion): Generate
	calls to library functions convert_char4_to_char1 and
	convert_char1_to_char4 for character conversions.
	(gfc_conv_intrinsic_char): Allow all character kings.
	(gfc_conv_intrinsic_strcmp): Fix whitespace.
	(gfc_conv_intrinsic_repeat): Take care of all character kinds.
	* intrinsic.texi: For all GNU intrinsics accepting character
	arguments, mention that they're restricted to the default kind.
	* simplify.c (simplify_achar_char): New function.
	(gfc_simplify_achar, gfc_simplify_char): Call simplify_achar_char.
	gfc_simplify_ichar): Don't error out for wide characters.
	(gfc_convert_char_constant): New function.

	* gfortran.dg/achar_3.f90: Adjust error messages.
	* gfortran.dg/achar_5.f90: New test.
	* gfortran.dg/achar_6.F90: New test.
	* gfortran.dg/widechar_1.f90: New test.
	* gfortran.dg/widechar_2.f90: New test.
	* gfortran.dg/widechar_3.f90: New test.
	* gfortran.dg/widechar_4.f90: New test.
	* gfortran.dg/widechar_intrinsics_1.f90: New test.
	* gfortran.dg/widechar_intrinsics_2.f90: New test.
	* gfortran.dg/widechar_intrinsics_3.f90: New test.
	* gfortran.dg/widechar_intrinsics_4.f90: New test.
	* gfortran.dg/widechar_intrinsics_5.f90: New test.
	* gfortran.dg/widechar_select_1.f90: New test.
	* gfortran.dg/widechar_select_2.f90: New test.

From-SVN: r135515

1 files changed, 59 insertions, 40 deletions

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 64829e3..6afac5d 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -99,7 +99,6 @@ gfc_trans_label_assign (gfc_code * code)
   tree len;
   tree addr;
   tree len_tree;
-  char *label_str;
   int label_len;
 
   /* Start a new block.  */
@@ -119,14 +118,13 @@ gfc_trans_label_assign (gfc_code * code)
     }
   else
     {
-      label_len = code->label->format->value.character.length;
-      label_str
-	= gfc_widechar_to_char (code->label->format->value.character.string,
-				label_len);
+      gfc_expr *format = code->label->format;
+
+      label_len = format->value.character.length;
       len_tree = build_int_cst (NULL_TREE, label_len);
-      label_tree = gfc_build_string_const (label_len + 1, label_str);
+      label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
+						format->value.character.string);
       label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
-      gfc_free (label_str);
     }
 
   gfc_add_modify_expr (&se.pre, len, len_tree);
@@ -1321,41 +1319,56 @@ gfc_trans_logical_select (gfc_code * code)
 static tree
 gfc_trans_character_select (gfc_code *code)
 {
-  tree init, node, end_label, tmp, type, case_num, label;
+  tree init, node, end_label, tmp, type, case_num, label, fndecl;
   stmtblock_t block, body;
   gfc_case *cp, *d;
   gfc_code *c;
   gfc_se se;
-  int n;
+  int n, k;
+
+  /* The jump table types are stored in static variables to avoid
+     constructing them from scratch every single time.  */
+  static tree select_struct[2];
+  static tree ss_string1[2], ss_string1_len[2];
+  static tree ss_string2[2], ss_string2_len[2];
+  static tree ss_target[2];
 
-  static tree select_struct;
-  static tree ss_string1, ss_string1_len;
-  static tree ss_string2, ss_string2_len;
-  static tree ss_target;
+  tree pchartype = gfc_get_pchar_type (code->expr->ts.kind);
+
+  if (code->expr->ts.kind == 1)
+    k = 0;
+  else if (code->expr->ts.kind == 4)
+    k = 1;
+  else
+    gcc_unreachable ();
 
-  if (select_struct == NULL)
+  if (select_struct[k] == NULL)
     {
-      tree gfc_int4_type_node = gfc_get_int_type (4);
+      select_struct[k] = make_node (RECORD_TYPE);
 
-      select_struct = make_node (RECORD_TYPE);
-      TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
+      if (code->expr->ts.kind == 1)
+	TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
+      else if (code->expr->ts.kind == 4)
+	TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
+      else
+	gcc_unreachable ();
 
 #undef ADD_FIELD
-#define ADD_FIELD(NAME, TYPE)				\
-  ss_##NAME = gfc_add_field_to_struct			\
-     (&(TYPE_FIELDS (select_struct)), select_struct,	\
+#define ADD_FIELD(NAME, TYPE)					\
+  ss_##NAME[k] = gfc_add_field_to_struct				\
+     (&(TYPE_FIELDS (select_struct[k])), select_struct[k],	\
       get_identifier (stringize(NAME)), TYPE)
 
-      ADD_FIELD (string1, pchar_type_node);
-      ADD_FIELD (string1_len, gfc_int4_type_node);
+      ADD_FIELD (string1, pchartype);
+      ADD_FIELD (string1_len, gfc_charlen_type_node);
 
-      ADD_FIELD (string2, pchar_type_node);
-      ADD_FIELD (string2_len, gfc_int4_type_node);
+      ADD_FIELD (string2, pchartype);
+      ADD_FIELD (string2_len, gfc_charlen_type_node);
 
       ADD_FIELD (target, integer_type_node);
 #undef ADD_FIELD
 
-      gfc_finish_type (select_struct);
+      gfc_finish_type (select_struct[k]);
     }
 
   cp = code->block->ext.case_list;
@@ -1401,40 +1414,40 @@ gfc_trans_character_select (gfc_code *code)
 
       if (d->low == NULL)
         {
-          node = tree_cons (ss_string1, null_pointer_node, node);
-          node = tree_cons (ss_string1_len, integer_zero_node, node);
+          node = tree_cons (ss_string1[k], null_pointer_node, node);
+          node = tree_cons (ss_string1_len[k], integer_zero_node, node);
         }
       else
         {
           gfc_conv_expr_reference (&se, d->low);
 
-          node = tree_cons (ss_string1, se.expr, node);
-          node = tree_cons (ss_string1_len, se.string_length, node);
+          node = tree_cons (ss_string1[k], se.expr, node);
+          node = tree_cons (ss_string1_len[k], se.string_length, node);
         }
 
       if (d->high == NULL)
         {
-          node = tree_cons (ss_string2, null_pointer_node, node);
-          node = tree_cons (ss_string2_len, integer_zero_node, node);
+          node = tree_cons (ss_string2[k], null_pointer_node, node);
+          node = tree_cons (ss_string2_len[k], integer_zero_node, node);
         }
       else
         {
           gfc_init_se (&se, NULL);
           gfc_conv_expr_reference (&se, d->high);
 
-          node = tree_cons (ss_string2, se.expr, node);
-          node = tree_cons (ss_string2_len, se.string_length, node);
+          node = tree_cons (ss_string2[k], se.expr, node);
+          node = tree_cons (ss_string2_len[k], se.string_length, node);
         }
 
-      node = tree_cons (ss_target, build_int_cst (integer_type_node, d->n),
+      node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n),
 			node);
 
-      tmp = build_constructor_from_list (select_struct, nreverse (node));
+      tmp = build_constructor_from_list (select_struct[k], nreverse (node));
       init = tree_cons (NULL_TREE, tmp, init);
     }
 
-  type = build_array_type (select_struct, build_index_type
-			   (build_int_cst (NULL_TREE, n - 1)));
+  type = build_array_type (select_struct[k],
+			   build_index_type (build_int_cst (NULL_TREE, n-1)));
 
   init = build_constructor_from_list (type, nreverse(init));
   TREE_CONSTANT (init) = 1;
@@ -1455,9 +1468,15 @@ gfc_trans_character_select (gfc_code *code)
 
   gfc_add_block_to_block (&block, &se.pre);
 
-  tmp = build_call_expr (gfor_fndecl_select_string, 4, init,
-			 build_int_cst (NULL_TREE, n), se.expr,
-			 se.string_length);
+  if (code->expr->ts.kind == 1)
+    fndecl = gfor_fndecl_select_string;
+  else if (code->expr->ts.kind == 4)
+    fndecl = gfor_fndecl_select_string_char4;
+  else
+    gcc_unreachable ();
+
+  tmp = build_call_expr (fndecl, 4, init, build_int_cst (NULL_TREE, n),
+			 se.expr, se.string_length);
   case_num = gfc_create_var (integer_type_node, "case_num");
   gfc_add_modify_expr (&block, case_num, tmp);