+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
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);
}
}
- 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);
}
}
}
- 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);
}
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;
}
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
- tree esize;
gfc_conv_expr (se, expr);
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)))
{
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;
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);
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;
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);
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);
/* 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);
}
+/* 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)
{
tree tmp;
tree lower;
tree upper;
- /*tree stride;*/
int n;
arg = expr->value.function.actual->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));
/* 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));
/* 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));
/* 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));
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
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;
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);
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);
+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.
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+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
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,
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
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,
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
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,
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
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];
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;
}
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,
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
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];
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;
}
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,
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
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];
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;
}
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,
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
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];
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;
}
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,
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
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];
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;
}
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,
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
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];
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;
}
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,
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
_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;
_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;
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);
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];
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;
}
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, \
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);
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];
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;
}
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, \
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);
gfc_charlen_type start, last, delta, i;
if (sslen == 0)
- return 1;
+ return back ? (slen + 1) : 1;
if (sslen > slen)
return 0;
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,
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'
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];
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;
}
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,
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'
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];
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;
}
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,
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'
projects / thirdparty / gcc.git / commitdiff
