* 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
+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
}
+/* 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. */
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;
}
/* 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;
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;
}
{
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;
}
{
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;
{
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;
}
{
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;
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;
}
{
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;
{
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;
}
{
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;
{
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;
}
{
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;
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;
{
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;
{
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)
{
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)
{
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)
{
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)
{
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)
{
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;
}
{
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;
}
{
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;
}
{
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;
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;
}
{
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;
}
{
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;
}
{
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;
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;
}
{
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;
}
{
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;
}
{
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;
{
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;
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)
}
-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))
{
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))
{
c = c >> 4;
buf[2] = xdigit[c & 0x0F];
- buf[1] = '\\';
- buf[0] = 'u';
+ buf[1] = 'u';
+ buf[0] = '\\';
}
else
{
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. */
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');
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);
}
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 *);
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);
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 }
}
+/* 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. */
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);
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);
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,
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,
}
+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)
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. */
{
gfc_free (functions);
gfc_free (conversion);
+ gfc_free (char_conversions);
gfc_free_namespace (gfc_intrinsic_namespace);
}
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 "
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;
}
&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;
+}
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 *);
/* 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 *);
@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}:
@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
@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
@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.
@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.
@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}:
@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
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
@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}:
@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.
@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}:
@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}:
@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}:
@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}:
@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
@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}:
@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
@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
@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}:
@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}:
@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.
@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}:
@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}:
@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.
}
+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)
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");
+ }
}
case BT_REAL:
case BT_INTEGER:
case BT_LOGICAL:
+ case BT_CHARACTER:
kind = source->ts.kind;
break;
= 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;
}
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])
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;
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);
}
{
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;
}
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;
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;
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;
}
return result;
}
-/* We use the processor's collating sequence, because all
- systems that gfortran currently works on are ASCII. */
-gfc_expr *
-gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+static gfc_expr *
+simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
{
gfc_expr *result;
- int c, kind;
- const char *ch;
+ int kind;
+ bool too_large = false;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
+ kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
if (kind == -1)
return &gfc_bad_expr;
- ch = gfc_extract_int (e, &c);
+ if (mpz_cmp_si (e->value.integer, 0) < 0)
+ {
+ gfc_error ("Argument of %s function at %L is negative", name,
+ &e->where);
+ return &gfc_bad_expr;
+ }
- if (ch != NULL)
- gfc_internal_error ("gfc_simplify_achar: %s", ch);
+ if (ascii && gfc_option.warn_surprising
+ && mpz_cmp_si (e->value.integer, 127) > 0)
+ gfc_warning ("Argument of %s function at %L outside of range [0,127]",
+ name, &e->where);
- if (gfc_option.warn_surprising && (c < 0 || c > 127))
- gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
- &e->where);
+ if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
+ too_large = true;
+ else if (kind == 4)
+ {
+ mpz_t t;
+ mpz_init_set_ui (t, 2);
+ mpz_pow_ui (t, t, 32);
+ mpz_sub_ui (t, t, 1);
+ if (mpz_cmp (e->value.integer, t) > 0)
+ too_large = true;
+ mpz_clear (t);
+ }
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ if (too_large)
+ {
+ gfc_error ("Argument of %s function at %L is too large for the "
+ "collating sequence of kind %d", name, &e->where, kind);
+ return &gfc_bad_expr;
+ }
+ result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
result->value.character.string = gfc_get_wide_string (2);
-
result->value.character.length = 1;
- result->value.character.string[0] = c;
+ result->value.character.string[0] = mpz_get_ui (e->value.integer);
result->value.character.string[1] = '\0'; /* For debugger */
return result;
}
+
+/* We use the processor's collating sequence, because all
+ systems that gfortran currently works on are ASCII. */
+
+gfc_expr *
+gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+{
+ return simplify_achar_char (e, k, "ACHAR", true);
+}
+
+
gfc_expr *
gfc_simplify_acos (gfc_expr *x)
{
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);
}
}
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;
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;
+}
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;
}
}
-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;
}
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;
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:
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. */
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)
{
{
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;
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;
{
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++;
/* 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;
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);
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
+#include "target-memory.h"
tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
return val;
}
+/* Build a string constant with C char type. */
+
tree
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. */
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);
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;
}
gfc_conv_constant_to_tree (gfc_expr * expr)
{
tree res;
- char *s;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
}
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:
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 *);
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;
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;
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. */
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")),
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 =
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);
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);
}
{
/* 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. */
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);
/* 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);
}
{
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);
}
}
}
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)
{
}
+/* 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;
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
{
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
{
}
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;
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
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);
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),
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);
}
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;
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;
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,
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)
{
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
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;
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));
}
{
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));
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,
/* 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));
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. */
tree len;
tree addr;
tree len_tree;
- char *label_str;
int label_len;
/* Start a new block. */
}
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);
static tree
gfc_trans_character_select (gfc_code *code)
{
- tree init, node, end_label, tmp, type, case_num, label;
+ tree init, node, end_label, tmp, type, case_num, label, fndecl;
stmtblock_t block, body;
gfc_case *cp, *d;
gfc_code *c;
gfc_se se;
- int n;
+ int n, k;
+
+ /* The jump table types are stored in static variables to avoid
+ constructing them from scratch every single time. */
+ static tree select_struct[2];
+ static tree ss_string1[2], ss_string1_len[2];
+ static tree ss_string2[2], ss_string2_len[2];
+ static tree ss_target[2];
- static tree select_struct;
- static tree ss_string1, ss_string1_len;
- static tree ss_string2, ss_string2_len;
- static tree ss_target;
+ tree pchartype = gfc_get_pchar_type (code->expr->ts.kind);
+
+ if (code->expr->ts.kind == 1)
+ k = 0;
+ else if (code->expr->ts.kind == 4)
+ k = 1;
+ else
+ gcc_unreachable ();
- if (select_struct == NULL)
+ if (select_struct[k] == NULL)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
+ select_struct[k] = make_node (RECORD_TYPE);
- select_struct = make_node (RECORD_TYPE);
- TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
+ if (code->expr->ts.kind == 1)
+ TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
+ else if (code->expr->ts.kind == 4)
+ TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
+ else
+ gcc_unreachable ();
#undef ADD_FIELD
-#define ADD_FIELD(NAME, TYPE) \
- ss_##NAME = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (select_struct)), select_struct, \
+#define ADD_FIELD(NAME, TYPE) \
+ ss_##NAME[k] = gfc_add_field_to_struct \
+ (&(TYPE_FIELDS (select_struct[k])), select_struct[k], \
get_identifier (stringize(NAME)), TYPE)
- ADD_FIELD (string1, pchar_type_node);
- ADD_FIELD (string1_len, gfc_int4_type_node);
+ ADD_FIELD (string1, pchartype);
+ ADD_FIELD (string1_len, gfc_charlen_type_node);
- ADD_FIELD (string2, pchar_type_node);
- ADD_FIELD (string2_len, gfc_int4_type_node);
+ ADD_FIELD (string2, pchartype);
+ ADD_FIELD (string2_len, gfc_charlen_type_node);
ADD_FIELD (target, integer_type_node);
#undef ADD_FIELD
- gfc_finish_type (select_struct);
+ gfc_finish_type (select_struct[k]);
}
cp = code->block->ext.case_list;
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;
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);
/* 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. */
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 *);
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;
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;
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;
+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.
! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+ 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / platform / upstream / gcc.git / commitdiff