+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,
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';
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;
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;
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);
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)
{
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);
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;
}
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;
}
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;
}
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;
}
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;
}
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);
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;
/* 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)
{
"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;
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);
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 "
static void
-show_char_const (const char *c, int length)
+show_char_const (const gfc_char_t *c, int length)
{
int i;
{
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);
}
}
-/* 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];
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
if (c == '\t')
c = ' ';
- print_wide_char (c);
+ error_string (gfc_print_wide_char (c));
}
error_char ('\n');
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;
gfc_copy_expr (gfc_expr *p)
{
gfc_expr *q;
- char *s;
+ gfc_char_t *s;
+ char *c;
if (p == NULL)
return NULL;
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. */
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. */
}
else
memcpy (s, p->value.character.string,
- p->value.character.length + 1);
+ (p->value.character.length + 1) * sizeof (gfc_char_t));
}
break;
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)
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;
}
if (gfc_is_constant_expr (p))
{
- char *s;
+ gfc_char_t *s;
int start, end;
if (p->ref && p->ref->u.ss.start)
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;
struct
{
int length;
- char *string;
+ gfc_char_t *string;
}
character;
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);
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);
/* 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;
if (mode == MODE_COPY)
*format_string++ = c;
- c = TOUPPER ((unsigned char) c);
+ c = gfc_wide_toupper (c);
return c;
}
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;
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;
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--)
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);
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);
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;
}
}
/* 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 "
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
}
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");
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");
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);
}
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
{
{
gfc_expr *e;
atom_type t;
+ char *s;
int flag;
mio_lparen ();
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;
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:
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;
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;
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;
return MATCH_ERROR;
}
- *p++ = (unsigned char) c;
+ *p++ = c;
}
*p = '\0'; /* TODO: C-style string is for development/debug purposes. */
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))
{
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
{
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)
{
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)
{
}
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;
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;
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);
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);
else
buflen = 132;
- *pbuf = gfc_getmem ((buflen + 1) * sizeof (gfc_char_t));
+ *pbuf = gfc_get_wide_string (buflen + 1);
}
i = 0;
/* 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. */
while (*c == ' ' || *c == '\t')
c++;
- if (wide_strncasecmp (c, "include", 7))
+ if (gfc_wide_strncasecmp (c, "include", 7))
return false;
c += 7;
*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;
&& 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);
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)
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)
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;
{
gfc_expr *result;
int count, i, len;
- char ch;
+ gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
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)
{
{
gfc_expr *result;
int count, i, len;
- char ch;
+ gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
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)
{
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 */
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;
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",
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;
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)
#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);
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
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 */
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;
}
+/* 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)
{
{
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;
}
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];
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;
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);
static size_t
-size_character (int length)
+size_character (int length, int kind)
{
- return length;
+ return length * kind;
}
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:
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;
}
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:
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;
}
}
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 =
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;
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;
}
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
}
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,
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;
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;
}
}
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);
projects / gcc.git / commitdiff