int
gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
mpfr_t real)
{
mpfr_init (real);
gfc_conv_tree_to_mpfr (real,
native_interpret_expr (gfc_get_real_type (kind),
buffer, buffer_size));
return size_float (kind);
}
tree
gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
{
tree type;
int n;
REAL_VALUE_TYPE real;
n = gfc_validate_kind (BT_REAL, kind, false);
gcc_assert (gfc_real_kinds[n].radix == 2);
type = gfc_get_real_type (kind);
if (mpfr_nan_p (f) && is_snan)
real_from_string (&real, "SNaN");
else
real_from_mpfr (&real, f, type, GFC_RND_MODE);
return build_real (type, real);
}
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
tree res;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
/* If it is has a prescribed memory representation, we build a string
constant and VIEW_CONVERT to its type. */
switch (expr->ts.type)
{
case BT_INTEGER:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_real_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
case BT_LOGICAL:
if (expr->representation.string)
{
tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
if (!integer_zerop (tmp) && !integer_onep (tmp))
gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
" has undefined result at %L", &expr->where);
return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
}
else
return build_int_cst (gfc_get_logical_type (expr->ts.kind),
expr->value.logical);
case BT_COMPLEX:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_complex_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
{
tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
expr->ts.kind, expr->is_snan);
tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
expr->ts.kind, expr->is_snan);
return build_complex (gfc_typenode_for_spec (&expr->ts),
real, imag);
}
case BT_CHARACTER:
res = gfc_build_wide_string_const (expr->ts.kind,
expr->value.character.length,
expr->value.character.string);
return res;
case BT_HOLLERITH:
return gfc_build_string_const (expr->representation.length,
expr->representation.string);
default:
fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
gfc_typename (&expr->ts));
}
}
static size_t
size_float (int kind)
{
return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
}
tree
gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
{
tree res;
tree type;
mp_exp_t exp;
char *p;
char *q;
int n;
int edigits;
for (n = 0; gfc_real_kinds[n].kind != 0; n++)
{
if (gfc_real_kinds[n].kind == kind)
break;
}
gcc_assert (gfc_real_kinds[n].kind);
n = MAX (abs (gfc_real_kinds[n].min_exponent),
abs (gfc_real_kinds[n].max_exponent));
edigits = 1;
while (n > 0)
{
n = n / 10;
edigits += 3;
}
if (kind == gfc_default_double_kind)
p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE);
else
p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE);
/* We also have one minus sign, "e", "." and a null terminator. */
q = (char *) gfc_getmem (strlen (p) + edigits + 4);
if (p[0])
{
if (p[0] == '-')
{
strcpy (&q[2], &p[1]);
q[0] = '-';
q[1] = '.';
}
else
{
strcpy (&q[1], p);
q[0] = '.';
}
strcat (q, "e");
sprintf (&q[strlen (q)], "%d", (int) exp);
}
else
{
strcpy (q, "0");
}
type = gfc_get_real_type (kind);
res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
gfc_free (q);
gfc_free (p);
return res;
}
