diff options
| author | Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2008-05-18 22:45:05 +0000 |
|---|---|---|
| committer | François-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2008-05-18 22:45:05 +0000 |
| commit | d393bbd73754dfe54fac24d350c789316f17428f (patch) | |
| tree | 8a592f8dffb59a80d1cbd5fbc829a670104539c2 /gcc | |
| parent | 45a7844faf66271c1b2491d2931aa761c80c2f90 (diff) | |
| download | gcc-d393bbd73754dfe54fac24d350c789316f17428f.zip gcc-d393bbd73754dfe54fac24d350c789316f17428f.tar.gz gcc-d393bbd73754dfe54fac24d350c789316f17428f.tar.bz2 | |
intrinsic.c (char_conversions, ncharconv): New static variables.
* intrinsic.c (char_conversions, ncharconv): New static variables.
(find_char_conv): New function.
(add_functions): Add simplification functions for ADJUSTL and
ADJUSTR. Don't check the kind of their argument. Add checking for
LGE, LLE, LGT and LLT.
(add_subroutines): Fix argument type for SLEEP. Fix argument name
for SYSTEM.
(add_char_conversions): New function.
(gfc_intrinsic_init_1): Call add_char_conversions.
(gfc_intrinsic_done_1): Free char_conversions.
(check_arglist): Use kind == 0 as a signal that we don't want
the kind value to be checked.
(do_simplify): Also simplify character functions.
(gfc_convert_chartype): New function
* trans-array.c (gfc_trans_array_ctor_element): Don't force the
use of default character type.
(gfc_trans_array_constructor_value): Likewise.
(get_array_ctor_var_strlen): Use integer kind to build an integer
instead of a character kind!
(gfc_build_constant_array_constructor): Don't force the use of
default character type.
(gfc_conv_loop_setup): Likewise.
* trans-expr.c (gfc_conv_string_tmp): Don't force the use of
default character type. Allocate enough memory for wide strings.
(gfc_conv_concat_op): Make sure operand kind are the same.
(string_to_single_character): Remove gfc_ prefix. Reindent.
Don't force the use of default character type.
(gfc_conv_scalar_char_value): Likewise.
(gfc_build_compare_string): Call string_to_single_character.
(fill_with_spaces): New function
(gfc_trans_string_copy): Add kind arguments. Use them to deal
with wide character kinds.
(gfc_conv_statement_function): Whitespace fix. Call
gfc_trans_string_copy with new kind arguments.
(gfc_conv_substring_expr): Call gfc_build_wide_string_const
instead of using gfc_widechar_to_char.
(gfc_conv_string_parameter): Don't force the use of default
character type.
(gfc_trans_scalar_assign): Pass kind args to gfc_trans_string_copy.
* intrinsic.h (gfc_check_lge_lgt_lle_llt, gfc_convert_char_constant,
gfc_resolve_adjustl, gfc_resolve_adjustr): New prototypes.
* decl.c (gfc_set_constant_character_len): Don't assert the
existence of a single character kind.
* trans-array.h (gfc_trans_string_copy): New prototype.
* gfortran.h (gfc_check_character_range, gfc_convert_chartype):
New prototypes.
* error.c (print_wide_char_into_buffer): New function lifting
code from gfc_print_wide_char. Fix order to output '\x??' instead
of 'x\??'.
(gfc_print_wide_char): Call print_wide_char_into_buffer.
(show_locus): Call print_wide_char_into_buffer with buffer local
to this function.
* trans-const.c (gfc_build_wide_string_const): New function.
(gfc_conv_string_init): Deal with wide characters strings
constructors.
(gfc_conv_constant_to_tree): Call gfc_build_wide_string_const.
* trans-stmt.c (gfc_trans_label_assign): Likewise.
(gfc_trans_character_select): Deal with wide strings.
* expr.c (gfc_check_assign): Allow conversion between character
kinds on assignment.
* trans-const.h (gfc_build_wide_string_const): New prototype.
* trans-types.c (gfc_get_character_type_len_for_eltype,
gfc_get_character_type_len): Create too variants of the old
gfc_get_character_type_len, one getting kind argument and the
other one directly taking a type tree.
* trans.h (gfor_fndecl_select_string_char4,
gfor_fndecl_convert_char1_to_char4,
gfor_fndecl_convert_char4_to_char1): New prototypes.
* trans-types.h (gfc_get_character_type_len_for_eltype): New
prototype.
* resolve.c (resolve_operator): Exit early when kind mismatches
are detected, because that makes us issue an error message later.
(validate_case_label_expr): Fix wording of error message.
* iresolve.c (gfc_resolve_adjustl, gfc_resolve_adjustr): New
functions.
(gfc_resolve_pack): Call _char4 variants of library function
when dealing with wide characters.
(gfc_resolve_reshape): Likewise.
(gfc_resolve_spread): Likewise.
(gfc_resolve_transpose): Likewise.
(gfc_resolve_unpack): Likewise.
* target-memory.c (size_character): Take character kind bit size
correctly into account (not that it changes anything for now, but
it's more generic).
(gfc_encode_character): Added gfc_ prefix. Encoding each
character of a string by calling native_encode_expr for the
corresponding unsigned integer.
(gfc_target_encode_expr): Add gfc_ prefix to encode_character.
* trans-decl.c (gfc_build_intrinsic_function_decls): Build
gfor_fndecl_select_string_char4, gfor_fndecl_convert_char1_to_char4
and gfor_fndecl_convert_char4_to_char1.
* target-memory.h (gfc_encode_character): New prototype.
* arith.c (gfc_check_character_range): New function.
(eval_intrinsic): Allow non-default character kinds.
* check.c (gfc_check_access_func): Only allow default
character kind arguments.
(gfc_check_chdir): Likewise.
(gfc_check_chdir_sub): Likewise.
(gfc_check_chmod): Likewise.
(gfc_check_chmod_sub): Likewise.
(gfc_check_lge_lgt_lle_llt): New function.
(gfc_check_link): Likewise.
(gfc_check_link_sub): Likewise.
(gfc_check_symlnk): Likewise.
(gfc_check_symlnk_sub): Likewise.
(gfc_check_rename): Likewise.
(gfc_check_rename_sub): Likewise.
(gfc_check_fgetputc_sub): Likewise.
(gfc_check_fgetput_sub): Likewise.
(gfc_check_stat): Likewise.
(gfc_check_stat_sub): Likewise.
(gfc_check_date_and_time): Likewise.
(gfc_check_ctime_sub): Likewise.
(gfc_check_fdate_sub): Likewise.
(gfc_check_gerror): Likewise.
(gfc_check_getcwd_sub): Likewise.
(gfc_check_getarg): Likewise.
(gfc_check_getlog): Likewise.
(gfc_check_hostnm): Likewise.
(gfc_check_hostnm_sub): Likewise.
(gfc_check_ttynam_sub): Likewise.
(gfc_check_perror): Likewise.
(gfc_check_unlink): Likewise.
(gfc_check_unlink_sub): Likewise.
(gfc_check_system_sub): Likewise.
* primary.c (got_delim): Perform correct character range checking
for all kinds.
* trans-intrinsic.c (gfc_conv_intrinsic_conversion): Generate
calls to library functions convert_char4_to_char1 and
convert_char1_to_char4 for character conversions.
(gfc_conv_intrinsic_char): Allow all character kings.
(gfc_conv_intrinsic_strcmp): Fix whitespace.
(gfc_conv_intrinsic_repeat): Take care of all character kinds.
* intrinsic.texi: For all GNU intrinsics accepting character
arguments, mention that they're restricted to the default kind.
* simplify.c (simplify_achar_char): New function.
(gfc_simplify_achar, gfc_simplify_char): Call simplify_achar_char.
gfc_simplify_ichar): Don't error out for wide characters.
(gfc_convert_char_constant): New function.
* gfortran.dg/achar_3.f90: Adjust error messages.
* gfortran.dg/achar_5.f90: New test.
* gfortran.dg/achar_6.F90: New test.
* gfortran.dg/widechar_1.f90: New test.
* gfortran.dg/widechar_2.f90: New test.
* gfortran.dg/widechar_3.f90: New test.
* gfortran.dg/widechar_4.f90: New test.
* gfortran.dg/widechar_intrinsics_1.f90: New test.
* gfortran.dg/widechar_intrinsics_2.f90: New test.
* gfortran.dg/widechar_intrinsics_3.f90: New test.
* gfortran.dg/widechar_intrinsics_4.f90: New test.
* gfortran.dg/widechar_intrinsics_5.f90: New test.
* gfortran.dg/widechar_select_1.f90: New test.
* gfortran.dg/widechar_select_2.f90: New test.
From-SVN: r135515
Diffstat (limited to 'gcc')
42 files changed, 2219 insertions, 321 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 35c564c..ffbc9c5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index cbfcf29..6e09f8a 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -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; diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index f0497a1..87d962e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 5a1ce03..79044eb 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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) diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index a9cbe9e..c34899f 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -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'); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index e6c1e4e..a872743 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5fa3bc1..e3a9446 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 6def478..e902f69 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -39,9 +39,10 @@ const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; locus *gfc_current_intrinsic_where; static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; +static gfc_intrinsic_sym *char_conversions; static gfc_intrinsic_arg *next_arg; -static int nfunc, nsub, nargs, nconv; +static int nfunc, nsub, nargs, nconv, ncharconv; static enum { SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS } @@ -148,6 +149,28 @@ find_conv (gfc_typespec *from, gfc_typespec *to) } +/* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node + that corresponds to the conversion. Returns NULL if the conversion + isn't found. */ + +static gfc_intrinsic_sym * +find_char_conv (gfc_typespec *from, gfc_typespec *to) +{ + gfc_intrinsic_sym *sym; + const char *target; + int i; + + target = conv_name (from, to); + sym = char_conversions; + + for (i = 0; i < ncharconv; i++, sym++) + if (target == sym->name) + return sym; + + return NULL; +} + + /* Interface to the check functions. We break apart an argument list and call the proper check function rather than forcing each function to manipulate the argument list. */ @@ -974,15 +997,15 @@ add_functions (void) make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008); - add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, - NULL, gfc_simplify_adjustl, NULL, - stg, BT_CHARACTER, dc, REQUIRED); + add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl, + gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED); make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95); - add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, - NULL, gfc_simplify_adjustr, NULL, - stg, BT_CHARACTER, dc, REQUIRED); + add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr, + gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED); make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95); @@ -1760,26 +1783,26 @@ add_functions (void) make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008); - add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77, - NULL, gfc_simplify_lge, NULL, + add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL, sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77); - add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77, - NULL, gfc_simplify_lgt, NULL, + add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL, sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77); - add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77, - NULL, gfc_simplify_lle, NULL, + add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL, sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77); - add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77, - NULL, gfc_simplify_llt, NULL, + add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL, sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77); @@ -2625,7 +2648,7 @@ add_subroutines (void) add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub, - val, BT_CHARACTER, dc, REQUIRED); + val, BT_INTEGER, di, REQUIRED); add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub, @@ -2654,7 +2677,7 @@ add_subroutines (void) add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub, - c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_system_clock, NULL, gfc_resolve_system_clock, @@ -2817,6 +2840,52 @@ add_conversions (void) } +static void +add_char_conversions (void) +{ + int n, i, j; + + /* Count possible conversions. */ + for (i = 0; gfc_character_kinds[i].kind != 0; i++) + for (j = 0; gfc_character_kinds[j].kind != 0; j++) + if (i != j) + ncharconv++; + + /* Allocate memory. */ + char_conversions = gfc_getmem (sizeof (gfc_intrinsic_sym) * ncharconv); + + /* Add the conversions themselves. */ + n = 0; + for (i = 0; gfc_character_kinds[i].kind != 0; i++) + for (j = 0; gfc_character_kinds[j].kind != 0; j++) + { + gfc_typespec from, to; + + if (i == j) + continue; + + gfc_clear_ts (&from); + from.type = BT_CHARACTER; + from.kind = gfc_character_kinds[i].kind; + + gfc_clear_ts (&to); + to.type = BT_CHARACTER; + to.kind = gfc_character_kinds[j].kind; + + char_conversions[n].name = conv_name (&from, &to); + char_conversions[n].lib_name = char_conversions[n].name; + char_conversions[n].simplify.cc = gfc_convert_char_constant; + char_conversions[n].standard = GFC_STD_F2003; + char_conversions[n].elemental = 1; + char_conversions[n].conversion = 0; + char_conversions[n].ts = to; + char_conversions[n].id = GFC_ISYM_CONVERSION; + + n++; + } +} + + /* Initialize the table of intrinsics. */ void gfc_intrinsic_init_1 (void) @@ -2852,6 +2921,9 @@ gfc_intrinsic_init_1 (void) add_subroutines (); add_conversions (); + /* Character conversion intrinsics need to be treated separately. */ + add_char_conversions (); + /* Set the pure flag. All intrinsic functions are pure, and intrinsic subroutines are pure if they are elemental. */ @@ -2868,6 +2940,7 @@ gfc_intrinsic_done_1 (void) { gfc_free (functions); gfc_free (conversion); + gfc_free (char_conversions); gfc_free_namespace (gfc_intrinsic_namespace); } @@ -3052,10 +3125,18 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, i = 0; for (; formal; formal = formal->next, actual = actual->next, i++) { + gfc_typespec ts; + if (actual->expr == NULL) continue; - if (!gfc_compare_types (&formal->ts, &actual->expr->ts)) + ts = formal->ts; + + /* A kind of 0 means we don't check for kind. */ + if (ts.kind == 0) + ts.kind = actual->expr->ts.kind; + + if (!gfc_compare_types (&ts, &actual->expr->ts)) { if (error_flag) gfc_error ("Type of argument '%s' in call to '%s' at %L should " @@ -3199,9 +3280,10 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) a1 = arg->expr; arg = arg->next; - if (specific->simplify.cc == gfc_convert_constant) + if (specific->simplify.cc == gfc_convert_constant + || specific->simplify.cc == gfc_convert_char_constant) { - result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind); + result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind); goto finish; } @@ -3687,3 +3769,60 @@ bad: &expr->where); /* Not reached */ } + + +try +gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) +{ + gfc_intrinsic_sym *sym; + gfc_typespec from_ts; + locus old_where; + gfc_expr *new; + int rank; + mpz_t *shape; + + gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER); + from_ts = expr->ts; /* expr->ts gets clobbered */ + + sym = find_char_conv (&expr->ts, ts); + gcc_assert (sym); + + /* Insert a pre-resolved function call to the right function. */ + old_where = expr->where; + rank = expr->rank; + shape = expr->shape; + + new = gfc_get_expr (); + *new = *expr; + + new = gfc_build_conversion (new); + new->value.function.name = sym->lib_name; + new->value.function.isym = sym; + new->where = old_where; + new->rank = rank; + new->shape = gfc_copy_shape (shape, rank); + + gfc_get_ha_sym_tree (sym->name, &new->symtree); + new->symtree->n.sym->ts = *ts; + new->symtree->n.sym->attr.flavor = FL_PROCEDURE; + new->symtree->n.sym->attr.function = 1; + new->symtree->n.sym->attr.elemental = 1; + new->symtree->n.sym->attr.pure = 1; + new->symtree->n.sym->attr.referenced = 1; + gfc_intrinsic_symbol(new->symtree->n.sym); + gfc_commit_symbol (new->symtree->n.sym); + + *expr = *new; + + gfc_free (new); + expr->ts = *ts; + + if (gfc_is_constant_expr (expr->value.function.actual->expr) + && do_simplify (sym, expr) == FAILURE) + { + /* Error already generated in do_simplify() */ + return FAILURE; + } + + return SUCCESS; +} diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index ac996b6..e280c50 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index e8f98df..6852d64 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -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. diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 2a3c6bd..4b7e17d 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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); } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index be5fca0..a9b47d8 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -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; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index dd251af..c3354a9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 4159374..e094a62 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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; +} diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index 389e2a5..e1f9b7c 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -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: diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h index 04b9c78..bc3a1e8 100644 --- a/gcc/fortran/target-memory.h +++ b/gcc/fortran/target-memory.h @@ -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. */ diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 784f1bc..a691ad5 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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; diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 511f04b..2b644c7 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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); diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 6c9032f..e4da3f0 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -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: diff --git a/gcc/fortran/trans-const.h b/gcc/fortran/trans-const.h index 808a1a5..2cba791 100644 --- a/gcc/fortran/trans-const.h +++ b/gcc/fortran/trans-const.h @@ -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 *); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 49eb2aa..57914ae 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 563e840..482e8b1 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -977,7 +977,7 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, build_int_cst (gfc_charlen_type_node, 1)); tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); - tmp = build_array_type (gfc_character1_type_node, tmp); + tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp); var = gfc_create_var (tmp, "str"); var = gfc_build_addr_expr (type, var); } @@ -985,7 +985,10 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) { /* Allocate a temporary to hold the result. */ var = gfc_create_var (type, "pstr"); - tmp = gfc_call_malloc (&se->pre, type, len); + tmp = gfc_call_malloc (&se->pre, type, + fold_build2 (MULT_EXPR, TREE_TYPE (len), len, + fold_convert (TREE_TYPE (len), + TYPE_SIZE (type)))); gfc_add_modify_expr (&se->pre, var, tmp); /* Free the temporary afterwards. */ @@ -1008,6 +1011,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER && expr->value.op.op2->ts.type == BT_CHARACTER); + gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind); gfc_init_se (&lse, se); gfc_conv_expr (&lse, expr->value.op.op1); @@ -1238,14 +1242,14 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) /* If a string's length is one, we convert it to a single character. */ static tree -gfc_to_single_character (tree len, tree str) +string_to_single_character (tree len, tree str, int kind) { gcc_assert (POINTER_TYPE_P (TREE_TYPE (str))); if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1 - && TREE_INT_CST_HIGH (len) == 0) + && TREE_INT_CST_HIGH (len) == 0) { - str = fold_convert (pchar_type_node, str); + str = fold_convert (gfc_get_pchar_type (kind), str); return build_fold_indirect_ref (str); } @@ -1293,18 +1297,21 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) { if ((*expr)->ref == NULL) { - se->expr = gfc_to_single_character + se->expr = string_to_single_character (build_int_cst (integer_type_node, 1), - gfc_build_addr_expr (pchar_type_node, + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), gfc_get_symbol_decl - ((*expr)->symtree->n.sym))); + ((*expr)->symtree->n.sym)), + (*expr)->ts.kind); } else { gfc_conv_variable (se, *expr); - se->expr = gfc_to_single_character + se->expr = string_to_single_character (build_int_cst (integer_type_node, 1), - gfc_build_addr_expr (pchar_type_node, se->expr)); + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), + se->expr), + (*expr)->ts.kind); } } } @@ -1324,8 +1331,8 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); - sc1 = gfc_to_single_character (len1, str1); - sc2 = gfc_to_single_character (len2, str2); + sc1 = string_to_single_character (len1, str1, kind); + sc2 = string_to_single_character (len2, str2, kind); if (sc1 != NULL_TREE && sc2 != NULL_TREE) { @@ -2827,11 +2834,77 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, } +/* Fill a character string with spaces. */ + +static tree +fill_with_spaces (tree start, tree type, tree size) +{ + stmtblock_t block, loop; + tree i, el, exit_label, cond, tmp; + + /* For a simple char type, we can call memset(). */ + if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0) + return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start, + build_int_cst (gfc_get_int_type (gfc_c_int_kind), + lang_hooks.to_target_charset (' ')), + size); + + /* Otherwise, we use a loop: + for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type)) + *el = (type) ' '; + */ + + /* Initialize variables. */ + gfc_init_block (&block); + i = gfc_create_var (sizetype, "i"); + gfc_add_modify_expr (&block, i, fold_convert (sizetype, size)); + el = gfc_create_var (build_pointer_type (type), "el"); + gfc_add_modify_expr (&block, el, fold_convert (TREE_TYPE (el), start)); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + + /* Loop body. */ + gfc_init_block (&loop); + + /* Exit condition. */ + cond = fold_build2 (LE_EXPR, boolean_type_node, i, + fold_convert (sizetype, integer_zero_node)); + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&loop, tmp); + + /* Assignment. */ + gfc_add_modify_expr (&loop, fold_build1 (INDIRECT_REF, type, el), + build_int_cst (type, + lang_hooks.to_target_charset (' '))); + + /* Increment loop variables. */ + gfc_add_modify_expr (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i, + TYPE_SIZE_UNIT (type))); + gfc_add_modify_expr (&loop, el, fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (el), el, + TYPE_SIZE_UNIT (type))); + + /* Making the loop... actually loop! */ + tmp = gfc_finish_block (&loop); + tmp = build1_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&block, tmp); + + /* The exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + + return gfc_finish_block (&block); +} + + /* Generate code to copy a string. */ void gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, - tree slength, tree src) + int dkind, tree slength, tree src, int skind) { tree tmp, dlen, slen; tree dsc; @@ -2841,12 +2914,15 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, tree tmp2; tree tmp3; tree tmp4; + tree chartype; stmtblock_t tempblock; + gcc_assert (dkind == skind); + if (slength != NULL_TREE) { slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); - ssc = gfc_to_single_character (slen, src); + ssc = string_to_single_character (slen, src, skind); } else { @@ -2857,7 +2933,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (dlength != NULL_TREE) { dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); - dsc = gfc_to_single_character (slen, dest); + dsc = string_to_single_character (slen, dest, dkind); } else { @@ -2866,14 +2942,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, } if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src))) - ssc = gfc_to_single_character (slen, src); + ssc = string_to_single_character (slen, src, skind); if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest))) - dsc = gfc_to_single_character (dlen, dest); + dsc = string_to_single_character (dlen, dest, dkind); /* Assign directly if the types are compatible. */ if (dsc != NULL_TREE && ssc != NULL_TREE - && TREE_TYPE (dsc) == TREE_TYPE (ssc)) + && TREE_TYPE (dsc) == TREE_TYPE (ssc)) { gfc_add_modify_expr (block, dsc, ssc); return; @@ -2906,6 +2982,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, We're now doing it here for better optimization, but the logic is the same. */ + /* For non-default character kinds, we have to multiply the string + length by the base type size. */ + chartype = gfc_get_char_type (dkind); + slen = fold_build2 (MULT_EXPR, size_type_node, slen, + TYPE_SIZE_UNIT (chartype)); + dlen = fold_build2 (MULT_EXPR, size_type_node, dlen, + TYPE_SIZE_UNIT (chartype)); + if (dlength) dest = fold_convert (pvoid_type_node, dest); else @@ -2927,12 +3011,9 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest, fold_convert (sizetype, slen)); - tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, - tmp4, - build_int_cst (gfc_get_int_type (gfc_c_int_kind), - lang_hooks.to_target_charset (' ')), - fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), - dlen, slen)); + tmp4 = fill_with_spaces (tmp4, chartype, + fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), + dlen, slen)); gfc_init_block (&tempblock); gfc_add_expr_to_block (&tempblock, tmp3); @@ -2994,7 +3075,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) tree arglen; gcc_assert (fsym->ts.cl && fsym->ts.cl->length - && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); + && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); tmp = gfc_build_addr_expr (build_pointer_type (type), @@ -3005,8 +3086,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->pre, &lse.pre); gfc_add_block_to_block (&se->pre, &rse.pre); - gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length, - rse.expr); + gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind, + rse.string_length, rse.expr, fsym->ts.kind); gfc_add_block_to_block (&se->pre, &lse.post); gfc_add_block_to_block (&se->pre, &rse.post); } @@ -3042,7 +3123,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) tmp = gfc_create_var (type, sym->name); tmp = gfc_build_addr_expr (build_pointer_type (type), tmp); gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp, - se->string_length, se->expr); + sym->ts.kind, se->string_length, se->expr, + sym->ts.kind); se->expr = tmp; } se->string_length = sym->ts.cl->backend_decl; @@ -3501,17 +3583,14 @@ static void gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) { gfc_ref *ref; - char *s; ref = expr->ref; gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); - gcc_assert (expr->ts.kind == gfc_default_character_kind); - s = gfc_widechar_to_char (expr->value.character.string, - expr->value.character.length); - se->expr = gfc_build_string_const (expr->value.character.length, s); - gfc_free (s); + se->expr = gfc_build_wide_string_const (expr->ts.kind, + expr->value.character.length, + expr->value.character.string); se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1; @@ -3824,15 +3903,18 @@ gfc_conv_string_parameter (gfc_se * se) if (TREE_CODE (se->expr) == STRING_CST) { - se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + type = TREE_TYPE (TREE_TYPE (se->expr)); + se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); return; } - type = TREE_TYPE (se->expr); - if (TYPE_STRING_FLAG (type)) + if (TYPE_STRING_FLAG (TREE_TYPE (se->expr))) { if (TREE_CODE (se->expr) != INDIRECT_REF) - se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + { + type = TREE_TYPE (se->expr); + se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); + } else { type = gfc_get_character_type_len (gfc_default_character_kind, @@ -3881,7 +3963,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, rlen = rse->string_length; } - gfc_trans_string_copy (&block, llen, lse->expr, rlen, rse->expr); + gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen, + rse->expr, ts.kind); } else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 03ddefd..990a127 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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. */ diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 64829e3..6afac5d 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -99,7 +99,6 @@ gfc_trans_label_assign (gfc_code * code) tree len; tree addr; tree len_tree; - char *label_str; int label_len; /* Start a new block. */ @@ -119,14 +118,13 @@ gfc_trans_label_assign (gfc_code * code) } else { - label_len = code->label->format->value.character.length; - label_str - = gfc_widechar_to_char (code->label->format->value.character.string, - label_len); + gfc_expr *format = code->label->format; + + label_len = format->value.character.length; len_tree = build_int_cst (NULL_TREE, label_len); - label_tree = gfc_build_string_const (label_len + 1, label_str); + label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1, + format->value.character.string); label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); - gfc_free (label_str); } gfc_add_modify_expr (&se.pre, len, len_tree); @@ -1321,41 +1319,56 @@ gfc_trans_logical_select (gfc_code * code) static tree gfc_trans_character_select (gfc_code *code) { - tree init, node, end_label, tmp, type, case_num, label; + tree init, node, end_label, tmp, type, case_num, label, fndecl; stmtblock_t block, body; gfc_case *cp, *d; gfc_code *c; gfc_se se; - int n; + int n, k; + + /* The jump table types are stored in static variables to avoid + constructing them from scratch every single time. */ + static tree select_struct[2]; + static tree ss_string1[2], ss_string1_len[2]; + static tree ss_string2[2], ss_string2_len[2]; + static tree ss_target[2]; - static tree select_struct; - static tree ss_string1, ss_string1_len; - static tree ss_string2, ss_string2_len; - static tree ss_target; + tree pchartype = gfc_get_pchar_type (code->expr->ts.kind); + + if (code->expr->ts.kind == 1) + k = 0; + else if (code->expr->ts.kind == 4) + k = 1; + else + gcc_unreachable (); - if (select_struct == NULL) + if (select_struct[k] == NULL) { - tree gfc_int4_type_node = gfc_get_int_type (4); + select_struct[k] = make_node (RECORD_TYPE); - select_struct = make_node (RECORD_TYPE); - TYPE_NAME (select_struct) = get_identifier ("_jump_struct"); + if (code->expr->ts.kind == 1) + TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1"); + else if (code->expr->ts.kind == 4) + TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4"); + else + gcc_unreachable (); #undef ADD_FIELD -#define ADD_FIELD(NAME, TYPE) \ - ss_##NAME = gfc_add_field_to_struct \ - (&(TYPE_FIELDS (select_struct)), select_struct, \ +#define ADD_FIELD(NAME, TYPE) \ + ss_##NAME[k] = gfc_add_field_to_struct \ + (&(TYPE_FIELDS (select_struct[k])), select_struct[k], \ get_identifier (stringize(NAME)), TYPE) - ADD_FIELD (string1, pchar_type_node); - ADD_FIELD (string1_len, gfc_int4_type_node); + ADD_FIELD (string1, pchartype); + ADD_FIELD (string1_len, gfc_charlen_type_node); - ADD_FIELD (string2, pchar_type_node); - ADD_FIELD (string2_len, gfc_int4_type_node); + ADD_FIELD (string2, pchartype); + ADD_FIELD (string2_len, gfc_charlen_type_node); ADD_FIELD (target, integer_type_node); #undef ADD_FIELD - gfc_finish_type (select_struct); + gfc_finish_type (select_struct[k]); } cp = code->block->ext.case_list; @@ -1401,40 +1414,40 @@ gfc_trans_character_select (gfc_code *code) if (d->low == NULL) { - node = tree_cons (ss_string1, null_pointer_node, node); - node = tree_cons (ss_string1_len, integer_zero_node, node); + node = tree_cons (ss_string1[k], null_pointer_node, node); + node = tree_cons (ss_string1_len[k], integer_zero_node, node); } else { gfc_conv_expr_reference (&se, d->low); - node = tree_cons (ss_string1, se.expr, node); - node = tree_cons (ss_string1_len, se.string_length, node); + node = tree_cons (ss_string1[k], se.expr, node); + node = tree_cons (ss_string1_len[k], se.string_length, node); } if (d->high == NULL) { - node = tree_cons (ss_string2, null_pointer_node, node); - node = tree_cons (ss_string2_len, integer_zero_node, node); + node = tree_cons (ss_string2[k], null_pointer_node, node); + node = tree_cons (ss_string2_len[k], integer_zero_node, node); } else { gfc_init_se (&se, NULL); gfc_conv_expr_reference (&se, d->high); - node = tree_cons (ss_string2, se.expr, node); - node = tree_cons (ss_string2_len, se.string_length, node); + node = tree_cons (ss_string2[k], se.expr, node); + node = tree_cons (ss_string2_len[k], se.string_length, node); } - node = tree_cons (ss_target, build_int_cst (integer_type_node, d->n), + node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n), node); - tmp = build_constructor_from_list (select_struct, nreverse (node)); + tmp = build_constructor_from_list (select_struct[k], nreverse (node)); init = tree_cons (NULL_TREE, tmp, init); } - type = build_array_type (select_struct, build_index_type - (build_int_cst (NULL_TREE, n - 1))); + type = build_array_type (select_struct[k], + build_index_type (build_int_cst (NULL_TREE, n-1))); init = build_constructor_from_list (type, nreverse(init)); TREE_CONSTANT (init) = 1; @@ -1455,9 +1468,15 @@ gfc_trans_character_select (gfc_code *code) gfc_add_block_to_block (&block, &se.pre); - tmp = build_call_expr (gfor_fndecl_select_string, 4, init, - build_int_cst (NULL_TREE, n), se.expr, - se.string_length); + if (code->expr->ts.kind == 1) + fndecl = gfor_fndecl_select_string; + else if (code->expr->ts.kind == 4) + fndecl = gfor_fndecl_select_string_char4; + else + gcc_unreachable (); + + tmp = build_call_expr (fndecl, 4, init, build_int_cst (NULL_TREE, n), + se.expr, se.string_length); case_num = gfc_create_var (integer_type_node, "case_num"); gfc_add_modify_expr (&block, case_num, tmp); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 1c15d64..fa1bf24 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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. */ diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 0da736d..7074913 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -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 *); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index ffd1b84..d0ce235 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5580d8c..77c5dab 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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. diff --git a/gcc/testsuite/gfortran.dg/achar_3.f90 b/gcc/testsuite/gfortran.dg/achar_3.f90 index 3b6f902..b33bfd1 100644 --- a/gcc/testsuite/gfortran.dg/achar_3.f90 +++ b/gcc/testsuite/gfortran.dg/achar_3.f90 @@ -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 index 0000000..c4f78c0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/achar_5.f90 @@ -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 index 0000000..dd93c27 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/achar_6.F90 @@ -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 index 0000000..804de9d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_1.f90 @@ -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 index 0000000..706901e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_2.f90 @@ -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 index 0000000..653f1d9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_3.f90 @@ -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 index 0000000..1166f8b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_4.f90 @@ -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 index 0000000..cb98042 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 @@ -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 index 0000000..0a1d449 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 @@ -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 index 0000000..7073b89 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 @@ -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 index 0000000..c9f8e8c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 @@ -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 index 0000000..8475a67 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 @@ -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 index 0000000..64315af --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_select_1.f90 @@ -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 index 0000000..2eea9ae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_select_2.f90 @@ -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 |