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, 122 insertions, 39 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 563e840..482e8b1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -977,7 +977,7 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
       tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
 			 build_int_cst (gfc_charlen_type_node, 1));
       tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
-      tmp = build_array_type (gfc_character1_type_node, tmp);
+      tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
       var = gfc_create_var (tmp, "str");
       var = gfc_build_addr_expr (type, var);
     }
@@ -985,7 +985,10 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
     {
       /* Allocate a temporary to hold the result.  */
       var = gfc_create_var (type, "pstr");
-      tmp = gfc_call_malloc (&se->pre, type, len);
+      tmp = gfc_call_malloc (&se->pre, type,
+			     fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
+					  fold_convert (TREE_TYPE (len),
+							TYPE_SIZE (type))));
       gfc_add_modify_expr (&se->pre, var, tmp);
 
       /* Free the temporary afterwards.  */
@@ -1008,6 +1011,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
 
   gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
 	      && expr->value.op.op2->ts.type == BT_CHARACTER);
+  gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
 
   gfc_init_se (&lse, se);
   gfc_conv_expr (&lse, expr->value.op.op1);
@@ -1238,14 +1242,14 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
 /* If a string's length is one, we convert it to a single character.  */
 
 static tree
-gfc_to_single_character (tree len, tree str)
+string_to_single_character (tree len, tree str, int kind)
 {
   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
 
   if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
-    && TREE_INT_CST_HIGH (len) == 0)
+      && TREE_INT_CST_HIGH (len) == 0)
     {
-      str = fold_convert (pchar_type_node, str);
+      str = fold_convert (gfc_get_pchar_type (kind), str);
       return build_fold_indirect_ref (str);
     }
 
@@ -1293,18 +1297,21 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
         {
 	  if ((*expr)->ref == NULL)
 	    {
-	      se->expr = gfc_to_single_character
+	      se->expr = string_to_single_character
 		(build_int_cst (integer_type_node, 1),
-		 gfc_build_addr_expr (pchar_type_node,
+		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
 				      gfc_get_symbol_decl
-				      ((*expr)->symtree->n.sym)));
+				      ((*expr)->symtree->n.sym)),
+		 (*expr)->ts.kind);
 	    }
 	  else
 	    {
 	      gfc_conv_variable (se, *expr);
-	      se->expr = gfc_to_single_character
+	      se->expr = string_to_single_character
 		(build_int_cst (integer_type_node, 1),
-		 gfc_build_addr_expr (pchar_type_node, se->expr));
+		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
+				      se->expr),
+		 (*expr)->ts.kind);
 	    }
 	}
     }
@@ -1324,8 +1331,8 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
 
-  sc1 = gfc_to_single_character (len1, str1);
-  sc2 = gfc_to_single_character (len2, str2);
+  sc1 = string_to_single_character (len1, str1, kind);
+  sc2 = string_to_single_character (len2, str2, kind);
 
   if (sc1 != NULL_TREE && sc2 != NULL_TREE)
     {
@@ -2827,11 +2834,77 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 }
 
 
+/* Fill a character string with spaces.  */
+
+static tree
+fill_with_spaces (tree start, tree type, tree size)
+{
+  stmtblock_t block, loop;
+  tree i, el, exit_label, cond, tmp;
+
+  /* For a simple char type, we can call memset().  */
+  if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
+    return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
+			    build_int_cst (gfc_get_int_type (gfc_c_int_kind),
+					   lang_hooks.to_target_charset (' ')),
+			    size);
+
+  /* Otherwise, we use a loop:
+	for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
+	  *el = (type) ' ';
+   */
+
+  /* Initialize variables.  */
+  gfc_init_block (&block);
+  i = gfc_create_var (sizetype, "i");
+  gfc_add_modify_expr (&block, i, fold_convert (sizetype, size));
+  el = gfc_create_var (build_pointer_type (type), "el");
+  gfc_add_modify_expr (&block, el, fold_convert (TREE_TYPE (el), start));
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  TREE_USED (exit_label) = 1;
+
+
+  /* Loop body.  */
+  gfc_init_block (&loop);
+
+  /* Exit condition.  */
+  cond = fold_build2 (LE_EXPR, boolean_type_node, i,
+		      fold_convert (sizetype, integer_zero_node));
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&loop, tmp);
+
+  /* Assignment.  */
+  gfc_add_modify_expr (&loop, fold_build1 (INDIRECT_REF, type, el),
+		       build_int_cst (type,
+				      lang_hooks.to_target_charset (' ')));
+
+  /* Increment loop variables.  */
+  gfc_add_modify_expr (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
+					      TYPE_SIZE_UNIT (type)));
+  gfc_add_modify_expr (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
+					       TREE_TYPE (el), el,
+					       TYPE_SIZE_UNIT (type)));
+
+  /* Making the loop... actually loop!  */
+  tmp = gfc_finish_block (&loop);
+  tmp = build1_v (LOOP_EXPR, tmp);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* The exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+
+  return gfc_finish_block (&block);
+}
+
+
 /* Generate code to copy a string.  */
 
 void
 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
-		       tree slength, tree src)
+		       int dkind, tree slength, tree src, int skind)
 {
   tree tmp, dlen, slen;
   tree dsc;
@@ -2841,12 +2914,15 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
   tree tmp2;
   tree tmp3;
   tree tmp4;
+  tree chartype;
   stmtblock_t tempblock;
 
+  gcc_assert (dkind == skind);
+
   if (slength != NULL_TREE)
     {
       slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
-      ssc = gfc_to_single_character (slen, src);
+      ssc = string_to_single_character (slen, src, skind);
     }
   else
     {
@@ -2857,7 +2933,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
   if (dlength != NULL_TREE)
     {
       dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
-      dsc = gfc_to_single_character (slen, dest);
+      dsc = string_to_single_character (slen, dest, dkind);
     }
   else
     {
@@ -2866,14 +2942,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
     }
 
   if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
-    ssc = gfc_to_single_character (slen, src);
+    ssc = string_to_single_character (slen, src, skind);
   if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
-    dsc = gfc_to_single_character (dlen, dest);
+    dsc = string_to_single_character (dlen, dest, dkind);
 
 
   /* Assign directly if the types are compatible.  */
   if (dsc != NULL_TREE && ssc != NULL_TREE
-	&& TREE_TYPE (dsc) == TREE_TYPE (ssc))
+      && TREE_TYPE (dsc) == TREE_TYPE (ssc))
     {
       gfc_add_modify_expr (block, dsc, ssc);
       return;
@@ -2906,6 +2982,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
      We're now doing it here for better optimization, but the logic
      is the same.  */
 
+  /* For non-default character kinds, we have to multiply the string
+     length by the base type size.  */
+  chartype = gfc_get_char_type (dkind);
+  slen = fold_build2 (MULT_EXPR, size_type_node, slen,
+		      TYPE_SIZE_UNIT (chartype));
+  dlen = fold_build2 (MULT_EXPR, size_type_node, dlen,
+		      TYPE_SIZE_UNIT (chartype));
+
   if (dlength)
     dest = fold_convert (pvoid_type_node, dest);
   else
@@ -2927,12 +3011,9 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
 
   tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
 		      fold_convert (sizetype, slen));
-  tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
-			  tmp4, 
-			  build_int_cst (gfc_get_int_type (gfc_c_int_kind),
-					 lang_hooks.to_target_charset (' ')),
-			  fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
-				       dlen, slen));
+  tmp4 = fill_with_spaces (tmp4, chartype,
+			   fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
+					dlen, slen));
 
   gfc_init_block (&tempblock);
   gfc_add_expr_to_block (&tempblock, tmp3);
@@ -2994,7 +3075,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
           tree arglen;
 
           gcc_assert (fsym->ts.cl && fsym->ts.cl->length
-                     && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
+		      && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
 
           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
           tmp = gfc_build_addr_expr (build_pointer_type (type),
@@ -3005,8 +3086,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
           gfc_add_block_to_block (&se->pre, &lse.pre);
           gfc_add_block_to_block (&se->pre, &rse.pre);
 
-	  gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
-				 rse.expr);
+	  gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
+				 rse.string_length, rse.expr, fsym->ts.kind);
           gfc_add_block_to_block (&se->pre, &lse.post);
           gfc_add_block_to_block (&se->pre, &rse.post);
         }
@@ -3042,7 +3123,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
 	  tmp = gfc_create_var (type, sym->name);
 	  tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
 	  gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
-				 se->string_length, se->expr);
+				 sym->ts.kind, se->string_length, se->expr,
+				 sym->ts.kind);
 	  se->expr = tmp;
 	}
       se->string_length = sym->ts.cl->backend_decl;
@@ -3501,17 +3583,14 @@ static void
 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
 {
   gfc_ref *ref;
-  char *s;
 
   ref = expr->ref;
 
   gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
 
-  gcc_assert (expr->ts.kind == gfc_default_character_kind);
-  s = gfc_widechar_to_char (expr->value.character.string,
-			    expr->value.character.length);
-  se->expr = gfc_build_string_const (expr->value.character.length, s);
-  gfc_free (s);
+  se->expr = gfc_build_wide_string_const (expr->ts.kind,
+					  expr->value.character.length,
+					  expr->value.character.string);
 
   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
   TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
@@ -3824,15 +3903,18 @@ gfc_conv_string_parameter (gfc_se * se)
 
   if (TREE_CODE (se->expr) == STRING_CST)
     {
-      se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
+      type = TREE_TYPE (TREE_TYPE (se->expr));
+      se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
       return;
     }
 
-  type = TREE_TYPE (se->expr);
-  if (TYPE_STRING_FLAG (type))
+  if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
     {
       if (TREE_CODE (se->expr) != INDIRECT_REF)
-        se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
+	{
+	  type = TREE_TYPE (se->expr);
+          se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
+	}
       else
 	{
 	  type = gfc_get_character_type_len (gfc_default_character_kind,
@@ -3881,7 +3963,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	  rlen = rse->string_length;
 	}
 
-      gfc_trans_string_copy (&block, llen, lse->expr, rlen, rse->expr);
+      gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
+			     rse->expr, ts.kind);
     }
   else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
     {