int
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
#ifdef HAVE_mpc
mpc_t complex
#else
mpfr_t real, mpfr_t imaginary
#endif
)
{
int size;
size = gfc_interpret_float (kind, &buffer[0], buffer_size,
#ifdef HAVE_mpc
mpc_realref (complex)
#else
real
#endif
);
size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
#ifdef HAVE_mpc
mpc_imagref (complex)
#else
imaginary
#endif
);
return size;
}
int
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
mpfr_t real, mpfr_t imaginary)
{
int size;
size = gfc_interpret_float (kind, &buffer[0], buffer_size, real);
size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
imaginary);
return size;
}
int
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
mpc_t complex)
{
int size;
size = gfc_interpret_float (kind, &buffer[0], buffer_size,
mpc_realref (complex));
size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
mpc_imagref (complex));
return size;
}
bool
gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
{
size_t buffer_size, boz_bit_size, ts_bit_size;
int index;
unsigned char *buffer;
if (!expr->is_boz)
return true;
gcc_assert (expr->expr_type == EXPR_CONSTANT
&& expr->ts.type == BT_INTEGER);
/* Don't convert BOZ to logical, character, derived etc. */
if (ts->type == BT_REAL)
{
buffer_size = size_float (ts->kind);
ts_bit_size = buffer_size * 8;
}
else if (ts->type == BT_COMPLEX)
{
buffer_size = size_complex (ts->kind);
ts_bit_size = buffer_size * 8 / 2;
}
else
return true;
/* Convert BOZ to the smallest possible integer kind. */
boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
if (boz_bit_size > ts_bit_size)
{
gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
&expr->where, (long) boz_bit_size, (long) ts_bit_size);
return false;
}
for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
break;
expr->ts.kind = gfc_integer_kinds[index].kind;
buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
buffer = (unsigned char*)alloca (buffer_size);
encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
mpz_clear (expr->value.integer);
if (ts->type == BT_REAL)
{
mpfr_init (expr->value.real);
gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
}
else
{
#ifdef HAVE_mpc
mpc_init2 (expr->value.complex, mpfr_get_default_prec());
#else
mpfr_init (expr->value.complex.r);
mpfr_init (expr->value.complex.i);
#endif
gfc_interpret_complex (ts->kind, buffer, buffer_size,
#ifdef HAVE_mpc
expr->value.complex
#else
expr->value.complex.r, expr->value.complex.i
#endif
);
}
expr->is_boz = 0;
expr->ts.type = ts->type;
expr->ts.kind = ts->kind;
return true;
}
/* Read a binary buffer to a constant expression. */
int
gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
gfc_expr *result)
{
if (result->expr_type == EXPR_ARRAY)
return interpret_array (buffer, buffer_size, result);
switch (result->ts.type)
{
case BT_INTEGER:
result->representation.length =
gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
result->value.integer);
break;
case BT_REAL:
result->representation.length =
gfc_interpret_float (result->ts.kind, buffer, buffer_size,
result->value.real);
break;
case BT_COMPLEX:
result->representation.length =
gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
#ifdef HAVE_mpc
result->value.complex
#else
result->value.complex.r,
result->value.complex.i
#endif
);
break;
case BT_LOGICAL:
result->representation.length =
gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
&result->value.logical);
break;
case BT_CHARACTER:
result->representation.length =
gfc_interpret_character (buffer, buffer_size, result);
break;
case BT_DERIVED:
result->representation.length =
gfc_interpret_derived (buffer, buffer_size, result);
break;
default:
gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
break;
}
if (result->ts.type == BT_CHARACTER)
result->representation.string
= gfc_widechar_to_char (result->value.character.string,
result->value.character.length);
else
{
result->representation.string =
(char *) gfc_getmem (result->representation.length + 1);
memcpy (result->representation.string, buffer,
result->representation.length);
result->representation.string[result->representation.length] = '\0';
}
return result->representation.length;
}