mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-02 04:50:27 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/36319 (Segfault with wide characters in DATA)

Browse Source 
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
This commit is contained in:
Francois-Xavier Coudert 2008-05-28 21:11:39 +00:00 committed by François-Xavier Coudert
parent b608a1bc71
commit 691da334bc
34 changed files with 1339 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/fortran/ChangeLog
View File

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

1
gcc/fortran/intrinsic.c
View File

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

32
gcc/fortran/iresolve.c
View File

@ -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);
}

89
gcc/fortran/simplify.c
View File

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

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

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

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

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

14
gcc/testsuite/ChangeLog
View File

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

59
gcc/testsuite/gfortran.dg/widechar_5.f90 Normal file
View File

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

64
gcc/testsuite/gfortran.dg/widechar_6.f90 Normal file
View File

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

19
gcc/testsuite/gfortran.dg/widechar_7.f90 Normal file
View File

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

89
gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 Normal file
View File

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

16
gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90
View File

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

109
gcc/testsuite/gfortran.dg/widechar_intrinsics_6.f90 Normal file
View File

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

125
gcc/testsuite/gfortran.dg/widechar_intrinsics_7.f90 Normal file
View File

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

85
gcc/testsuite/gfortran.dg/widechar_intrinsics_8.f90 Normal file
View File

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

70
gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 Normal file
View File

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

34
libgfortran/ChangeLog
View File

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

21
libgfortran/generated/cshift1_16.c
View File

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

21
libgfortran/generated/cshift1_4.c
View File

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

21
libgfortran/generated/cshift1_8.c
View File

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

42
libgfortran/generated/eoshift1_16.c
View File

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

42
libgfortran/generated/eoshift1_4.c
View File

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

42
libgfortran/generated/eoshift1_8.c
View File

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

42
libgfortran/generated/eoshift3_16.c
View File

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

42
libgfortran/generated/eoshift3_4.c
View File

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

42
libgfortran/generated/eoshift3_8.c
View File

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

25
libgfortran/gfortran.map
View File

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

18
libgfortran/intrinsics/cshift0.c
View File

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

38
libgfortran/intrinsics/eoshift0.c
View File

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

39
libgfortran/intrinsics/eoshift2.c
View File

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

2
libgfortran/intrinsics/string_intrinsics_inc.c
View File

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

21
libgfortran/m4/cshift1.m4
View File

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

42
libgfortran/m4/eoshift1.m4
View File

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

42
libgfortran/m4/eoshift3.m4
View File

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