OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
Francois-Xavier Coudert 2008-05-18 22:45:05 +00:00 committed by François-Xavier Coudert
parent 45a7844faf
commit d393bbd737
42 changed files with 2232 additions and 334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
gcc/fortran/ChangeLog
View File

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

27
gcc/fortran/arith.c
View File

@ -280,6 +280,23 @@ gfc_arith_done_1 (void)
}
/* Given a wide character value and a character kind, determine whether
the character is representable for that kind. */
bool
gfc_check_character_range (gfc_char_t c, int kind)
{
/* As wide characters are stored as 32-bit values, they're all
representable in UCS=4. */
if (kind == 4)
return true;
if (kind == 1)
return c <= 255 ? true : false;
gcc_unreachable ();
}
/* Given an integer and a kind, make sure that the integer lies within
the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
ARITH_OVERFLOW. */
@ -1655,6 +1672,11 @@ eval_intrinsic (gfc_intrinsic_op operator,
unary = 0;
temp.ts.type = BT_LOGICAL;
temp.ts.kind = gfc_default_logical_kind;
/* If kind mismatch, exit and we'll error out later. */
if (op1->ts.kind != op2->ts.kind)
goto runtime;
break;
}
@ -1696,11 +1718,12 @@ eval_intrinsic (gfc_intrinsic_op operator,
/* Character binary */
case INTRINSIC_CONCAT:
if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
|| op1->ts.kind != op2->ts.kind)
goto runtime;
temp.ts.type = BT_CHARACTER;
temp.ts.kind = gfc_default_character_kind;
temp.ts.kind = op1->ts.kind;
unary = 0;
break;

99
gcc/fortran/check.c
View File

@ -492,10 +492,14 @@ gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
if (type_check (name, 0, BT_CHARACTER) == FAILURE
|| scalar_check (name, 0) == FAILURE)
return FAILURE;
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE
|| scalar_check (mode, 1) == FAILURE)
return FAILURE;
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
@ -716,6 +720,8 @@ gfc_check_chdir (gfc_expr *dir)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
@ -726,13 +732,14 @@ gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
{
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
if (type_check (status, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
@ -745,9 +752,13 @@ gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
return SUCCESS;
}
@ -758,9 +769,13 @@ gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
return FAILURE;
if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
return FAILURE;
if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE)
return FAILURE;
if (status == NULL)
return SUCCESS;
@ -1496,14 +1511,35 @@ 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;

2
gcc/fortran/decl.c
View File

@ -1093,7 +1093,7 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
int slen;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
gcc_assert (expr->ts.type == BT_CHARACTER);
slen = expr->value.character.length;
if (len != slen)

36
gcc/fortran/error.c
View File

@ -152,14 +152,11 @@ error_integer (long int i)
}
static char wide_char_print_buffer[11];
const char *
gfc_print_wide_char (gfc_char_t c)
static void
print_wide_char_into_buffer (gfc_char_t c, char *buf)
{
static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
'7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
char *buf = wide_char_print_buffer;
if (gfc_wide_is_printable (c))
{
@ -173,8 +170,8 @@ gfc_print_wide_char (gfc_char_t c)
c = c >> 4;
buf[2] = xdigit[c & 0x0F];
buf[1] = '\\';
buf[0] = 'x';
buf[1] = 'x';
buf[0] = '\\';
}
else if (c < ((gfc_char_t) 1 << 16))
{
@ -187,8 +184,8 @@ gfc_print_wide_char (gfc_char_t c)
c = c >> 4;
buf[2] = xdigit[c & 0x0F];
buf[1] = '\\';
buf[0] = 'u';
buf[1] = 'u';
buf[0] = '\\';
}
else
{
@ -209,13 +206,21 @@ gfc_print_wide_char (gfc_char_t c)
c = c >> 4;
buf[2] = xdigit[c & 0x0F];
buf[1] = '\\';
buf[0] = 'U';
buf[1] = 'U';
buf[0] = '\\';
}
return buf;
}
static char wide_char_print_buffer[11];
const char *
gfc_print_wide_char (gfc_char_t c)
{
print_wide_char_into_buffer (c, wide_char_print_buffer);
return wide_char_print_buffer;
}
/* Show the file, where it was included, and the source line, give a
locus. Calls error_printf() recursively, but the recursion is at
most one level deep. */
@ -317,11 +322,14 @@ show_locus (locus *loc, int c1, int c2)
for (; i > 0; i--)
{
static char buffer[11];
c = *p++;
if (c == '\t')
c = ' ';
error_string (gfc_print_wide_char (c));
print_wide_char_into_buffer (c, buffer);
error_string (buffer);
}
error_char ('\n');

10
gcc/fortran/expr.c
View File

@ -2847,6 +2847,16 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
return FAILURE;
}
/* Assignment is the only case where character variables of different
kind values can be converted into one another. */
if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
{
if (lvalue->ts.kind != rvalue->ts.kind)
gfc_convert_chartype (rvalue, &lvalue->ts);
return SUCCESS;
}
return gfc_convert_type (rvalue, &lvalue->ts, 1);
}

2
gcc/fortran/gfortran.h
View File

@ -2069,6 +2069,7 @@ void gfc_arith_init_1 (void);
void gfc_arith_done_1 (void);
gfc_expr *gfc_enum_initializer (gfc_expr *, locus);
arith gfc_check_integer_range (mpz_t p, int kind);
bool gfc_check_character_range (gfc_char_t, int);
/* trans-types.c */
try gfc_validate_c_kind (gfc_typespec *);
@ -2225,6 +2226,7 @@ char gfc_type_letter (bt);
gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
try gfc_convert_type (gfc_expr *, gfc_typespec *, int);
try gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int);
try gfc_convert_chartype (gfc_expr *, gfc_typespec *);
int gfc_generic_intrinsic (const char *);
int gfc_specific_intrinsic (const char *);
int gfc_intrinsic_name (const char *, int);

179
gcc/fortran/intrinsic.c
View File

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

4
gcc/fortran/intrinsic.h
View File

@ -91,6 +91,7 @@ try gfc_check_kind (gfc_expr *);
try gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_len_lentrim (gfc_expr *, gfc_expr *);
try gfc_check_link (gfc_expr *, gfc_expr *);
try gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *);
try gfc_check_loc (gfc_expr *);
try gfc_check_logical (gfc_expr *, gfc_expr *);
try gfc_check_min_max (gfc_actual_arglist *);
@ -317,11 +318,14 @@ gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);
/* Constant conversion simplification. */
gfc_expr *gfc_convert_constant (gfc_expr *, bt, int);
gfc_expr *gfc_convert_char_constant (gfc_expr *, bt, int);
/* Resolution functions. */
void gfc_resolve_abs (gfc_expr *, gfc_expr *);
void gfc_resolve_access (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_adjustl (gfc_expr *, gfc_expr *);
void gfc_resolve_adjustr (gfc_expr *, gfc_expr *);
void gfc_resolve_achar (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_acos (gfc_expr *, gfc_expr *);
void gfc_resolve_acosh (gfc_expr *, gfc_expr *);

126
gcc/fortran/intrinsic.texi
View File

@ -428,13 +428,14 @@ Inquiry function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{NAME} @tab Scalar @code{CHARACTER} with the file name.
Tailing blank are ignored unless the character @code{achar(0)} is
present, then all characters up to and excluding @code{achar(0)} are
@item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the
file name. Tailing blank are ignored unless the character @code{achar(0)}
is present, then all characters up to and excluding @code{achar(0)} are
used as file name.
@item @var{MODE} @tab Scalar @code{CHARACTER} with the file access mode,
may be any concatenation of @code{"r"} (readable), @code{"w"} (writable)
and @code{"x"} (executable), or @code{" "} to check for existence.
@item @var{MODE} @tab Scalar @code{CHARACTER} of default kind with the
file access mode, may be any concatenation of @code{"r"} (readable),
@code{"w"} (writable) and @code{"x"} (executable), or @code{" "} to check
for existence.
@end multitable
@item @emph{Return value}:
@ -644,9 +645,9 @@ Elemental function
@end multitable
@item @emph{Return value}:
The return value is of type @code{CHARACTER} where leading spaces
are removed and the same number of spaces are inserted on the end
of @var{STR}. The return value has the same kind as @var{STRING}.
The return value is of type @code{CHARACTER} and of the same kind as
@var{STRING} where leading spaces are removed and the same number of
spaces are inserted on the end of @var{STRING}.
@item @emph{Example}:
@smallexample
@ -689,9 +690,9 @@ Elemental function
@end multitable
@item @emph{Return value}:
The return value is of type @code{CHARACTER} where trailing spaces
are removed and the same number of spaces are inserted at the start
of @var{STR}. The return value has the same kind as @var{STRING}.
The return value is of type @code{CHARACTER} and of the same kind as
@var{STRING} where trailing spaces are removed and the same number of
spaces are inserted at the start of @var{STRING}.
@item @emph{Example}:
@smallexample
@ -2262,8 +2263,9 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{NAME} @tab The type shall be @code{CHARACTER} and shall
specify a valid path within the file system.
@item @var{NAME} @tab The type shall be @code{CHARACTER} of default
kind and shall specify a valid path within the
file system.
@item @var{STATUS} @tab (Optional) @code{INTEGER} status flag of the default
kind. Returns 0 on success, and a system specific
and nonzero error code otherwise.
@ -2314,14 +2316,15 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{NAME} @tab Scalar @code{CHARACTER} with the file name.
Trailing blanks are ignored unless the character @code{achar(0)} is
present, then all characters up to and excluding @code{achar(0)} are
used as the file name.
@item @var{MODE} @tab Scalar @code{CHARACTER} giving the file permission.
@var{MODE} uses the same syntax as the @var{MODE} argument of
@code{/bin/chmod}.
@item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the
file name. Trailing blanks are ignored unless the character
@code{achar(0)} is present, then all characters up to and excluding
@code{achar(0)} are used as the file name.
@item @var{MODE} @tab Scalar @code{CHARACTER} of default kind giving the
file permission. @var{MODE} uses the same syntax as the @var{MODE}
argument of @code{/bin/chmod}.
@item @var{STATUS} @tab (optional) scalar @code{INTEGER}, which is
@code{0} on success and nonzero otherwise.
@ -2873,7 +2876,8 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{TIME} @tab The type shall be of type @code{INTEGER(KIND=8)}.
@item @var{RESULT} @tab The type shall be of type @code{CHARACTER}.
@item @var{RESULT} @tab The type shall be of type @code{CHARACTER} and
of default kind.
@end multitable
@item @emph{Return value}:
@ -2940,9 +2944,12 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{DATE} @tab (Optional) The type shall be @code{CHARACTER(8)} or larger.
@item @var{TIME} @tab (Optional) The type shall be @code{CHARACTER(10)} or larger.
@item @var{ZONE} @tab (Optional) The type shall be @code{CHARACTER(5)} or larger.
@item @var{DATE} @tab (Optional) The type shall be @code{CHARACTER(LEN=8)}
or larger, and of default kind.
@item @var{TIME} @tab (Optional) The type shall be @code{CHARACTER(LEN=10)}
or larger, and of default kind.
@item @var{ZONE} @tab (Optional) The type shall be @code{CHARACTER(LEN=5)}
or larger, and of default kind.
@item @var{VALUES}@tab (Optional) The type shall be @code{INTEGER(8)}.
@end multitable
@ -3887,7 +3894,8 @@ TIME())}.
This intrinsic is provided in both subroutine and function forms; however,
only one form can be used in any given program unit.
@var{DATE} is an @code{INTENT(OUT)} @code{CHARACTER} variable.
@var{DATE} is an @code{INTENT(OUT)} @code{CHARACTER} variable of the
default kind.
@item @emph{Standard}:
GNU extension
@ -3903,7 +3911,8 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{DATE}@tab The type shall be of type @code{CHARACTER}.
@item @var{DATE}@tab The type shall be of type @code{CHARACTER} of the
default kind
@end multitable
@item @emph{Return value}:
@ -3999,7 +4008,8 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{C} @tab The type shall be @code{CHARACTER}.
@item @var{C} @tab The type shall be @code{CHARACTER} and of default
kind.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
Returns 0 on success, -1 on end-of-file, and a
system specific positive error code otherwise.
@ -4061,9 +4071,11 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{UNIT} @tab The type shall be @code{INTEGER}.
@item @var{C} @tab The type shall be @code{CHARACTER}.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success,
-1 on end-of-file and a system specific positive error code otherwise.
@item @var{C} @tab The type shall be @code{CHARACTER} and of default
kind.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
Returns 0 on success, -1 on end-of-file and a
system specific positive error code otherwise.
@end multitable
@item @emph{Example}:
@ -4241,9 +4253,11 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{C} @tab The type shall be @code{CHARACTER}.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success,
-1 on end-of-file and a system specific positive error code otherwise.
@item @var{C} @tab The type shall be @code{CHARACTER} and of default
kind.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
Returns 0 on success, -1 on end-of-file and a
system specific positive error code otherwise.
@end multitable
@item @emph{Example}:
@ -4296,9 +4310,11 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{UNIT} @tab The type shall be @code{INTEGER}.
@item @var{C} @tab The type shall be @code{CHARACTER}.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success,
-1 on end-of-file and a system specific positive error code otherwise.
@item @var{C} @tab The type shall be @code{CHARACTER} and of default
kind.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
Returns 0 on success, -1 on end-of-file and a
system specific positive error code otherwise.
@end multitable
@item @emph{Example}:
@ -4656,7 +4672,7 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{RESULT} @tab Shall of type @code{CHARACTER}.
@item @var{RESULT} @tab Shall of type @code{CHARACTER} and of default
@end multitable
@item @emph{Example}:
@ -4703,6 +4719,8 @@ Subroutine
@multitable @columnfractions .15 .70
@item @var{POS} @tab Shall be of type @code{INTEGER} and not wider than
the default integer kind; @math{@var{POS} \geq 0}
@item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default
kind.
@item @var{VALUE} @tab Shall be of type @code{CHARACTER}.
@end multitable
@ -4757,7 +4775,8 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{COMMAND} @tab Shall be of type @code{CHARACTER}.
@item @var{COMMAND} @tab Shall be of type @code{CHARACTER} and of default
kind.
@end multitable
@item @emph{Return value}:
@ -4802,8 +4821,10 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{NUMBER} @tab Shall be a scalar of type @code{INTEGER(4)}, @math{@var{N} \geq 0}.
@item @var{VALUE} @tab (Option) Shall be a scalar of type @code{CHARACTER(1)}.
@item @var{NUMBER} @tab Shall be a scalar of type @code{INTEGER(4)},
@math{@var{NUMBER} \geq 0}
@item @var{VALUE} @tab Shall be a scalar of type @code{CHARACTER}
and of default kind.
@item @var{LENGTH} @tab (Option) Shall be a scalar of type @code{INTEGER(4)}.
@item @var{STATUS} @tab (Option) Shall be a scalar of type @code{INTEGER(4)}.
@end multitable
@ -4865,7 +4886,7 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{C} @tab The type shall be @code{CHARACTER}.
@item @var{C} @tab The type shall be @code{CHARACTER} and of default kind.
@item @var{STATUS} @tab (Optional) status flag. Returns 0 on success,
a system specific and nonzero error code otherwise.
@end multitable
@ -4910,8 +4931,8 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{NAME} @tab Shall be of type @code{CHARACTER}.
@item @var{VALUE} @tab Shall be of type @code{CHARACTER}.
@item @var{NAME} @tab Shall be of type @code{CHARACTER} and of default kind.
@item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default kind.
@end multitable
@item @emph{Return value}:
@ -5039,7 +5060,7 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{C} @tab Shall be of type @code{CHARACTER}.
@item @var{C} @tab Shall be of type @code{CHARACTER} and of default kind.
@end multitable
@item @emph{Return value}:
@ -5215,7 +5236,7 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{C } @tab Shall of type @code{CHARACTER}.
@item @var{C} @tab Shall of type @code{CHARACTER} and of default kind.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}.
Returns 0 on success, or a system specific error
code otherwise.
@ -7132,10 +7153,11 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{FILE} @tab The type shall be @code{CHARACTER}, a valid path within the file system.
@item @var{FILE} @tab The type shall be @code{CHARACTER} of the default
kind, a valid path within the file system.
@item @var{BUFF} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0
on success and a system specific error code otherwise.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}.
Returns 0 on success and a system specific error code otherwise.
@end multitable
@item @emph{Example}:
@ -8407,7 +8429,8 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{STRING} @tab A scalar of default @code{CHARACTER} type.
@item @var{STRING} @tab A scalar of type @code{CHARACTER} and of the
default kind.
@end multitable
@item @emph{See also}:
@ -10158,7 +10181,8 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{FILE} @tab The type shall be @code{CHARACTER}, a valid path within the file system.
@item @var{FILE} @tab The type shall be @code{CHARACTER}, of the
default kind and a valid path within the file system.
@item @var{BUFF} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0
on success and a system specific error code otherwise.

96
gcc/fortran/iresolve.c
View File

@ -143,6 +143,24 @@ gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
}
void
gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
}
void
gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
}
static void
gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
const char *name)
@ -1690,11 +1708,27 @@ gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
resolve_mask_arg (mask);
if (mask->rank != 0)
f->value.function.name = (array->ts.type == BT_CHARACTER
? PREFIX ("pack_char") : PREFIX ("pack"));
{
if (array->ts.type == BT_CHARACTER)
f->value.function.name
= array->ts.kind == 1 ? PREFIX ("pack_char")
: gfc_get_string
(PREFIX ("pack_char%d"),
array->ts.kind);
else
f->value.function.name = PREFIX ("pack");
}
else
f->value.function.name = (array->ts.type == BT_CHARACTER
? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
{
if (array->ts.type == BT_CHARACTER)
f->value.function.name
= array->ts.kind == 1 ? PREFIX ("pack_s_char")
: gfc_get_string
(PREFIX ("pack_s_char%d"),
array->ts.kind);
else
f->value.function.name = PREFIX ("pack_s");
}
}
@ -1801,6 +1835,7 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
case BT_REAL:
case BT_INTEGER:
case BT_LOGICAL:
case BT_CHARACTER:
kind = source->ts.kind;
break;
@ -1820,15 +1855,17 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
= gfc_get_string (PREFIX ("reshape_%c%d"),
gfc_type_letter (source->ts.type),
source->ts.kind);
else if (source->ts.type == BT_CHARACTER)
f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
kind);
else
f->value.function.name
= gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
break;
default:
f->value.function.name = (source->ts.type == BT_CHARACTER
? PREFIX ("reshape_char") : PREFIX ("reshape"));
? PREFIX ("reshape_char") : PREFIX ("reshape"));
break;
}
@ -2000,13 +2037,27 @@ gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
f->ts = source->ts;
f->rank = source->rank + 1;
if (source->rank == 0)
f->value.function.name = (source->ts.type == BT_CHARACTER
? PREFIX ("spread_char_scalar")
: PREFIX ("spread_scalar"));
{
if (source->ts.type == BT_CHARACTER)
f->value.function.name
= source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
: gfc_get_string
(PREFIX ("spread_char%d_scalar"),
source->ts.kind);
else
f->value.function.name = PREFIX ("spread_scalar");
}
else
f->value.function.name = (source->ts.type == BT_CHARACTER
? PREFIX ("spread_char")
: PREFIX ("spread"));
{
if (source->ts.type == BT_CHARACTER)
f->value.function.name
= source->ts.kind == 1 ? PREFIX ("spread_char")
: gfc_get_string
(PREFIX ("spread_char%d"),
source->ts.kind);
else
f->value.function.name = PREFIX ("spread");
}
if (dim && gfc_is_constant_expr (dim)
&& ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
@ -2313,7 +2364,10 @@ gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
break;
default:
f->value.function.name = PREFIX ("transpose");
if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
f->value.function.name = PREFIX ("transpose_char4");
else
f->value.function.name = PREFIX ("transpose");
break;
}
break;
@ -2413,9 +2467,19 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
f->rank = mask->rank;
resolve_mask_arg (mask);
f->value.function.name
= gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
vector->ts.type == BT_CHARACTER ? "_char" : "");
if (vector->ts.type == BT_CHARACTER)
{
if (vector->ts.kind == 1)
f->value.function.name
= gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
else
f->value.function.name
= gfc_get_string (PREFIX ("unpack%d_char%d"),
field->rank > 0 ? 1 : 0, vector->ts.kind);
}
else
f->value.function.name
= gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
}

6
gcc/fortran/primary.c
View File

@ -992,10 +992,10 @@ got_delim:
{
c = next_string_char (delimiter, &ret);
if (!gfc_wide_fits_in_byte (c))
if (!gfc_check_character_range (c, kind))
{
gfc_error ("Unimplemented feature at %C: gfortran currently only "
"supports character strings with one-byte characters");
gfc_error ("Character '%s' in string at %C is not representable "
"in character kind %d", gfc_print_wide_char (c), kind);
return MATCH_ERROR;
}

10
gcc/fortran/resolve.c
View File

@ -2965,7 +2965,8 @@ resolve_operator (gfc_expr *e)
goto bad_op;
case INTRINSIC_CONCAT:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
&& op1->ts.kind == op2->ts.kind)
{
e->ts.type = BT_CHARACTER;
e->ts.kind = op1->ts.kind;
@ -3030,7 +3031,8 @@ resolve_operator (gfc_expr *e)
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
&& op1->ts.kind == op2->ts.kind)
{
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_default_logical_kind;
@ -5124,8 +5126,8 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
{
gfc_error("Expression in CASE statement at %L must be kind %d",
&e->where, case_expr->ts.kind);
gfc_error ("Expression in CASE statement at %L must be of kind %d",
&e->where, case_expr->ts.kind);
return FAILURE;
}

153
gcc/fortran/simplify.c
View File

@ -256,40 +256,70 @@ gfc_simplify_abs (gfc_expr *e)
return result;
}
static gfc_expr *
simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
{
gfc_expr *result;
int kind;
bool too_large = false;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
if (kind == -1)
return &gfc_bad_expr;
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 (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 (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);
}
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] = 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)
{
gfc_expr *result;
int c, kind;
const char *ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
if (kind == -1)
return &gfc_bad_expr;
ch = gfc_extract_int (e, &c);
if (ch != NULL)
gfc_internal_error ("gfc_simplify_achar: %s", ch);
if (gfc_option.warn_surprising && (c < 0 || c > 127))
gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
&e->where);
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[1] = '\0'; /* For debugger */
return result;
return simplify_achar_char (e, k, "ACHAR", true);
}
@ -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;
}

37
gcc/fortran/target-memory.c
View File

@ -75,7 +75,8 @@ size_logical (int kind)
static size_t
size_character (int length, int kind)
{
return length * kind;
int i = gfc_validate_kind (BT_CHARACTER, kind, false);
return length * gfc_character_kinds[i].bit_size / 8;
}
@ -182,20 +183,19 @@ encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size
}
static int
encode_character (int kind, int length, gfc_char_t *string,
unsigned char *buffer, size_t buffer_size)
int
gfc_encode_character (int kind, int length, const gfc_char_t *string,
unsigned char *buffer, size_t buffer_size)
{
char *s;
size_t elsize = size_character (1, kind);
tree type = gfc_get_char_type (kind);
int i;
gcc_assert (buffer_size >= size_character (length, kind));
/* FIXME -- when we support wide character types, we'll need to go
via integers for them. For now, we keep the simple memcpy(). */
gcc_assert (kind == gfc_default_character_kind);
s = gfc_widechar_to_char (string, length);
memcpy (buffer, s, length);
gfc_free (s);
for (i = 0; i < length; i++)
native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
elsize);
return length;
}
@ -268,10 +268,10 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
buffer_size);
case BT_CHARACTER:
if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
return encode_character (source->ts.kind,
source->value.character.length,
source->value.character.string, buffer,
buffer_size);
return gfc_encode_character (source->ts.kind,
source->value.character.length,
source->value.character.string,
buffer, buffer_size);
else
{
int start, end;
@ -279,10 +279,9 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
gcc_assert (source->expr_type == EXPR_SUBSTRING);
gfc_extract_int (source->ref->u.ss.start, &start);
gfc_extract_int (source->ref->u.ss.end, &end);
return encode_character (source->ts.kind,
MAX(end - start + 1, 0),
&source->value.character.string[start-1],
buffer, buffer_size);
return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
&source->value.character.string[start-1],
buffer, buffer_size);
}
case BT_DERIVED:

2
gcc/fortran/target-memory.h
View File

@ -31,6 +31,8 @@ bool gfc_convert_boz (gfc_expr *, gfc_typespec *);
size_t gfc_target_expr_size (gfc_expr *);
/* Write a constant expression in binary form to a target buffer. */
int gfc_encode_character (int, int, const gfc_char_t *, unsigned char *,
size_t);
int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t);
/* Read a target buffer into a constant expression. */

35
gcc/fortran/trans-array.c
View File

@ -992,12 +992,11 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
else
{
/* The temporary is an array of string values. */
tmp = gfc_build_addr_expr (pchar_type_node, tmp);
tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
/* We know the temporary and the value will be the same length,
so can use memcpy. */
gfc_trans_string_copy (&se->pre, esize, tmp,
se->string_length,
se->expr);
gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
se->string_length, se->expr, expr->ts.kind);
}
if (flag_bounds_check && !typespec_chararray_ctor)
{
@ -1185,15 +1184,15 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
/* For constant character array constructors we build
an array of pointers. */
if (p->expr->ts.type == BT_CHARACTER
&& POINTER_TYPE_P (type))
{
/* For constant character array constructors we build
an array of pointers. */
se.expr = gfc_build_addr_expr (pchar_type_node,
se.expr);
}
se.expr = gfc_build_addr_expr
(gfc_get_pchar_type (p->expr->ts.kind),
se.expr);
list = tree_cons (NULL_TREE, se.expr, list);
c = p;
p = p->next;
@ -1394,8 +1393,7 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
mpz_init_set_ui (char_len, 1);
mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
*len = gfc_conv_mpz_to_tree (char_len,
gfc_default_character_kind);
*len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
*len = convert (gfc_charlen_type_node, *len);
mpz_clear (char_len);
return;
@ -1546,9 +1544,9 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, c->expr);
if (c->expr->ts.type == BT_CHARACTER
&& POINTER_TYPE_P (type))
se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
se.expr);
list = tree_cons (NULL_TREE, se.expr, list);
c = c->next;
nelem++;
@ -3488,8 +3486,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
/* Make absolutely sure that this is a complete type. */
if (loop->temp_ss->string_length)
loop->temp_ss->data.temp.type
= gfc_get_character_type_len (gfc_default_character_kind,
loop->temp_ss->string_length);
= gfc_get_character_type_len_for_eltype
(TREE_TYPE (loop->temp_ss->data.temp.type),
loop->temp_ss->string_length);
tmp = loop->temp_ss->data.temp.type;
len = loop->temp_ss->string_length;

2
gcc/fortran/trans-array.h
View File

@ -139,4 +139,4 @@ unsigned HOST_WIDE_INT gfc_constant_array_constructor_p (gfc_constructor *);
tree gfc_build_constant_array_constructor (gfc_expr *, tree);
/* Copy a string from src to dest. */
void gfc_trans_string_copy (stmtblock_t *, tree, tree, tree, tree);
void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int);

61
gcc/fortran/trans-const.c
View File

@ -33,6 +33,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
#include "target-memory.h"
tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
@ -66,6 +67,8 @@ gfc_build_const (tree type, tree intval)
return val;
}
/* Build a string constant with C char type. */
tree
gfc_build_string_const (int length, const char *s)
{
@ -81,6 +84,36 @@ gfc_build_string_const (int length, const char *s)
return str;
}
/* Build a string constant with a type given by its kind; take care of
non-default character kinds. */
tree
gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
{
int i;
tree str, len;
size_t size;
char *s;
i = gfc_validate_kind (BT_CHARACTER, kind, false);
size = length * gfc_character_kinds[i].bit_size / 8;
s = gfc_getmem (size);
gfc_encode_character (kind, length, string, (unsigned char *) s, size);
str = build_string (size, s);
gfc_free (s);
len = build_int_cst (NULL_TREE, length);
TREE_TYPE (str) =
build_array_type (gfc_get_char_type (kind),
build_range_type (gfc_charlen_type_node,
integer_one_node, len));
return str;
}
/* Build a Fortran character constant from a zero-terminated string.
There a two version of this function, one that translates the string
and one that doesn't. */
@ -106,13 +139,13 @@ tree
gfc_conv_string_init (tree length, gfc_expr * expr)
{
gfc_char_t *s;
char *c;
HOST_WIDE_INT len;
int slen;
tree str;
bool free_s = false;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
gcc_assert (expr->ts.type == BT_CHARACTER);
gcc_assert (INTEGER_CST_P (length));
gcc_assert (TREE_INT_CST_HIGH (length) == 0);
@ -124,18 +157,15 @@ gfc_conv_string_init (tree length, gfc_expr * expr)
s = gfc_get_wide_string (len);
memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
gfc_wide_memset (&s[slen], ' ', len - slen);
/* FIXME -- currently ignore wide character strings; see assert
above. */
c = gfc_widechar_to_char (s, len);
gfc_free (s);
free_s = true;
}
else
c = gfc_widechar_to_char (expr->value.character.string,
expr->value.character.length);
s = expr->value.character.string;
str = gfc_build_string_const (len, c);
gfc_free (c);
str = gfc_build_wide_string_const (expr->ts.kind, len, s);
if (free_s)
gfc_free (s);
return str;
}
@ -223,7 +253,6 @@ tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
tree res;
char *s;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
@ -278,11 +307,9 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
}
case BT_CHARACTER:
gcc_assert (expr->ts.kind == 1);
s = gfc_widechar_to_char (expr->value.character.string,
expr->value.character.length);
res = gfc_build_string_const (expr->value.character.length, s);
gfc_free (s);
res = gfc_build_wide_string_const (expr->ts.kind,
expr->value.character.length,
expr->value.character.string);
return res;
case BT_HOLLERITH:

1
gcc/fortran/trans-const.h
View File

@ -37,6 +37,7 @@ tree gfc_conv_constant_to_tree (gfc_expr *);
void gfc_conv_constant (gfc_se *, gfc_expr *);
tree gfc_build_string_const (int, const char *);
tree gfc_build_wide_string_const (int, int, const gfc_char_t *);
tree gfc_build_cstring_const (const char *);
tree gfc_build_localized_cstring_const (const char *);

44
gcc/fortran/trans-decl.c
View File

@ -77,7 +77,6 @@ tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
tree gfor_fndecl_stop_string;
tree gfor_fndecl_select_string;
tree gfor_fndecl_runtime_error;
tree gfor_fndecl_runtime_error_at;
tree gfor_fndecl_os_error;
@ -116,6 +115,7 @@ tree gfor_fndecl_string_trim;
tree gfor_fndecl_string_minmax;
tree gfor_fndecl_adjustl;
tree gfor_fndecl_adjustr;
tree gfor_fndecl_select_string;
tree gfor_fndecl_compare_string_char4;
tree gfor_fndecl_concat_string_char4;
tree gfor_fndecl_string_len_trim_char4;
@ -126,6 +126,12 @@ tree gfor_fndecl_string_trim_char4;
tree gfor_fndecl_string_minmax_char4;
tree gfor_fndecl_adjustl_char4;
tree gfor_fndecl_adjustr_char4;
tree gfor_fndecl_select_string_char4;
/* Conversion between character kinds. */
tree gfor_fndecl_convert_char1_to_char4;
tree gfor_fndecl_convert_char4_to_char1;
/* Other misc. runtime library functions. */
@ -2084,6 +2090,12 @@ gfc_build_intrinsic_function_decls (void)
void_type_node, 3, pchar1_type_node,
gfc_charlen_type_node, pchar1_type_node);
gfor_fndecl_select_string =
gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
integer_type_node, 4, pvoid_type_node,
integer_type_node, pchar1_type_node,
gfc_charlen_type_node);
gfor_fndecl_compare_string_char4 =
gfc_build_library_function_decl (get_identifier
(PREFIX("compare_string_char4")),
@ -2155,6 +2167,30 @@ gfc_build_intrinsic_function_decls (void)
void_type_node, 3, pchar4_type_node,
gfc_charlen_type_node, pchar4_type_node);
gfor_fndecl_select_string_char4 =
gfc_build_library_function_decl (get_identifier
(PREFIX("select_string_char4")),
integer_type_node, 4, pvoid_type_node,
integer_type_node, pvoid_type_node,
gfc_charlen_type_node);
/* Conversion between character kinds. */
gfor_fndecl_convert_char1_to_char4 =
gfc_build_library_function_decl (get_identifier
(PREFIX("convert_char1_to_char4")),
void_type_node, 3,
build_pointer_type (pchar4_type_node),
gfc_charlen_type_node, pchar1_type_node);
gfor_fndecl_convert_char4_to_char1 =
gfc_build_library_function_decl (get_identifier
(PREFIX("convert_char4_to_char1")),
void_type_node, 3,
build_pointer_type (pchar1_type_node),
gfc_charlen_type_node, pchar4_type_node);
/* Misc. functions. */
gfor_fndecl_ttynam =
@ -2362,12 +2398,6 @@ gfc_build_builtin_function_decls (void)
void_type_node, 2, pchar_type_node,
gfc_int4_type_node);
gfor_fndecl_select_string =
gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
integer_type_node, 4, pvoid_type_node,
integer_type_node, pchar_type_node,
integer_type_node);
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
void_type_node, -1, pchar_type_node);

161
gcc/fortran/trans-expr.c
View File

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

65
gcc/fortran/trans-intrinsic.c
View File

@ -250,6 +250,41 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
gcc_assert (expr->value.function.actual->expr);
gfc_conv_intrinsic_function_args (se, expr, args, nargs);
/* Conversion between character kinds involves a call to a library
function. */
if (expr->ts.type == BT_CHARACTER)
{
tree fndecl, var, addr, tmp;
if (expr->ts.kind == 1
&& expr->value.function.actual->expr->ts.kind == 4)
fndecl = gfor_fndecl_convert_char4_to_char1;
else if (expr->ts.kind == 4
&& expr->value.function.actual->expr->ts.kind == 1)
fndecl = gfor_fndecl_convert_char1_to_char4;
else
gcc_unreachable ();
/* Create the variable storing the converted value. */
type = gfc_get_pchar_type (expr->ts.kind);
var = gfc_create_var (type, "str");
addr = gfc_build_addr_expr (build_pointer_type (type), var);
/* Call the library function that will perform the conversion. */
gcc_assert (nargs >= 2);
tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards. */
tmp = gfc_call_free (var);
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
se->string_length = args[0];
return;
}
/* Conversion from complex to non-complex involves taking the real
component of the value. */
if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
@ -1273,16 +1308,13 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
tree type;
unsigned int num_args;
/* We must allow for the KIND argument, even though.... */
num_args = gfc_intrinsic_argument_list_length (expr);
gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
/* .... we currently don't support character types != 1. */
gcc_assert (expr->ts.kind == 1);
type = gfc_character1_type_node;
type = gfc_get_char_type (expr->ts.kind);
var = gfc_create_var (type, "char");
arg[0] = convert (type, arg[0]);
arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
gfc_add_modify_expr (&se->pre, var, arg[0]);
se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
se->string_length = integer_one_node;
@ -3290,7 +3322,7 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
se->expr
= gfc_build_compare_string (args[0], args[1], args[2], args[3],
expr->value.function.actual->expr->ts.kind);
expr->value.function.actual->expr->ts.kind);
se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
build_int_cst (TREE_TYPE (se->expr), 0));
}
@ -3892,9 +3924,14 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
{
tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
tree type, cond, tmp, count, exit_label, n, max, largest;
tree size;
stmtblock_t block, body;
int i;
/* We store in charsize the size of an character. */
i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
/* Get the arguments. */
gfc_conv_intrinsic_function_args (se, expr, args, 3);
slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
@ -3939,7 +3976,6 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
cond);
gfc_trans_runtime_check (cond, &se->pre, &expr->where,
"Argument NCOPIES of REPEAT intrinsic is too large");
/* Compute the destination length. */
dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
@ -3950,7 +3986,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
/* Generate the code to do the repeat operation:
for (i = 0; i < ncopies; i++)
memmove (dest + (i * slen), src, slen); */
memmove (dest + (i * slen * size), src, slen*size); */
gfc_start_block (&block);
count = gfc_create_var (ncopies_type, "count");
gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
@ -3967,15 +4003,18 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
/* Call memmove (dest + (i*slen), src, slen). */
/* Call memmove (dest + (i*slen*size), src, slen*size). */
tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
fold_convert (gfc_charlen_type_node, slen),
fold_convert (gfc_charlen_type_node, count));
tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
fold_convert (pchar_type_node, dest),
tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
tmp, fold_convert (gfc_charlen_type_node, size));
tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
fold_convert (pvoid_type_node, dest),
fold_convert (sizetype, tmp));
tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
tmp, src, slen);
tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
fold_build2 (MULT_EXPR, size_type_node, slen,
fold_convert (size_type_node, size)));
gfc_add_expr_to_block (&body, tmp);
/* Increment count. */

99
gcc/fortran/trans-stmt.c
View File

@ -99,7 +99,6 @@ gfc_trans_label_assign (gfc_code * code)
tree len;
tree addr;
tree len_tree;
char *label_str;
int label_len;
/* Start a new block. */
@ -119,14 +118,13 @@ gfc_trans_label_assign (gfc_code * code)
}
else
{
label_len = code->label->format->value.character.length;
label_str
= gfc_widechar_to_char (code->label->format->value.character.string,
label_len);
gfc_expr *format = code->label->format;
label_len = format->value.character.length;
len_tree = build_int_cst (NULL_TREE, label_len);
label_tree = gfc_build_string_const (label_len + 1, label_str);
label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
format->value.character.string);
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
gfc_free (label_str);
}
gfc_add_modify_expr (&se.pre, len, len_tree);
@ -1321,41 +1319,56 @@ gfc_trans_logical_select (gfc_code * code)
static tree
gfc_trans_character_select (gfc_code *code)
{
tree init, node, end_label, tmp, type, case_num, label;
tree init, node, end_label, tmp, type, case_num, label, fndecl;
stmtblock_t block, body;
gfc_case *cp, *d;
gfc_code *c;
gfc_se se;
int n;
int n, k;
static tree select_struct;
static tree ss_string1, ss_string1_len;
static tree ss_string2, ss_string2_len;
static tree ss_target;
/* 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];
if (select_struct == NULL)
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[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);

13
gcc/fortran/trans-types.c
View File

@ -874,19 +874,24 @@ gfc_get_pchar_type (int kind)
/* Create a character type with the given kind and length. */
tree
gfc_get_character_type_len (int kind, tree len)
gfc_get_character_type_len_for_eltype (tree eltype, tree len)
{
tree bounds, type;
gfc_validate_kind (BT_CHARACTER, kind, false);
bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
type = build_array_type (gfc_get_char_type (kind), bounds);
type = build_array_type (eltype, bounds);
TYPE_STRING_FLAG (type) = 1;
return type;
}
tree
gfc_get_character_type_len (int kind, tree len)
{
gfc_validate_kind (BT_CHARACTER, kind, false);
return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
}
/* Get a type node for a character kind. */

1
gcc/fortran/trans-types.h
View File

@ -59,6 +59,7 @@ tree gfc_get_char_type (int);
tree gfc_get_pchar_type (int);
tree gfc_get_character_type (int, gfc_charlen *);
tree gfc_get_character_type_len (int, tree);
tree gfc_get_character_type_len_for_eltype (tree, tree);
tree gfc_sym_type (gfc_symbol *);
tree gfc_typenode_for_spec (gfc_typespec *);

7
gcc/fortran/trans.h
View File

@ -504,7 +504,6 @@ extern GTY(()) tree gfor_fndecl_pause_numeric;
extern GTY(()) tree gfor_fndecl_pause_string;
extern GTY(()) tree gfor_fndecl_stop_numeric;
extern GTY(()) tree gfor_fndecl_stop_string;
extern GTY(()) tree gfor_fndecl_select_string;
extern GTY(()) tree gfor_fndecl_runtime_error;
extern GTY(()) tree gfor_fndecl_runtime_error_at;
extern GTY(()) tree gfor_fndecl_os_error;
@ -551,6 +550,7 @@ extern GTY(()) tree gfor_fndecl_string_trim;
extern GTY(()) tree gfor_fndecl_string_minmax;
extern GTY(()) tree gfor_fndecl_adjustl;
extern GTY(()) tree gfor_fndecl_adjustr;
extern GTY(()) tree gfor_fndecl_select_string;
extern GTY(()) tree gfor_fndecl_compare_string_char4;
extern GTY(()) tree gfor_fndecl_concat_string_char4;
extern GTY(()) tree gfor_fndecl_string_len_trim_char4;
@ -561,6 +561,11 @@ extern GTY(()) tree gfor_fndecl_string_trim_char4;
extern GTY(()) tree gfor_fndecl_string_minmax_char4;
extern GTY(()) tree gfor_fndecl_adjustl_char4;
extern GTY(()) tree gfor_fndecl_adjustr_char4;
extern GTY(()) tree gfor_fndecl_select_string_char4;
/* Conversion between character kinds. */
extern GTY(()) tree gfor_fndecl_convert_char1_to_char4;
extern GTY(()) tree gfor_fndecl_convert_char4_to_char1;
/* Other misc. runtime library functions. */
extern GTY(()) tree gfor_fndecl_size0;

17
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,20 @@
2008-05-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* gfortran.dg/achar_3.f90: Adjust error messages.
* gfortran.dg/achar_5.f90: New test.
* gfortran.dg/achar_6.F90: New test.
* gfortran.dg/widechar_1.f90: New test.
* gfortran.dg/widechar_2.f90: New test.
* gfortran.dg/widechar_3.f90: New test.
* gfortran.dg/widechar_4.f90: New test.
* gfortran.dg/widechar_intrinsics_1.f90: New test.
* gfortran.dg/widechar_intrinsics_2.f90: New test.
* gfortran.dg/widechar_intrinsics_3.f90: New test.
* gfortran.dg/widechar_intrinsics_4.f90: New test.
* gfortran.dg/widechar_intrinsics_5.f90: New test.
* gfortran.dg/widechar_select_1.f90: New test.
* gfortran.dg/widechar_select_2.f90: New test.
2008-05-18 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/loop_optimization2.ad[sb]: New test.

6
gcc/testsuite/gfortran.dg/achar_3.f90
View File

@ -1,9 +1,9 @@
! { dg-do compile }
! { dg-options "-Wall" }
program main
print *,achar(-3) ! { dg-warning "outside of range" }
print *,achar(-3) ! { dg-error "negative" }
print *,achar(200) ! { dg-warning "outside of range" }
print *,char(222+221) ! { dg-error "outside of range" }
print *,char(-44) ! { dg-error "outside of range" }
print *,char(222+221) ! { dg-error "too large for the collating sequence" }
print *,char(-44) ! { dg-error "negative" }
print *,iachar("ü") ! { dg-warning "outside of range" }
end program main

45
gcc/testsuite/gfortran.dg/achar_5.f90 Normal file
View File

@ -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

70
gcc/testsuite/gfortran.dg/achar_6.F90 Normal file
View File

@ -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

33
gcc/testsuite/gfortran.dg/widechar_1.f90 Normal file
View File

@ -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

69
gcc/testsuite/gfortran.dg/widechar_2.f90 Normal file
View File

@ -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

112
gcc/testsuite/gfortran.dg/widechar_3.f90 Normal file
View File

@ -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

147
gcc/testsuite/gfortran.dg/widechar_4.f90 Normal file
View File

@ -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

116
gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 Normal file
View File

@ -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

129
gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 Normal file
View File

@ -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

69
gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 Normal file
View File

@ -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

121
gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 Normal file
View File

@ -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

120
gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 Normal file
View File

@ -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

55
gcc/testsuite/gfortran.dg/widechar_select_1.f90 Normal file
View File

@ -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

37
gcc/testsuite/gfortran.dg/widechar_select_2.f90 Normal file
View File

@ -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