diff options
author | Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2008-05-28 21:11:39 +0000 |
---|---|---|
committer | François-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2008-05-28 21:11:39 +0000 |
commit | 691da334bca13d0056d6d6e6f919995c1f1f9e4e (patch) | |
tree | a956a38d25628c3640e2911e48de624e53210afa | |
parent | b608a1bc71edb6b778407dd9bfdf0cbd6bcb4c1b (diff) | |
download | gcc-691da334bca13d0056d6d6e6f919995c1f1f9e4e.zip gcc-691da334bca13d0056d6d6e6f919995c1f1f9e4e.tar.gz gcc-691da334bca13d0056d6d6e6f919995c1f1f9e4e.tar.bz2 |
re PR fortran/36319 (Segfault with wide characters in DATA)
PR fortran/36319
* intrinsic.c (gfc_convert_chartype): Don't mark conversion
function as pure.
* trans-array.c (gfc_trans_array_ctor_element): Divide element
size by the size of one character to obtain length.
* iresolve.c (gfc_resolve_cshift): Call the _char4 variant when
appropriate.
(gfc_resolve_eoshift): Likewise.
* trans-intrinsic.c (gfc_conv_intrinsic_ctime): Minor beautification.
(gfc_conv_intrinsic_fdate): Minor beautification.
(gfc_conv_intrinsic_ttynam): Minor beautification.
(gfc_conv_intrinsic_minmax_char): Allow all character kinds.
(size_of_string_in_bytes): New function.
(gfc_conv_intrinsic_size): Call size_of_string_in_bytes for
character expressions.
(gfc_conv_intrinsic_sizeof): Likewise.
(gfc_conv_intrinsic_array_transfer): Likewise.
(gfc_conv_intrinsic_trim): Allow all character kinds. Minor
beautification.
(gfc_conv_intrinsic_repeat): Fix comment typo.
* simplify.c (gfc_convert_char_constant): Take care of conversion
of array constructors.
* intrinsics/string_intrinsics_inc.c (string_index): Return
correct value for zero-length substring.
* intrinsics/cshift0.c: Add _char4 variant.
* intrinsics/eoshift0.c (eoshift0): Allow filler to be a pattern
wider than a single byte. Add _char4 variant and use above
functionality.
* intrinsics/eoshift2.c (eoshift2): Likewise.
* m4/eoshift1.m4: Likewise.
* m4/eoshift3.m4: Likewise.
* m4/cshift1.m4: Add _char4 variants.
* gfortran.map (GFORTRAN_1.1): Add _gfortran_cshift0_1_char4,
_gfortran_cshift0_2_char4, _gfortran_cshift0_4_char4,
_gfortran_cshift0_8_char4, _gfortran_cshift1_16_char4,
_gfortran_cshift1_4_char4, _gfortran_cshift1_8_char4,
_gfortran_eoshift0_1_char4, _gfortran_eoshift0_2_char4,
_gfortran_eoshift0_4_char4, _gfortran_eoshift0_8_char4,
_gfortran_eoshift1_16_char4, _gfortran_eoshift1_4_char4,
_gfortran_eoshift1_8_char4, _gfortran_eoshift2_1_char4,
_gfortran_eoshift2_2_char4, _gfortran_eoshift2_4_char4,
_gfortran_eoshift2_8_char4, _gfortran_eoshift3_16_char4,
_gfortran_eoshift3_4_char4 and _gfortran_eoshift3_8_char4.
* generated/eoshift3_4.c: Regenerate.
* generated/eoshift1_8.c: Regenerate.
* generated/eoshift1_16.c: Regenerate.
* generated/cshift1_4.c: Regenerate.
* generated/eoshift1_4.c: Regenerate.
* generated/eoshift3_8.c: Regenerate.
* generated/eoshift3_16.c: Regenerate.
* generated/cshift1_8.c: Regenerate.
* generated/cshift1_16.c: Regenerate.
* gfortran.dg/widechar_5.f90: New file.
* gfortran.dg/widechar_6.f90: New file.
* gfortran.dg/widechar_7.f90: New file.
* gfortran.dg/widechar_intrinsics_5.f90: Uncomment the lines
testing the SPREAD intrinsic.
* gfortran.dg/widechar_intrinsics_6.f90: New file.
* gfortran.dg/widechar_intrinsics_7.f90: New file.
* gfortran.dg/widechar_intrinsics_8.f90: New file.
* gfortran.dg/widechar_intrinsics_9.f90: New file.
* gfortran.dg/widechar_intrinsics_10.f90: New file.
From-SVN: r136129
34 files changed, 1339 insertions, 112 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d879a4c..1995f6a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,28 @@ +2008-05-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36319 + * intrinsic.c (gfc_convert_chartype): Don't mark conversion + function as pure. + * trans-array.c (gfc_trans_array_ctor_element): Divide element + size by the size of one character to obtain length. + * iresolve.c (gfc_resolve_cshift): Call the _char4 variant when + appropriate. + (gfc_resolve_eoshift): Likewise. + * trans-intrinsic.c (gfc_conv_intrinsic_ctime): Minor beautification. + (gfc_conv_intrinsic_fdate): Minor beautification. + (gfc_conv_intrinsic_ttynam): Minor beautification. + (gfc_conv_intrinsic_minmax_char): Allow all character kinds. + (size_of_string_in_bytes): New function. + (gfc_conv_intrinsic_size): Call size_of_string_in_bytes for + character expressions. + (gfc_conv_intrinsic_sizeof): Likewise. + (gfc_conv_intrinsic_array_transfer): Likewise. + (gfc_conv_intrinsic_trim): Allow all character kinds. Minor + beautification. + (gfc_conv_intrinsic_repeat): Fix comment typo. + * simplify.c (gfc_convert_char_constant): Take care of conversion + of array constructors. + 2008-05-27 Tobias Burnus <burnus@net-b.de> PR fortran/36316 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index e902f69..62ee442 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3807,7 +3807,6 @@ gfc_convert_chartype (gfc_expr *expr, gfc_typespec *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); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 94ed4a6..acbf5be 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -627,9 +627,19 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, } } - f->value.function.name - = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind, - array->ts.type == BT_CHARACTER ? "_char" : ""); + if (array->ts.type == BT_CHARACTER) + { + if (array->ts.kind == gfc_default_character_kind) + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind, + array->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind); } @@ -768,9 +778,19 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, } } - f->value.function.name - = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind, - array->ts.type == BT_CHARACTER ? "_char" : ""); + if (array->ts.type == BT_CHARACTER) + { + if (array->ts.kind == gfc_default_character_kind) + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind, + array->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind); } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 8c1c6b3..59b425f 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4811,26 +4811,75 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) 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); + if (e->expr_type == EXPR_CONSTANT) + { + /* Simple case of a scalar. */ + result = gfc_constant_result (BT_CHARACTER, kind, &e->where); + if (result == NULL) return &gfc_bad_expr; - } - return result; + 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; + } + else if (e->expr_type == EXPR_ARRAY) + { + /* For an array constructor, we convert each constructor element. */ + gfc_constructor *head = NULL, *tail = NULL, *c; + + for (c = e->value.constructor; c; c = c->next) + { + if (head == NULL) + head = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + + tail->where = c->where; + tail->expr = gfc_convert_char_constant (c->expr, type, kind); + if (tail->expr == &gfc_bad_expr) + { + tail->expr = NULL; + return &gfc_bad_expr; + } + + if (tail->expr == NULL) + { + gfc_free_constructor (head); + return NULL; + } + } + + result = gfc_get_expr (); + result->ts.type = type; + result->ts.kind = kind; + result->expr_type = EXPR_ARRAY; + result->value.constructor = head; + result->shape = gfc_copy_shape (e->shape, e->rank); + result->where = e->where; + result->rank = e->rank; + result->ts.cl = e->ts.cl; + + return result; + } + else + return NULL; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index bc6d13a..7df192c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -969,7 +969,6 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, tree offset, gfc_se * se, gfc_expr * expr) { tree tmp; - tree esize; gfc_conv_expr (se, expr); @@ -977,11 +976,17 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc)); tmp = gfc_build_array_ref (tmp, offset, NULL); - esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); - esize = fold_convert (gfc_charlen_type_node, esize); - if (expr->ts.type == BT_CHARACTER) { + int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); + tree esize; + + esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); + esize = fold_convert (gfc_charlen_type_node, esize); + esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize, + build_int_cst (gfc_charlen_type_node, + gfc_character_kinds[i].bit_size / 8)); + gfc_conv_string_parameter (se); if (POINTER_TYPE_P (TREE_TYPE (tmp))) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 990a127..73e14a3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1327,9 +1327,7 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; - tree gfc_int8_type_node = gfc_get_int_type (8); tree fndecl; tree *args; unsigned int num_args; @@ -1337,9 +1335,8 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) num_args = gfc_intrinsic_argument_list_length (expr) + 2; args = alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int8_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (8), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = build_fold_addr_expr (var); @@ -1368,9 +1365,7 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; - tree gfc_int4_type_node = gfc_get_int_type (4); tree fndecl; tree *args; unsigned int num_args; @@ -1378,9 +1373,8 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) num_args = gfc_intrinsic_argument_list_length (expr) + 2; args = alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int4_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = build_fold_addr_expr (var); @@ -1411,19 +1405,16 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; tree fndecl; - tree gfc_int4_type_node = gfc_get_int_type (4); tree *args; unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; args = alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int4_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = build_fold_addr_expr (var); @@ -1551,7 +1542,7 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) /* Create the result variables. */ len = gfc_create_var (gfc_charlen_type_node, "len"); args[0] = build_fold_addr_expr (len); - var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr"); + var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); args[1] = gfc_build_addr_expr (ppvoid_type_node, var); args[2] = build_int_cst (NULL_TREE, op); args[3] = build_int_cst (NULL_TREE, nargs / 2); @@ -3237,6 +3228,24 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) } +/* Helper function to compute the size of a character variable, + excluding the terminating null characters. The result has + gfc_array_index_type type. */ + +static tree +size_of_string_in_bytes (int kind, tree string_length) +{ + tree bytesize; + int i = gfc_validate_kind (BT_CHARACTER, kind, false); + + bytesize = build_int_cst (gfc_array_index_type, + gfc_character_kinds[i].bit_size / 8); + + return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize, + fold_convert (gfc_array_index_type, string_length)); +} + + static void gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) { @@ -3249,7 +3258,6 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) tree tmp; tree lower; tree upper; - /*tree stride;*/ int n; arg = expr->value.function.actual->expr; @@ -3268,8 +3276,8 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) /* Obtain the source word length. */ if (arg->ts.type == BT_CHARACTER) - source_bytes = fold_convert (gfc_array_index_type, - argse.string_length); + source_bytes = size_of_string_in_bytes (arg->ts.kind, + argse.string_length); else source_bytes = fold_convert (gfc_array_index_type, size_in_bytes (type)); @@ -3283,7 +3291,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) /* Obtain the argument's word length. */ if (arg->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (type)); @@ -3404,7 +3412,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) /* Obtain the source word length. */ if (arg->expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (source_type)); @@ -3443,7 +3452,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) /* Obtain the source word length. */ if (arg->expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (source_type)); @@ -3495,7 +3505,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) if (arg->expr->ts.type == BT_CHARACTER) { - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp); } else @@ -3869,12 +3879,10 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) static void gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) { - tree gfc_int4_type_node = gfc_get_int_type (4); tree var; tree len; tree addr; tree tmp; - tree type; tree cond; tree fndecl; tree function; @@ -3884,10 +3892,9 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) num_args = gfc_intrinsic_argument_list_length (expr) + 2; args = alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); + var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); addr = gfc_build_addr_expr (ppvoid_type_node, var); - len = gfc_create_var (gfc_int4_type_node, "len"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = build_fold_addr_expr (len); @@ -3928,7 +3935,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) stmtblock_t block, body; int i; - /* We store in charsize the size of an character. */ + /* We store in charsize the size of a 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b715c2d..1a33d2e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2008-05-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36319 + * gfortran.dg/widechar_5.f90: New file. + * gfortran.dg/widechar_6.f90: New file. + * gfortran.dg/widechar_7.f90: New file. + * gfortran.dg/widechar_intrinsics_5.f90: Uncomment the lines + testing the SPREAD intrinsic. + * gfortran.dg/widechar_intrinsics_6.f90: New file. + * gfortran.dg/widechar_intrinsics_7.f90: New file. + * gfortran.dg/widechar_intrinsics_8.f90: New file. + * gfortran.dg/widechar_intrinsics_9.f90: New file. + * gfortran.dg/widechar_intrinsics_10.f90: New file. + 2008-05-28 Seongbae Park <seongbae.park@gmail.com> * gcc.dg/tree-prof/ic-misattribution-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/widechar_5.f90 b/gcc/testsuite/gfortran.dg/widechar_5.f90 new file mode 100644 index 0000000..ed2f32f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_5.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + +module kinds + implicit none + integer, parameter :: one = 1, four = 4 +end module kinds + +module inner + use kinds + implicit none + character(kind=one,len=*), parameter :: inner1 = "abcdefg \xEF kl" + character(kind=four,len=*), parameter :: & + inner4 = 4_"\u9317x \U001298cef dea\u10De" +end module inner + +module middle + use inner + implicit none + character(kind=one,len=len(inner1)), dimension(2,2), parameter :: middle1 & + = reshape ([ character(kind=one,len=len(inner1)) :: inner1, ""], & + [ 2, 2 ], & + [ character(kind=one,len=len(inner1)) :: "foo", "ba " ]) + character(kind=four,len=len(inner4)), dimension(2,2), parameter :: middle4 & + = reshape ([ character(kind=four,len=len(inner4)) :: inner4, 4_""], & + [ 2, 2 ], & + [ character(kind=four,len=len(inner4)) :: 4_"foo", 4_"ba " ]) +end module middle + +module outer + use middle + implicit none + character(kind=one,len=*), parameter :: my1(2) = middle1(1,:) + character(kind=four,len=*), parameter :: my4(2) = middle4(1,:) +end module outer + +program test_modules + use outer, outer1 => my1, outer4 => my4 + implicit none + + if (len (inner1) /= len(inner4)) call abort + if (len (inner1) /= len_trim(inner1)) call abort + if (len (inner4) /= len_trim(inner4)) call abort + + if (len(middle1) /= len(inner1)) call abort + if (len(outer1) /= len(inner1)) call abort + if (len(middle4) /= len(inner4)) call abort + if (len(outer4) /= len(inner4)) call abort + + if (any (len_trim (middle1) /= reshape([len(middle1), 0, 3, 2], [2,2]))) & + call abort + if (any (len_trim (middle4) /= reshape([len(middle4), 0, 3, 2], [2,2]))) & + call abort + if (any (len_trim (outer1) /= [len(outer1), 3])) call abort + if (any (len_trim (outer4) /= [len(outer4), 3])) call abort + +end program test_modules + +! { dg-final { cleanup-modules "kinds inner middle outer" } } diff --git a/gcc/testsuite/gfortran.dg/widechar_6.f90 b/gcc/testsuite/gfortran.dg/widechar_6.f90 new file mode 100644 index 0000000..9151adb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_6.f90 @@ -0,0 +1,64 @@ +! { dg-do run } + +module mod + + interface cut + module procedure cut1 + module procedure cut4 + end interface cut + +contains + + function cut1 (s) + character(kind=1,len=*), intent(in) :: s + character(kind=1,len=max(0,len(s)-3)) :: cut1 + + cut1 = s(4:) + end function cut1 + + function cut4 (s) + character(kind=4,len=*), intent(in) :: s + character(kind=4,len=max(0,len(s)-3)) :: cut4 + + cut4 = s(4:) + end function cut4 + +end module mod + +program test + use mod + + if (len (cut1("")) /= 0 .or. cut1("") /= "") call abort + if (len (cut1("1")) /= 0 .or. cut1("") /= "") call abort + if (len (cut1("12")) /= 0 .or. cut1("") /= "") call abort + if (len (cut1("123")) /= 0 .or. cut1("") /= "") call abort + if (len (cut1("1234")) /= 1 .or. cut1("4") /= "") call abort + if (len (cut1("12345")) /= 2 .or. cut1("45") /= "") call abort + + if (len (cut4(4_"")) /= 0 .or. cut4(4_"") /= 4_"") call abort + if (len (cut4(4_"1")) /= 0 .or. cut4(4_"") /= 4_"") call abort + if (len (cut4(4_"12")) /= 0 .or. cut4(4_"") /= 4_"") call abort + if (len (cut4(4_"123")) /= 0 .or. cut4(4_"") /= 4_"") call abort + if (len (cut4(4_"1234")) /= 1 .or. cut4(4_"4") /= 4_"") call abort + if (len (cut4(4_"12345")) /= 2 .or. cut4(4_"45") /= 4_"") call abort + + if (kind (cut("")) /= kind("")) call abort + if (kind (cut(4_"")) /= kind(4_"")) call abort + + if (len (cut("")) /= 0 .or. cut("") /= "") call abort + if (len (cut("1")) /= 0 .or. cut("") /= "") call abort + if (len (cut("12")) /= 0 .or. cut("") /= "") call abort + if (len (cut("123")) /= 0 .or. cut("") /= "") call abort + if (len (cut("1234")) /= 1 .or. cut("4") /= "") call abort + if (len (cut("12345")) /= 2 .or. cut("45") /= "") call abort + + if (len (cut(4_"")) /= 0 .or. cut(4_"") /= 4_"") call abort + if (len (cut(4_"1")) /= 0 .or. cut(4_"") /= 4_"") call abort + if (len (cut(4_"12")) /= 0 .or. cut(4_"") /= 4_"") call abort + if (len (cut(4_"123")) /= 0 .or. cut(4_"") /= 4_"") call abort + if (len (cut(4_"1234")) /= 1 .or. cut(4_"4") /= 4_"") call abort + if (len (cut(4_"12345")) /= 2 .or. cut(4_"45") /= 4_"") call abort + +end program test + +! { dg-final { cleanup-modules "mod" } } diff --git a/gcc/testsuite/gfortran.dg/widechar_7.f90 b/gcc/testsuite/gfortran.dg/widechar_7.f90 new file mode 100644 index 0000000..4368321 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_7.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } + +program test + + character(kind=1,len=10) :: s1 = 4_"foobargee", t1 = 4_"" + character(kind=4,len=10) :: s4 = "foobargee", t4 = "" + + t1(5:5) = s1(6:6) + t4(5:5) = s4(6:6) + t4(5:5) = s1(6:6) + t1(5:5) = s4(6:6) + + call sub (t1, t4) + +end program test + +! { dg-final { scan-tree-dump-times "memmove" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 new file mode 100644 index 0000000..c961d93 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + implicit none + character(kind=1,len=3) :: s1(3) + character(kind=4,len=3) :: s4(3) + + s1 = [ "abc", "def", "ghi" ] + s4 = s1 + s4 = [ "abc", "def", "ghi" ] + + if (any (cshift (s1, 0) /= s1)) call abort + if (any (cshift (s4, 0) /= s4)) call abort + if (any (cshift (s1, 3) /= s1)) call abort + if (any (cshift (s4, 3) /= s4)) call abort + if (any (cshift (s1, 6) /= s1)) call abort + if (any (cshift (s4, 6) /= s4)) call abort + if (any (cshift (s1, -3) /= s1)) call abort + if (any (cshift (s4, -3) /= s4)) call abort + if (any (cshift (s1, -6) /= s1)) call abort + if (any (cshift (s4, -6) /= s4)) call abort + + if (any (cshift (s1, 1) /= [ s1(2:3), s1(1) ])) call abort + if (any (cshift (s1, -1) /= [ s1(3), s1(1:2) ])) call abort + if (any (cshift (s1, 4) /= [ s1(2:3), s1(1) ])) call abort + if (any (cshift (s1, -4) /= [ s1(3), s1(1:2) ])) call abort + + if (any (cshift (s4, 1) /= [ s4(2:3), s4(1) ])) call abort + if (any (cshift (s4, -1) /= [ s4(3), s4(1:2) ])) call abort + if (any (cshift (s4, 4) /= [ s4(2:3), s4(1) ])) call abort + if (any (cshift (s4, -4) /= [ s4(3), s4(1:2) ])) call abort + + if (any (cshift (s1, 2) /= [ s1(3), s1(1:2) ])) call abort + if (any (cshift (s1, -2) /= [ s1(2:3), s1(1) ])) call abort + if (any (cshift (s1, 5) /= [ s1(3), s1(1:2) ])) call abort + if (any (cshift (s1, -5) /= [ s1(2:3), s1(1) ])) call abort + + if (any (cshift (s4, 2) /= [ s4(3), s4(1:2) ])) call abort + if (any (cshift (s4, -2) /= [ s4(2:3), s4(1) ])) call abort + if (any (cshift (s4, 5) /= [ s4(3), s4(1:2) ])) call abort + if (any (cshift (s4, -5) /= [ s4(2:3), s4(1) ])) call abort + + + if (any (eoshift (s1, 0) /= s1)) call abort + if (any (eoshift (s4, 0) /= s4)) call abort + if (any (eoshift (s1, 3) /= "")) call abort + if (any (eoshift (s4, 3) /= 4_"")) call abort + if (any (eoshift (s1, 3, " ") /= "")) call abort + if (any (eoshift (s4, 3, 4_" ") /= 4_"")) call abort + if (any (eoshift (s1, 3, " x ") /= " x")) call abort + if (any (eoshift (s4, 3, 4_" x ") /= 4_" x")) call abort + if (any (eoshift (s1, -3) /= "")) call abort + if (any (eoshift (s4, -3) /= 4_"")) call abort + if (any (eoshift (s1, -3, " ") /= "")) call abort + if (any (eoshift (s4, -3, 4_" ") /= 4_"")) call abort + if (any (eoshift (s1, -3, " x ") /= " x")) call abort + if (any (eoshift (s4, -3, 4_" x ") /= 4_" x")) call abort + if (any (eoshift (s1, 4) /= "")) call abort + if (any (eoshift (s4, 4) /= 4_"")) call abort + if (any (eoshift (s1, 4, " ") /= "")) call abort + if (any (eoshift (s4, 4, 4_" ") /= 4_"")) call abort + if (any (eoshift (s1, 4, " x ") /= " x")) call abort + if (any (eoshift (s4, 4, 4_" x ") /= 4_" x")) call abort + if (any (eoshift (s1, -4) /= "")) call abort + if (any (eoshift (s4, -4) /= 4_"")) call abort + if (any (eoshift (s1, -4, " ") /= "")) call abort + if (any (eoshift (s4, -4, 4_" ") /= 4_"")) call abort + if (any (eoshift (s1, -4, " x ") /= " x")) call abort + if (any (eoshift (s4, -4, 4_" x ") /= 4_" x")) call abort + + if (any (eoshift (s1, 1) /= [ s1(2:3), " " ])) call abort + if (any (eoshift (s1, -1) /= [ " ", s1(1:2) ])) call abort + if (any (eoshift (s1, 1, " x ") /= [ s1(2:3), " x " ])) call abort + if (any (eoshift (s1, -1, " x ") /= [ " x ", s1(1:2) ])) call abort + if (any (eoshift (s4, 1) /= [ s4(2:3), 4_" " ])) call abort + if (any (eoshift (s4, -1) /= [ 4_" ", s4(1:2) ])) call abort + if (any (eoshift (s4, 1, 4_" x ") /= [ s4(2:3), 4_" x " ])) call abort + if (any (eoshift (s4, -1, 4_" x ") /= [ 4_" x ", s4(1:2) ])) call abort + + if (any (eoshift (s1, 2) /= [ s1(3), " ", " " ])) call abort + if (any (eoshift (s1, -2) /= [ " ", " ", s1(1) ])) call abort + if (any (eoshift (s1, 2, " x ") /= [ s1(3), " x ", " x " ])) call abort + if (any (eoshift (s1, -2, " x ") /= [ " x ", " x ", s1(1) ])) call abort + if (any (eoshift (s4, 2) /= [ s4(3), 4_" ", 4_" " ])) call abort + if (any (eoshift (s4, -2) /= [ 4_" ", 4_" ", s4(1) ])) call abort + if (any (eoshift (s4, 2, 4_" x ") /= [ s4(3), 4_" x ", 4_" x " ])) call abort + if (any (eoshift (s4, -2, 4_" x ") /= [ 4_" x ", 4_" x ", s4(1) ])) call abort + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 index 5c989cc..e388685 100644 --- a/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 @@ -70,15 +70,13 @@ 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 (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 diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_6.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_6.f90 new file mode 100644 index 0000000..68b46d8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_6.f90 @@ -0,0 +1,109 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1, len=3) :: s1 + character(kind=4, len=3) :: s4 + integer :: i + + s1 = "fo " + s4 = 4_"fo " + i = 3 + + ! Check the REPEAT intrinsic + + if (repeat (1_"foo", 2) /= 1_"foofoo") call abort + if (repeat (1_"fo ", 2) /= 1_"fo fo ") call abort + if (repeat (1_"fo ", 2) /= 1_"fo fo") call abort + if (repeat (1_"fo ", 0) /= 1_"") call abort + if (repeat (s1, 2) /= 1_"fo fo ") call abort + if (repeat (s1, 2) /= 1_"fo fo") call abort + if (repeat (s1, 2) /= s1 // s1) call abort + if (repeat (s1, 3) /= s1 // s1 // s1) call abort + if (repeat (s1, 1) /= s1) call abort + if (repeat (s1, 0) /= "") call abort + + if (repeat (4_"foo", 2) /= 4_"foofoo") call abort + if (repeat (4_"fo ", 2) /= 4_"fo fo ") call abort + if (repeat (4_"fo ", 2) /= 4_"fo fo") call abort + if (repeat (4_"fo ", 0) /= 4_"") call abort + if (repeat (s4, 2) /= 4_"fo fo ") call abort + if (repeat (s4, 2) /= 4_"fo fo") call abort + if (repeat (s4, 3) /= s4 // s4 // s4) call abort + if (repeat (s4, 1) /= s4) call abort + if (repeat (s4, 0) /= 4_"") call abort + + call check_repeat (s1, s4) + call check_repeat ("", 4_"") + call check_repeat ("truc", 4_"truc") + call check_repeat ("truc ", 4_"truc ") + + ! Check NEW_LINE + + if (ichar(new_line ("")) /= 10) call abort + if (len(new_line ("")) /= 1) call abort + if (ichar(new_line (s1)) /= 10) call abort + if (len(new_line (s1)) /= 1) call abort + if (ichar(new_line (["",""])) /= 10) call abort + if (len(new_line (["",""])) /= 1) call abort + if (ichar(new_line ([s1,s1])) /= 10) call abort + if (len(new_line ([s1,s1])) /= 1) call abort + + if (ichar(new_line (4_"")) /= 10) call abort + if (len(new_line (4_"")) /= 1) call abort + if (ichar(new_line (s4)) /= 10) call abort + if (len(new_line (s4)) /= 1) call abort + if (ichar(new_line ([4_"",4_""])) /= 10) call abort + if (len(new_line ([4_"",4_""])) /= 1) call abort + if (ichar(new_line ([s4,s4])) /= 10) call abort + if (len(new_line ([s4,s4])) /= 1) call abort + + ! Check SIZEOF + + if (sizeof ("") /= 0) call abort + if (sizeof (4_"") /= 0) call abort + if (sizeof ("x") /= 1) call abort + if (sizeof ("\xFF") /= 1) call abort + if (sizeof (4_"x") /= 4) call abort + if (sizeof (4_"\UFFFFFFFF") /= 4) call abort + if (sizeof (s1) /= 3) call abort + if (sizeof (s4) /= 12) call abort + + if (sizeof (["a", "x", "z"]) / sizeof ("a") /= 3) call abort + if (sizeof ([4_"a", 4_"x", 4_"z"]) / sizeof (4_"a") /= 3) call abort + + call check_sizeof ("", 4_"", 0) + call check_sizeof ("x", 4_"x", 1) + call check_sizeof ("\xFF", 4_"\UFEBCE19E", 1) + call check_sizeof ("\xFF ", 4_"\UFEBCE19E ", 2) + call check_sizeof (s1, s4, 3) + +contains + + subroutine check_repeat (s1, s4) + character(kind=1, len=*), intent(in) :: s1 + character(kind=4, len=*), intent(in) :: s4 + integer :: i + + do i = 0, 10 + if (len (repeat(s1, i)) /= i * len(s1)) call abort + if (len (repeat(s4, i)) /= i * len(s4)) call abort + + if (len_trim (repeat(s1, i)) & + /= max(0, (i - 1) * len(s1) + len_trim (s1))) call abort + if (len_trim (repeat(s4, i)) & + /= max(0, (i - 1) * len(s4) + len_trim (s4))) call abort + end do + end subroutine check_repeat + + subroutine check_sizeof (s1, s4, i) + character(kind=1, len=*), intent(in) :: s1 + character(kind=4, len=*), intent(in) :: s4 + character(kind=4, len=len(s4)) :: t4 + integer, intent(in) :: i + + if (sizeof (s1) /= i) call abort + if (sizeof (s4) / sizeof (4_" ") /= i) call abort + if (sizeof (t4) / sizeof (4_" ") /= i) call abort + end subroutine check_sizeof + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_7.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_7.f90 new file mode 100644 index 0000000..7971af3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_7.f90 @@ -0,0 +1,125 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1, len=10) :: s1, t1 + character(kind=4, len=10) :: s4, t4 + + call check1("foobargeefoobargee", "arg", & + [ index ("foobargeefoobargee", "arg", .true.), & + index ("foobargeefoobargee", "arg", .false.), & + scan ("foobargeefoobargee", "arg", .true.), & + scan ("foobargeefoobargee", "arg", .false.), & + verify ("foobargeefoobargee", "arg", .true.), & + verify ("foobargeefoobargee", "arg", .false.) ], & + 4_"foobargeefoobargee", 4_"arg", & + [ index (4_"foobargeefoobargee", 4_"arg", .true.), & + index (4_"foobargeefoobargee", 4_"arg", .false.), & + scan (4_"foobargeefoobargee", 4_"arg", .true.), & + scan (4_"foobargeefoobargee", 4_"arg", .false.), & + verify (4_"foobargeefoobargee", 4_"arg", .true.), & + verify (4_"foobargeefoobargee", 4_"arg", .false.) ]) + + call check1("foobargeefoobargee", "", & + [ index ("foobargeefoobargee", "", .true.), & + index ("foobargeefoobargee", "", .false.), & + scan ("foobargeefoobargee", "", .true.), & + scan ("foobargeefoobargee", "", .false.), & + verify ("foobargeefoobargee", "", .true.), & + verify ("foobargeefoobargee", "", .false.) ], & + 4_"foobargeefoobargee", 4_"", & + [ index (4_"foobargeefoobargee", 4_"", .true.), & + index (4_"foobargeefoobargee", 4_"", .false.), & + scan (4_"foobargeefoobargee", 4_"", .true.), & + scan (4_"foobargeefoobargee", 4_"", .false.), & + verify (4_"foobargeefoobargee", 4_"", .true.), & + verify (4_"foobargeefoobargee", 4_"", .false.) ]) + call check1("foobargeefoobargee", "klm", & + [ index ("foobargeefoobargee", "klm", .true.), & + index ("foobargeefoobargee", "klm", .false.), & + scan ("foobargeefoobargee", "klm", .true.), & + scan ("foobargeefoobargee", "klm", .false.), & + verify ("foobargeefoobargee", "klm", .true.), & + verify ("foobargeefoobargee", "klm", .false.) ], & + 4_"foobargeefoobargee", 4_"klm", & + [ index (4_"foobargeefoobargee", 4_"klm", .true.), & + index (4_"foobargeefoobargee", 4_"klm", .false.), & + scan (4_"foobargeefoobargee", 4_"klm", .true.), & + scan (4_"foobargeefoobargee", 4_"klm", .false.), & + verify (4_"foobargeefoobargee", 4_"klm", .true.), & + verify (4_"foobargeefoobargee", 4_"klm", .false.) ]) + call check1("foobargeefoobargee", "gee", & + [ index ("foobargeefoobargee", "gee", .true.), & + index ("foobargeefoobargee", "gee", .false.), & + scan ("foobargeefoobargee", "gee", .true.), & + scan ("foobargeefoobargee", "gee", .false.), & + verify ("foobargeefoobargee", "gee", .true.), & + verify ("foobargeefoobargee", "gee", .false.) ], & + 4_"foobargeefoobargee", 4_"gee", & + [ index (4_"foobargeefoobargee", 4_"gee", .true.), & + index (4_"foobargeefoobargee", 4_"gee", .false.), & + scan (4_"foobargeefoobargee", 4_"gee", .true.), & + scan (4_"foobargeefoobargee", 4_"gee", .false.), & + verify (4_"foobargeefoobargee", 4_"gee", .true.), & + verify (4_"foobargeefoobargee", 4_"gee", .false.) ]) + call check1("foobargeefoobargee", "foo", & + [ index ("foobargeefoobargee", "foo", .true.), & + index ("foobargeefoobargee", "foo", .false.), & + scan ("foobargeefoobargee", "foo", .true.), & + scan ("foobargeefoobargee", "foo", .false.), & + verify ("foobargeefoobargee", "foo", .true.), & + verify ("foobargeefoobargee", "foo", .false.) ], & + 4_"foobargeefoobargee", 4_"foo", & + [ index (4_"foobargeefoobargee", 4_"foo", .true.), & + index (4_"foobargeefoobargee", 4_"foo", .false.), & + scan (4_"foobargeefoobargee", 4_"foo", .true.), & + scan (4_"foobargeefoobargee", 4_"foo", .false.), & + verify (4_"foobargeefoobargee", 4_"foo", .true.), & + verify (4_"foobargeefoobargee", 4_"foo", .false.) ]) + + call check1(" \b fe \b\0 bar cad", " \b\0", & + [ index (" \b fe \b\0 bar cad", " \b\0", .true.), & + index (" \b fe \b\0 bar cad", " \b\0", .false.), & + scan (" \b fe \b\0 bar cad", " \b\0", .true.), & + scan (" \b fe \b\0 bar cad", " \b\0", .false.), & + verify (" \b fe \b\0 bar cad", " \b\0", .true.), & + verify (" \b fe \b\0 bar cad", " \b\0", .false.) ], & + 4_" \uC096 fe \uC096\uB8DE bar cad", 4_" \uC096\uB8DE", & + [ index (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + index (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.), & + scan (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + scan (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.), & + verify (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + verify (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.) ]) + +contains + + subroutine check1 (s1, t1, res1, s4, t4, res4) + character(kind=1, len=*) :: s1, t1 + character(kind=4, len=*) :: s4, t4 + integer :: res1(6), res4(6) + + if (any (res1 /= res4)) call abort + + if (index (s1, t1, .true.) /= res1(1)) call abort + if (index (s1, t1, .false.) /= res1(2)) call abort + if (scan (s1, t1, .true.) /= res1(3)) call abort + if (scan (s1, t1, .false.) /= res1(4)) call abort + if (verify (s1, t1, .true.) /= res1(5)) call abort + if (verify (s1, t1, .false.) /= res1(6)) call abort + + if (index (s4, t4, .true.) /= res4(1)) call abort + if (index (s4, t4, .false.) /= res4(2)) call abort + if (scan (s4, t4, .true.) /= res4(3)) call abort + if (scan (s4, t4, .false.) /= res4(4)) call abort + if (verify (s4, t4, .true.) /= res4(5)) call abort + if (verify (s4, t4, .false.) /= res4(6)) call abort + + end subroutine check1 + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_8.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_8.f90 new file mode 100644 index 0000000..eeeabbc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_8.f90 @@ -0,0 +1,85 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + logical, parameter :: bigendian = transfer ((/1_1,0_1,0_1,0_1/), 0_4) /= 1 + + character(kind=1,len=3) :: s1, t1, u1 + character(kind=4,len=3) :: s4, t4, u4 + + ! Test MERGE intrinsic + + call check_merge1 ("foo", "gee", .true., .false.) + call check_merge4 (4_"foo", 4_"gee", .true., .false.) + + if (merge ("foo", "gee", .true.) /= "foo") call abort + if (merge ("foo", "gee", .false.) /= "gee") call abort + if (merge (4_"foo", 4_"gee", .true.) /= 4_"foo") call abort + if (merge (4_"foo", 4_"gee", .false.) /= 4_"gee") call abort + + ! Test TRANSFER intrinsic + + if (bigendian) then + if (transfer (4_"x", " ") /= "\0\0\0x") call abort + else + if (transfer (4_"x", " ") /= "x\0\0\0") call abort + endif + if (transfer (4_"\U44444444", " ") /= "\x44\x44\x44\x44") call abort + if (transfer (4_"\U3FE91B5A", 0_4) /= int(z'3FE91B5A', 4)) call abort + + call check_transfer_i (4_"\U3FE91B5A", [int(z'3FE91B5A', 4)]) + call check_transfer_i (4_"\u1B5A", [int(z'1B5A', 4)]) + +contains + + subroutine check_merge1 (s1, t1, t, f) + character(kind=1,len=*) :: s1, t1 + logical :: t, f + + if (merge (s1, t1, .true.) /= s1) call abort + if (merge (s1, t1, .false.) /= t1) call abort + if (len (merge (s1, t1, .true.)) /= len (s1)) call abort + if (len (merge (s1, t1, .false.)) /= len (t1)) call abort + if (len_trim (merge (s1, t1, .true.)) /= len_trim (s1)) call abort + if (len_trim (merge (s1, t1, .false.)) /= len_trim (t1)) call abort + + if (merge (s1, t1, t) /= s1) call abort + if (merge (s1, t1, f) /= t1) call abort + if (len (merge (s1, t1, t)) /= len (s1)) call abort + if (len (merge (s1, t1, f)) /= len (t1)) call abort + if (len_trim (merge (s1, t1, t)) /= len_trim (s1)) call abort + if (len_trim (merge (s1, t1, f)) /= len_trim (t1)) call abort + + end subroutine check_merge1 + + subroutine check_merge4 (s4, t4, t, f) + character(kind=4,len=*) :: s4, t4 + logical :: t, f + + if (merge (s4, t4, .true.) /= s4) call abort + if (merge (s4, t4, .false.) /= t4) call abort + if (len (merge (s4, t4, .true.)) /= len (s4)) call abort + if (len (merge (s4, t4, .false.)) /= len (t4)) call abort + if (len_trim (merge (s4, t4, .true.)) /= len_trim (s4)) call abort + if (len_trim (merge (s4, t4, .false.)) /= len_trim (t4)) call abort + + if (merge (s4, t4, t) /= s4) call abort + if (merge (s4, t4, f) /= t4) call abort + if (len (merge (s4, t4, t)) /= len (s4)) call abort + if (len (merge (s4, t4, f)) /= len (t4)) call abort + if (len_trim (merge (s4, t4, t)) /= len_trim (s4)) call abort + if (len_trim (merge (s4, t4, f)) /= len_trim (t4)) call abort + + end subroutine check_merge4 + + subroutine check_transfer_i (s, i) + character(kind=4,len=*) :: s + integer(kind=4), dimension(len(s)) :: i + + if (transfer (s, 0_4) /= ichar (s(1:1))) call abort + if (transfer (s, 0_4) /= i(1)) call abort + if (any (transfer (s, [0_4]) /= i)) call abort + if (any (transfer (s, 0_4, len(s)) /= i)) call abort + + end subroutine check_transfer_i + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 new file mode 100644 index 0000000..ca6fa58 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + implicit none + character(kind=1,len=3) :: s1, t1 + character(kind=4,len=3) :: s4, t4 + + s1 = "foo" ; t1 = "bar" + call check_minmax_1 ("foo", "bar", min("foo","bar"), max("foo","bar")) + call check_minmax_1 ("bar", "foo", min("foo","bar"), max("foo","bar")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = " " ; t1 = "bar" + call check_minmax_1 (" ", "bar", min(" ","bar"), max(" ","bar")) + call check_minmax_1 ("bar", " ", min(" ","bar"), max(" ","bar")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = " " ; t1 = " " + call check_minmax_1 (" ", " ", min(" "," "), max(" "," ")) + call check_minmax_1 (" ", " ", min(" "," "), max(" "," ")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = "d\xFF " ; t1 = "d " + call check_minmax_1 ("d\xFF ", "d ", min("d\xFF ","d "), max("d\xFF ","d ")) + call check_minmax_1 ("d ", "d\xFF ", min("d\xFF ","d "), max("d\xFF ","d ")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s4 = 4_" " ; t4 = 4_"xxx" + call check_minmax_2 (4_" ", 4_"xxx", min(4_" ", 4_"xxx"), & + max(4_" ", 4_"xxx")) + call check_minmax_2 (4_"xxx", 4_" ", min(4_" ", 4_"xxx"), & + max(4_" ", 4_"xxx")) + call check_minmax_2 (s4, t4, min(s4,t4), max(s4,t4)) + call check_minmax_2 (t4, s4, min(s4,t4), max(s4,t4)) + + s4 = 4_" \u1be3m" ; t4 = 4_"xxx" + call check_minmax_2 (4_" \u1be3m", 4_"xxx", min(4_" \u1be3m", 4_"xxx"), & + max(4_" \u1be3m", 4_"xxx")) + call check_minmax_2 (4_"xxx", 4_" \u1be3m", min(4_" \u1be3m", 4_"xxx"), & + max(4_" \u1be3m", 4_"xxx")) + call check_minmax_2 (s4, t4, min(s4,t4), max(s4,t4)) + call check_minmax_2 (t4, s4, min(s4,t4), max(s4,t4)) + +contains + + subroutine check_minmax_1 (s1, s2, smin, smax) + implicit none + character(kind=1,len=*), intent(in) :: s1, s2, smin, smax + character(kind=4,len=len(s1)) :: w1, w2, wmin, wmax + + w1 = s1 ; w2 = s2 ; wmin = smin ; wmax = smax + if (min (w1, w2) /= wmin) call abort + if (max (w1, w2) /= wmax) call abort + if (min (s1, s2) /= smin) call abort + if (max (s1, s2) /= smax) call abort + end subroutine check_minmax_1 + + subroutine check_minmax_2 (s1, s2, smin, smax) + implicit none + character(kind=4,len=*), intent(in) :: s1, s2, smin, smax + + if (min (s1, s2) /= smin) call abort + if (max (s1, s2) /= smax) call abort + end subroutine check_minmax_2 + +end diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 877ab62..9a25ecd 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,37 @@ +2008-05-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36319 + * intrinsics/string_intrinsics_inc.c (string_index): Return + correct value for zero-length substring. + * intrinsics/cshift0.c: Add _char4 variant. + * intrinsics/eoshift0.c (eoshift0): Allow filler to be a pattern + wider than a single byte. Add _char4 variant and use above + functionality. + * intrinsics/eoshift2.c (eoshift2): Likewise. + * m4/eoshift1.m4: Likewise. + * m4/eoshift3.m4: Likewise. + * m4/cshift1.m4: Add _char4 variants. + * gfortran.map (GFORTRAN_1.1): Add _gfortran_cshift0_1_char4, + _gfortran_cshift0_2_char4, _gfortran_cshift0_4_char4, + _gfortran_cshift0_8_char4, _gfortran_cshift1_16_char4, + _gfortran_cshift1_4_char4, _gfortran_cshift1_8_char4, + _gfortran_eoshift0_1_char4, _gfortran_eoshift0_2_char4, + _gfortran_eoshift0_4_char4, _gfortran_eoshift0_8_char4, + _gfortran_eoshift1_16_char4, _gfortran_eoshift1_4_char4, + _gfortran_eoshift1_8_char4, _gfortran_eoshift2_1_char4, + _gfortran_eoshift2_2_char4, _gfortran_eoshift2_4_char4, + _gfortran_eoshift2_8_char4, _gfortran_eoshift3_16_char4, + _gfortran_eoshift3_4_char4 and _gfortran_eoshift3_8_char4. + * generated/eoshift3_4.c: Regenerate. + * generated/eoshift1_8.c: Regenerate. + * generated/eoshift1_16.c: Regenerate. + * generated/cshift1_4.c: Regenerate. + * generated/eoshift1_4.c: Regenerate. + * generated/eoshift3_8.c: Regenerate. + * generated/eoshift3_16.c: Regenerate. + * generated/cshift1_8.c: Regenerate. + * generated/cshift1_16.c: Regenerate. + 2008-05-25 Tobias Burnus <burnus@net-b.de> PR fortran/32600 diff --git a/libgfortran/generated/cshift1_16.c b/libgfortran/generated/cshift1_16.c index a29bf79..2943c3e 100644 --- a/libgfortran/generated/cshift1_16.c +++ b/libgfortran/generated/cshift1_16.c @@ -212,6 +212,7 @@ cshift1_16 (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); } + void cshift1_16_char (gfc_array_char * const restrict ret, GFC_INTEGER_4, const gfc_array_char * const restrict array, @@ -231,4 +232,24 @@ cshift1_16_char (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, array_length); } + +void cshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_16_char4); + +void +cshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); +} + #endif diff --git a/libgfortran/generated/cshift1_4.c b/libgfortran/generated/cshift1_4.c index 0525873..3f4f9e0b 100644 --- a/libgfortran/generated/cshift1_4.c +++ b/libgfortran/generated/cshift1_4.c @@ -212,6 +212,7 @@ cshift1_4 (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); } + void cshift1_4_char (gfc_array_char * const restrict ret, GFC_INTEGER_4, const gfc_array_char * const restrict array, @@ -231,4 +232,24 @@ cshift1_4_char (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, array_length); } + +void cshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_4_char4); + +void +cshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); +} + #endif diff --git a/libgfortran/generated/cshift1_8.c b/libgfortran/generated/cshift1_8.c index 624b662..4d246e5 100644 --- a/libgfortran/generated/cshift1_8.c +++ b/libgfortran/generated/cshift1_8.c @@ -212,6 +212,7 @@ cshift1_8 (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); } + void cshift1_8_char (gfc_array_char * const restrict ret, GFC_INTEGER_4, const gfc_array_char * const restrict array, @@ -231,4 +232,24 @@ cshift1_8_char (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, array_length); } + +void cshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_8_char4); + +void +cshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); +} + #endif diff --git a/libgfortran/generated/eoshift1_16.c b/libgfortran/generated/eoshift1_16.c index e16db20..63b75bd 100644 --- a/libgfortran/generated/eoshift1_16.c +++ b/libgfortran/generated/eoshift1_16.c @@ -42,7 +42,7 @@ eoshift1 (gfc_array_char * const restrict ret, const gfc_array_i16 * const restrict h, const char * const restrict pbound, const GFC_INTEGER_16 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -183,7 +183,14 @@ eoshift1 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -234,9 +241,11 @@ eoshift1_16 (gfc_array_char * const restrict ret, const char * const restrict pbound, const GFC_INTEGER_16 * const restrict pwhich) { - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + void eoshift1_16_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -256,7 +265,32 @@ eoshift1_16_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); + eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); +} + + +void eoshift1_16_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const char * const restrict, + const GFC_INTEGER_16 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_16_char4); + +void +eoshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift1_4.c b/libgfortran/generated/eoshift1_4.c index 11cc71f..58ce7e9 100644 --- a/libgfortran/generated/eoshift1_4.c +++ b/libgfortran/generated/eoshift1_4.c @@ -42,7 +42,7 @@ eoshift1 (gfc_array_char * const restrict ret, const gfc_array_i4 * const restrict h, const char * const restrict pbound, const GFC_INTEGER_4 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -183,7 +183,14 @@ eoshift1 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -234,9 +241,11 @@ eoshift1_4 (gfc_array_char * const restrict ret, const char * const restrict pbound, const GFC_INTEGER_4 * const restrict pwhich) { - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + void eoshift1_4_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -256,7 +265,32 @@ eoshift1_4_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); + eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); +} + + +void eoshift1_4_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const char * const restrict, + const GFC_INTEGER_4 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_4_char4); + +void +eoshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift1_8.c b/libgfortran/generated/eoshift1_8.c index 4b7d0e04..0e9c2f1 100644 --- a/libgfortran/generated/eoshift1_8.c +++ b/libgfortran/generated/eoshift1_8.c @@ -42,7 +42,7 @@ eoshift1 (gfc_array_char * const restrict ret, const gfc_array_i8 * const restrict h, const char * const restrict pbound, const GFC_INTEGER_8 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -183,7 +183,14 @@ eoshift1 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -234,9 +241,11 @@ eoshift1_8 (gfc_array_char * const restrict ret, const char * const restrict pbound, const GFC_INTEGER_8 * const restrict pwhich) { - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + void eoshift1_8_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -256,7 +265,32 @@ eoshift1_8_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); + eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); +} + + +void eoshift1_8_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const char * const restrict, + const GFC_INTEGER_8 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_8_char4); + +void +eoshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift3_16.c b/libgfortran/generated/eoshift3_16.c index 1dda668..214f378 100644 --- a/libgfortran/generated/eoshift3_16.c +++ b/libgfortran/generated/eoshift3_16.c @@ -42,7 +42,7 @@ eoshift3 (gfc_array_char * const restrict ret, const gfc_array_i16 * const restrict h, const gfc_array_char * const restrict bound, const GFC_INTEGER_16 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -198,7 +198,14 @@ eoshift3 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -253,9 +260,11 @@ eoshift3_16 (gfc_array_char * const restrict ret, const gfc_array_char * const restrict bound, const GFC_INTEGER_16 * const restrict pwhich) { - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + extern void eoshift3_16_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -275,7 +284,32 @@ eoshift3_16_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); + eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); +} + + +extern void eoshift3_16_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_16 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_16_char4); + +void +eoshift3_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift3_4.c b/libgfortran/generated/eoshift3_4.c index aa46f7c..e96ef25 100644 --- a/libgfortran/generated/eoshift3_4.c +++ b/libgfortran/generated/eoshift3_4.c @@ -42,7 +42,7 @@ eoshift3 (gfc_array_char * const restrict ret, const gfc_array_i4 * const restrict h, const gfc_array_char * const restrict bound, const GFC_INTEGER_4 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -198,7 +198,14 @@ eoshift3 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -253,9 +260,11 @@ eoshift3_4 (gfc_array_char * const restrict ret, const gfc_array_char * const restrict bound, const GFC_INTEGER_4 * const restrict pwhich) { - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + extern void eoshift3_4_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -275,7 +284,32 @@ eoshift3_4_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); + eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); +} + + +extern void eoshift3_4_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_4 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_4_char4); + +void +eoshift3_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift3_8.c b/libgfortran/generated/eoshift3_8.c index 04e81b8..dc39b94 100644 --- a/libgfortran/generated/eoshift3_8.c +++ b/libgfortran/generated/eoshift3_8.c @@ -42,7 +42,7 @@ eoshift3 (gfc_array_char * const restrict ret, const gfc_array_i8 * const restrict h, const gfc_array_char * const restrict bound, const GFC_INTEGER_8 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -198,7 +198,14 @@ eoshift3 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -253,9 +260,11 @@ eoshift3_8 (gfc_array_char * const restrict ret, const gfc_array_char * const restrict bound, const GFC_INTEGER_8 * const restrict pwhich) { - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + extern void eoshift3_8_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -275,7 +284,32 @@ eoshift3_8_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); + eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); +} + + +extern void eoshift3_8_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_8 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_8_char4); + +void +eoshift3_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 4244aca..60ef853 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1040,10 +1040,31 @@ GFORTRAN_1.1 { _gfortran_convert_char4_to_char1; _gfortran_cshift0_16; _gfortran_cshift0_16_char; + _gfortran_cshift0_1_char4; + _gfortran_cshift0_2_char4; + _gfortran_cshift0_4_char4; + _gfortran_cshift0_8_char4; + _gfortran_cshift1_16_char4; + _gfortran_cshift1_4_char4; + _gfortran_cshift1_8_char4; _gfortran_eoshift0_16; _gfortran_eoshift0_16_char; + _gfortran_eoshift0_1_char4; + _gfortran_eoshift0_2_char4; + _gfortran_eoshift0_4_char4; + _gfortran_eoshift0_8_char4; + _gfortran_eoshift1_16_char4; + _gfortran_eoshift1_4_char4; + _gfortran_eoshift1_8_char4; _gfortran_eoshift2_16; _gfortran_eoshift2_16_char; + _gfortran_eoshift2_1_char4; + _gfortran_eoshift2_2_char4; + _gfortran_eoshift2_4_char4; + _gfortran_eoshift2_8_char4; + _gfortran_eoshift3_16_char4; + _gfortran_eoshift3_4_char4; + _gfortran_eoshift3_8_char4; _gfortran_erfc_scaled_r10; _gfortran_erfc_scaled_r16; _gfortran_erfc_scaled_r4; @@ -1051,17 +1072,17 @@ GFORTRAN_1.1 { _gfortran_pack_char4; _gfortran_pack_s_char4; _gfortran_reshape_char4; - _gfortran_select_string_char4; _gfortran_selected_char_kind; + _gfortran_select_string_char4; _gfortran_spread_char4; _gfortran_spread_char4_scalar; - _gfortran_st_wait; _gfortran_string_index_char4; _gfortran_string_len_trim_char4; _gfortran_string_minmax_char4; _gfortran_string_scan_char4; _gfortran_string_trim_char4; _gfortran_string_verify_char4; + _gfortran_st_wait; _gfortran_transpose_char4; _gfortran_unpack0_char4; _gfortran_unpack1_char4; diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c index 7157465..76ce97e 100644 --- a/libgfortran/intrinsics/cshift0.c +++ b/libgfortran/intrinsics/cshift0.c @@ -334,6 +334,24 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, GFC_INTEGER_4 array_length) \ { \ cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \ + } \ + \ + extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + const GFC_INTEGER_##N *, GFC_INTEGER_4); \ + export_proto(cshift0_##N##_char4); \ + \ + void \ + cshift0_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length) \ + { \ + cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t)); \ } DEFINE_CSHIFT (1); diff --git a/libgfortran/intrinsics/eoshift0.c b/libgfortran/intrinsics/eoshift0.c index c75199c..ac7a0ba 100644 --- a/libgfortran/intrinsics/eoshift0.c +++ b/libgfortran/intrinsics/eoshift0.c @@ -39,7 +39,7 @@ Boston, MA 02110-1301, USA. */ static void eoshift0 (gfc_array_char * ret, const gfc_array_char * array, int shift, const char * pbound, int which, index_type size, - char filler) + const char *filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -175,7 +175,14 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size ; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -223,7 +230,7 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, const GFC_INTEGER_##N *pdim) \ { \ eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ - GFC_DESCRIPTOR_SIZE (array), 0); \ + GFC_DESCRIPTOR_SIZE (array), "\0", 1); \ } \ \ extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \ @@ -244,7 +251,30 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, GFC_INTEGER_4 bound_length __attribute__((unused))) \ { \ eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ - array_length, ' '); \ + array_length, " ", 1); \ + } \ + \ + extern void eoshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, const char *, \ + const GFC_INTEGER_##N *, GFC_INTEGER_4, \ + GFC_INTEGER_4); \ + export_proto(eoshift0_##N##_char4); \ + \ + void \ + eoshift0_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const char *pbound, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length, \ + GFC_INTEGER_4 bound_length __attribute__((unused))) \ + { \ + static const gfc_char4_t space = (unsigned char) ' '; \ + eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t), (const char *) &space, \ + sizeof (gfc_char4_t)); \ } DEFINE_EOSHIFT (1); diff --git a/libgfortran/intrinsics/eoshift2.c b/libgfortran/intrinsics/eoshift2.c index f74cb01..239d971 100644 --- a/libgfortran/intrinsics/eoshift2.c +++ b/libgfortran/intrinsics/eoshift2.c @@ -39,7 +39,7 @@ Boston, MA 02110-1301, USA. */ static void eoshift2 (gfc_array_char *ret, const gfc_array_char *array, int shift, const gfc_array_char *bound, int which, - index_type size, char filler) + index_type size, const char *filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -192,7 +192,14 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size ; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -243,7 +250,7 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, const GFC_INTEGER_##N *pdim) \ { \ eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ - GFC_DESCRIPTOR_SIZE (array), 0); \ + GFC_DESCRIPTOR_SIZE (array), "\0", 1); \ } \ \ extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4, \ @@ -265,7 +272,31 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, GFC_INTEGER_4 bound_length __attribute__((unused))) \ { \ eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ - array_length, ' '); \ + array_length, " ", 1); \ + } \ + \ + extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + GFC_INTEGER_4, GFC_INTEGER_4); \ + export_proto(eoshift2_##N##_char4); \ + \ + void \ + eoshift2_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const gfc_array_char *pbound, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length, \ + GFC_INTEGER_4 bound_length __attribute__((unused))) \ + { \ + static const gfc_char4_t space = (unsigned char) ' '; \ + eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t), (const char *) &space, \ + sizeof (gfc_char4_t)); \ } DEFINE_EOSHIFT (1); diff --git a/libgfortran/intrinsics/string_intrinsics_inc.c b/libgfortran/intrinsics/string_intrinsics_inc.c index 87e137e..0008db5 100644 --- a/libgfortran/intrinsics/string_intrinsics_inc.c +++ b/libgfortran/intrinsics/string_intrinsics_inc.c @@ -214,7 +214,7 @@ string_index (gfc_charlen_type slen, const CHARTYPE *str, gfc_charlen_type start, last, delta, i; if (sslen == 0) - return 1; + return back ? (slen + 1) : 1; if (sslen > slen) return 0; diff --git a/libgfortran/m4/cshift1.m4 b/libgfortran/m4/cshift1.m4 index 735621d..28fae59 100644 --- a/libgfortran/m4/cshift1.m4 +++ b/libgfortran/m4/cshift1.m4 @@ -213,6 +213,7 @@ cshift1_'atype_kind` (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); } + void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret, GFC_INTEGER_4, const gfc_array_char * const restrict array, @@ -232,4 +233,24 @@ cshift1_'atype_kind`_char (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, array_length); } + +void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const 'atype` * const restrict h, + const 'atype_name` * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_'atype_kind`_char4); + +void +cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const 'atype` * const restrict h, + const 'atype_name` * const restrict pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); +} + #endif' diff --git a/libgfortran/m4/eoshift1.m4 b/libgfortran/m4/eoshift1.m4 index efa38b2..8ce24ef 100644 --- a/libgfortran/m4/eoshift1.m4 +++ b/libgfortran/m4/eoshift1.m4 @@ -43,7 +43,7 @@ eoshift1 (gfc_array_char * const restrict ret, const 'atype` * const restrict h, const char * const restrict pbound, const 'atype_name` * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -184,7 +184,14 @@ eoshift1 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -235,9 +242,11 @@ eoshift1_'atype_kind` (gfc_array_char * const restrict ret, const char * const restrict pbound, const 'atype_name` * const restrict pwhich) { - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + void eoshift1_'atype_kind`_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -257,7 +266,32 @@ eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift1 (ret, array, h, pbound, pwhich, array_length, ''` ''`); + eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); +} + + +void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const 'atype` * const restrict, + const char * const restrict, + const 'atype_name` * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_'atype_kind`_char4); + +void +eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const 'atype` * const restrict h, + const char * const restrict pbound, + const 'atype_name` * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ''` ''`; + eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif' diff --git a/libgfortran/m4/eoshift3.m4 b/libgfortran/m4/eoshift3.m4 index 050f527..081ff92 100644 --- a/libgfortran/m4/eoshift3.m4 +++ b/libgfortran/m4/eoshift3.m4 @@ -43,7 +43,7 @@ eoshift3 (gfc_array_char * const restrict ret, const 'atype` * const restrict h, const gfc_array_char * const restrict bound, const 'atype_name` * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -199,7 +199,14 @@ eoshift3 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -254,9 +261,11 @@ eoshift3_'atype_kind` (gfc_array_char * const restrict ret, const gfc_array_char * const restrict bound, const 'atype_name` * const restrict pwhich) { - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -276,7 +285,32 @@ eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift3 (ret, array, h, bound, pwhich, array_length, ''` ''`); + eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); +} + + +extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const 'atype` * const restrict, + const gfc_array_char * const restrict, + const 'atype_name` * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_'atype_kind`_char4); + +void +eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const 'atype` * const restrict h, + const gfc_array_char * const restrict bound, + const 'atype_name` * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ''` ''`; + eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif' |