aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog54
-rw-r--r--gcc/fortran/arith.c50
-rw-r--r--gcc/fortran/data.c36
-rw-r--r--gcc/fortran/decl.c9
-rw-r--r--gcc/fortran/dump-parse-tree.c6
-rw-r--r--gcc/fortran/error.c64
-rw-r--r--gcc/fortran/expr.c42
-rw-r--r--gcc/fortran/gfortran.h11
-rw-r--r--gcc/fortran/io.c84
-rw-r--r--gcc/fortran/module.c13
-rw-r--r--gcc/fortran/primary.c23
-rw-r--r--gcc/fortran/resolve.c7
-rw-r--r--gcc/fortran/scanner.c83
-rw-r--r--gcc/fortran/simplify.c107
-rw-r--r--gcc/fortran/symbol.c4
-rw-r--r--gcc/fortran/target-memory.c49
-rw-r--r--gcc/fortran/trans-const.c31
-rw-r--r--gcc/fortran/trans-expr.c9
-rw-r--r--gcc/fortran/trans-io.c3
-rw-r--r--gcc/fortran/trans-stmt.c5
20 files changed, 458 insertions, 232 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 083a1de..66873c0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,59 @@
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,
gfc_simplify_bessel_jn,gfc_simplify_bessel_y0,
gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): Mark arguments
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index 4b8d45b..cbfcf29 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -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;
}
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 13af445..6cc7223 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -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;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 6b462f9..24606c4 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -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 "
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index c195dcf..44a4941 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -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);
}
diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c
index c119bca..a9cbe9e 100644
--- a/gcc/fortran/error.c
+++ b/gcc/fortran/error.c
@@ -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);
+ {
+ buf[1] = '\0';
+ buf[0] = (unsigned char) c;
+ }
else if (c < ((gfc_char_t) 1 << 8))
{
- buf[2] = '\0';
- buf[1] = xdigit[c & 0x0F];
+ buf[4] = '\0';
+ buf[3] = xdigit[c & 0x0F];
c = c >> 4;
- buf[0] = xdigit[c & 0x0F];
+ buf[2] = xdigit[c & 0x0F];
- error_char ('\\');
- error_char ('x');
- error_string (buf);
+ buf[1] = '\\';
+ buf[0] = 'x';
}
else if (c < ((gfc_char_t) 1 << 16))
{
- buf[4] = '\0';
- buf[3] = xdigit[c & 0x0F];
+ buf[6] = '\0';
+ buf[5] = xdigit[c & 0x0F];
c = c >> 4;
- buf[2] = xdigit[c & 0x0F];
+ buf[4] = xdigit[c & 0x0F];
c = c >> 4;
- buf[1] = xdigit[c & 0x0F];
+ buf[3] = xdigit[c & 0x0F];
c = c >> 4;
- buf[0] = xdigit[c & 0x0F];
+ buf[2] = xdigit[c & 0x0F];
- error_char ('\\');
- error_char ('u');
- error_string (buf);
+ 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');
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 70914c1..87ea9e9 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -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;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 36c970c..b11cfa3 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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);
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 07848a1..736253f 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -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
{
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 832f686..8d8b22a 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -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:
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index d7491c1..fbc26af 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -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. */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4244205..6338b06 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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
{
diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c
index 871739c..21b9311 100644
--- a/gcc/fortran/scanner.c
+++ b/gcc/fortran/scanner.c
@@ -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, 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++)
+ {
+ 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 = gfc_wide_strlen (s), i;
- char *res = gfc_getmem (len + 1);
+ 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] = gfc_wide_fits_in_byte (s[i]) ? (unsigned char) s[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)
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 5de686f..e87804c 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -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;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6e87881..1d6867b 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -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);
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index e16c163..149afa1 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -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 =
diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c
index 37251ef..6c9032f 100644
--- a/gcc/fortran/trans-const.c
+++ b/gcc/fortran/trans-const.c
@@ -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,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index aae1d72..08c2591 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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;
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 6316a42..2f35002 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -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;
}
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 5660ae6..9220315 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -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);
generated by cgit v1.1 at 2024-07-20 09:31:14 +0000