tree
gfc_conv_string_init (tree length, gfc_expr * expr)
{
gfc_char_t *s;
HOST_WIDE_INT len;
int slen;
tree str;
bool free_s = false;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
gcc_assert (expr->ts.type == BT_CHARACTER);
gcc_assert (INTEGER_CST_P (length));
gcc_assert (TREE_INT_CST_HIGH (length) == 0);
len = TREE_INT_CST_LOW (length);
slen = expr->value.character.length;
if (len > slen)
{
s = gfc_get_wide_string (len);
memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
gfc_wide_memset (&s[slen], ' ', len - slen);
free_s = true;
}
else
s = expr->value.character.string;
str = gfc_build_wide_string_const (expr->ts.kind, len, s);
if (free_s)
free (s);
return str;
}
int
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);
gcc_assert (buffer_size >= size_character (result->value.character.length,
result->ts.kind));
result->value.character.string =
gfc_get_wide_string (result->value.character.length + 1);
if (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];
else
{
mpz_t integer;
unsigned bytes = size_character (1, result->ts.kind);
mpz_init (integer);
gcc_assert (bytes <= sizeof (unsigned long));
for (i = 0; i < result->value.character.length; i++)
{
gfc_conv_tree_to_mpz (integer,
native_interpret_expr (gfc_get_char_type (result->ts.kind),
&buffer[bytes*i], buffer_size-bytes*i));
result->value.character.string[i]
= (gfc_char_t) mpz_get_ui (integer);
}
mpz_clear (integer);
}
result->value.character.string[result->value.character.length] = '\0';
return result->value.character.length;
}
static gfc_expr *
create_character_intializer (gfc_expr *init, gfc_typespec *ts,
gfc_ref *ref, gfc_expr *rvalue)
{
int len, start, end;
gfc_char_t *dest;
gfc_extract_int (ts->cl->length, &len);
if (init == NULL)
{
/* Create a new initializer. */
init = gfc_get_expr ();
init->expr_type = EXPR_CONSTANT;
init->ts = *ts;
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)
gfc_wide_memset (dest, ' ', len);
}
else
dest = init->value.character.string;
if (ref)
{
gfc_expr *start_expr, *end_expr;
gcc_assert (ref->type == REF_SUBSTRING);
/* Only set a substring of the destination. Fortran substring bounds
are one-based [start, end], we want zero based [start, end). */
start_expr = gfc_copy_expr (ref->u.ss.start);
end_expr = gfc_copy_expr (ref->u.ss.end);
if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
{
gfc_error ("failure to simplify substring reference in DATA "
"statement at %L", &ref->u.ss.start->where);
return NULL;
}
gfc_extract_int (start_expr, &start);
start--;
gfc_extract_int (end_expr, &end);
}
else
{
/* Set the whole string. */
start = 0;
end = len;
}
/* Copy the initial value. */
if (rvalue->ts.type == BT_HOLLERITH)
len = rvalue->representation.length;
else
len = rvalue->value.character.length;
if (len > end - start)
{
len = end - start;
gfc_warning_now ("initialization string truncated to match variable "
"at %L", &rvalue->where);
}
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)
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
= gfc_widechar_to_char (init->value.character.string,
init->value.character.length);
}
return init;
}
