OSDN Git Service

* intrinsic.c (char_conversions, ncharconv): New static variables.
authorfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 18 May 2008 22:45:05 +0000 (22:45 +0000)
committerfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 18 May 2008 22:45:05 +0000 (22:45 +0000)
(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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@135515 138bc75d-0d04-0410-961f-82ee72b054a4

42 files changed:
gcc/fortran/ChangeLog
gcc/fortran/arith.c
gcc/fortran/check.c
gcc/fortran/decl.c
gcc/fortran/error.c
gcc/fortran/expr.c
gcc/fortran/gfortran.h
gcc/fortran/intrinsic.c
gcc/fortran/intrinsic.h
gcc/fortran/intrinsic.texi
gcc/fortran/iresolve.c
gcc/fortran/primary.c
gcc/fortran/resolve.c
gcc/fortran/simplify.c
gcc/fortran/target-memory.c
gcc/fortran/target-memory.h
gcc/fortran/trans-array.c
gcc/fortran/trans-array.h
gcc/fortran/trans-const.c
gcc/fortran/trans-const.h
gcc/fortran/trans-decl.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans-stmt.c
gcc/fortran/trans-types.c
gcc/fortran/trans-types.h
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/achar_3.f90
gcc/testsuite/gfortran.dg/achar_5.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/achar_6.F90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_4.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_select_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/widechar_select_2.f90 [new file with mode: 0644]

index 35c564c..ffbc9c5 100644 (file)
@@ -1,3 +1,145 @@
+2008-05-18  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+       * 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.
+
 2008-05-18  Steven G. Kargl  <kargls@comcast.net>
 
        PR fortran/36251
index cbfcf29..6e09f8a 100644 (file)
@@ -280,6 +280,23 @@ gfc_arith_done_1 (void)
 }
 
 
+/* Given a wide character value and a character kind, determine whether
+   the character is representable for that kind.  */
+bool
+gfc_check_character_range (gfc_char_t c, int kind)
+{
+  /* As wide characters are stored as 32-bit values, they're all
+     representable in UCS=4.  */
+  if (kind == 4)
+    return true;
+
+  if (kind == 1)
+    return c <= 255 ? true : false;
+
+  gcc_unreachable ();
+}
+
+
 /* Given an integer and a kind, make sure that the integer lies within
    the range of the kind.  Returns ARITH_OK, ARITH_ASYMMETRIC or
    ARITH_OVERFLOW.  */
@@ -1655,6 +1672,11 @@ eval_intrinsic (gfc_intrinsic_op operator,
          unary = 0;
          temp.ts.type = BT_LOGICAL;
          temp.ts.kind = gfc_default_logical_kind;
+
+         /* If kind mismatch, exit and we'll error out later.  */
+         if (op1->ts.kind != op2->ts.kind)
+           goto runtime;
+
          break;
        }
 
@@ -1696,11 +1718,12 @@ eval_intrinsic (gfc_intrinsic_op operator,
 
     /* Character binary  */
     case INTRINSIC_CONCAT:
-      if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
+      if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
+         || op1->ts.kind != op2->ts.kind)
        goto runtime;
 
       temp.ts.type = BT_CHARACTER;
-      temp.ts.kind = gfc_default_character_kind;
+      temp.ts.kind = op1->ts.kind;
       unary = 0;
       break;
 
index f0497a1..87d962e 100644 (file)
@@ -492,10 +492,14 @@ gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
   if (type_check (name, 0, BT_CHARACTER) == FAILURE
       || scalar_check (name, 0) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (mode, 1, BT_CHARACTER) == FAILURE
       || scalar_check (mode, 1) == FAILURE)
     return FAILURE;
+  if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -716,6 +720,8 @@ gfc_check_chdir (gfc_expr *dir)
 {
   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -726,13 +732,14 @@ gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
 {
   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
 
   if (type_check (status, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
-
   if (scalar_check (status, 1) == FAILURE)
     return FAILURE;
 
@@ -745,9 +752,13 @@ gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
 {
   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -758,9 +769,13 @@ gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
 {
   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -1497,13 +1512,34 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
 
 
 try
+gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
+{
+  if (type_check (a, 0, BT_CHARACTER) == FAILURE)
+    return FAILURE;
+  if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
+
+  if (type_check (b, 1, BT_CHARACTER) == FAILURE)
+    return FAILURE;
+  if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
 {
   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -1514,9 +1550,13 @@ gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
 {
   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -1543,9 +1583,13 @@ gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
 {
   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -1556,9 +1600,13 @@ gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
 {
   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -2166,9 +2214,13 @@ gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
 {
   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -2179,9 +2231,13 @@ gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
 {
   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -2535,6 +2591,8 @@ gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
 
   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -2560,6 +2618,8 @@ gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
 {
   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -2705,6 +2765,8 @@ gfc_check_stat (gfc_expr *name, gfc_expr *array)
 {
   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (array, 1, BT_INTEGER) == FAILURE
       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
@@ -2722,6 +2784,8 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
 {
   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (type_check (array, 1, BT_INTEGER) == FAILURE
       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
@@ -2914,6 +2978,8 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
     {
       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
        return FAILURE;
+      if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
+       return FAILURE;
       if (scalar_check (date, 0) == FAILURE)
        return FAILURE;
       if (variable_check (date, 0) == FAILURE)
@@ -2924,6 +2990,8 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
     {
       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
        return FAILURE;
+      if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE)
+       return FAILURE;
       if (scalar_check (time, 1) == FAILURE)
        return FAILURE;
       if (variable_check (time, 1) == FAILURE)
@@ -2934,6 +3002,8 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
     {
       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
        return FAILURE;
+      if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE)
+       return FAILURE;
       if (scalar_check (zone, 2) == FAILURE)
        return FAILURE;
       if (variable_check (zone, 2) == FAILURE)
@@ -3246,12 +3316,13 @@ gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
 {
   if (scalar_check (time, 0) == FAILURE)
     return FAILURE;
-
   if (type_check (time, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
 
   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3315,6 +3386,8 @@ gfc_check_fdate_sub (gfc_expr *date)
 {
   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3325,6 +3398,8 @@ gfc_check_gerror (gfc_expr *msg)
 {
   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3335,6 +3410,8 @@ gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
 {
   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -3366,6 +3443,8 @@ gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
 
   if (type_check (value, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3376,6 +3455,8 @@ gfc_check_getlog (gfc_expr *msg)
 {
   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3431,6 +3512,8 @@ gfc_check_hostnm (gfc_expr *name)
 {
   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3441,6 +3524,8 @@ gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
 {
   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -3519,6 +3604,8 @@ gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
 
   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3555,6 +3642,8 @@ gfc_check_perror (gfc_expr *string)
 {
   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3600,6 +3689,8 @@ gfc_check_unlink (gfc_expr *name)
 {
   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -3610,6 +3701,8 @@ gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
 {
   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (status == NULL)
     return SUCCESS;
@@ -3686,6 +3779,8 @@ gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
 {
   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
+  if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
 
   if (scalar_check (status, 1) == FAILURE)
     return FAILURE;
index 5a1ce03..79044eb 100644 (file)
@@ -1093,7 +1093,7 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
   int slen;
 
   gcc_assert (expr->expr_type == EXPR_CONSTANT);
-  gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
+  gcc_assert (expr->ts.type == BT_CHARACTER);
 
   slen = expr->value.character.length;
   if (len != slen)
index a9cbe9e..c34899f 100644 (file)
@@ -152,14 +152,11 @@ error_integer (long int i)
 }
 
 
-static char wide_char_print_buffer[11];
-
-const char *
-gfc_print_wide_char (gfc_char_t c)
+static void
+print_wide_char_into_buffer (gfc_char_t c, char *buf)
 {
   static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
     '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
-  char *buf = wide_char_print_buffer;
 
   if (gfc_wide_is_printable (c))
     {
@@ -173,8 +170,8 @@ gfc_print_wide_char (gfc_char_t c)
       c = c >> 4;
       buf[2] = xdigit[c & 0x0F];
 
-      buf[1] = '\\';
-      buf[0] = 'x';
+      buf[1] = 'x';
+      buf[0] = '\\';
     }
   else if (c < ((gfc_char_t) 1 << 16))
     {
@@ -187,8 +184,8 @@ gfc_print_wide_char (gfc_char_t c)
       c = c >> 4;
       buf[2] = xdigit[c & 0x0F];
 
-      buf[1] = '\\';
-      buf[0] = 'u';
+      buf[1] = 'u';
+      buf[0] = '\\';
     }
   else
     {
@@ -209,13 +206,21 @@ gfc_print_wide_char (gfc_char_t c)
       c = c >> 4;
       buf[2] = xdigit[c & 0x0F];
 
-      buf[1] = '\\';
-      buf[0] = 'U';
+      buf[1] = 'U';
+      buf[0] = '\\';
     }
+}
 
-  return buf;
+static char wide_char_print_buffer[11];
+
+const char *
+gfc_print_wide_char (gfc_char_t c)
+{
+  print_wide_char_into_buffer (c, wide_char_print_buffer);
+  return wide_char_print_buffer;
 }
 
+
 /* Show the file, where it was included, and the source line, give a
    locus.  Calls error_printf() recursively, but the recursion is at
    most one level deep.  */
@@ -317,11 +322,14 @@ show_locus (locus *loc, int c1, int c2)
 
   for (; i > 0; i--)
     {
+      static char buffer[11];
+
       c = *p++;
       if (c == '\t')
        c = ' ';
 
-      error_string (gfc_print_wide_char (c));
+      print_wide_char_into_buffer (c, buffer);
+      error_string (buffer);
     }
 
   error_char ('\n');
index e6c1e4e..a872743 100644 (file)
@@ -2847,6 +2847,16 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
       return FAILURE;
     }
 
+  /* Assignment is the only case where character variables of different
+     kind values can be converted into one another.  */
+  if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
+    {
+      if (lvalue->ts.kind != rvalue->ts.kind)
+       gfc_convert_chartype (rvalue, &lvalue->ts);
+
+      return SUCCESS;
+    }
+
   return gfc_convert_type (rvalue, &lvalue->ts, 1);
 }
 
index 5fa3bc1..e3a9446 100644 (file)
@@ -2069,6 +2069,7 @@ void gfc_arith_init_1 (void);
 void gfc_arith_done_1 (void);
 gfc_expr *gfc_enum_initializer (gfc_expr *, locus);
 arith gfc_check_integer_range (mpz_t p, int kind);
+bool gfc_check_character_range (gfc_char_t, int);
 
 /* trans-types.c */
 try gfc_validate_c_kind (gfc_typespec *);
@@ -2225,6 +2226,7 @@ char gfc_type_letter (bt);
 gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
 try gfc_convert_type (gfc_expr *, gfc_typespec *, int);
 try gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int);
+try gfc_convert_chartype (gfc_expr *, gfc_typespec *);
 int gfc_generic_intrinsic (const char *);
 int gfc_specific_intrinsic (const char *);
 int gfc_intrinsic_name (const char *, int);
index 6def478..e902f69 100644 (file)
@@ -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;
+}
index ac996b6..e280c50 100644 (file)
@@ -91,6 +91,7 @@ try gfc_check_kind (gfc_expr *);
 try gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_len_lentrim (gfc_expr *, gfc_expr *);
 try gfc_check_link (gfc_expr *, gfc_expr *);
+try gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *);
 try gfc_check_loc (gfc_expr *);
 try gfc_check_logical (gfc_expr *, gfc_expr *);
 try gfc_check_min_max (gfc_actual_arglist *);
@@ -317,11 +318,14 @@ gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);
 
 /* Constant conversion simplification.  */
 gfc_expr *gfc_convert_constant (gfc_expr *, bt, int);
+gfc_expr *gfc_convert_char_constant (gfc_expr *, bt, int);
 
 
 /* Resolution functions.  */
 void gfc_resolve_abs (gfc_expr *, gfc_expr *);
 void gfc_resolve_access (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_adjustl (gfc_expr *, gfc_expr *);
+void gfc_resolve_adjustr (gfc_expr *, gfc_expr *);
 void gfc_resolve_achar (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_acos (gfc_expr *, gfc_expr *);
 void gfc_resolve_acosh (gfc_expr *, gfc_expr *);
index e8f98df..6852d64 100644 (file)
@@ -428,13 +428,14 @@ Inquiry function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{NAME} @tab Scalar @code{CHARACTER} with the file name.
-Tailing blank are ignored unless the character @code{achar(0)} is
-present, then all characters up to and excluding @code{achar(0)} are
+@item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the
+file name. Tailing blank are ignored unless the character @code{achar(0)}
+is present, then all characters up to and excluding @code{achar(0)} are
 used as file name.
-@item @var{MODE} @tab Scalar @code{CHARACTER} with the file access mode,
-may be any concatenation of @code{"r"} (readable), @code{"w"} (writable)
-and @code{"x"} (executable), or @code{" "} to check for existence.
+@item @var{MODE} @tab Scalar @code{CHARACTER} of default kind with the
+file access mode, may be any concatenation of @code{"r"} (readable),
+@code{"w"} (writable) and @code{"x"} (executable), or @code{" "} to check
+for existence.
 @end multitable
 
 @item @emph{Return value}:
@@ -644,9 +645,9 @@ Elemental function
 @end multitable
 
 @item @emph{Return value}:
-The return value is of type @code{CHARACTER} where leading spaces 
-are removed and the same number of spaces are inserted on the end
-of @var{STR}. The return value has the same kind as @var{STRING}.
+The return value is of type @code{CHARACTER} and of the same kind as
+@var{STRING} where leading spaces are removed and the same number of
+spaces are inserted on the end of @var{STRING}.
 
 @item @emph{Example}:
 @smallexample
@@ -689,9 +690,9 @@ Elemental function
 @end multitable
 
 @item @emph{Return value}:
-The return value is of type @code{CHARACTER} where trailing spaces 
-are removed and the same number of spaces are inserted at the start
-of @var{STR}. The return value has the same kind as @var{STRING}.
+The return value is of type @code{CHARACTER} and of the same kind as
+@var{STRING} where trailing spaces are removed and the same number of
+spaces are inserted at the start of @var{STRING}.
 
 @item @emph{Example}:
 @smallexample
@@ -2262,8 +2263,9 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{NAME}   @tab The type shall be @code{CHARACTER} and shall
-                        specify a valid path within the file system.
+@item @var{NAME}   @tab The type shall be @code{CHARACTER} of default
+                        kind and shall specify a valid path within the
+                       file system.
 @item @var{STATUS} @tab (Optional) @code{INTEGER} status flag of the default
                         kind.  Returns 0 on success, and a system specific
                         and nonzero error code otherwise.
@@ -2314,14 +2316,15 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{NAME} @tab Scalar @code{CHARACTER} with the file name.
-Trailing blanks are ignored unless the character @code{achar(0)} is
-present, then all characters up to and excluding @code{achar(0)} are
-used as the file name.
 
-@item @var{MODE} @tab Scalar @code{CHARACTER} giving the file permission.
-@var{MODE} uses the same syntax as the @var{MODE} argument of
-@code{/bin/chmod}.
+@item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the
+file name. Trailing blanks are ignored unless the character
+@code{achar(0)} is present, then all characters up to and excluding
+@code{achar(0)} are used as the file name.
+
+@item @var{MODE} @tab Scalar @code{CHARACTER} of default kind giving the
+file permission. @var{MODE} uses the same syntax as the @var{MODE}
+argument of @code{/bin/chmod}.
 
 @item @var{STATUS} @tab (optional) scalar @code{INTEGER}, which is
 @code{0} on success and nonzero otherwise.
@@ -2873,7 +2876,8 @@ Subroutine, function
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
 @item @var{TIME}    @tab The type shall be of type @code{INTEGER(KIND=8)}.
-@item @var{RESULT}  @tab The type shall be of type @code{CHARACTER}.
+@item @var{RESULT}  @tab The type shall be of type @code{CHARACTER} and
+                         of default kind.
 @end multitable
 
 @item @emph{Return value}:
@@ -2940,9 +2944,12 @@ Subroutine
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{DATE}  @tab (Optional) The type shall be @code{CHARACTER(8)} or larger.
-@item @var{TIME}  @tab (Optional) The type shall be @code{CHARACTER(10)} or larger.
-@item @var{ZONE}  @tab (Optional) The type shall be @code{CHARACTER(5)} or larger.
+@item @var{DATE}  @tab (Optional) The type shall be @code{CHARACTER(LEN=8)}
+                                  or larger, and of default kind.
+@item @var{TIME}  @tab (Optional) The type shall be @code{CHARACTER(LEN=10)}
+                                  or larger, and of default kind.
+@item @var{ZONE}  @tab (Optional) The type shall be @code{CHARACTER(LEN=5)}
+                                  or larger, and of default kind.
 @item @var{VALUES}@tab (Optional) The type shall be @code{INTEGER(8)}.
 @end multitable
 
@@ -3887,7 +3894,8 @@ TIME())}.
 This intrinsic is provided in both subroutine and function forms; however,
 only one form can be used in any given program unit.
 
-@var{DATE} is an @code{INTENT(OUT)} @code{CHARACTER} variable.
+@var{DATE} is an @code{INTENT(OUT)} @code{CHARACTER} variable of the
+default kind.
 
 @item @emph{Standard}:
 GNU extension
@@ -3903,7 +3911,8 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{DATE}@tab The type shall be of type @code{CHARACTER}.
+@item @var{DATE}@tab The type shall be of type @code{CHARACTER} of the
+default kind
 @end multitable
 
 @item @emph{Return value}:
@@ -3999,7 +4008,8 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{C}      @tab The type shall be @code{CHARACTER}.
+@item @var{C}      @tab The type shall be @code{CHARACTER} and of default
+                        kind.
 @item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
                         Returns 0 on success, -1 on end-of-file, and a
                         system specific positive error code otherwise.
@@ -4061,9 +4071,11 @@ Subroutine, function
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
 @item @var{UNIT}   @tab The type shall be @code{INTEGER}.
-@item @var{C}      @tab The type shall be @code{CHARACTER}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success,
-                        -1 on end-of-file and a system specific positive error code otherwise.
+@item @var{C}      @tab The type shall be @code{CHARACTER} and of default
+                        kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
+                        Returns 0 on success, -1 on end-of-file and a
+                        system specific positive error code otherwise.
 @end multitable
 
 @item @emph{Example}:
@@ -4241,9 +4253,11 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{C}      @tab The type shall be @code{CHARACTER}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success,
-                        -1 on end-of-file and a system specific positive error code otherwise.
+@item @var{C}      @tab The type shall be @code{CHARACTER} and of default
+                        kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
+                        Returns 0 on success, -1 on end-of-file and a
+                        system specific positive error code otherwise.
 @end multitable
 
 @item @emph{Example}:
@@ -4296,9 +4310,11 @@ Subroutine, function
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
 @item @var{UNIT}   @tab The type shall be @code{INTEGER}.
-@item @var{C}      @tab The type shall be @code{CHARACTER}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success,
-                        -1 on end-of-file and a system specific positive error code otherwise.
+@item @var{C}      @tab The type shall be @code{CHARACTER} and of default
+                        kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
+                        Returns 0 on success, -1 on end-of-file and a
+                        system specific positive error code otherwise.
 @end multitable
 
 @item @emph{Example}:
@@ -4656,7 +4672,7 @@ Subroutine
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{RESULT}  @tab Shall of type @code{CHARACTER}.
+@item @var{RESULT}  @tab Shall of type @code{CHARACTER} and of default
 @end multitable
 
 @item @emph{Example}:
@@ -4703,6 +4719,8 @@ Subroutine
 @multitable @columnfractions .15 .70
 @item @var{POS}   @tab Shall be of type @code{INTEGER} and not wider than
 the default integer kind; @math{@var{POS} \geq 0}
+@item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default
+kind.
 @item @var{VALUE} @tab Shall be of type @code{CHARACTER}. 
 @end multitable
 
@@ -4757,7 +4775,8 @@ Subroutine
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{COMMAND} @tab Shall be of type @code{CHARACTER}. 
+@item @var{COMMAND} @tab Shall be of type @code{CHARACTER} and of default
+kind.
 @end multitable
 
 @item @emph{Return value}:
@@ -4802,8 +4821,10 @@ Subroutine
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{NUMBER} @tab Shall be a scalar of type @code{INTEGER(4)}, @math{@var{N} \geq 0}.
-@item @var{VALUE}  @tab (Option) Shall be a scalar of type @code{CHARACTER(1)}. 
+@item @var{NUMBER} @tab Shall be a scalar of type @code{INTEGER(4)},
+                        @math{@var{NUMBER} \geq 0}
+@item @var{VALUE}  @tab Shall be a scalar of type @code{CHARACTER}
+                        and of default kind.
 @item @var{LENGTH} @tab (Option) Shall be a scalar of type @code{INTEGER(4)}. 
 @item @var{STATUS} @tab (Option) Shall be a scalar of type @code{INTEGER(4)}. 
 @end multitable
@@ -4865,7 +4886,7 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{C}      @tab The type shall be @code{CHARACTER}.
+@item @var{C} @tab The type shall be @code{CHARACTER} and of default kind.
 @item @var{STATUS} @tab (Optional) status flag. Returns 0 on success, 
                         a system specific and nonzero error code otherwise.
 @end multitable
@@ -4910,8 +4931,8 @@ Subroutine
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{NAME}   @tab Shall be of type @code{CHARACTER}. 
-@item @var{VALUE}  @tab Shall be of type @code{CHARACTER}. 
+@item @var{NAME}  @tab Shall be of type @code{CHARACTER} and of default kind.
+@item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default kind.
 @end multitable
 
 @item @emph{Return value}:
@@ -5039,7 +5060,7 @@ Subroutine
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{C} @tab Shall be of type @code{CHARACTER}.
+@item @var{C} @tab Shall be of type @code{CHARACTER} and of default kind.
 @end multitable
 
 @item @emph{Return value}:
@@ -5215,7 +5236,7 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{C }      @tab Shall of type @code{CHARACTER}.
+@item @var{C}    @tab Shall of type @code{CHARACTER} and of default kind.
 @item @var{STATUS}  @tab (Optional) status flag of type @code{INTEGER}.
                          Returns 0 on success, or a system specific error
                          code otherwise.
@@ -7132,10 +7153,11 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{FILE}   @tab The type shall be @code{CHARACTER}, a valid path within the file system.
+@item @var{FILE}   @tab The type shall be @code{CHARACTER} of the default
+kind, a valid path within the file system.
 @item @var{BUFF}   @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 
-                        on success and a system specific error code otherwise.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}.
+Returns 0 on success and a system specific error code otherwise.
 @end multitable
 
 @item @emph{Example}:
@@ -8407,7 +8429,8 @@ Subroutine
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{STRING} @tab A scalar of default @code{CHARACTER} type.
+@item @var{STRING} @tab A scalar of type @code{CHARACTER} and of the
+default kind.
 @end multitable
 
 @item @emph{See also}:
@@ -10158,7 +10181,8 @@ Subroutine, function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{FILE}   @tab The type shall be @code{CHARACTER}, a valid path within the file system.
+@item @var{FILE}   @tab The type shall be @code{CHARACTER}, of the
+default kind and a valid path within the file system.
 @item @var{BUFF}   @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
 @item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 
                         on success and a system specific error code otherwise.
index 2a3c6bd..4b7e17d 100644 (file)
@@ -143,6 +143,24 @@ gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 }
 
 
+void
+gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = string->ts.kind;
+  f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
+}
+
+
+void
+gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = string->ts.kind;
+  f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
+}
+
+
 static void
 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
                        const char *name)
@@ -1690,11 +1708,27 @@ gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
   resolve_mask_arg (mask);
 
   if (mask->rank != 0)
-    f->value.function.name = (array->ts.type == BT_CHARACTER
-                             ? PREFIX ("pack_char") : PREFIX ("pack"));
+    {
+      if (array->ts.type == BT_CHARACTER)
+       f->value.function.name
+         = array->ts.kind == 1 ? PREFIX ("pack_char")
+                               : gfc_get_string
+                                       (PREFIX ("pack_char%d"),
+                                        array->ts.kind);
+      else
+       f->value.function.name = PREFIX ("pack");
+    }
   else
-    f->value.function.name = (array->ts.type == BT_CHARACTER
-                             ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
+    {
+      if (array->ts.type == BT_CHARACTER)
+       f->value.function.name
+         = array->ts.kind == 1 ? PREFIX ("pack_s_char")
+                               : gfc_get_string
+                                       (PREFIX ("pack_s_char%d"),
+                                        array->ts.kind);
+      else
+       f->value.function.name = PREFIX ("pack_s");
+    }
 }
 
 
@@ -1801,6 +1835,7 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
     case BT_REAL:
     case BT_INTEGER:
     case BT_LOGICAL:
+    case BT_CHARACTER:
       kind = source->ts.kind;
       break;
 
@@ -1820,15 +1855,17 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
          = gfc_get_string (PREFIX ("reshape_%c%d"),
                            gfc_type_letter (source->ts.type),
                            source->ts.kind);
+      else if (source->ts.type == BT_CHARACTER)
+       f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
+                                                kind);
       else
        f->value.function.name
          = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
-
       break;
 
     default:
       f->value.function.name = (source->ts.type == BT_CHARACTER
-                            ? PREFIX ("reshape_char") : PREFIX ("reshape"));
+                               ? PREFIX ("reshape_char") : PREFIX ("reshape"));
       break;
     }
 
@@ -2000,13 +2037,27 @@ gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
   f->ts = source->ts;
   f->rank = source->rank + 1;
   if (source->rank == 0)
-    f->value.function.name = (source->ts.type == BT_CHARACTER
-                             ? PREFIX ("spread_char_scalar")
-                             : PREFIX ("spread_scalar"));
+    {
+      if (source->ts.type == BT_CHARACTER)
+       f->value.function.name
+         = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
+                                : gfc_get_string
+                                       (PREFIX ("spread_char%d_scalar"),
+                                        source->ts.kind);
+      else
+       f->value.function.name = PREFIX ("spread_scalar");
+    }
   else
-    f->value.function.name = (source->ts.type == BT_CHARACTER
-                             ? PREFIX ("spread_char")
-                             : PREFIX ("spread"));
+    {
+      if (source->ts.type == BT_CHARACTER)
+       f->value.function.name
+         = source->ts.kind == 1 ? PREFIX ("spread_char")
+                                : gfc_get_string
+                                       (PREFIX ("spread_char%d"),
+                                        source->ts.kind);
+      else
+       f->value.function.name = PREFIX ("spread");
+    }
 
   if (dim && gfc_is_constant_expr (dim)
       && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
@@ -2313,7 +2364,10 @@ gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
          break;
 
        default:
-         f->value.function.name = PREFIX ("transpose");
+         if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
+           f->value.function.name = PREFIX ("transpose_char4");
+         else
+           f->value.function.name = PREFIX ("transpose");
          break;
        }
       break;
@@ -2413,9 +2467,19 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
   f->rank = mask->rank;
   resolve_mask_arg (mask);
 
-  f->value.function.name
-    = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
-                     vector->ts.type == BT_CHARACTER ? "_char" : "");
+  if (vector->ts.type == BT_CHARACTER)
+    {
+      if (vector->ts.kind == 1)
+       f->value.function.name
+         = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
+      else
+       f->value.function.name
+         = gfc_get_string (PREFIX ("unpack%d_char%d"),
+                           field->rank > 0 ? 1 : 0, vector->ts.kind);
+    }
+  else
+    f->value.function.name
+      = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
 }
 
 
index be5fca0..a9b47d8 100644 (file)
@@ -992,10 +992,10 @@ got_delim:
     {
       c = next_string_char (delimiter, &ret);
 
-      if (!gfc_wide_fits_in_byte (c))
+      if (!gfc_check_character_range (c, kind))
        {
-         gfc_error ("Unimplemented feature at %C: gfortran currently only "
-                    "supports character strings with one-byte characters");
+         gfc_error ("Character '%s' in string at %C is not representable "
+                    "in character kind %d", gfc_print_wide_char (c), kind);
          return MATCH_ERROR;
        }
 
index dd251af..c3354a9 100644 (file)
@@ -2965,7 +2965,8 @@ resolve_operator (gfc_expr *e)
       goto bad_op;
 
     case INTRINSIC_CONCAT:
-      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
+      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+         && op1->ts.kind == op2->ts.kind)
        {
          e->ts.type = BT_CHARACTER;
          e->ts.kind = op1->ts.kind;
@@ -3030,7 +3031,8 @@ resolve_operator (gfc_expr *e)
     case INTRINSIC_EQ_OS:
     case INTRINSIC_NE:
     case INTRINSIC_NE_OS:
-      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
+      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+         && op1->ts.kind == op2->ts.kind)
        {
          e->ts.type = BT_LOGICAL;
          e->ts.kind = gfc_default_logical_kind;
@@ -5124,8 +5126,8 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
 
   if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
     {
-      gfc_error("Expression in CASE statement at %L must be kind %d",
-               &e->where, case_expr->ts.kind);
+      gfc_error ("Expression in CASE statement at %L must be of kind %d",
+                &e->where, case_expr->ts.kind);
       return FAILURE;
     }
 
index 4159374..e094a62 100644 (file)
@@ -256,43 +256,73 @@ gfc_simplify_abs (gfc_expr *e)
   return result;
 }
 
-/* We use the processor's collating sequence, because all
-   systems that gfortran currently works on are ASCII.  */
 
-gfc_expr *
-gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+static gfc_expr *
+simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
 {
   gfc_expr *result;
-  int c, kind;
-  const char *ch;
+  int kind;
+  bool too_large = false;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
+  kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
   if (kind == -1)
     return &gfc_bad_expr;
 
-  ch = gfc_extract_int (e, &c);
+  if (mpz_cmp_si (e->value.integer, 0) < 0)
+    {
+      gfc_error ("Argument of %s function at %L is negative", name,
+                &e->where);
+      return &gfc_bad_expr;
+    }
 
-  if (ch != NULL)
-    gfc_internal_error ("gfc_simplify_achar: %s", ch);
+  if (ascii && gfc_option.warn_surprising
+      && mpz_cmp_si (e->value.integer, 127) > 0)
+    gfc_warning ("Argument of %s function at %L outside of range [0,127]",
+                name, &e->where);
 
-  if (gfc_option.warn_surprising && (c < 0 || c > 127))
-    gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
-                &e->where);
+  if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
+    too_large = true;
+  else if (kind == 4)
+    {
+      mpz_t t;
+      mpz_init_set_ui (t, 2);
+      mpz_pow_ui (t, t, 32);
+      mpz_sub_ui (t, t, 1);
+      if (mpz_cmp (e->value.integer, t) > 0)
+       too_large = true;
+      mpz_clear (t);
+    }
 
-  result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+  if (too_large)
+    {
+      gfc_error ("Argument of %s function at %L is too large for the "
+                "collating sequence of kind %d", name, &e->where, kind);
+      return &gfc_bad_expr;
+    }
 
+  result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
   result->value.character.string = gfc_get_wide_string (2);
-
   result->value.character.length = 1;
-  result->value.character.string[0] = c;
+  result->value.character.string[0] = mpz_get_ui (e->value.integer);
   result->value.character.string[1] = '\0';    /* For debugger */
   return result;
 }
 
 
+
+/* We use the processor's collating sequence, because all
+   systems that gfortran currently works on are ASCII.  */
+
+gfc_expr *
+gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+{
+  return simplify_achar_char (e, k, "ACHAR", true);
+}
+
+
 gfc_expr *
 gfc_simplify_acos (gfc_expr *x)
 {
@@ -821,35 +851,7 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
 gfc_expr *
 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
 {
-  gfc_expr *result;
-  int c, kind;
-  const char *ch;
-
-  kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
-  if (kind == -1)
-    return &gfc_bad_expr;
-
-  if (e->expr_type != EXPR_CONSTANT)
-    return NULL;
-
-  ch = gfc_extract_int (e, &c);
-
-  if (ch != NULL)
-    gfc_internal_error ("gfc_simplify_char: %s", ch);
-
-  if (c < 0 || c > UCHAR_MAX)
-    gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
-              &e->where);
-
-  result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
-
-  result->value.character.length = 1;
-  result->value.character.string = gfc_get_wide_string (2);
-
-  result->value.character.string[0] = c;
-  result->value.character.string[1] = '\0';    /* For debugger */
-
-  return result;
+  return simplify_achar_char (e, k, "CHAR", false);
 }
 
 
@@ -1698,8 +1700,6 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
     }
 
   index = e->value.character.string[0];
-  if (index > UCHAR_MAX)
-    gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
 
   if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
     return &gfc_bad_expr;
@@ -4799,3 +4799,38 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
 
   return result;
 }
+
+
+/* Function for converting character constants.  */
+gfc_expr *
+gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
+{
+  gfc_expr *result;
+  int i;
+
+  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);
+       return &gfc_bad_expr;
+      }
+
+  return result;
+}
index 389e2a5..e1f9b7c 100644 (file)
@@ -75,7 +75,8 @@ size_logical (int kind)
 static size_t
 size_character (int length, int kind)
 {
-  return length * kind;
+  int i = gfc_validate_kind (BT_CHARACTER, kind, false);
+  return length * gfc_character_kinds[i].bit_size / 8;
 }
 
 
@@ -182,20 +183,19 @@ encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size
 }
 
 
-static int
-encode_character (int kind, int length, gfc_char_t *string,
-                 unsigned char *buffer, size_t buffer_size)
+int
+gfc_encode_character (int kind, int length, const gfc_char_t *string,
+                     unsigned char *buffer, size_t buffer_size)
 {
-  char *s;
+  size_t elsize = size_character (1, kind);
+  tree type = gfc_get_char_type (kind);
+  int i;
 
   gcc_assert (buffer_size >= size_character (length, kind));
-  /* FIXME -- when we support wide character types, we'll need to go
-     via integers for them.  For now, we keep the simple memcpy().  */
-  gcc_assert (kind == gfc_default_character_kind);
 
-  s = gfc_widechar_to_char (string, length);
-  memcpy (buffer, s, length);
-  gfc_free (s);
+  for (i = 0; i < length; i++)
+    native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
+                       elsize);
 
   return length;
 }
@@ -268,10 +268,10 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
                             buffer_size);
     case BT_CHARACTER:
       if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
-       return encode_character (source->ts.kind,
-                                source->value.character.length,
-                                source->value.character.string, buffer,
-                                buffer_size);
+       return gfc_encode_character (source->ts.kind,
+                                    source->value.character.length,
+                                    source->value.character.string,
+                                    buffer, buffer_size);
       else
        {
          int start, end;
@@ -279,10 +279,9 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
          gcc_assert (source->expr_type == EXPR_SUBSTRING);
          gfc_extract_int (source->ref->u.ss.start, &start);
          gfc_extract_int (source->ref->u.ss.end, &end);
-         return encode_character (source->ts.kind,
-                                  MAX(end - start + 1, 0),
-                                  &source->value.character.string[start-1],
-                                  buffer, buffer_size);
+         return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
+                                      &source->value.character.string[start-1],
+                                      buffer, buffer_size);
        }
 
     case BT_DERIVED:
index 04b9c78..bc3a1e8 100644 (file)
@@ -31,6 +31,8 @@ bool gfc_convert_boz (gfc_expr *, gfc_typespec *);
 size_t gfc_target_expr_size (gfc_expr *);
 
 /* Write a constant expression in binary form to a target buffer.  */
+int gfc_encode_character (int, int, const gfc_char_t *, unsigned char *,
+                         size_t);
 int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t);
 
 /* Read a target buffer into a constant expression.  */
index 784f1bc..a691ad5 100644 (file)
@@ -992,12 +992,11 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
       else
        {
          /* The temporary is an array of string values.  */
-         tmp = gfc_build_addr_expr (pchar_type_node, tmp);
+         tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
          /* We know the temporary and the value will be the same length,
             so can use memcpy.  */
-         gfc_trans_string_copy (&se->pre, esize, tmp,
-                                se->string_length,
-                                se->expr);
+         gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
+                                se->string_length, se->expr, expr->ts.kind);
        }
       if (flag_bounds_check && !typespec_chararray_ctor)
        {
@@ -1185,15 +1184,15 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
                {
                  gfc_init_se (&se, NULL);
                  gfc_conv_constant (&se, p->expr);
+
+                 /* For constant character array constructors we build
+                    an array of pointers.  */
                  if (p->expr->ts.type == BT_CHARACTER
                      && POINTER_TYPE_P (type))
-                   {
-                     /* For constant character array constructors we build
-                        an array of pointers.  */
-                     se.expr = gfc_build_addr_expr (pchar_type_node,
-                                                    se.expr);
-                   }
-                   
+                   se.expr = gfc_build_addr_expr
+                               (gfc_get_pchar_type (p->expr->ts.kind),
+                                se.expr);
+
                  list = tree_cons (NULL_TREE, se.expr, list);
                  c = p;
                  p = p->next;
@@ -1394,8 +1393,7 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
          mpz_init_set_ui (char_len, 1);
          mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
          mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
-         *len = gfc_conv_mpz_to_tree (char_len,
-                                      gfc_default_character_kind);
+         *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
          *len = convert (gfc_charlen_type_node, *len);
          mpz_clear (char_len);
          return;
@@ -1546,9 +1544,9 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
     {
       gfc_init_se (&se, NULL);
       gfc_conv_constant (&se, c->expr);
-      if (c->expr->ts.type == BT_CHARACTER
-         && POINTER_TYPE_P (type))
-       se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
+      if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
+       se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
+                                      se.expr);
       list = tree_cons (NULL_TREE, se.expr, list);
       c = c->next;
       nelem++;
@@ -3488,8 +3486,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
       /* Make absolutely sure that this is a complete type.  */
       if (loop->temp_ss->string_length)
        loop->temp_ss->data.temp.type
-               = gfc_get_character_type_len (gfc_default_character_kind,
-                                             loop->temp_ss->string_length);
+               = gfc_get_character_type_len_for_eltype
+                       (TREE_TYPE (loop->temp_ss->data.temp.type),
+                        loop->temp_ss->string_length);
 
       tmp = loop->temp_ss->data.temp.type;
       len = loop->temp_ss->string_length;
index 511f04b..2b644c7 100644 (file)
@@ -139,4 +139,4 @@ unsigned HOST_WIDE_INT gfc_constant_array_constructor_p (gfc_constructor *);
 tree gfc_build_constant_array_constructor (gfc_expr *, tree);
 
 /* Copy a string from src to dest.  */
-void gfc_trans_string_copy (stmtblock_t *, tree, tree, tree, tree);
+void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int);
index 6c9032f..e4da3f0 100644 (file)
@@ -33,6 +33,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans.h"
 #include "trans-const.h"
 #include "trans-types.h"
+#include "target-memory.h"
 
 tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
 
@@ -66,6 +67,8 @@ gfc_build_const (tree type, tree intval)
   return val;
 }
 
+/* Build a string constant with C char type.  */
+
 tree
 gfc_build_string_const (int length, const char *s)
 {
@@ -81,6 +84,36 @@ gfc_build_string_const (int length, const char *s)
   return str;
 }
 
+
+/* Build a string constant with a type given by its kind; take care of
+   non-default character kinds.  */
+
+tree
+gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
+{
+  int i;
+  tree str, len;
+  size_t size;
+  char *s;
+
+  i = gfc_validate_kind (BT_CHARACTER, kind, false);
+  size = length * gfc_character_kinds[i].bit_size / 8;
+
+  s = gfc_getmem (size);
+  gfc_encode_character (kind, length, string, (unsigned char *) s, size);
+
+  str = build_string (size, s);
+  gfc_free (s);
+
+  len = build_int_cst (NULL_TREE, length);
+  TREE_TYPE (str) =
+    build_array_type (gfc_get_char_type (kind),
+                     build_range_type (gfc_charlen_type_node,
+                                       integer_one_node, len));
+  return str;
+}
+
+
 /* Build a Fortran character constant from a zero-terminated string.
    There a two version of this function, one that translates the string
    and one that doesn't.  */
@@ -106,13 +139,13 @@ tree
 gfc_conv_string_init (tree length, gfc_expr * expr)
 {
   gfc_char_t *s;
-  char *c;
   HOST_WIDE_INT len;
   int slen;
   tree str;
+  bool free_s = false;
 
   gcc_assert (expr->expr_type == EXPR_CONSTANT);
-  gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
+  gcc_assert (expr->ts.type == BT_CHARACTER);
   gcc_assert (INTEGER_CST_P (length));
   gcc_assert (TREE_INT_CST_HIGH (length) == 0);
 
@@ -124,18 +157,15 @@ gfc_conv_string_init (tree length, gfc_expr * expr)
       s = gfc_get_wide_string (len);
       memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
       gfc_wide_memset (&s[slen], ' ', len - slen);
-
-      /* FIXME -- currently ignore wide character strings; see assert
-        above.  */
-      c = gfc_widechar_to_char (s, len);
-      gfc_free (s);
+      free_s = true;
     }
   else
-    c = gfc_widechar_to_char (expr->value.character.string,
-                             expr->value.character.length);
+    s = expr->value.character.string;
 
-  str = gfc_build_string_const (len, c);
-  gfc_free (c);
+  str = gfc_build_wide_string_const (expr->ts.kind, len, s);
+
+  if (free_s)
+    gfc_free (s);
 
   return str;
 }
@@ -223,7 +253,6 @@ tree
 gfc_conv_constant_to_tree (gfc_expr * expr)
 {
   tree res;
-  char *s;
 
   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 
@@ -278,11 +307,9 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
        }
 
     case BT_CHARACTER:
-      gcc_assert (expr->ts.kind == 1);
-      s = gfc_widechar_to_char (expr->value.character.string,
-                               expr->value.character.length);
-      res = gfc_build_string_const (expr->value.character.length, s);
-      gfc_free (s);
+      res = gfc_build_wide_string_const (expr->ts.kind,
+                                        expr->value.character.length,
+                                        expr->value.character.string);
       return res;
 
     case BT_HOLLERITH:
index 808a1a5..2cba791 100644 (file)
@@ -37,6 +37,7 @@ tree gfc_conv_constant_to_tree (gfc_expr *);
 void gfc_conv_constant (gfc_se *, gfc_expr *);
 
 tree gfc_build_string_const (int, const char *);
+tree gfc_build_wide_string_const (int, int, const gfc_char_t *);
 tree gfc_build_cstring_const (const char *);
 tree gfc_build_localized_cstring_const (const char *);
 
index 49eb2aa..57914ae 100644 (file)
@@ -77,7 +77,6 @@ tree gfor_fndecl_pause_numeric;
 tree gfor_fndecl_pause_string;
 tree gfor_fndecl_stop_numeric;
 tree gfor_fndecl_stop_string;
-tree gfor_fndecl_select_string;
 tree gfor_fndecl_runtime_error;
 tree gfor_fndecl_runtime_error_at;
 tree gfor_fndecl_os_error;
@@ -116,6 +115,7 @@ tree gfor_fndecl_string_trim;
 tree gfor_fndecl_string_minmax;
 tree gfor_fndecl_adjustl;
 tree gfor_fndecl_adjustr;
+tree gfor_fndecl_select_string;
 tree gfor_fndecl_compare_string_char4;
 tree gfor_fndecl_concat_string_char4;
 tree gfor_fndecl_string_len_trim_char4;
@@ -126,6 +126,12 @@ tree gfor_fndecl_string_trim_char4;
 tree gfor_fndecl_string_minmax_char4;
 tree gfor_fndecl_adjustl_char4;
 tree gfor_fndecl_adjustr_char4;
+tree gfor_fndecl_select_string_char4;
+
+
+/* Conversion between character kinds.  */
+tree gfor_fndecl_convert_char1_to_char4;
+tree gfor_fndecl_convert_char4_to_char1;
 
 
 /* Other misc. runtime library functions.  */
@@ -2084,6 +2090,12 @@ gfc_build_intrinsic_function_decls (void)
                                     void_type_node, 3, pchar1_type_node,
                                     gfc_charlen_type_node, pchar1_type_node);
 
+  gfor_fndecl_select_string =
+    gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
+                                    integer_type_node, 4, pvoid_type_node,
+                                    integer_type_node, pchar1_type_node,
+                                    gfc_charlen_type_node);
+
   gfor_fndecl_compare_string_char4 =
     gfc_build_library_function_decl (get_identifier
                                        (PREFIX("compare_string_char4")),
@@ -2155,6 +2167,30 @@ gfc_build_intrinsic_function_decls (void)
                                     void_type_node, 3, pchar4_type_node,
                                     gfc_charlen_type_node, pchar4_type_node);
 
+  gfor_fndecl_select_string_char4 =
+    gfc_build_library_function_decl (get_identifier
+                                       (PREFIX("select_string_char4")),
+                                    integer_type_node, 4, pvoid_type_node,
+                                    integer_type_node, pvoid_type_node,
+                                    gfc_charlen_type_node);
+
+
+  /* Conversion between character kinds.  */
+
+  gfor_fndecl_convert_char1_to_char4 =
+    gfc_build_library_function_decl (get_identifier
+                                       (PREFIX("convert_char1_to_char4")),
+                                    void_type_node, 3,
+                                    build_pointer_type (pchar4_type_node),
+                                    gfc_charlen_type_node, pchar1_type_node);
+
+  gfor_fndecl_convert_char4_to_char1 =
+    gfc_build_library_function_decl (get_identifier
+                                       (PREFIX("convert_char4_to_char1")),
+                                    void_type_node, 3,
+                                    build_pointer_type (pchar1_type_node),
+                                    gfc_charlen_type_node, pchar4_type_node);
+
   /* Misc. functions.  */
 
   gfor_fndecl_ttynam =
@@ -2362,12 +2398,6 @@ gfc_build_builtin_function_decls (void)
                                     void_type_node, 2, pchar_type_node,
                                      gfc_int4_type_node);
 
-  gfor_fndecl_select_string =
-    gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
-                                    integer_type_node, 4, pvoid_type_node,
-                                    integer_type_node, pchar_type_node,
-                                    integer_type_node);
-
   gfor_fndecl_runtime_error =
     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
                                     void_type_node, -1, pchar_type_node);
index 563e840..482e8b1 100644 (file)
@@ -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)
     {
index 03ddefd..990a127 100644 (file)
@@ -250,6 +250,41 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
   gcc_assert (expr->value.function.actual->expr);
   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 
+  /* Conversion between character kinds involves a call to a library
+     function.  */
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      tree fndecl, var, addr, tmp;
+
+      if (expr->ts.kind == 1
+         && expr->value.function.actual->expr->ts.kind == 4)
+       fndecl = gfor_fndecl_convert_char4_to_char1;
+      else if (expr->ts.kind == 4
+              && expr->value.function.actual->expr->ts.kind == 1)
+       fndecl = gfor_fndecl_convert_char1_to_char4;
+      else
+       gcc_unreachable ();
+
+      /* Create the variable storing the converted value.  */
+      type = gfc_get_pchar_type (expr->ts.kind);
+      var = gfc_create_var (type, "str");
+      addr = gfc_build_addr_expr (build_pointer_type (type), var);
+
+      /* Call the library function that will perform the conversion.  */
+      gcc_assert (nargs >= 2);
+      tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]);
+      gfc_add_expr_to_block (&se->pre, tmp);
+
+      /* Free the temporary afterwards.  */
+      tmp = gfc_call_free (var);
+      gfc_add_expr_to_block (&se->post, tmp);
+
+      se->expr = var;
+      se->string_length = args[0];
+
+      return;
+    }
+
   /* Conversion from complex to non-complex involves taking the real
      component of the value.  */
   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
@@ -1273,16 +1308,13 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
   tree type;
   unsigned int num_args;
 
-  /* We must allow for the KIND argument, even though.... */
   num_args = gfc_intrinsic_argument_list_length (expr);
   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
 
-  /* .... we currently don't support character types != 1.  */
-  gcc_assert (expr->ts.kind == 1);
-  type = gfc_character1_type_node;
+  type = gfc_get_char_type (expr->ts.kind);
   var = gfc_create_var (type, "char");
 
-  arg[0] = convert (type, arg[0]);
+  arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
   gfc_add_modify_expr (&se->pre, var, arg[0]);
   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
   se->string_length = integer_one_node;
@@ -3290,7 +3322,7 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
 
   se->expr
     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
-                               expr->value.function.actual->expr->ts.kind);
+                               expr->value.function.actual->expr->ts.kind);
   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
                          build_int_cst (TREE_TYPE (se->expr), 0));
 }
@@ -3892,9 +3924,14 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
 {
   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
   tree type, cond, tmp, count, exit_label, n, max, largest;
+  tree size;
   stmtblock_t block, body;
   int i;
 
+  /* We store in charsize the size of an 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);
+
   /* Get the arguments.  */
   gfc_conv_intrinsic_function_args (se, expr, args, 3);
   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
@@ -3939,7 +3976,6 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
                      cond);
   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
                           "Argument NCOPIES of REPEAT intrinsic is too large");
-                          
 
   /* Compute the destination length.  */
   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
@@ -3950,7 +3986,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
 
   /* Generate the code to do the repeat operation:
        for (i = 0; i < ncopies; i++)
-         memmove (dest + (i * slen), src, slen);  */
+         memmove (dest + (i * slen * size), src, slen*size);  */
   gfc_start_block (&block);
   count = gfc_create_var (ncopies_type, "count");
   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
@@ -3967,15 +4003,18 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
                     build_empty_stmt ());
   gfc_add_expr_to_block (&body, tmp);
 
-  /* Call memmove (dest + (i*slen), src, slen).  */
+  /* Call memmove (dest + (i*slen*size), src, slen*size).  */
   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
                     fold_convert (gfc_charlen_type_node, slen),
                     fold_convert (gfc_charlen_type_node, count));
-  tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
-                    fold_convert (pchar_type_node, dest),
+  tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
+                    tmp, fold_convert (gfc_charlen_type_node, size));
+  tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
+                    fold_convert (pvoid_type_node, dest),
                     fold_convert (sizetype, tmp));
-  tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
-                        tmp, src, slen);
+  tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
+                        fold_build2 (MULT_EXPR, size_type_node, slen,
+                                     fold_convert (size_type_node, size)));
   gfc_add_expr_to_block (&body, tmp);
 
   /* Increment count.  */
index 64829e3..6afac5d 100644 (file)
@@ -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);
 
index 1c15d64..fa1bf24 100644 (file)
@@ -874,19 +874,24 @@ gfc_get_pchar_type (int kind)
 /* Create a character type with the given kind and length.  */
 
 tree
-gfc_get_character_type_len (int kind, tree len)
+gfc_get_character_type_len_for_eltype (tree eltype, tree len)
 {
   tree bounds, type;
 
-  gfc_validate_kind (BT_CHARACTER, kind, false);
-
   bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
-  type = build_array_type (gfc_get_char_type (kind), bounds);
+  type = build_array_type (eltype, bounds);
   TYPE_STRING_FLAG (type) = 1;
 
   return type;
 }
 
+tree
+gfc_get_character_type_len (int kind, tree len)
+{
+  gfc_validate_kind (BT_CHARACTER, kind, false);
+  return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
+}
+
 
 /* Get a type node for a character kind.  */
 
index 0da736d..7074913 100644 (file)
@@ -59,6 +59,7 @@ tree gfc_get_char_type (int);
 tree gfc_get_pchar_type (int);
 tree gfc_get_character_type (int, gfc_charlen *);
 tree gfc_get_character_type_len (int, tree);
+tree gfc_get_character_type_len_for_eltype (tree, tree);
 
 tree gfc_sym_type (gfc_symbol *);
 tree gfc_typenode_for_spec (gfc_typespec *);
index ffd1b84..d0ce235 100644 (file)
@@ -504,7 +504,6 @@ extern GTY(()) tree gfor_fndecl_pause_numeric;
 extern GTY(()) tree gfor_fndecl_pause_string;
 extern GTY(()) tree gfor_fndecl_stop_numeric;
 extern GTY(()) tree gfor_fndecl_stop_string;
-extern GTY(()) tree gfor_fndecl_select_string;
 extern GTY(()) tree gfor_fndecl_runtime_error;
 extern GTY(()) tree gfor_fndecl_runtime_error_at;
 extern GTY(()) tree gfor_fndecl_os_error;
@@ -551,6 +550,7 @@ extern GTY(()) tree gfor_fndecl_string_trim;
 extern GTY(()) tree gfor_fndecl_string_minmax;
 extern GTY(()) tree gfor_fndecl_adjustl;
 extern GTY(()) tree gfor_fndecl_adjustr;
+extern GTY(()) tree gfor_fndecl_select_string;
 extern GTY(()) tree gfor_fndecl_compare_string_char4;
 extern GTY(()) tree gfor_fndecl_concat_string_char4;
 extern GTY(()) tree gfor_fndecl_string_len_trim_char4;
@@ -561,6 +561,11 @@ extern GTY(()) tree gfor_fndecl_string_trim_char4;
 extern GTY(()) tree gfor_fndecl_string_minmax_char4;
 extern GTY(()) tree gfor_fndecl_adjustl_char4;
 extern GTY(()) tree gfor_fndecl_adjustr_char4;
+extern GTY(()) tree gfor_fndecl_select_string_char4;
+
+/* Conversion between character kinds.  */
+extern GTY(()) tree gfor_fndecl_convert_char1_to_char4;
+extern GTY(()) tree gfor_fndecl_convert_char4_to_char1;
 
 /* Other misc. runtime library functions.  */
 extern GTY(()) tree gfor_fndecl_size0;
index 5580d8c..77c5dab 100644 (file)
@@ -1,3 +1,20 @@
+2008-05-18  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+       * 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.
+
 2008-05-18  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/loop_optimization2.ad[sb]: New test.
index 3b6f902..b33bfd1 100644 (file)
@@ -1,9 +1,9 @@
 ! { dg-do compile }
 ! { dg-options "-Wall" }
 program main
-  print *,achar(-3)     ! { dg-warning "outside of range" }
+  print *,achar(-3)     ! { dg-error "negative" }
   print *,achar(200)    ! { dg-warning "outside of range" }
-  print *,char(222+221) ! { dg-error "outside of range" }
-  print *,char(-44)     ! { dg-error "outside of range" }
+  print *,char(222+221) ! { dg-error "too large for the collating sequence" }
+  print *,char(-44)     ! { dg-error "negative" }
   print *,iachar("ΓΌ")   ! { dg-warning "outside of range" }
 end program main
diff --git a/gcc/testsuite/gfortran.dg/achar_5.f90 b/gcc/testsuite/gfortran.dg/achar_5.f90
new file mode 100644 (file)
index 0000000..c4f78c0
--- /dev/null
@@ -0,0 +1,45 @@
+! { dg-do compile }
+!
+program test
+
+  print *, char(255)
+  print *, achar(255)
+  print *, char(255,kind=1)
+  print *, achar(255,kind=1)
+  print *, char(255,kind=4)
+  print *, achar(255,kind=4)
+
+  print *, char(0)
+  print *, achar(0)
+  print *, char(0,kind=1)
+  print *, achar(0,kind=1)
+  print *, char(0,kind=4)
+  print *, achar(0,kind=4)
+
+  print *, char(297) ! { dg-error "too large for the collating sequence" }
+  print *, achar(297) ! { dg-error "too large for the collating sequence" }
+  print *, char(297,kind=1) ! { dg-error "too large for the collating sequence" }
+  print *, achar(297,kind=1) ! { dg-error "too large for the collating sequence" }
+  print *, char(297,kind=4)
+  print *, achar(297,kind=4)
+
+  print *, char(-1) ! { dg-error "negative" }
+  print *, achar(-1) ! { dg-error "negative" }
+  print *, char(-1,kind=1) ! { dg-error "negative" }
+  print *, achar(-1,kind=1) ! { dg-error "negative" }
+  print *, char(-1,kind=4) ! { dg-error "negative" }
+  print *, achar(-1,kind=4) ! { dg-error "negative" }
+
+  print *, char(huge(0_8)) ! { dg-error "too large for the collating sequence" }
+  print *, achar(huge(0_8)) ! { dg-error "too large for the collating sequence" }
+  print *, char(huge(0_8),kind=1) ! { dg-error "too large for the collating sequence" }
+  print *, achar(huge(0_8),kind=1) ! { dg-error "too large for the collating sequence" }
+  print *, char(huge(0_8),kind=4) ! { dg-error "too large for the collating sequence" }
+  print *, achar(huge(0_8),kind=4) ! { dg-error "too large for the collating sequence" }
+
+  print *, char(z'FFFFFFFF', kind=4)
+  print *, achar(z'FFFFFFFF', kind=4)
+  print *, char(z'100000000', kind=4) ! { dg-error "too large for the collating sequence" }
+  print *, achar(z'100000000', kind=4) ! { dg-error "too large for the collating sequence" }
+
+end program test
diff --git a/gcc/testsuite/gfortran.dg/achar_6.F90 b/gcc/testsuite/gfortran.dg/achar_6.F90
new file mode 100644 (file)
index 0000000..dd93c27
--- /dev/null
@@ -0,0 +1,70 @@
+! { dg-do run }
+! { dg-options "-fbackslash" }
+
+#define TEST(x,y,z) \
+  call test (x, y, z, iachar(x), iachar(y), ichar(x), ichar(y))
+
+  TEST("a", 4_"a", 97)
+  TEST("\0", 4_"\0", 0)
+  TEST("\b", 4_"\b", 8)
+  TEST("\x80", 4_"\x80", int(z'80'))
+  TEST("\xFF", 4_"\xFF", int(z'FF'))
+
+#define TEST2(y,z) \
+  call test_bis (y, z, iachar(y), ichar(y))
+
+  TEST2(4_"\u0100", int(z'0100'))
+  TEST2(4_"\ufe00", int(z'fe00'))
+  TEST2(4_"\u106a", int(z'106a'))
+  TEST2(4_"\uff00", int(z'ff00'))
+  TEST2(4_"\uffff", int(z'ffff'))
+
+contains
+
+subroutine test (s1, s4, i, i1, i2, i3, i4)
+  character(kind=1,len=1) :: s1
+  character(kind=4,len=1) :: s4
+  integer :: i, i1, i2, i3, i4
+
+  if (i /= i1) call abort
+  if (i /= i2) call abort
+  if (i /= i3) call abort
+  if (i /= i4) call abort
+
+  if (iachar (s1) /= i) call abort
+  if (iachar (s4) /= i) call abort
+  
+  if (ichar (s1) /= i) call abort
+  if (ichar (s4) /= i) call abort
+  
+  if (achar(i, kind=1) /= s1) call abort
+  if (achar(i, kind=4) /= s4) call abort
+
+  if (char(i, kind=1) /= s1) call abort
+  if (char(i, kind=4) /= s4) call abort
+
+  if (iachar(achar(i, kind=1)) /= i) call abort
+  if (iachar(achar(i, kind=4)) /= i) call abort
+
+  if (ichar(char(i, kind=1)) /= i) call abort
+  if (ichar(char(i, kind=4)) /= i) call abort
+
+end subroutine test
+
+subroutine test_bis (s4, i, i2, i4)
+  character(kind=4,len=1) :: s4
+  integer :: i, i2, i4
+
+  if (i /= i2) call abort
+  if (i /= i4) call abort
+
+  if (iachar (s4) /= i) call abort
+  if (ichar (s4) /= i) call abort
+  if (achar(i, kind=4) /= s4) call abort
+  if (char(i, kind=4) /= s4) call abort
+  if (iachar(achar(i, kind=4)) /= i) call abort
+  if (ichar(char(i, kind=4)) /= i) call abort
+
+end subroutine test_bis
+
+end
diff --git a/gcc/testsuite/gfortran.dg/widechar_1.f90 b/gcc/testsuite/gfortran.dg/widechar_1.f90
new file mode 100644 (file)
index 0000000..804de9d
--- /dev/null
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! { dg-options "-fbackslash" }
+
+  character(len=20,kind=4) :: s4
+  character(len=20,kind=1) :: s1
+
+  s1 = "foo\u0000"
+  s1 = "foo\u00ff"
+  s1 = "foo\u0100" ! { dg-error "is not representable" }
+  s1 = "foo\u0101" ! { dg-error "is not representable" }
+  s1 = "foo\U00000101" ! { dg-error "is not representable" }
+
+  s1 = 4_"foo bar"
+  s1 = 4_"foo\u00ff"
+  s1 = 4_"foo\u0101" ! { dg-error "cannot be converted" }
+  s1 = 4_"foo\u1101" ! { dg-error "cannot be converted" }
+  s1 = 4_"foo\UFFFFFFFF" ! { dg-error "cannot be converted" }
+
+  s4 = "foo\u0000"
+  s4 = "foo\u00ff"
+  s4 = "foo\u0100" ! { dg-error "is not representable" }
+  s4 = "foo\U00000100" ! { dg-error "is not representable" }
+
+  s4 = 4_"foo bar"
+  s4 = 4_"\xFF\x96"
+  s4 = 4_"\x00\x96"
+  s4 = 4_"foo\u00ff"
+  s4 = 4_"foo\u0101"
+  s4 = 4_"foo\u1101"
+  s4 = 4_"foo\Uab98EF56"
+  s4 = 4_"foo\UFFFFFFFF"
+
+end
diff --git a/gcc/testsuite/gfortran.dg/widechar_2.f90 b/gcc/testsuite/gfortran.dg/widechar_2.f90
new file mode 100644 (file)
index 0000000..706901e
--- /dev/null
@@ -0,0 +1,69 @@
+! { dg-do run }
+! { dg-options "-fbackslash" }
+
+  character(kind=1,len=20) :: s1
+  character(kind=4,len=20) :: s4
+
+  s1 = "this is me!"
+  s4 = s1
+  call check(s1, 4_"this is me!         ")
+  call check2(s1, 4_"this is me!         ")
+  s4 = "this is me!"
+  call check(s1, 4_"this is me!         ")
+  call check2(s1, 4_"this is me!         ")
+
+  s1 = ""
+  s4 = s1
+  call check(s1, 4_"                    ")
+  call check2(s1, 4_"                    ")
+  s4 = ""
+  call check(s1, 4_"                    ")
+  call check2(s1, 4_"                    ")
+
+  s1 = " \xFF"
+  s4 = s1
+  call check(s1, 4_" \xFF                  ")
+  call check2(s1, 4_" \xFF                  ")
+  s4 = " \xFF"
+  call check(s1, 4_" \xFF                  ")
+  call check2(s1, 4_" \xFF                  ")
+
+  s1 = "  \xFF"
+  s4 = s1
+  call check(s1, 4_"  \xFF                 ")
+  call check2(s1, 4_"  \xFF                 ")
+  s4 = "  \xFF"
+  call check(s1, 4_"  \xFF                 ")
+  call check2(s1, 4_"  \xFF                 ")
+
+contains
+  subroutine check(s1,s4)
+    character(kind=1,len=20) :: s1, t1
+    character(kind=4,len=20) :: s4
+    t1 = s4
+    if (t1 /= s1) call abort
+    if (len(s1) /= len(t1)) call abort
+    if (len(s1) /= len(s4)) call abort
+    if (len_trim(s1) /= len_trim(t1)) call abort
+    if (len_trim(s1) /= len_trim(s4)) call abort
+  end subroutine check
+
+  subroutine check2(s1,s4)
+    character(kind=1,len=*) :: s1
+    character(kind=4,len=*) :: s4
+    character(kind=1,len=len(s1)) :: t1
+    character(kind=4,len=len(s4)) :: t4
+
+    t1 = s4
+    t4 = s1
+    if (t1 /= s1) call abort
+    if (t4 /= s4) call abort
+    if (len(s1) /= len(t1)) call abort
+    if (len(s1) /= len(s4)) call abort
+    if (len(s1) /= len(t4)) call abort
+    if (len_trim(s1) /= len_trim(t1)) call abort
+    if (len_trim(s1) /= len_trim(s4)) call abort
+    if (len_trim(s1) /= len_trim(t4)) call abort
+  end subroutine check2
+
+end
diff --git a/gcc/testsuite/gfortran.dg/widechar_3.f90 b/gcc/testsuite/gfortran.dg/widechar_3.f90
new file mode 100644 (file)
index 0000000..653f1d9
--- /dev/null
@@ -0,0 +1,112 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000" }
+
+  character(kind=1,len=20) :: s1, t1
+  character(kind=4,len=20) :: s4, t4
+
+  print *, "" // ""
+  print *, "" // 4_"" ! { dg-error "Operands of string concatenation operator" }
+  print *, 4_"" // "" ! { dg-error "Operands of string concatenation operator" }
+  print *, 4_"" // 4_""
+
+  print *, s1 // ""
+  print *, s1 // 4_"" ! { dg-error "Operands of string concatenation operator" }
+  print *, s4 // "" ! { dg-error "Operands of string concatenation operator" }
+  print *, s4 // 4_""
+
+  print *, "" // s1
+  print *, 4_"" // s1 ! { dg-error "Operands of string concatenation operator" }
+  print *, "" // s4 ! { dg-error "Operands of string concatenation operator" }
+  print *, 4_"" // s4
+
+  print *, s1 // t1
+  print *, s1 // t4 ! { dg-error "Operands of string concatenation operator" }
+  print *, s4 // t1 ! { dg-error "Operands of string concatenation operator" }
+  print *, s4 // t4
+
+  print *, s1 .eq. ""
+  print *, s1 .eq. 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .eq. "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .eq. 4_""
+
+  print *, s1 == ""
+  print *, s1 == 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 == "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 == 4_""
+
+  print *, s1 .ne. ""
+  print *, s1 .ne. 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .ne. "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .ne. 4_""
+
+  print *, s1 /= ""
+  print *, s1 /= 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 /= "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 /= 4_""
+
+  print *, s1 .le. ""
+  print *, s1 .le. 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .le. "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .le. 4_""
+
+  print *, s1 <= ""
+  print *, s1 <= 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 <= "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 <= 4_""
+
+  print *, s1 .ge. ""
+  print *, s1 .ge. 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .ge. "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .ge. 4_""
+
+  print *, s1 >= ""
+  print *, s1 >= 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 >= "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 >= 4_""
+
+  print *, s1 .lt. ""
+  print *, s1 .lt. 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .lt. "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .lt. 4_""
+
+  print *, s1 < ""
+  print *, s1 < 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 < "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 < 4_""
+
+  print *, s1 .gt. ""
+  print *, s1 .gt. 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .gt. "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 .gt. 4_""
+
+  print *, s1 > ""
+  print *, s1 > 4_"" ! { dg-error "Operands of comparison operator" }
+  print *, s4 > "" ! { dg-error "Operands of comparison operator" }
+  print *, s4 > 4_""
+
+  print *, "" ==  ""
+  print *, 4_"" ==  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" .eq.  ""
+  print *, 4_"" .eq.  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" /=  ""
+  print *, 4_"" /=  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" .ne.  ""
+  print *, 4_"" .ne.  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" .lt.  ""
+  print *, 4_"" .lt.  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" <  ""
+  print *, 4_"" <  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" .le.  ""
+  print *, 4_"" .le.  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" <=  ""
+  print *, 4_"" <=  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" .gt.  ""
+  print *, 4_"" .gt.  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" >  ""
+  print *, 4_"" >  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" .ge.  ""
+  print *, 4_"" .ge.  "" ! { dg-error "Operands of comparison operator" }
+  print *, "" >=  ""
+  print *, 4_"" >=  "" ! { dg-error "Operands of comparison operator" }
+
+  end
diff --git a/gcc/testsuite/gfortran.dg/widechar_4.f90 b/gcc/testsuite/gfortran.dg/widechar_4.f90
new file mode 100644 (file)
index 0000000..1166f8b
--- /dev/null
@@ -0,0 +1,147 @@
+! { dg-do run }
+! { dg-options "-fbackslash" }
+
+  character(kind=1,len=20) :: s1, t1
+  character(kind=4,len=20) :: s4, t4
+
+  call test (4_"ccc  ", 4_"bbb", 4_"ccc", 4_"ddd")
+  call test (4_" \xACp  ", 4_" \x900000 ", 4_" \xACp  ", 4_"ddd")
+  call test (4_" \xACp  ", 4_" \x900000 ", 4_" \xACp  ", 4_"ddd")
+
+  call test2 (4_" \x900000 ", 4_" \xACp  ", 4_"ddd")
+
+contains
+
+  subroutine test(s4, t4, u4, v4)
+    character(kind=4,len=*) :: s4, t4, u4, v4
+
+    if (.not. (s4 >= t4)) call abort
+    if (.not. (s4 > t4)) call abort
+    if (.not. (s4 .ge. t4)) call abort
+    if (.not. (s4 .gt. t4)) call abort
+    if (      (s4 == t4)) call abort
+    if (.not. (s4 /= t4)) call abort
+    if (      (s4 .eq. t4)) call abort
+    if (.not. (s4 .ne. t4)) call abort
+    if (      (s4 <= t4)) call abort
+    if (      (s4 < t4)) call abort
+    if (      (s4 .le. t4)) call abort
+    if (      (s4 .lt. t4)) call abort
+
+    if (.not. (s4 >= u4)) call abort
+    if (      (s4 > u4)) call abort
+    if (.not. (s4 .ge. u4)) call abort
+    if (      (s4 .gt. u4)) call abort
+    if (.not. (s4 == u4)) call abort
+    if (      (s4 /= u4)) call abort
+    if (.not. (s4 .eq. u4)) call abort
+    if (      (s4 .ne. u4)) call abort
+    if (.not. (s4 <= u4)) call abort
+    if (      (s4 < u4)) call abort
+    if (.not. (s4 .le. u4)) call abort
+    if (      (s4 .lt. u4)) call abort
+
+    if (      (s4 >= v4)) call abort
+    if (      (s4 > v4)) call abort
+    if (      (s4 .ge. v4)) call abort
+    if (      (s4 .gt. v4)) call abort
+    if (      (s4 == v4)) call abort
+    if (.not. (s4 /= v4)) call abort
+    if (      (s4 .eq. v4)) call abort
+    if (.not. (s4 .ne. v4)) call abort
+    if (.not. (s4 <= v4)) call abort
+    if (.not. (s4 < v4)) call abort
+    if (.not. (s4 .le. v4)) call abort
+    if (.not. (s4 .lt. v4)) call abort
+
+  end subroutine test
+
+  subroutine test2(t4, u4, v4)
+    character(kind=4,len=*) :: t4, u4, v4
+
+    if (.not. (4_" \xACp  " >= t4)) call abort
+    if (.not. (4_" \xACp  " > t4)) call abort
+    if (.not. (4_" \xACp  " .ge. t4)) call abort
+    if (.not. (4_" \xACp  " .gt. t4)) call abort
+    if (      (4_" \xACp  " == t4)) call abort
+    if (.not. (4_" \xACp  " /= t4)) call abort
+    if (      (4_" \xACp  " .eq. t4)) call abort
+    if (.not. (4_" \xACp  " .ne. t4)) call abort
+    if (      (4_" \xACp  " <= t4)) call abort
+    if (      (4_" \xACp  " < t4)) call abort
+    if (      (4_" \xACp  " .le. t4)) call abort
+    if (      (4_" \xACp  " .lt. t4)) call abort
+
+    if (.not. (4_" \xACp  " >= u4)) call abort
+    if (      (4_" \xACp  " > u4)) call abort
+    if (.not. (4_" \xACp  " .ge. u4)) call abort
+    if (      (4_" \xACp  " .gt. u4)) call abort
+    if (.not. (4_" \xACp  " == u4)) call abort
+    if (      (4_" \xACp  " /= u4)) call abort
+    if (.not. (4_" \xACp  " .eq. u4)) call abort
+    if (      (4_" \xACp  " .ne. u4)) call abort
+    if (.not. (4_" \xACp  " <= u4)) call abort
+    if (      (4_" \xACp  " < u4)) call abort
+    if (.not. (4_" \xACp  " .le. u4)) call abort
+    if (      (4_" \xACp  " .lt. u4)) call abort
+
+    if (      (4_" \xACp  " >= v4)) call abort
+    if (      (4_" \xACp  " > v4)) call abort
+    if (      (4_" \xACp  " .ge. v4)) call abort
+    if (      (4_" \xACp  " .gt. v4)) call abort
+    if (      (4_" \xACp  " == v4)) call abort
+    if (.not. (4_" \xACp  " /= v4)) call abort
+    if (      (4_" \xACp  " .eq. v4)) call abort
+    if (.not. (4_" \xACp  " .ne. v4)) call abort
+    if (.not. (4_" \xACp  " <= v4)) call abort
+    if (.not. (4_" \xACp  " < v4)) call abort
+    if (.not. (4_" \xACp  " .le. v4)) call abort
+    if (.not. (4_" \xACp  " .lt. v4)) call abort
+
+  end subroutine test2
+
+  subroutine test3(t4, u4, v4)
+    character(kind=4,len=*) :: t4, u4, v4
+
+    if (.not. (4_" \xACp  " >= 4_" \x900000 ")) call abort
+    if (.not. (4_" \xACp  " > 4_" \x900000 ")) call abort
+    if (.not. (4_" \xACp  " .ge. 4_" \x900000 ")) call abort
+    if (.not. (4_" \xACp  " .gt. 4_" \x900000 ")) call abort
+    if (      (4_" \xACp  " == 4_" \x900000 ")) call abort
+    if (.not. (4_" \xACp  " /= 4_" \x900000 ")) call abort
+    if (      (4_" \xACp  " .eq. 4_" \x900000 ")) call abort
+    if (.not. (4_" \xACp  " .ne. 4_" \x900000 ")) call abort
+    if (      (4_" \xACp  " <= 4_" \x900000 ")) call abort
+    if (      (4_" \xACp  " < 4_" \x900000 ")) call abort
+    if (      (4_" \xACp  " .le. 4_" \x900000 ")) call abort
+    if (      (4_" \xACp  " .lt. 4_" \x900000 ")) call abort
+
+    if (.not. (4_" \xACp  " >= 4_" \xACp  ")) call abort
+    if (      (4_" \xACp  " > 4_" \xACp  ")) call abort
+    if (.not. (4_" \xACp  " .ge. 4_" \xACp  ")) call abort
+    if (      (4_" \xACp  " .gt. 4_" \xACp  ")) call abort
+    if (.not. (4_" \xACp  " == 4_" \xACp  ")) call abort
+    if (      (4_" \xACp  " /= 4_" \xACp  ")) call abort
+    if (.not. (4_" \xACp  " .eq. 4_" \xACp  ")) call abort
+    if (      (4_" \xACp  " .ne. 4_" \xACp  ")) call abort
+    if (.not. (4_" \xACp  " <= 4_" \xACp  ")) call abort
+    if (      (4_" \xACp  " < 4_" \xACp  ")) call abort
+    if (.not. (4_" \xACp  " .le. 4_" \xACp  ")) call abort
+    if (      (4_" \xACp  " .lt. 4_" \xACp  ")) call abort
+
+    if (      (4_" \xACp  " >= 4_"ddd")) call abort
+    if (      (4_" \xACp  " > 4_"ddd")) call abort
+    if (      (4_" \xACp  " .ge. 4_"ddd")) call abort
+    if (      (4_" \xACp  " .gt. 4_"ddd")) call abort
+    if (      (4_" \xACp  " == 4_"ddd")) call abort
+    if (.not. (4_" \xACp  " /= 4_"ddd")) call abort
+    if (      (4_" \xACp  " .eq. 4_"ddd")) call abort
+    if (.not. (4_" \xACp  " .ne. 4_"ddd")) call abort
+    if (.not. (4_" \xACp  " <= 4_"ddd")) call abort
+    if (.not. (4_" \xACp  " < 4_"ddd")) call abort
+    if (.not. (4_" \xACp  " .le. 4_"ddd")) call abort
+    if (.not. (4_" \xACp  " .lt. 4_"ddd")) call abort
+
+  end subroutine test3
+
+end
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90
new file mode 100644 (file)
index 0000000..cb98042
--- /dev/null
@@ -0,0 +1,116 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=100000" }
+
+  character(kind=1,len=20) :: s1, t1, u1, v1
+  character(kind=4,len=20) :: s4, t4, u4, v4
+
+  call date_and_time(date=s1)
+  call date_and_time(time=s1)
+  call date_and_time(zone=s1)
+  call date_and_time(s1, t1, u1)
+
+  call date_and_time(date=s4) ! { dg-error "must be of kind 1" }
+  call date_and_time(time=s4) ! { dg-error "must be of kind 1" }
+  call date_and_time(zone=s4) ! { dg-error "must be of kind 1" }
+  call date_and_time(s4, t4, u4) ! { dg-error "must be of kind 1" }
+
+  call get_command(s1)
+  call get_command(s4) ! { dg-error "Type of argument" }
+
+  call get_command_argument(1, s1)
+  call get_command_argument(1, s4) ! { dg-error "Type of argument" }
+
+  call get_environment_variable("PATH", s1)
+  call get_environment_variable(s1)
+  call get_environment_variable(s1, t1)
+  call get_environment_variable(4_"PATH", s1) ! { dg-error "Type of argument" }
+  call get_environment_variable(s4) ! { dg-error "Type of argument" }
+  call get_environment_variable(s1, t4) ! { dg-error "Type of argument" }
+  call get_environment_variable(s4, t1) ! { dg-error "Type of argument" }
+
+  print *, lge(s1,t1)
+  print *, lge(s1,"foo")
+  print *, lge("foo",t1)
+  print *, lge("bar","foo")
+
+  print *, lge(s1,t4) ! { dg-error "must be of kind 1" }
+  print *, lge(s1,4_"foo") ! { dg-error "must be of kind 1" }
+  print *, lge("foo",t4) ! { dg-error "must be of kind 1" }
+  print *, lge("bar",4_"foo") ! { dg-error "must be of kind 1" }
+
+  print *, lge(s4,t1) ! { dg-error "must be of kind 1" }
+  print *, lge(s4,"foo") ! { dg-error "must be of kind 1" }
+  print *, lge(4_"foo",t1) ! { dg-error "must be of kind 1" }
+  print *, lge(4_"bar","foo") ! { dg-error "must be of kind 1" }
+
+  print *, lge(s4,t4) ! { dg-error "must be of kind 1" }
+  print *, lge(s4,4_"foo") ! { dg-error "must be of kind 1" }
+  print *, lge(4_"foo",t4) ! { dg-error "must be of kind 1" }
+  print *, lge(4_"bar",4_"foo") ! { dg-error "must be of kind 1" }
+
+  print *, lgt(s1,t1)
+  print *, lgt(s1,"foo")
+  print *, lgt("foo",t1)
+  print *, lgt("bar","foo")
+
+  print *, lgt(s1,t4) ! { dg-error "must be of kind 1" }
+  print *, lgt(s1,4_"foo") ! { dg-error "must be of kind 1" }
+  print *, lgt("foo",t4) ! { dg-error "must be of kind 1" }
+  print *, lgt("bar",4_"foo") ! { dg-error "must be of kind 1" }
+
+  print *, lgt(s4,t1) ! { dg-error "must be of kind 1" }
+  print *, lgt(s4,"foo") ! { dg-error "must be of kind 1" }
+  print *, lgt(4_"foo",t1) ! { dg-error "must be of kind 1" }
+  print *, lgt(4_"bar","foo") ! { dg-error "must be of kind 1" }
+
+  print *, lgt(s4,t4) ! { dg-error "must be of kind 1" }
+  print *, lgt(s4,4_"foo") ! { dg-error "must be of kind 1" }
+  print *, lgt(4_"foo",t4) ! { dg-error "must be of kind 1" }
+  print *, lgt(4_"bar",4_"foo") ! { dg-error "must be of kind 1" }
+
+  print *, lle(s1,t1)
+  print *, lle(s1,"foo")
+  print *, lle("foo",t1)
+  print *, lle("bar","foo")
+
+  print *, lle(s1,t4) ! { dg-error "must be of kind 1" }
+  print *, lle(s1,4_"foo") ! { dg-error "must be of kind 1" }
+  print *, lle("foo",t4) ! { dg-error "must be of kind 1" }
+  print *, lle("bar",4_"foo") ! { dg-error "must be of kind 1" }
+
+  print *, lle(s4,t1) ! { dg-error "must be of kind 1" }
+  print *, lle(s4,"foo") ! { dg-error "must be of kind 1" }
+  print *, lle(4_"foo",t1) ! { dg-error "must be of kind 1" }
+  print *, lle(4_"bar","foo") ! { dg-error "must be of kind 1" }
+
+  print *, lle(s4,t4) ! { dg-error "must be of kind 1" }
+  print *, lle(s4,4_"foo") ! { dg-error "must be of kind 1" }
+  print *, lle(4_"foo",t4) ! { dg-error "must be of kind 1" }
+  print *, lle(4_"bar",4_"foo") ! { dg-error "must be of kind 1" }
+
+  print *, llt(s1,t1)
+  print *, llt(s1,"foo")
+  print *, llt("foo",t1)
+  print *, llt("bar","foo")
+
+  print *, llt(s1,t4) ! { dg-error "must be of kind 1" }
+  print *, llt(s1,4_"foo") ! { dg-error "must be of kind 1" }
+  print *, llt("foo",t4) ! { dg-error "must be of kind 1" }
+  print *, llt("bar",4_"foo") ! { dg-error "must be of kind 1" }
+
+  print *, llt(s4,t1) ! { dg-error "must be of kind 1" }
+  print *, llt(s4,"foo") ! { dg-error "must be of kind 1" }
+  print *, llt(4_"foo",t1) ! { dg-error "must be of kind 1" }
+  print *, llt(4_"bar","foo") ! { dg-error "must be of kind 1" }
+
+  print *, llt(s4,t4) ! { dg-error "must be of kind 1" }
+  print *, llt(s4,4_"foo") ! { dg-error "must be of kind 1" }
+  print *, llt(4_"foo",t4) ! { dg-error "must be of kind 1" }
+  print *, llt(4_"bar",4_"foo") ! { dg-error "must be of kind 1" }
+
+  print *, selected_char_kind("foo")
+  print *, selected_char_kind(4_"foo") ! { dg-error "must be of kind 1" }
+  print *, selected_char_kind(s1)
+  print *, selected_char_kind(s4) ! { dg-error "must be of kind 1" }
+
+  end
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90
new file mode 100644 (file)
index 0000000..0a1d449
--- /dev/null
@@ -0,0 +1,129 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000" }
+
+program failme
+
+  integer :: i, j, array(20)
+  integer(kind=4) :: i4
+  integer(kind=8) :: i8
+  character(kind=1,len=20) :: s1, t1
+  character(kind=4,len=20) :: s4, t4
+
+  call ctime (i8, s1)
+  call ctime (i8, s4) ! { dg-error "must be of kind" }
+
+  call chdir (s1)
+  call chdir (s1, i)
+  call chdir (s4) ! { dg-error "must be of kind" }
+  call chdir (s4, i) ! { dg-error "must be of kind" }
+
+  call chmod (s1, t1)
+  call chmod (s1, t4) ! { dg-error "must be of kind" }
+  call chmod (s4, t1) ! { dg-error "must be of kind" }
+  call chmod (s4, t4) ! { dg-error "must be of kind" }
+  call chmod (s1, t1, i)
+  call chmod (s1, t4, i) ! { dg-error "must be of kind" }
+  call chmod (s4, t1, i) ! { dg-error "must be of kind" }
+  call chmod (s4, t4, i) ! { dg-error "must be of kind" }
+
+  call fdate (s1)
+  call fdate (s4) ! { dg-error "must be of kind" }
+
+  call gerror (s1)
+  call gerror (s4) ! { dg-error "must be of kind" }
+
+  call getcwd (s1)
+  call getcwd (s1, i)
+  call getcwd (s4) ! { dg-error "must be of kind" }
+  call getcwd (s4, i) ! { dg-error "must be of kind" }
+
+  call getenv (s1, t1)
+  call getenv (s1, t4) ! { dg-error "Type of argument" }
+  call getenv (s4, t1) ! { dg-error "Type of argument" }
+  call getenv (s4, t4) ! { dg-error "Type of argument" }
+
+  call getarg (i, s1)
+  call getarg (i, s4) ! { dg-error "must be of kind" }
+
+  call getlog (s1)
+  call getlog (s4) ! { dg-error "must be of kind" }
+
+  call fgetc (j, s1)
+  call fgetc (j, s1, i)
+  call fgetc (j, s4) ! { dg-error "must be of kind" }
+  call fgetc (j, s4, i) ! { dg-error "must be of kind" }
+
+  call fget (s1)
+  call fget (s1, i)
+  call fget (s4) ! { dg-error "must be of kind" }
+  call fget (s4, i) ! { dg-error "must be of kind" }
+
+  call fputc (j, s1)
+  call fputc (j, s1, i)
+  call fputc (j, s4) ! { dg-error "must be of kind" }
+  call fputc (j, s4, i) ! { dg-error "must be of kind" }
+
+  call fput (s1)
+  call fput (s1, i)
+  call fput (s4) ! { dg-error "must be of kind" }
+  call fput (s4, i) ! { dg-error "must be of kind" }
+
+  call hostnm (s1)
+  call hostnm (s1, i)
+  call hostnm (s4) ! { dg-error "must be of kind" }
+  call hostnm (s4, i) ! { dg-error "must be of kind" }
+
+  call link (s1, t1)
+  call link (s1, t4) ! { dg-error "must be of kind" }
+  call link (s4, t1) ! { dg-error "must be of kind" }
+  call link (s4, t4) ! { dg-error "must be of kind" }
+  call link (s1, t1, i)
+  call link (s1, t4, i) ! { dg-error "must be of kind" }
+  call link (s4, t1, i) ! { dg-error "must be of kind" }
+  call link (s4, t4, i) ! { dg-error "must be of kind" }
+
+  call perror (s1)
+  call perror (s4) ! { dg-error "must be of kind" }
+
+  call rename (s1, t1)
+  call rename (s1, t4) ! { dg-error "must be of kind" }
+  call rename (s4, t1) ! { dg-error "must be of kind" }
+  call rename (s4, t4) ! { dg-error "must be of kind" }
+  call rename (s1, t1, i)
+  call rename (s1, t4, i) ! { dg-error "must be of kind" }
+  call rename (s4, t1, i) ! { dg-error "must be of kind" }
+  call rename (s4, t4, i) ! { dg-error "must be of kind" }
+
+  call lstat (s1, array)
+  call lstat (s1, array, i)
+  call lstat (s4, array) ! { dg-error "must be of kind" }
+  call lstat (s4, array, i) ! { dg-error "must be of kind" }
+
+  call stat (s1, array)
+  call stat (s1, array, i)
+  call stat (s4, array) ! { dg-error "must be of kind" }
+  call stat (s4, array, i) ! { dg-error "must be of kind" }
+
+  call symlnk (s1, t1)
+  call symlnk (s1, t4) ! { dg-error "must be of kind" }
+  call symlnk (s4, t1) ! { dg-error "must be of kind" }
+  call symlnk (s4, t4) ! { dg-error "must be of kind" }
+  call symlnk (s1, t1, i)
+  call symlnk (s1, t4, i) ! { dg-error "must be of kind" }
+  call symlnk (s4, t1, i) ! { dg-error "must be of kind" }
+  call symlnk (s4, t4, i) ! { dg-error "must be of kind" }
+
+  call system (s1)
+  call system (s1, i)
+  call system (s4) ! { dg-error "Type of argument" }
+  call system (s4, i) ! { dg-error "Type of argument" }
+
+  call ttynam (i, s1)
+  call ttynam (i, s4) ! { dg-error "must be of kind" }
+
+  call unlink (s1)
+  call unlink (s1, i)
+  call unlink (s4) ! { dg-error "must be of kind" }
+  call unlink (s4, i) ! { dg-error "must be of kind" }
+
+end program failme
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90
new file mode 100644 (file)
index 0000000..7073b89
--- /dev/null
@@ -0,0 +1,69 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000" }
+
+program failme
+
+  integer :: i, array(20)
+  integer(kind=4) :: i4
+  integer(kind=8) :: i8
+  character(kind=1,len=20) :: s1, t1
+  character(kind=4,len=20) :: s4, t4
+
+  print *, access (s1, t1)
+  print *, access (s1, t4) ! { dg-error "must be of kind" }
+  print *, access (s4, t1) ! { dg-error "must be of kind" }
+  print *, access (s4, t4) ! { dg-error "must be of kind" }
+
+  print *, chdir (s1)
+  print *, chdir (s4) ! { dg-error "must be of kind" }
+
+  print *, chmod (s1, t1)
+  print *, chmod (s1, t4) ! { dg-error "must be of kind" }
+  print *, chmod (s4, t1) ! { dg-error "must be of kind" }
+  print *, chmod (s4, t4) ! { dg-error "must be of kind" }
+
+  print *, fget (s1)
+  print *, fget (s4) ! { dg-error "must be of kind" }
+
+  print *, fgetc (i, s1)
+  print *, fgetc (i, s4) ! { dg-error "must be of kind" }
+
+  print *, fput (s1)
+  print *, fput (s4) ! { dg-error "must be of kind" }
+
+  print *, fputc (i, s1)
+  print *, fputc (i, s4) ! { dg-error "must be of kind" }
+
+  print *, getcwd (s1)
+  print *, getcwd (s4) ! { dg-error "Type of argument" }
+
+  print *, hostnm (s1)
+  print *, hostnm (s4) ! { dg-error "must be of kind" }
+
+  print *, link (s1, t1)
+  print *, link (s1, t4) ! { dg-error "must be of kind" }
+  print *, link (s4, t1) ! { dg-error "must be of kind" }
+  print *, link (s4, t4) ! { dg-error "must be of kind" }
+
+  print *, lstat (s1, array)
+  print *, lstat (s4, array) ! { dg-error "must be of kind" }
+  print *, stat (s1, array)
+  print *, stat (s4, array) ! { dg-error "must be of kind" }
+
+  print *, rename (s1, t1)
+  print *, rename (s1, t4) ! { dg-error "must be of kind" }
+  print *, rename (s4, t1) ! { dg-error "must be of kind" }
+  print *, rename (s4, t4) ! { dg-error "must be of kind" }
+
+  print *, symlnk (s1, t1)
+  print *, symlnk (s1, t4) ! { dg-error "must be of kind" }
+  print *, symlnk (s4, t1) ! { dg-error "must be of kind" }
+  print *, symlnk (s4, t4) ! { dg-error "must be of kind" }
+
+  print *, system (s1)
+  print *, system (s4) ! { dg-error "Type of argument" }
+
+  print *, unlink (s1)
+  print *, unlink (s4) ! { dg-error "must be of kind" }
+
+end program failme
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90
new file mode 100644 (file)
index 0000000..c9f8e8c
--- /dev/null
@@ -0,0 +1,121 @@
+! { dg-do run }
+! { dg-options "-fbackslash" }
+
+  character(kind=1,len=20) :: s1
+  character(kind=4,len=20) :: s4
+
+  call test_adjust1 ("  foo bar ", 4_"  foo bar ")
+  s1 = "  foo bar " ; s4 = 4_"  foo bar "
+  call test_adjust2 (s1, s4)
+
+  call test_adjust1 ("  foo bar \xFF", 4_"  foo bar \xFF")
+  s1 = "  foo bar \xFF" ; s4 = 4_"  foo bar \xFF"
+  call test_adjust2 (s1, s4)
+
+  call test_adjust1 ("\0  foo bar \xFF", 4_"\0  foo bar \xFF")
+  s1 = "\0  foo bar \xFF" ; s4 = 4_"\0  foo bar \xFF"
+  call test_adjust2 (s1, s4)
+
+  s4 = "\0  foo bar \xFF"
+  if (adjustl (s4) /= adjustl (4_"\0  foo bar \xFF        ")) call abort
+  if (adjustr (s4) /= adjustr (4_"\0  foo bar \xFF        ")) call abort
+
+  s4 = "   \0  foo bar \xFF"
+  if (adjustl (s4) /= adjustl (4_"   \0  foo bar \xFF     ")) call abort
+  if (adjustr (s4) /= adjustr (4_"   \0  foo bar \xFF     ")) call abort
+
+  s4 = 4_" \U12345678\xeD bar \ufd30"
+  if (adjustl (s4) /= &
+      adjustl (4_" \U12345678\xeD bar \ufd30           ")) call abort
+  if (adjustr (s4) /= &
+      adjustr (4_" \U12345678\xeD bar \ufd30           ")) call abort
+
+contains
+
+  subroutine test_adjust1 (s1, s4)
+
+    character(kind=1,len=*) :: s1
+    character(kind=4,len=*) :: s4
+
+    character(kind=1,len=len(s4)) :: t1
+    character(kind=4,len=len(s1)) :: t4
+
+    if (len(s1) /= len(s4)) call abort
+    if (len(t1) /= len(t4)) call abort
+
+    if (len_trim(s1) /= len_trim (s4)) call abort
+
+    t1 = adjustl (s4)
+    t4 = adjustl (s1)
+    if (t1 /= adjustl (s1)) call abort
+    if (t4 /= adjustl (s4)) call abort
+    if (len_trim (t1) /= len_trim (t4)) call abort
+    if (len_trim (adjustl (s1)) /= len_trim (t4)) call abort
+    if (len_trim (adjustl (s4)) /= len_trim (t1)) call abort
+
+    if (len_trim (t1) /= len (trim (t1))) call abort
+    if (len_trim (s1) /= len (trim (s1))) call abort
+    if (len_trim (t4) /= len (trim (t4))) call abort
+    if (len_trim (s4) /= len (trim (s4))) call abort
+
+    t1 = adjustr (s4)
+    t4 = adjustr (s1)
+    if (t1 /= adjustr (s1)) call abort
+    if (t4 /= adjustr (s4)) call abort
+    if (len_trim (t1) /= len_trim (t4)) call abort
+    if (len_trim (adjustr (s1)) /= len_trim (t4)) call abort
+    if (len_trim (adjustr (s4)) /= len_trim (t1)) call abort
+    if (len (t1) /= len_trim (t1)) call abort
+    if (len (t4) /= len_trim (t4)) call abort
+
+    if (len_trim (t1) /= len (trim (t1))) call abort
+    if (len_trim (s1) /= len (trim (s1))) call abort
+    if (len_trim (t4) /= len (trim (t4))) call abort
+    if (len_trim (s4) /= len (trim (s4))) call abort
+
+  end subroutine test_adjust1
+
+  subroutine test_adjust2 (s1, s4)
+
+    character(kind=1,len=20) :: s1
+    character(kind=4,len=20) :: s4
+
+    character(kind=1,len=len(s4)) :: t1
+    character(kind=4,len=len(s1)) :: t4
+
+    if (len(s1) /= len(s4)) call abort
+    if (len(t1) /= len(t4)) call abort
+
+    if (len_trim(s1) /= len_trim (s4)) call abort
+
+    t1 = adjustl (s4)
+    t4 = adjustl (s1)
+    if (t1 /= adjustl (s1)) call abort
+    if (t4 /= adjustl (s4)) call abort
+    if (len_trim (t1) /= len_trim (t4)) call abort
+    if (len_trim (adjustl (s1)) /= len_trim (t4)) call abort
+    if (len_trim (adjustl (s4)) /= len_trim (t1)) call abort
+
+    if (len_trim (t1) /= len (trim (t1))) call abort
+    if (len_trim (s1) /= len (trim (s1))) call abort
+    if (len_trim (t4) /= len (trim (t4))) call abort
+    if (len_trim (s4) /= len (trim (s4))) call abort
+
+    t1 = adjustr (s4)
+    t4 = adjustr (s1)
+    if (t1 /= adjustr (s1)) call abort
+    if (t4 /= adjustr (s4)) call abort
+    if (len_trim (t1) /= len_trim (t4)) call abort
+    if (len_trim (adjustr (s1)) /= len_trim (t4)) call abort
+    if (len_trim (adjustr (s4)) /= len_trim (t1)) call abort
+    if (len (t1) /= len_trim (t1)) call abort
+    if (len (t4) /= len_trim (t4)) call abort
+
+    if (len_trim (t1) /= len (trim (t1))) call abort
+    if (len_trim (s1) /= len (trim (s1))) call abort
+    if (len_trim (t4) /= len (trim (t4))) call abort
+    if (len_trim (s4) /= len (trim (s4))) call abort
+
+  end subroutine test_adjust2
+
+end
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90
new file mode 100644 (file)
index 0000000..8475a67
--- /dev/null
@@ -0,0 +1,120 @@
+  implicit none
+  integer :: i, j
+  character(kind=4,len=5), dimension(3,3), parameter :: &
+    p = reshape([4_" \xFF   ", 4_"\0    ", 4_" foo ", &
+                 4_"\u1230\uD67Bde\U31DC8B30", 4_"", 4_"fa fe", &
+                 4_"", 4_"foo  ", 4_"nul\0l"], [3,3])
+       
+  character(kind=4,len=5), dimension(3,3) :: m1
+  character(kind=4,len=5), allocatable, dimension(:,:) :: m2
+
+  if (kind (p) /= 4) call abort
+  if (kind (m1) /= 4) call abort
+  if (kind (m2) /= 4) call abort
+
+  m1 = reshape (p, [3,3])
+
+  allocate (m2(3,3))
+  m2(:,:) = reshape (m1, [3,3])
+
+  if (any (m1 /= p)) call abort
+  if (any (m2 /= p)) call abort
+
+  if (size (p) /= 9) call abort
+  if (size (m1) /= 9) call abort
+  if (size (m2) /= 9) call abort
+  if (size (p,1) /= 3) call abort
+  if (size (m1,1) /= 3) call abort
+  if (size (m2,1) /= 3) call abort
+  if (size (p,2) /= 3) call abort
+  if (size (m1,2) /= 3) call abort
+  if (size (m2,2) /= 3) call abort
+
+  call check_shape (p, (/3,3/), 5)
+  call check_shape (p, shape(p), 5)
+  call check_shape (m1, (/3,3/), 5)
+  call check_shape (m1, shape(m1), 5)
+  call check_shape (m1, (/3,3/), 5)
+  call check_shape (m1, shape(m1), 5)
+
+  deallocate (m2)
+
+
+  allocate (m2(3,4))
+  m2 = reshape (m1, [3,4], p)
+  if (any (m2(1:3,1:3) /= p)) call abort
+  if (any (m2(1:3,4) /= m1(1:3,1))) call abort
+  call check_shape (m2, (/3,4/), 5)
+  deallocate (m2)
+
+  allocate (m2(3,3))
+  do i = 1, 3
+    do j = 1, 3
+      m2(i,j) = m1(i,j)
+    end do
+  end do
+
+  m2 = transpose(m2)
+  if (any(transpose(p) /= m2)) call abort
+  if (any(transpose(m1) /= m2)) call abort
+  if (any(transpose(m2) /= p)) call abort
+  if (any(transpose(m2) /= m1)) call abort
+
+  m1 = transpose(p)
+  if (any(transpose(p) /= m2)) call abort
+  if (any(m1 /= m2)) call abort
+  if (any(transpose(m2) /= p)) call abort
+  if (any(transpose(m2) /= transpose(m1))) call abort
+  deallocate (m2)
+
+  ! Tests below should be uncommented when PR36257 is fixed.
+  !
+  !allocate (m2(3,3))
+  !m2 = p
+  !m1 = m2
+  !if (any (spread ( p, 1, 2) /= spread (m1, 1, 2))) call abort
+  !if (any (spread ( p, 1, 2) /= spread (m2, 1, 2))) call abort
+  !if (any (spread (m1, 1, 2) /= spread (m2, 1, 2))) call abort
+  !deallocate (m2)
+
+  allocate (m2(3,3))
+  m2 = p
+  m1 = m2
+  if (any (pack (p, p /= 4_"") /= [4_" \xFF   ", 4_"\0    ", 4_" foo ", &
+                                   4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", &
+                                   4_"foo  ", 4_"nul\0l"])) call abort
+  if (any (len_trim (pack (p, p /= 4_"")) /= [2,1,4,5,5,3,5])) call abort
+  if (any (pack (m1, m1 /= 4_"") /= [4_" \xFF   ", 4_"\0    ", 4_" foo ", &
+                                   4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", &
+                                   4_"foo  ", 4_"nul\0l"])) call abort
+  if (any (len_trim (pack (m1, m1 /= 4_"")) /= [2,1,4,5,5,3,5])) call abort
+  if (any (pack (m2, m2 /= 4_"") /= [4_" \xFF   ", 4_"\0    ", 4_" foo ", &
+                                   4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", &
+                                   4_"foo  ", 4_"nul\0l"])) call abort
+  if (any (len_trim (pack (m2, m2 /= 4_"")) /= [2,1,4,5,5,3,5])) call abort
+  deallocate (m2)
+
+  allocate (m2(1,7))
+  m2 = reshape ([4_" \xFF   ", 4_"\0    ", 4_" foo ", &
+                 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", &
+                 4_"foo  ", 4_"nul\0l"], [1,7])
+  m1 = p
+  if (any (unpack(m2(1,:), p /= 4_"", 4_"     ") /= p)) call abort
+  if (any (unpack(m2(1,:), m1 /= 4_"", 4_"     ") /= m1)) call abort
+  deallocate (m2)
+
+contains
+
+  subroutine check_shape (array, res, l)
+    character(kind=4,len=*), dimension(:,:) :: array
+    integer, dimension(:) :: res
+    integer :: l
+
+    if (kind (array) /= 4) call abort
+    if (len(array) /= l) call abort
+
+    if (size (res) /= size (shape (array))) call abort
+    if (any (shape (array) /= res)) call abort
+  end subroutine check_shape
+
+end
diff --git a/gcc/testsuite/gfortran.dg/widechar_select_1.f90 b/gcc/testsuite/gfortran.dg/widechar_select_1.f90
new file mode 100644 (file)
index 0000000..64315af
--- /dev/null
@@ -0,0 +1,55 @@
+! { dg-do run }
+! { dg-options "-fbackslash" }
+
+  call testme(test("foo"), test4(4_"foo"), 1)
+  call testme(test(""), test4(4_""), 1)
+  call testme(test("gee"), test4(4_"gee"), 4)
+  call testme(test("bar"), test4(4_"bar"), 1)
+  call testme(test("magi"), test4(4_"magi"), 4)
+  call testme(test("magic"), test4(4_"magic"), 2)
+  call testme(test("magic   "), test4(4_"magic   "), 2)
+  call testme(test("magica"), test4(4_"magica"), 4)
+  call testme(test("freeze"), test4(4_"freeze"), 3)
+  call testme(test("freeze "), test4(4_"freeze "), 3)
+  call testme(test("frugal"), test4(4_"frugal"), 3)
+  call testme(test("frugal "), test4(4_"frugal "), 3)
+  call testme(test("frugal \x01"), test4(4_"frugal \x01"), 3)
+  call testme(test("frugal \xFF"), test4(4_"frugal \xFF"), 4)
+
+contains
+  integer function test(s)
+    character(len=*) :: s
+  
+    select case (s)
+      case ("":"foo")
+        test = 1
+      case ("magic")
+        test = 2
+      case ("freeze":"frugal")
+        test = 3
+      case default
+        test = 4
+    end select
+  end function test
+
+  integer function test4(s)
+    character(kind=4,len=*) :: s
+  
+    select case (s)
+      case (4_"":4_"foo")
+        test4 = 1
+      case (4_"magic")
+        test4 = 2
+      case (4_"freeze":4_"frugal")
+        test4 = 3
+      case default
+        test4 = 4
+    end select
+  end function test4
+
+  subroutine testme(x,y,z)
+    integer :: x, y, z
+    if (x /= y) call abort
+    if (x /= z) call abort
+  end subroutine testme
+end
diff --git a/gcc/testsuite/gfortran.dg/widechar_select_2.f90 b/gcc/testsuite/gfortran.dg/widechar_select_2.f90
new file mode 100644 (file)
index 0000000..2eea9ae
--- /dev/null
@@ -0,0 +1,37 @@
+! { dg-do compile }
+
+  character(kind=1,len=20) :: s1
+  character(kind=4,len=20) :: s4
+
+  select case (s1)
+    case ("":4_"foo") ! { dg-error "must be of kind" }
+      test = 1
+    case (4_"gee") ! { dg-error "must be of kind" }
+      test = 1
+    case ("bar")
+      test = 1
+    case default
+      test = 4
+  end select
+
+  select case (s4)
+    case ("":4_"foo") ! { dg-error "must be of kind" }
+      test = 1
+    case (4_"gee")
+      test = 1
+    case ("bar") ! { dg-error "must be of kind" }
+      test = 1
+    case default
+      test = 4
+  end select
+
+  select case (s4)
+    case (4_"foo":4_"bar")
+      test = 1
+    case (4_"foo":4_"gee") ! { dg-error "overlaps with CASE label" }
+      test = 1
+    case (4_"foo") ! { dg-error "overlaps with CASE label" }
+      test = 1
+  end select
+
+end