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, 159 insertions, 20 deletions

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 6def478..e902f69 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -39,9 +39,10 @@ const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
 locus *gfc_current_intrinsic_where;
 
 static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym;
+static gfc_intrinsic_sym *char_conversions;
 static gfc_intrinsic_arg *next_arg;
 
-static int nfunc, nsub, nargs, nconv;
+static int nfunc, nsub, nargs, nconv, ncharconv;
 
 static enum
 { SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS }
@@ -148,6 +149,28 @@ find_conv (gfc_typespec *from, gfc_typespec *to)
 }
 
 
+/* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node
+   that corresponds to the conversion.  Returns NULL if the conversion
+   isn't found.  */
+
+static gfc_intrinsic_sym *
+find_char_conv (gfc_typespec *from, gfc_typespec *to)
+{
+  gfc_intrinsic_sym *sym;
+  const char *target;
+  int i;
+
+  target = conv_name (from, to);
+  sym = char_conversions;
+
+  for (i = 0; i < ncharconv; i++, sym++)
+    if (target == sym->name)
+      return sym;
+
+  return NULL;
+}
+
+
 /* Interface to the check functions.  We break apart an argument list
    and call the proper check function rather than forcing each
    function to manipulate the argument list.  */
@@ -974,15 +997,15 @@ add_functions (void)
 
   make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008);
 
-  add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
-	     NULL, gfc_simplify_adjustl, NULL,
-	     stg, BT_CHARACTER, dc, REQUIRED);
+  add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl,
+	     gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED);
 
   make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);
 
-  add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
-	     NULL, gfc_simplify_adjustr, NULL,
-	     stg, BT_CHARACTER, dc, REQUIRED);
+  add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr,
+	     gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED);
 
   make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);
 
@@ -1760,26 +1783,26 @@ add_functions (void)
   make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008);
 
 
-  add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77,
-	     NULL, gfc_simplify_lge, NULL,
+  add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL,
 	     sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
 
   make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
 
-  add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77,
-	     NULL, gfc_simplify_lgt, NULL,
+  add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL,
 	     sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
 
   make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
 
-  add_sym_2 ("lle",GFC_ISYM_LLE,  CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77,
-	     NULL, gfc_simplify_lle, NULL,
+  add_sym_2 ("lle",GFC_ISYM_LLE,  CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL,
 	     sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
 
   make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
 
-  add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77,
-	     NULL, gfc_simplify_llt, NULL,
+  add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL,
 	     sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
 
   make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
@@ -2625,7 +2648,7 @@ add_subroutines (void)
 
   add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
 	      gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
-	      val, BT_CHARACTER, dc, REQUIRED);
+	      val, BT_INTEGER, di, REQUIRED);
 
   add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
 	      gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
@@ -2654,7 +2677,7 @@ add_subroutines (void)
 
   add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
 	      NULL, NULL, gfc_resolve_system_sub,
-	      c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
+	      com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
 
   add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
 	      gfc_check_system_clock, NULL, gfc_resolve_system_clock,
@@ -2817,6 +2840,52 @@ add_conversions (void)
 }
 
 
+static void
+add_char_conversions (void)
+{
+  int n, i, j;
+
+  /* Count possible conversions.  */
+  for (i = 0; gfc_character_kinds[i].kind != 0; i++)
+    for (j = 0; gfc_character_kinds[j].kind != 0; j++)
+      if (i != j)
+	ncharconv++;
+
+  /* Allocate memory.  */
+  char_conversions = gfc_getmem (sizeof (gfc_intrinsic_sym) * ncharconv);
+
+  /* Add the conversions themselves.  */
+  n = 0;
+  for (i = 0; gfc_character_kinds[i].kind != 0; i++)
+    for (j = 0; gfc_character_kinds[j].kind != 0; j++)
+      {
+	gfc_typespec from, to;
+
+	if (i == j)
+	  continue;
+
+	gfc_clear_ts (&from);
+	from.type = BT_CHARACTER;
+	from.kind = gfc_character_kinds[i].kind;
+
+	gfc_clear_ts (&to);
+	to.type = BT_CHARACTER;
+	to.kind = gfc_character_kinds[j].kind;
+
+	char_conversions[n].name = conv_name (&from, &to);
+	char_conversions[n].lib_name = char_conversions[n].name;
+	char_conversions[n].simplify.cc = gfc_convert_char_constant;
+	char_conversions[n].standard = GFC_STD_F2003;
+	char_conversions[n].elemental = 1;
+	char_conversions[n].conversion = 0;
+	char_conversions[n].ts = to;
+	char_conversions[n].id = GFC_ISYM_CONVERSION;
+
+	n++;
+      }
+}
+
+
 /* Initialize the table of intrinsics.  */
 void
 gfc_intrinsic_init_1 (void)
@@ -2852,6 +2921,9 @@ gfc_intrinsic_init_1 (void)
   add_subroutines ();
   add_conversions ();
 
+  /* Character conversion intrinsics need to be treated separately.  */
+  add_char_conversions ();
+
   /* Set the pure flag.  All intrinsic functions are pure, and
      intrinsic subroutines are pure if they are elemental.  */
 
@@ -2868,6 +2940,7 @@ gfc_intrinsic_done_1 (void)
 {
   gfc_free (functions);
   gfc_free (conversion);
+  gfc_free (char_conversions);
   gfc_free_namespace (gfc_intrinsic_namespace);
 }
 
@@ -3052,10 +3125,18 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
   i = 0;
   for (; formal; formal = formal->next, actual = actual->next, i++)
     {
+      gfc_typespec ts;
+
       if (actual->expr == NULL)
 	continue;
 
-      if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
+      ts = formal->ts;
+
+      /* A kind of 0 means we don't check for kind.  */
+      if (ts.kind == 0)
+	ts.kind = actual->expr->ts.kind;
+
+      if (!gfc_compare_types (&ts, &actual->expr->ts))
 	{
 	  if (error_flag)
 	    gfc_error ("Type of argument '%s' in call to '%s' at %L should "
@@ -3199,9 +3280,10 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
   a1 = arg->expr;
   arg = arg->next;
 
-  if (specific->simplify.cc == gfc_convert_constant)
+  if (specific->simplify.cc == gfc_convert_constant
+      || specific->simplify.cc == gfc_convert_char_constant)
     {
-      result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
+      result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind);
       goto finish;
     }
 
@@ -3687,3 +3769,60 @@ bad:
 		      &expr->where);
   /* Not reached */
 }
+
+
+try
+gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
+{
+  gfc_intrinsic_sym *sym;
+  gfc_typespec from_ts;
+  locus old_where;
+  gfc_expr *new;
+  int rank;
+  mpz_t *shape;
+
+  gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER);
+  from_ts = expr->ts;		/* expr->ts gets clobbered */
+
+  sym = find_char_conv (&expr->ts, ts);
+  gcc_assert (sym);
+
+  /* Insert a pre-resolved function call to the right function.  */
+  old_where = expr->where;
+  rank = expr->rank;
+  shape = expr->shape;
+
+  new = gfc_get_expr ();
+  *new = *expr;
+
+  new = gfc_build_conversion (new);
+  new->value.function.name = sym->lib_name;
+  new->value.function.isym = sym;
+  new->where = old_where;
+  new->rank = rank;
+  new->shape = gfc_copy_shape (shape, rank);
+
+  gfc_get_ha_sym_tree (sym->name, &new->symtree);
+  new->symtree->n.sym->ts = *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);
+
+  *expr = *new;
+
+  gfc_free (new);
+  expr->ts = *ts;
+
+  if (gfc_is_constant_expr (expr->value.function.actual->expr)
+      && do_simplify (sym, expr) == FAILURE)
+    {
+      /* Error already generated in do_simplify() */
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}