git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

arith.c: (gfc_arith_concat... 

* arith.c: (gfc_arith_concat, gfc_compare_string,
	gfc_compare_with_Cstring, hollerith2representation,
	gfc_hollerith2int, gfc_hollerith2real, gfc_hollerith2complex,
	gfc_hollerith2character, gfc_hollerith2logical): Use wide
	characters for character constants.
	* data.c (create_character_intializer): Likewise.
	* decl.c (gfc_set_constant_character_len): Likewise.
	* dump-parse-tree.c (show_char_const): Correctly dump wide
	character strings.
	error.c (print_wide_char): Rename into gfc_print_wide_char.
	(show_locus): Adapt to new prototype of gfc_print_wide_char.
	expr.c (free_expr0): Representation is now disjunct from
	character string value, so we always free it.
	(gfc_copy_expr, find_substring_ref, gfc_simplify_expr): Adapt
	to wide character strings.
	* gfortran.h (gfc_expr): Make value.character.string a wide string.
	(gfc_wide_toupper, gfc_wide_strncasecmp, gfc_wide_memset,
	gfc_widechar_to_char, gfc_char_to_widechar): New prototypes.
	(gfc_get_wide_string): New macro.
	(gfc_print_wide_char): New prototype.
	* io.c (format_string): Make a wide string.
	(next_char, gfc_match_format, compare_to_allowed_values, 
	gfc_match_open): Deal with wide strings.
	* module.c (mio_expr): Convert between wide strings and ASCII ones.
	* primary.c (match_hollerith_constant, match_charkind_name): 
	Handle wide strings.
	* resolve.c (build_default_init_expr): Likewise.
	* scanner.c (gfc_wide_toupper, gfc_wide_memset,
	gfc_char_to_widechar): New functions.
	(wide_strchr, gfc_widechar_to_char, gfc_wide_strncasecmp):
	Changes in prototypes.
	(gfc_define_undef_line, load_line, preprocessor_line,
	include_line, load_file, gfc_read_orig_filename): Handle wide
	strings.
	* simplify.c (gfc_simplify_achar, gfc_simplify_adjustl,
	gfc_simplify_adjustr, gfc_simplify_char, gfc_simplify_iachar,
	gfc_simplify_ichar, simplify_min_max, gfc_simplify_new_line,
	gfc_simplify_repeat): Handle wide strings.
	(wide_strspn, wide_strcspn): New helper functions.
	(gfc_simplify_scan, gfc_simplify_trim, gfc_simplify_verify):
	Handle wide strings.
	* symbol.c (generate_isocbinding_symbol): Likewise.
	* target-memory.c (size_character, gfc_target_expr_size,
	encode_character, gfc_target_encode_expr, gfc_interpret_character,
	gfc_target_interpret_expr): Handle wide strings.
	* trans-const.c (gfc_conv_string_init): Lower wide strings to
	narrow ones.
	(gfc_conv_constant_to_tree): Likewise.
	* trans-expr.c (gfc_conv_substring_expr): Handle wide strings.
	* trans-io.c (gfc_new_nml_name_expr): Likewise.
	* trans-stmt.c (gfc_trans_label_assign): Likewise.

From-SVN: r135006
This commit is contained in:
Francois-Xavier Coudert 2008-05-06 21:06:20 +00:00 committed by François-Xavier Coudert
parent 1b38192d61
commit 006601890b
20 changed files with 461 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
gcc/fortran/ChangeLog
View File

@ -1,3 +1,57 @@
2008-05-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* arith.c: (gfc_arith_concat, gfc_compare_string,
gfc_compare_with_Cstring, hollerith2representation,
gfc_hollerith2int, gfc_hollerith2real, gfc_hollerith2complex,
gfc_hollerith2character, gfc_hollerith2logical): Use wide
characters for character constants.
* data.c (create_character_intializer): Likewise.
* decl.c (gfc_set_constant_character_len): Likewise.
* dump-parse-tree.c (show_char_const): Correctly dump wide
character strings.
error.c (print_wide_char): Rename into gfc_print_wide_char.
(show_locus): Adapt to new prototype of gfc_print_wide_char.
expr.c (free_expr0): Representation is now disjunct from
character string value, so we always free it.
(gfc_copy_expr, find_substring_ref, gfc_simplify_expr): Adapt
to wide character strings.
* gfortran.h (gfc_expr): Make value.character.string a wide string.
(gfc_wide_toupper, gfc_wide_strncasecmp, gfc_wide_memset,
gfc_widechar_to_char, gfc_char_to_widechar): New prototypes.
(gfc_get_wide_string): New macro.
(gfc_print_wide_char): New prototype.
* io.c (format_string): Make a wide string.
(next_char, gfc_match_format, compare_to_allowed_values,
gfc_match_open): Deal with wide strings.
* module.c (mio_expr): Convert between wide strings and ASCII ones.
* primary.c (match_hollerith_constant, match_charkind_name):
Handle wide strings.
* resolve.c (build_default_init_expr): Likewise.
* scanner.c (gfc_wide_toupper, gfc_wide_memset,
gfc_char_to_widechar): New functions.
(wide_strchr, gfc_widechar_to_char, gfc_wide_strncasecmp):
Changes in prototypes.
(gfc_define_undef_line, load_line, preprocessor_line,
include_line, load_file, gfc_read_orig_filename): Handle wide
strings.
* simplify.c (gfc_simplify_achar, gfc_simplify_adjustl,
gfc_simplify_adjustr, gfc_simplify_char, gfc_simplify_iachar,
gfc_simplify_ichar, simplify_min_max, gfc_simplify_new_line,
gfc_simplify_repeat): Handle wide strings.
(wide_strspn, wide_strcspn): New helper functions.
(gfc_simplify_scan, gfc_simplify_trim, gfc_simplify_verify):
Handle wide strings.
* symbol.c (generate_isocbinding_symbol): Likewise.
* target-memory.c (size_character, gfc_target_expr_size,
encode_character, gfc_target_encode_expr, gfc_interpret_character,
gfc_target_interpret_expr): Handle wide strings.
* trans-const.c (gfc_conv_string_init): Lower wide strings to
narrow ones.
(gfc_conv_constant_to_tree): Likewise.
* trans-expr.c (gfc_conv_substring_expr): Handle wide strings.
* trans-io.c (gfc_new_nml_name_expr): Likewise.
* trans-stmt.c (gfc_trans_label_assign): Likewise.
2008-05-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1,

50
gcc/fortran/arith.c
View File

@ -1102,14 +1102,15 @@ gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
len = op1->value.character.length + op2->value.character.length;
result->value.character.string = gfc_getmem (len + 1);
result->value.character.string = gfc_get_wide_string (len + 1);
result->value.character.length = len;
memcpy (result->value.character.string, op1->value.character.string,
op1->value.character.length);
op1->value.character.length * sizeof (gfc_char_t));
memcpy (result->value.character.string + op1->value.character.length,
op2->value.character.string, op2->value.character.length);
memcpy (&result->value.character.string[op1->value.character.length],
op2->value.character.string,
op2->value.character.length * sizeof (gfc_char_t));
result->value.character.string[len] = '\0';
@ -1203,7 +1204,8 @@ compare_complex (gfc_expr *op1, gfc_expr *op2)
int
gfc_compare_string (gfc_expr *a, gfc_expr *b)
{
int len, alen, blen, i, ac, bc;
int len, alen, blen, i;
gfc_char_t ac, bc;
alen = a->value.character.length;
blen = b->value.character.length;
@ -1212,10 +1214,8 @@ gfc_compare_string (gfc_expr *a, gfc_expr *b)
for (i = 0; i < len; i++)
{
/* We cast to unsigned char because default char, if it is signed,
would lead to ac < 0 for string[i] > 127. */
ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
bc = (unsigned char) ((i < blen) ? b->value.character.string[i] : ' ');
ac = ((i < alen) ? a->value.character.string[i] : ' ');
bc = ((i < blen) ? b->value.character.string[i] : ' ');
if (ac < bc)
return -1;
@ -1231,7 +1231,8 @@ gfc_compare_string (gfc_expr *a, gfc_expr *b)
int
gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
{
int len, alen, blen, i, ac, bc;
int len, alen, blen, i;
gfc_char_t ac, bc;
alen = a->value.character.length;
blen = strlen (b);
@ -1240,10 +1241,8 @@ gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
for (i = 0; i < len; i++)
{
/* We cast to unsigned char because default char, if it is signed,
would lead to ac < 0 for string[i] > 127. */
ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
bc = (unsigned char) ((i < blen) ? b[i] : ' ');
ac = ((i < alen) ? a->value.character.string[i] : ' ');
bc = ((i < blen) ? b[i] : ' ');
if (!case_sensitive)
{
@ -2438,7 +2437,7 @@ hollerith2representation (gfc_expr *result, gfc_expr *src)
result->representation.string = gfc_getmem (result_len + 1);
memcpy (result->representation.string, src->representation.string,
MIN (result_len, src_len));
MIN (result_len, src_len));
if (src_len < result_len)
memset (&result->representation.string[src_len], ' ', result_len - src_len);
@ -2462,8 +2461,8 @@ gfc_hollerith2int (gfc_expr *src, int kind)
result->where = src->where;
hollerith2representation (result, src);
gfc_interpret_integer(kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.integer);
gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.integer);
return result;
}
@ -2486,8 +2485,8 @@ gfc_hollerith2real (gfc_expr *src, int kind)
result->where = src->where;
hollerith2representation (result, src);
gfc_interpret_float(kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.real);
gfc_interpret_float (kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.real);
return result;
}
@ -2510,9 +2509,9 @@ gfc_hollerith2complex (gfc_expr *src, int kind)
result->where = src->where;
hollerith2representation (result, src);
gfc_interpret_complex(kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.complex.r,
result->value.complex.i);
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.complex.r,
result->value.complex.i);
return result;
}
@ -2529,8 +2528,9 @@ gfc_hollerith2character (gfc_expr *src, int kind)
result->ts.type = BT_CHARACTER;
result->ts.kind = kind;
result->value.character.string = result->representation.string;
result->value.character.length = result->representation.length;
result->value.character.string
= gfc_char_to_widechar (result->representation.string);
return result;
}
@ -2553,8 +2553,8 @@ gfc_hollerith2logical (gfc_expr *src, int kind)
result->where = src->where;
hollerith2representation (result, src);
gfc_interpret_logical(kind, (unsigned char *) result->representation.string,
result->representation.length, &result->value.logical);
gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
result->representation.length, &result->value.logical);
return result;
}

36
gcc/fortran/data.c
View File

@ -151,10 +151,8 @@ static gfc_expr *
create_character_intializer (gfc_expr *init, gfc_typespec *ts,
gfc_ref *ref, gfc_expr *rvalue)
{
int len;
int start;
int end;
char *dest, *rvalue_string;
int len, start, end;
gfc_char_t *dest;
gfc_extract_int (ts->cl->length, &len);
@ -165,13 +163,13 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts,
init->expr_type = EXPR_CONSTANT;
init->ts = *ts;
dest = gfc_getmem (len + 1);
dest = gfc_get_wide_string (len + 1);
dest[len] = '\0';
init->value.character.length = len;
init->value.character.string = dest;
/* Blank the string if we're only setting a substring. */
if (ref != NULL)
memset (dest, ' ', len);
gfc_wide_memset (dest, ' ', len);
}
else
dest = init->value.character.string;
@ -208,15 +206,9 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts,
/* Copy the initial value. */
if (rvalue->ts.type == BT_HOLLERITH)
{
len = rvalue->representation.length;
rvalue_string = rvalue->representation.string;
}
len = rvalue->representation.length;
else
{
len = rvalue->value.character.length;
rvalue_string = rvalue->value.character.string;
}
len = rvalue->value.character.length;
if (len > end - start)
{
@ -225,16 +217,26 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts,
"at %L", &rvalue->where);
}
memcpy (&dest[start], rvalue_string, len);
if (rvalue->ts.type == BT_HOLLERITH)
{
int i;
for (i = 0; i < len; i++)
dest[start+i] = rvalue->representation.string[i];
}
else
memcpy (&dest[start], rvalue->value.character.string,
len * sizeof (gfc_char_t));
/* Pad with spaces. Substrings will already be blanked. */
if (len < end - start && ref == NULL)
memset (&dest[start + len], ' ', end - (start + len));
gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
if (rvalue->ts.type == BT_HOLLERITH)
{
init->representation.length = init->value.character.length;
init->representation.string = init->value.character.string;
init->representation.string
= gfc_widechar_to_char (init->value.character.string,
init->value.character.length);
}
return init;

9
gcc/fortran/decl.c
View File

@ -1089,7 +1089,7 @@ build_sym (const char *name, gfc_charlen *cl,
void
gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
{
char *s;
gfc_char_t *s;
int slen;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
@ -1098,10 +1098,11 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
slen = expr->value.character.length;
if (len != slen)
{
s = gfc_getmem (len + 1);
memcpy (s, expr->value.character.string, MIN (len, slen));
s = gfc_get_wide_string (len + 1);
memcpy (s, expr->value.character.string,
MIN (len, slen) * sizeof (gfc_char_t));
if (len > slen)
memset (&s[slen], ' ', len - slen);
gfc_wide_memset (&s[slen], ' ', len - slen);
if (gfc_option.warn_character_truncation && slen > len)
gfc_warning_now ("CHARACTER expression at %L is being truncated "

6
gcc/fortran/dump-parse-tree.c
View File

@ -301,7 +301,7 @@ show_constructor (gfc_constructor *c)
static void
show_char_const (const char *c, int length)
show_char_const (const gfc_char_t *c, int length)
{
int i;
@ -310,10 +310,8 @@ show_char_const (const char *c, int length)
{
if (c[i] == '\'')
fputs ("''", dumpfile);
else if (ISPRINT (c[i]))
fputc (c[i], dumpfile);
else
fprintf (dumpfile, "' // ACHAR(%d) // '", c[i]);
fputs (gfc_print_wide_char (c[i]), dumpfile);
}
fputc ('\'', dumpfile);
}

70
gcc/fortran/error.c
View File

@ -152,48 +152,51 @@ error_integer (long int i)
}
/* Show the file, where it was included, and the source line, give a
locus. Calls error_printf() recursively, but the recursion is at
most one level deep. */
static char wide_char_print_buffer[11];
static void
print_wide_char (gfc_char_t c)
const char *
gfc_print_wide_char (gfc_char_t c)
{
static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
'7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
char buf[9];
char *buf = wide_char_print_buffer;
if (gfc_wide_is_printable (c))
error_char (c);
else if (c < ((gfc_char_t) 1 << 8))
{
buf[2] = '\0';
buf[1] = xdigit[c & 0x0F];
c = c >> 4;
buf[0] = xdigit[c & 0x0F];
error_char ('\\');
error_char ('x');
error_string (buf);
buf[1] = '\0';
buf[0] = (unsigned char) c;
}
else if (c < ((gfc_char_t) 1 << 16))
else if (c < ((gfc_char_t) 1 << 8))
{
buf[4] = '\0';
buf[3] = xdigit[c & 0x0F];
c = c >> 4;
buf[2] = xdigit[c & 0x0F];
c = c >> 4;
buf[1] = xdigit[c & 0x0F];
c = c >> 4;
buf[0] = xdigit[c & 0x0F];
error_char ('\\');
error_char ('u');
error_string (buf);
buf[1] = '\\';
buf[0] = 'x';
}
else if (c < ((gfc_char_t) 1 << 16))
{
buf[6] = '\0';
buf[5] = xdigit[c & 0x0F];
c = c >> 4;
buf[4] = xdigit[c & 0x0F];
c = c >> 4;
buf[3] = xdigit[c & 0x0F];
c = c >> 4;
buf[2] = xdigit[c & 0x0F];
buf[1] = '\\';
buf[0] = 'u';
}
else
{
buf[8] = '\0';
buf[10] = '\0';
buf[9] = xdigit[c & 0x0F];
c = c >> 4;
buf[8] = xdigit[c & 0x0F];
c = c >> 4;
buf[7] = xdigit[c & 0x0F];
c = c >> 4;
buf[6] = xdigit[c & 0x0F];
@ -205,17 +208,18 @@ print_wide_char (gfc_char_t c)
buf[3] = xdigit[c & 0x0F];
c = c >> 4;
buf[2] = xdigit[c & 0x0F];
c = c >> 4;
buf[1] = xdigit[c & 0x0F];
c = c >> 4;
buf[0] = xdigit[c & 0x0F];
error_char ('\\');
error_char ('U');
error_string (buf);
buf[1] = '\\';
buf[0] = 'U';
}
return buf;
}
/* Show the file, where it was included, and the source line, give a
locus. Calls error_printf() recursively, but the recursion is at
most one level deep. */
static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
static void
@ -317,7 +321,7 @@ show_locus (locus *loc, int c1, int c2)
if (c == '\t')
c = ' ';
print_wide_char (c);
error_string (gfc_print_wide_char (c));
}
error_char ('\n');

42
gcc/fortran/expr.c
View File

@ -164,9 +164,8 @@ free_expr0 (gfc_expr *e)
break;
}
/* Free the representation, except in character constants where it
is the same as value.character.string and thus already freed. */
if (e->representation.string && e->ts.type != BT_CHARACTER)
/* Free the representation. */
if (e->representation.string)
gfc_free (e->representation.string);
break;
@ -393,7 +392,8 @@ gfc_expr *
gfc_copy_expr (gfc_expr *p)
{
gfc_expr *q;
char *s;
gfc_char_t *s;
char *c;
if (p == NULL)
return NULL;
@ -404,20 +404,19 @@ gfc_copy_expr (gfc_expr *p)
switch (q->expr_type)
{
case EXPR_SUBSTRING:
s = gfc_getmem (p->value.character.length + 1);
s = gfc_get_wide_string (p->value.character.length + 1);
q->value.character.string = s;
memcpy (s, p->value.character.string, p->value.character.length + 1);
memcpy (s, p->value.character.string,
(p->value.character.length + 1) * sizeof (gfc_char_t));
break;
case EXPR_CONSTANT:
/* Copy target representation, if it exists. */
if (p->representation.string)
{
s = gfc_getmem (p->representation.length + 1);
q->representation.string = s;
memcpy (s, p->representation.string, p->representation.length + 1);
c = gfc_getmem (p->representation.length + 1);
q->representation.string = c;
memcpy (c, p->representation.string, (p->representation.length + 1));
}
/* Copy the values of any pointer components of p->value. */
@ -443,10 +442,11 @@ gfc_copy_expr (gfc_expr *p)
case BT_CHARACTER:
if (p->representation.string)
q->value.character.string = q->representation.string;
q->value.character.string
= gfc_char_to_widechar (q->representation.string);
else
{
s = gfc_getmem (p->value.character.length + 1);
s = gfc_get_wide_string (p->value.character.length + 1);
q->value.character.string = s;
/* This is the case for the C_NULL_CHAR named constant. */
@ -460,7 +460,7 @@ gfc_copy_expr (gfc_expr *p)
}
else
memcpy (s, p->value.character.string,
p->value.character.length + 1);
(p->value.character.length + 1) * sizeof (gfc_char_t));
}
break;
@ -1379,7 +1379,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
int end;
int start;
int length;
char *chr;
gfc_char_t *chr;
if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
@ -1392,9 +1392,10 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
length = end - start + 1;
chr = (*newp)->value.character.string = gfc_getmem (length + 1);
chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
(*newp)->value.character.length = length;
memcpy (chr, &p->value.character.string[start - 1], length);
memcpy (chr, &p->value.character.string[start - 1],
length * sizeof (gfc_char_t));
chr[length] = '\0';
return SUCCESS;
}
@ -1592,7 +1593,7 @@ gfc_simplify_expr (gfc_expr *p, int type)
if (gfc_is_constant_expr (p))
{
char *s;
gfc_char_t *s;
int start, end;
if (p->ref && p->ref->u.ss.start)
@ -1608,8 +1609,9 @@ gfc_simplify_expr (gfc_expr *p, int type)
else
end = p->value.character.length;
s = gfc_getmem (end - start + 2);
memcpy (s, p->value.character.string + start, end - start);
s = gfc_get_wide_string (end - start + 2);
memcpy (s, p->value.character.string + start,
(end - start) * sizeof (gfc_char_t));
s[end - start + 1] = '\0'; /* TODO: C-style string. */
gfc_free (p->value.character.string);
p->value.character.string = s;

11
gcc/fortran/gfortran.h
View File

@ -1497,7 +1497,7 @@ typedef struct gfc_expr
struct
{
int length;
char *string;
gfc_char_t *string;
}
character;
@ -1959,7 +1959,14 @@ int gfc_wide_is_printable (gfc_char_t);
int gfc_wide_is_digit (gfc_char_t);
int gfc_wide_fits_in_byte (gfc_char_t);
gfc_char_t gfc_wide_tolower (gfc_char_t);
gfc_char_t gfc_wide_toupper (gfc_char_t);
size_t gfc_wide_strlen (const gfc_char_t *);
int gfc_wide_strncasecmp (const gfc_char_t *, const char *, size_t);
gfc_char_t *gfc_wide_memset (gfc_char_t *, gfc_char_t, size_t);
char *gfc_widechar_to_char (const gfc_char_t *, int);
gfc_char_t *gfc_char_to_widechar (const char *);
#define gfc_get_wide_string(n) gfc_getmem((n) * sizeof(gfc_char_t))
void gfc_skip_comments (void);
gfc_char_t gfc_next_char_literal (int);
@ -2019,6 +2026,8 @@ typedef struct gfc_error_buf
void gfc_error_init_1 (void);
void gfc_buffer_error (int);
const char *gfc_print_wide_char (gfc_char_t);
void gfc_warning (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_warning_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_clear_warning (void);

84
gcc/fortran/io.c
View File

@ -117,7 +117,7 @@ format_token;
/* Local variables for checking format strings. The saved_token is
used to back up by a single format token during the parsing
process. */
static char *format_string;
static gfc_char_t *format_string;
static int format_length, use_last_char;
static format_token saved_token;
@ -165,7 +165,7 @@ next_char (int in_string)
if (mode == MODE_COPY)
*format_string++ = c;
c = TOUPPER ((unsigned char) c);
c = gfc_wide_toupper (c);
return c;
}
@ -782,7 +782,7 @@ data_desc:
gfc_warning ("The H format specifier at %C is"
" a Fortran 95 deleted feature");
if(mode == MODE_STRING)
if (mode == MODE_STRING)
{
format_string += value;
format_length -= value;
@ -1010,7 +1010,8 @@ gfc_match_format (void)
e->ts.type = BT_CHARACTER;
e->ts.kind = gfc_default_character_kind;
e->where = start;
e->value.character.string = format_string = gfc_getmem (format_length + 1);
e->value.character.string = format_string
= gfc_get_wide_string (format_length + 1);
e->value.character.length = format_length;
gfc_statement_label->format = e;
@ -1412,13 +1413,13 @@ gfc_resolve_open (gfc_open *open)
static int
compare_to_allowed_values (const char *specifier, const char *allowed[],
const char *allowed_f2003[],
const char *allowed_gnu[], char *value,
const char *allowed_gnu[], gfc_char_t *value,
const char *statement, bool warn)
{
int i;
unsigned int len;
len = strlen (value);
len = gfc_wide_strlen (value);
if (len > 0)
{
for (len--; len > 0; len--)
@ -1429,13 +1430,13 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
for (i = 0; allowed[i]; i++)
if (len == strlen (allowed[i])
&& strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
&& gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
return 1;
for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
if (len == strlen (allowed_f2003[i])
&& strncasecmp (value, allowed_f2003[i], strlen (allowed_f2003[i]))
== 0)
&& gfc_wide_strncasecmp (value, allowed_f2003[i],
strlen (allowed_f2003[i])) == 0)
{
notification n = gfc_notification_std (GFC_STD_F2003);
@ -1461,7 +1462,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
if (len == strlen (allowed_gnu[i])
&& strncasecmp (value, allowed_gnu[i], strlen (allowed_gnu[i])) == 0)
&& gfc_wide_strncasecmp (value, allowed_gnu[i],
strlen (allowed_gnu[i])) == 0)
{
notification n = gfc_notification_std (GFC_STD_GNU);
@ -1487,14 +1489,18 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
if (warn)
{
char *s = gfc_widechar_to_char (value, -1);
gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
specifier, statement, value);
specifier, statement, s);
gfc_free (s);
return 1;
}
else
{
char *s = gfc_widechar_to_char (value, -1);
gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
specifier, statement, value);
specifier, statement, s);
gfc_free (s);
return 0;
}
}
@ -1773,20 +1779,22 @@ gfc_match_open (void)
/* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
the FILE= specifier shall appear. */
if (open->file == NULL
&& (strncasecmp (open->status->value.character.string, "replace", 7)
== 0
|| strncasecmp (open->status->value.character.string, "new", 3)
== 0))
&& (gfc_wide_strncasecmp (open->status->value.character.string,
"replace", 7) == 0
|| gfc_wide_strncasecmp (open->status->value.character.string,
"new", 3) == 0))
{
char *s = gfc_widechar_to_char (open->status->value.character.string,
-1);
warn_or_error ("The STATUS specified in OPEN statement at %C is "
"'%s' and no FILE specifier is present",
open->status->value.character.string);
"'%s' and no FILE specifier is present", s);
gfc_free (s);
}
/* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
the FILE= specifier shall not appear. */
if (strncasecmp (open->status->value.character.string, "scratch", 7)
== 0 && open->file)
if (gfc_wide_strncasecmp (open->status->value.character.string,
"scratch", 7) == 0 && open->file)
{
warn_or_error ("The STATUS specified in OPEN statement at %C "
"cannot have the value SCRATCH if a FILE specifier "
@ -1798,8 +1806,8 @@ gfc_match_open (void)
if (open->form && open->form->expr_type == EXPR_CONSTANT
&& (open->delim || open->decimal || open->encoding || open->round
|| open->sign || open->pad || open->blank)
&& strncasecmp (open->form->value.character.string,
"unformatted", 11) == 0)
&& gfc_wide_strncasecmp (open->form->value.character.string,
"unformatted", 11) == 0)
{
const char *spec = (open->delim ? "DELIM "
: (open->pad ? "PAD " : open->blank
@ -1810,7 +1818,8 @@ gfc_match_open (void)
}
if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
&& strncasecmp (open->access->value.character.string, "stream", 6) == 0)
&& gfc_wide_strncasecmp (open->access->value.character.string,
"stream", 6) == 0)
{
warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
"stream I/O");
@ -1818,12 +1827,12 @@ gfc_match_open (void)
if (open->position
&& open->access && open->access->expr_type == EXPR_CONSTANT
&& !(strncasecmp (open->access->value.character.string,
"sequential", 10) == 0
|| strncasecmp (open->access->value.character.string,
"stream", 6) == 0
|| strncasecmp (open->access->value.character.string,
"append", 6) == 0))
&& !(gfc_wide_strncasecmp (open->access->value.character.string,
"sequential", 10) == 0
|| gfc_wide_strncasecmp (open->access->value.character.string,
"stream", 6) == 0
|| gfc_wide_strncasecmp (open->access->value.character.string,
"append", 6) == 0))
{
warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
"for stream or sequential ACCESS");
@ -2939,9 +2948,12 @@ if (condition) \
if (dt->id)
{
io_constraint (!dt->asynchronous
|| strcmp (dt->asynchronous->value.character.string,
"yes"),
bool not_yes
= !dt->asynchronous
|| gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
|| gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
"yes", 3) != 0;
io_constraint (not_yes,
"ID= specifier at %L must be with ASYNCHRONOUS='yes' "
"specifier", &dt->id->where);
}
@ -3137,9 +3149,11 @@ if (condition) \
if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
{
const char * advance = expr->value.character.string;
not_no = strcasecmp (advance, "no") != 0;
not_yes = strcasecmp (advance, "yes") != 0;
const gfc_char_t *advance = expr->value.character.string;
not_no = gfc_wide_strlen (advance) != 2
|| gfc_wide_strncasecmp (advance, "no", 2) != 0;
not_yes = gfc_wide_strlen (advance) != 3
|| gfc_wide_strncasecmp (advance, "yes", 3) != 0;
}
else
{

13
gcc/fortran/module.c
View File

@ -2708,6 +2708,7 @@ mio_expr (gfc_expr **ep)
{
gfc_expr *e;
atom_type t;
char *s;
int flag;
mio_lparen ();
@ -2832,8 +2833,10 @@ mio_expr (gfc_expr **ep)
break;
case EXPR_SUBSTRING:
e->value.character.string
= CONST_CAST (char *, mio_allocated_string (e->value.character.string));
s = gfc_widechar_to_char (e->value.character.string, -1);
s = CONST_CAST (char *, mio_allocated_string (s));
e->value.character.string = gfc_char_to_widechar (s);
gfc_free (s);
mio_ref_list (&e->ref);
break;
@ -2867,8 +2870,10 @@ mio_expr (gfc_expr **ep)
case BT_CHARACTER:
mio_integer (&e->value.character.length);
e->value.character.string
= CONST_CAST (char *, mio_allocated_string (e->value.character.string));
s = gfc_widechar_to_char (e->value.character.string, -1);
s = CONST_CAST (char *, mio_allocated_string (s));
e->value.character.string = gfc_char_to_widechar (s);
gfc_free (s);
break;
default:

23
gcc/fortran/primary.c
View File

@ -278,11 +278,18 @@ match_hollerith_constant (gfc_expr **result)
e->representation.string = gfc_getmem (num + 1);
/* FIXME -- determine what should be done for wide character
strings, and do it! */
for (i = 0; i < num; i++)
e->representation.string[i]
= (unsigned char) gfc_next_char_literal (1);
{
gfc_char_t c = gfc_next_char_literal (1);
if (! gfc_wide_fits_in_byte (c))
{
gfc_error ("Invalid Hollerith constant at %L contains a "
"wide character", &old_loc);
goto cleanup;
}
e->representation.string[i] = (unsigned char) c;
}
e->representation.string[num] = '\0';
e->representation.length = num;
@ -844,14 +851,14 @@ match_charkind_name (char *name)
static match
match_string_constant (gfc_expr **result)
{
char *p, name[GFC_MAX_SYMBOL_LEN + 1], peek;
char name[GFC_MAX_SYMBOL_LEN + 1], peek;
int i, kind, length, warn_ampersand, ret;
locus old_locus, start_locus;
gfc_symbol *sym;
gfc_expr *e;
const char *q;
match m;
gfc_char_t c, delimiter;
gfc_char_t c, delimiter, *p;
old_locus = gfc_current_locus;
@ -970,7 +977,7 @@ got_delim:
e->ts.is_iso_c = 0;
e->where = start_locus;
e->value.character.string = p = gfc_getmem (length + 1);
e->value.character.string = p = gfc_get_wide_string (length + 1);
e->value.character.length = length;
gfc_current_locus = start_locus;
@ -992,7 +999,7 @@ got_delim:
return MATCH_ERROR;
}
*p++ = (unsigned char) c;
*p++ = c;
}
*p = '\0'; /* TODO: C-style string is for development/debug purposes. */

7
gcc/fortran/resolve.c
View File

@ -6804,7 +6804,6 @@ build_default_init_expr (gfc_symbol *sym)
int char_len;
gfc_expr *init_expr;
int i;
char *ch;
/* These symbols should never have a default initialization. */
if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
@ -6922,10 +6921,10 @@ build_default_init_expr (gfc_symbol *sym)
{
char_len = mpz_get_si (sym->ts.cl->length->value.integer);
init_expr->value.character.length = char_len;
init_expr->value.character.string = gfc_getmem (char_len+1);
ch = init_expr->value.character.string;
init_expr->value.character.string = gfc_get_wide_string (char_len+1);
for (i = 0; i < char_len; i++)
*(ch++) = gfc_option.flag_init_character_value;
init_expr->value.character.string[i]
= (unsigned char) gfc_option.flag_init_character_value;
}
else
{

83
gcc/fortran/scanner.c
View File

@ -113,6 +113,12 @@ gfc_wide_tolower (gfc_char_t c)
return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
}
gfc_char_t
gfc_wide_toupper (gfc_char_t c)
{
return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c);
}
int
gfc_wide_is_digit (gfc_char_t c)
{
@ -143,6 +149,17 @@ gfc_wide_strlen (const gfc_char_t *str)
return i;
}
gfc_char_t *
gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len)
{
size_t i;
for (i = 0; i < len; i++)
b[i] = c;
return b;
}
static gfc_char_t *
wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
{
@ -155,25 +172,55 @@ wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
}
static gfc_char_t *
wide_strchr (gfc_char_t *s, gfc_char_t c)
wide_strchr (const gfc_char_t *s, gfc_char_t c)
{
do {
if (*s == c)
{
return (gfc_char_t *) s;
return CONST_CAST(gfc_char_t *, s);
}
} while (*s++);
return 0;
}
static char *
widechar_to_char (gfc_char_t *s)
char *
gfc_widechar_to_char (const gfc_char_t *s, int length)
{
size_t len = gfc_wide_strlen (s), i;
char *res = gfc_getmem (len + 1);
size_t len, i;
char *res;
if (s == NULL)
return NULL;
/* Passing a negative length is used to indicate that length should be
calculated using gfc_wide_strlen(). */
len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s));
res = gfc_getmem (len + 1);
for (i = 0; i < len; i++)
res[i] = gfc_wide_fits_in_byte (s[i]) ? (unsigned char) s[i] : '?';
{
gcc_assert (gfc_wide_fits_in_byte (s[i]));
res[i] = (unsigned char) s[i];
}
res[len] = '\0';
return res;
}
gfc_char_t *
gfc_char_to_widechar (const char *s)
{
size_t len, i;
gfc_char_t *res;
if (s == NULL)
return NULL;
len = strlen (s);
res = gfc_get_wide_string (len + 1);
for (i = 0; i < len; i++)
res[i] = (unsigned char) s[i];
res[len] = '\0';
return res;
@ -196,8 +243,8 @@ wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n)
return 0;
}
static int
wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
int
gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
{
gfc_char_t c1, c2;
@ -585,7 +632,7 @@ gfc_define_undef_line (void)
if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
{
tmp = widechar_to_char (&gfc_current_locus.nextc[8]);
tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
(*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
tmp);
gfc_free (tmp);
@ -593,7 +640,7 @@ gfc_define_undef_line (void)
if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
{
tmp = widechar_to_char (&gfc_current_locus.nextc[7]);
tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
(*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
tmp);
gfc_free (tmp);
@ -1294,7 +1341,7 @@ load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen)
else
buflen = 132;
*pbuf = gfc_getmem ((buflen + 1) * sizeof (gfc_char_t));
*pbuf = gfc_get_wide_string (buflen + 1);
}
i = 0;
@ -1556,7 +1603,7 @@ preprocessor_line (gfc_char_t *c)
/* Convert the filename in wide characters into a filename in narrow
characters. */
filename = widechar_to_char (wide_filename);
filename = gfc_widechar_to_char (wide_filename, -1);
/* Interpret flags. */
@ -1647,7 +1694,7 @@ include_line (gfc_char_t *line)
while (*c == ' ' || *c == '\t')
c++;
if (wide_strncasecmp (c, "include", 7))
if (gfc_wide_strncasecmp (c, "include", 7))
return false;
c += 7;
@ -1681,7 +1728,7 @@ include_line (gfc_char_t *line)
*stop = '\0'; /* It's ok to trash the buffer, as this line won't be
read by anything else. */
filename = widechar_to_char (begin);
filename = gfc_widechar_to_char (begin, -1);
load_file (filename, false);
gfc_free (filename);
return true;
@ -1779,7 +1826,7 @@ load_file (const char *filename, bool initial)
&& line[2] == (unsigned char) '\xBF')))
{
int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
gfc_char_t *new = gfc_getmem (line_len * sizeof (gfc_char_t));
gfc_char_t *new = gfc_get_wide_string (line_len);
wide_strcpy (new, &line[n]);
gfc_free (line);
@ -1944,7 +1991,7 @@ gfc_read_orig_filename (const char *filename, const char **canon_source_file)
if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
return NULL;
tmp = widechar_to_char (&gfc_src_preprocessor_lines[0][5]);
tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
filename = unescape_filename (tmp);
gfc_free (tmp);
if (filename == NULL)
@ -1962,7 +2009,7 @@ gfc_read_orig_filename (const char *filename, const char **canon_source_file)
if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
return filename;
tmp = widechar_to_char (&gfc_src_preprocessor_lines[1][5]);
tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
dirname = unescape_filename (tmp);
gfc_free (tmp);
if (dirname == NULL)

107
gcc/fortran/simplify.c
View File

@ -284,7 +284,7 @@ gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
result->value.character.string = gfc_getmem (2);
result->value.character.string = gfc_get_wide_string (2);
result->value.character.length = 1;
result->value.character.string[0] = c;
@ -343,7 +343,7 @@ gfc_simplify_adjustl (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
char ch;
gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
@ -353,7 +353,7 @@ gfc_simplify_adjustl (gfc_expr *e)
result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
result->value.character.length = len;
result->value.character.string = gfc_getmem (len + 1);
result->value.character.string = gfc_get_wide_string (len + 1);
for (count = 0, i = 0; i < len; ++i)
{
@ -380,7 +380,7 @@ gfc_simplify_adjustr (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
char ch;
gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
@ -390,7 +390,7 @@ gfc_simplify_adjustr (gfc_expr *e)
result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
result->value.character.length = len;
result->value.character.string = gfc_getmem (len + 1);
result->value.character.string = gfc_get_wide_string (len + 1);
for (count = 0, i = len - 1; i >= 0; --i)
{
@ -843,7 +843,7 @@ gfc_simplify_char (gfc_expr *e, gfc_expr *k)
result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
result->value.character.length = 1;
result->value.character.string = gfc_getmem (2);
result->value.character.string = gfc_get_wide_string (2);
result->value.character.string[0] = c;
result->value.character.string[1] = '\0'; /* For debugger */
@ -1460,7 +1460,7 @@ gfc_expr *
gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
gfc_char_t index;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
@ -1471,7 +1471,7 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
return &gfc_bad_expr;
}
index = (unsigned char) e->value.character.string[0];
index = e->value.character.string[0];
if (gfc_option.warn_surprising && index > 127)
gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
@ -1649,7 +1649,7 @@ gfc_expr *
gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
int index;
gfc_char_t index;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
@ -1660,9 +1660,8 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
return &gfc_bad_expr;
}
index = (unsigned char) e->value.character.string[0];
if (index < 0 || index > UCHAR_MAX)
index = e->value.character.string[0];
if (index > UCHAR_MAX)
gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
@ -2687,12 +2686,13 @@ simplify_min_max (gfc_expr *expr, int sign)
#define STRING(x) ((x)->expr->value.character.string)
if (LENGTH(extremum) < LENGTH(arg))
{
char * tmp = STRING(extremum);
gfc_char_t *tmp = STRING(extremum);
STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
memcpy (STRING(extremum), tmp, LENGTH(extremum));
memset (&STRING(extremum)[LENGTH(extremum)], ' ',
LENGTH(arg) - LENGTH(extremum));
STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
memcpy (STRING(extremum), tmp,
LENGTH(extremum) * sizeof (gfc_char_t));
gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
LENGTH(arg) - LENGTH(extremum));
STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
LENGTH(extremum) = LENGTH(arg);
gfc_free (tmp);
@ -2701,10 +2701,11 @@ simplify_min_max (gfc_expr *expr, int sign)
if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
{
gfc_free (STRING(extremum));
STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
memset (&STRING(extremum)[LENGTH(arg)], ' ',
LENGTH(extremum) - LENGTH(arg));
STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
memcpy (STRING(extremum), STRING(arg),
LENGTH(arg) * sizeof (gfc_char_t));
gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
LENGTH(extremum) - LENGTH(arg));
STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
}
#undef LENGTH
@ -3008,7 +3009,7 @@ gfc_simplify_new_line (gfc_expr *e)
gfc_expr *result;
result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
result->value.character.string = gfc_getmem (2);
result->value.character.string = gfc_get_wide_string (2);
result->value.character.length = 1;
result->value.character.string[0] = '\n';
result->value.character.string[1] = '\0'; /* For debugger */
@ -3329,19 +3330,18 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
if (ncop == 0)
{
result->value.character.string = gfc_getmem (1);
result->value.character.string = gfc_get_wide_string (1);
result->value.character.length = 0;
result->value.character.string[0] = '\0';
return result;
}
result->value.character.length = nlen;
result->value.character.string = gfc_getmem (nlen + 1);
result->value.character.string = gfc_get_wide_string (nlen + 1);
for (i = 0; i < ncop; i++)
for (j = 0; j < len; j++)
result->value.character.string[j + i * len]
= e->value.character.string[j];
result->value.character.string[j+i*len]= e->value.character.string[j];
result->value.character.string[nlen] = '\0'; /* For debugger */
return result;
@ -3696,6 +3696,51 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
}
/* Variants of strspn and strcspn that operate on wide characters. */
static size_t
wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
{
size_t i = 0;
const gfc_char_t *c;
while (s1[i])
{
for (c = s2; *c; c++)
{
if (s1[i] == *c)
break;
}
if (*c == '\0')
break;
i++;
}
return i;
}
static size_t
wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
{
size_t i = 0;
const gfc_char_t *c;
while (s1[i])
{
for (c = s2; *c; c++)
{
if (s1[i] == *c)
break;
}
if (*c)
break;
i++;
}
return i;
}
gfc_expr *
gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
{
@ -3729,8 +3774,8 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
{
if (back == 0)
{
indx = strcspn (e->value.character.string, c->value.character.string)
+ 1;
indx = wide_strcspn (e->value.character.string,
c->value.character.string) + 1;
if (indx > len)
indx = 0;
}
@ -4435,7 +4480,7 @@ gfc_simplify_trim (gfc_expr *e)
lentrim = len - count;
result->value.character.length = lentrim;
result->value.character.string = gfc_getmem (lentrim + 1);
result->value.character.string = gfc_get_wide_string (lentrim + 1);
for (i = 0; i < lentrim; i++)
result->value.character.string[i] = e->value.character.string[i];
@ -4492,8 +4537,8 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
return result;
}
index = strspn (s->value.character.string, set->value.character.string)
+ 1;
index = wide_strspn (s->value.character.string,
set->value.character.string) + 1;
if (index > len)
index = 0;

4
gcc/fortran/symbol.c
View File

@ -3833,9 +3833,9 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
tmp_sym->value->ts.is_c_interop = 1;
tmp_sym->value->ts.is_iso_c = 1;
tmp_sym->value->value.character.length = 1;
tmp_sym->value->value.character.string = gfc_getmem (2);
tmp_sym->value->value.character.string = gfc_get_wide_string (2);
tmp_sym->value->value.character.string[0]
= (char) c_interop_kinds_table[s].value;
= (gfc_char_t) c_interop_kinds_table[s].value;
tmp_sym->value->value.character.string[1] = '\0';
tmp_sym->ts.cl = gfc_get_charlen ();
tmp_sym->ts.cl->length = gfc_int_expr (1);

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

@ -73,9 +73,9 @@ size_logical (int kind)
static size_t
size_character (int length)
size_character (int length, int kind)
{
return length;
return length * kind;
}
@ -100,7 +100,7 @@ gfc_target_expr_size (gfc_expr *e)
case BT_LOGICAL:
return size_logical (e->ts.kind);
case BT_CHARACTER:
return size_character (e->value.character.length);
return size_character (e->value.character.length, e->ts.kind);
case BT_HOLLERITH:
return e->representation.length;
case BT_DERIVED:
@ -174,11 +174,20 @@ encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size
static int
encode_character (int length, char *string, unsigned char *buffer,
size_t buffer_size)
encode_character (int kind, int length, gfc_char_t *string,
unsigned char *buffer, size_t buffer_size)
{
gcc_assert (buffer_size >= size_character (length));
memcpy (buffer, string, length);
char *s;
gcc_assert (buffer_size >= size_character (length, kind));
/* FIXME -- when we support wide character types, we'll need to go
via integers for them. For now, we keep the simple memcpy(). */
gcc_assert (kind == gfc_default_character_kind);
s = gfc_widechar_to_char (string, length);
memcpy (buffer, s, length);
gfc_free (s);
return length;
}
@ -248,7 +257,7 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
return encode_logical (source->ts.kind, source->value.logical, buffer,
buffer_size);
case BT_CHARACTER:
return encode_character (source->value.character.length,
return encode_character (source->ts.kind, source->value.character.length,
source->value.character.string, buffer,
buffer_size);
case BT_DERIVED:
@ -351,18 +360,24 @@ gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
int
gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
gfc_expr *result)
{
int i;
if (result->ts.cl && result->ts.cl->length)
result->value.character.length =
(int)mpz_get_ui (result->ts.cl->length->value.integer);
(int) mpz_get_ui (result->ts.cl->length->value.integer);
gcc_assert (buffer_size >= size_character (result->value.character.length));
gcc_assert (buffer_size >= size_character (result->value.character.length,
result->ts.kind));
result->value.character.string =
gfc_getmem (result->value.character.length + 1);
memcpy (result->value.character.string, buffer,
result->value.character.length);
result->value.character.string [result->value.character.length] = '\0';
gfc_get_wide_string (result->value.character.length + 1);
gcc_assert (result->ts.kind == gfc_default_character_kind);
for (i = 0; i < result->value.character.length; i++)
result->value.character.string[i] = (gfc_char_t) buffer[i];
result->value.character.string[result->value.character.length] = '\0';
return result->value.character.length;
}
@ -481,7 +496,9 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
}
if (result->ts.type == BT_CHARACTER)
result->representation.string = result->value.character.string;
result->representation.string
= gfc_widechar_to_char (result->value.character.string,
result->value.character.length);
else
{
result->representation.string =

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

@ -105,7 +105,8 @@ gfc_build_localized_cstring_const (const char *msgid)
tree
gfc_conv_string_init (tree length, gfc_expr * expr)
{
char *s;
gfc_char_t *s;
char *c;
HOST_WIDE_INT len;
int slen;
tree str;
@ -120,14 +121,21 @@ gfc_conv_string_init (tree length, gfc_expr * expr)
if (len > slen)
{
s = gfc_getmem (len);
memcpy (s, expr->value.character.string, slen);
memset (&s[slen], ' ', len - slen);
str = gfc_build_string_const (len, s);
s = gfc_get_wide_string (len);
memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
gfc_wide_memset (&s[slen], ' ', len - slen);
/* FIXME -- currently ignore wide character strings; see assert
above. */
c = gfc_widechar_to_char (s, len);
gfc_free (s);
}
else
str = gfc_build_string_const (len, expr->value.character.string);
c = gfc_widechar_to_char (expr->value.character.string,
expr->value.character.length);
str = gfc_build_string_const (len, c);
gfc_free (c);
return str;
}
@ -214,6 +222,9 @@ gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
tree res;
char *s;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
/* If it is has a prescribed memory representation, we build a string
@ -267,8 +278,12 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
}
case BT_CHARACTER:
return gfc_build_string_const (expr->value.character.length,
expr->value.character.string);
gcc_assert (expr->ts.kind == 1);
s = gfc_widechar_to_char (expr->value.character.string,
expr->value.character.length);
res = gfc_build_string_const (expr->value.character.length, s);
gfc_free (s);
return res;
case BT_HOLLERITH:
return gfc_build_string_const (expr->representation.length,

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

@ -3488,13 +3488,18 @@ static void
gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
{
gfc_ref *ref;
char *s;
ref = expr->ref;
gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
se->expr = gfc_build_string_const (expr->value.character.length,
expr->value.character.string);
gcc_assert (expr->ts.kind == gfc_default_character_kind);
s = gfc_widechar_to_char (expr->value.character.string,
expr->value.character.length);
se->expr = gfc_build_string_const (expr->value.character.length, s);
gfc_free (s);
se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;

3
gcc/fortran/trans-io.c
View File

@ -1391,8 +1391,7 @@ gfc_new_nml_name_expr (const char * name)
nml_name->ts.kind = gfc_default_character_kind;
nml_name->ts.type = BT_CHARACTER;
nml_name->value.character.length = strlen(name);
nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
strcpy (nml_name->value.character.string, name);
nml_name->value.character.string = gfc_char_to_widechar (name);
return nml_name;
}

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

@ -119,11 +119,14 @@ gfc_trans_label_assign (gfc_code * code)
}
else
{
label_str = code->label->format->value.character.string;
label_len = code->label->format->value.character.length;
label_str
= gfc_widechar_to_char (code->label->format->value.character.string,
label_len);
len_tree = build_int_cst (NULL_TREE, label_len);
label_tree = gfc_build_string_const (label_len + 1, label_str);
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
gfc_free (label_str);
}
gfc_add_modify_expr (&se.pre, len, len_tree);