static void
mpfr_set_double_range (void)
{
mpfr_set_default_prec (54);
if (mpfr_get_default_prec () != 54)
ERROR ("get_default_prec failed (1)");
mpfr_set_default_prec (53);
if ((mpfr_get_default_prec) () != 53)
ERROR ("get_default_prec failed (2)");
/* in double precision format, the unbiased exponent is between 0 and
2047, where 0 is used for subnormal numbers, and 2047 for special
numbers (infinities, NaN), and the bias is 1023, thus "normal" numbers
have an exponent between -1022 and 1023, corresponding to numbers
between 2^(-1022) and previous(2^(1024)).
(The smallest subnormal number is 0.(0^51)1*2^(-1022)= 2^(-1074).)
The smallest normal power of two is 1.0*2^(-1022).
The largest normal power of two is 2^1023.
(We have to add one for mpfr since mantissa are between 1/2 and 1.)
*/
set_emin (-1021);
set_emax (1024);
}
std::string real::get_string(int p) const
{
std::string string;
char *raw_string;
mpfr_exp_t exp;
if (mpfr_nan_p(r) != 0)
{
string = "nan";
}
else if (mpfr_inf_p(r) != 0)
{
if (mpfr_sgn(r) < 0)
{
string = "-inf";
}
else
{
string = "inf";
}
}
else
{
// Dynamically allocate a character array to hold the base-10
// representation of the real.
raw_string = new char[(int)mpfr_get_default_prec()];
mpfr_get_str(raw_string, &exp, 10, p, r, MPFR_RNDN);
string = std::string(raw_string);
if (mpfr_zero_p(r) == 0)
{
// The cast is to prevent a warning in case mpfr_exp_t is not
// defined as an int, but as a short or a long.
std::sprintf(raw_string, "%d", (int)(exp - 1));
}
else
{
std::sprintf(raw_string, "0");
}
if (string[0] == '-')
{
string = string.substr(0, 2) + std::string(".") + string.substr(2) + std::string("e") + std::string(raw_string);
}
else
{
string = string.substr(0, 1) + std::string(".") + string.substr(1) + std::string("e") + std::string(raw_string);
}
// Free the array.
delete[] raw_string;
}
return string;
}
static
mpfr_prec_t
num_prec(num_t a)
{
mpfr_prec_t prec;
if (a != NULL && a->num_type == NUM_INT) {
/* XXX: completely arbitrary! */
return 2048;
} else if (a != NULL && a->num_type == NUM_FP) {
return mpfr_get_prec(F(a));
} else {
return mpfr_get_default_prec();
}
}
num_t
num_new_fp(int flags, num_t b)
{
num_t r;
r = num_new(flags);
r->num_type = NUM_FP;
mpfr_init(F(r));
if (b != NULL) {
mpfr_prec_t prec_b = num_prec(b);
if (prec_b > mpfr_get_default_prec())
mpfr_set_prec(F(r), prec_b);
if (b->num_type == NUM_INT)
mpfr_set_z(F(r), Z(b), round_mode);
else if (b->num_type == NUM_FP)
mpfr_set(F(r), F(b), round_mode);
}
return r;
}
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;
}
SEXP R_mpfr_set_default_prec(SEXP prec) {
// return the previous value
int prev = (int) mpfr_get_default_prec();
mpfr_set_default_prec((mpfr_prec_t) asInteger(prec));
return ScalarInteger(prev);
}
SEXP R_mpfr_get_default_prec(void) {
return ScalarInteger((int) mpfr_get_default_prec());
}
void Lib_Mpcr_Init(MpcrPtr* x)
{
(*x) = malloc (sizeof(__mpc_struct));
mpc_init2( (mpc_ptr) (*x), mpfr_get_default_prec());
}
