SEXP R_mpc_imag(SEXP e1) {
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (mpfr_fits_sint_p(mpc_imagref(*z1), GMP_RNDN)) {
return Rf_ScalarReal(mpfr_get_d(mpc_imagref(*z1),
GMP_RNDN));
} else {
Rf_error("Imaginary part doesn't fit in numeric.");
}
} else {
Rf_error("Invalid operand for MPC log.");
}
return R_NilValue; /* Not reached */
}
SEXP R_mpc_arg(SEXP e1) {
mpfr_t x;
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
mpc_arg(x, *z1, GMP_RNDN);
if (mpfr_fits_sint_p(x, GMP_RNDN)) {
return Rf_ScalarReal(mpfr_get_d(x, GMP_RNDN));
} else {
Rf_error("Arg doesn't fit in numeric.");
}
} else {
Rf_error("Invalid operand for MPC log.");
}
return R_NilValue; /* Not reached */
}
/* Convert R "mpfr" object (list of "mpfr1") to R "integer" vector : */
SEXP mpfr2i(SEXP x, SEXP rnd_mode) {
int n = length(x), i;
SEXP val = PROTECT(allocVector(INTSXP, n));
int *r = INTEGER(val);
mpfr_t R_i;
mpfr_init(R_i); /* with default precision */
for(i=0; i < n; i++) {
R_asMPFR(VECTOR_ELT(x, i), R_i);
if(!mpfr_fits_sint_p(R_i, R_rnd2MP(rnd_mode))) {
warning("NAs introduced by coercion from \"mpfr\" [%d]", i+1);
r[i] = NA_INTEGER;
}
else {
long lr = mpfr_get_si(R_i, R_rnd2MP(rnd_mode));
r[i] = (int) lr;
}
}
mpfr_clear (R_i);
mpfr_free_cache();
UNPROTECT(1);
return val;
}
int
main (void)
{
mpfr_t x;
tests_start_mpfr ();
mpfr_init2 (x, 256);
/* Check NAN */
mpfr_set_nan(x);
if (mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_slong_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_uint_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_sint_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_ushort_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR1;
/* Check INF */
mpfr_set_inf(x, 1);
if (mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_slong_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_uint_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_sint_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_ushort_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR1;
/* Check Zero */
MPFR_SET_ZERO(x);
if (!mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_slong_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_uint_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_sint_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_ushort_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR2;
/* Check small op */
mpfr_set_str1 (x, "1@-1");
if (!mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_slong_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_uint_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_sint_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_ushort_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR2;
/* Check 17 */
mpfr_set_ui (x, 17, GMP_RNDN);
if (!mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_slong_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_uint_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_sint_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_ushort_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR2;
/* Check all other values */
mpfr_set_ui(x, ULONG_MAX, GMP_RNDN);
mpfr_mul_2exp(x, x, 1, GMP_RNDN);
if (mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_slong_p(x, GMP_RNDN))
ERROR1;
mpfr_mul_2exp(x, x, 40, GMP_RNDN);
if (mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_uint_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_sint_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_ushort_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR1;
mpfr_set_ui(x, ULONG_MAX, GMP_RNDN);
if (!mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR2;
mpfr_set_ui(x, LONG_MAX, GMP_RNDN);
if (!mpfr_fits_slong_p(x, GMP_RNDN))
ERROR2;
mpfr_set_ui(x, UINT_MAX, GMP_RNDN);
if (!mpfr_fits_uint_p(x, GMP_RNDN))
ERROR2;
mpfr_set_ui(x, INT_MAX, GMP_RNDN);
if (!mpfr_fits_sint_p(x, GMP_RNDN))
ERROR2;
mpfr_set_ui(x, USHRT_MAX, GMP_RNDN);
if (!mpfr_fits_ushort_p(x, GMP_RNDN))
ERROR2;
mpfr_set_ui(x, SHRT_MAX, GMP_RNDN);
if (!mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR2;
mpfr_set_si(x, 1, GMP_RNDN);
if (!mpfr_fits_sint_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR2;
/* Check negative value */
mpfr_set_si (x, -1, GMP_RNDN);
if (!mpfr_fits_sint_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_sshort_p(x, GMP_RNDN))
ERROR2;
if (!mpfr_fits_slong_p(x, GMP_RNDN))
ERROR2;
if (mpfr_fits_uint_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_ushort_p(x, GMP_RNDN))
ERROR1;
if (mpfr_fits_ulong_p(x, GMP_RNDN))
ERROR1;
mpfr_clear (x);
check_intmax ();
tests_end_mpfr ();
return 0;
}
int
main (void)
{
mpfr_t x, y;
int i, r;
tests_start_mpfr ();
mpfr_init2 (x, 256);
mpfr_init2 (y, 8);
RND_LOOP (r)
{
/* Check NAN */
mpfr_set_nan (x);
if (mpfr_fits_ulong_p (x, (mpfr_rnd_t) r))
ERROR1 (1);
if (mpfr_fits_slong_p (x, (mpfr_rnd_t) r))
ERROR1 (2);
if (mpfr_fits_uint_p (x, (mpfr_rnd_t) r))
ERROR1 (3);
if (mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (4);
if (mpfr_fits_ushort_p (x, (mpfr_rnd_t) r))
ERROR1 (5);
if (mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (6);
/* Check INF */
mpfr_set_inf (x, 1);
if (mpfr_fits_ulong_p (x, (mpfr_rnd_t) r))
ERROR1 (7);
if (mpfr_fits_slong_p (x, (mpfr_rnd_t) r))
ERROR1 (8);
if (mpfr_fits_uint_p (x, (mpfr_rnd_t) r))
ERROR1 (9);
if (mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (10);
if (mpfr_fits_ushort_p (x, (mpfr_rnd_t) r))
ERROR1 (11);
if (mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (12);
/* Check Zero */
MPFR_SET_ZERO (x);
if (!mpfr_fits_ulong_p (x, (mpfr_rnd_t) r))
ERROR1 (13);
if (!mpfr_fits_slong_p (x, (mpfr_rnd_t) r))
ERROR1 (14);
if (!mpfr_fits_uint_p (x, (mpfr_rnd_t) r))
ERROR1 (15);
if (!mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (16);
if (!mpfr_fits_ushort_p (x, (mpfr_rnd_t) r))
ERROR1 (17);
if (!mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (18);
/* Check small positive op */
mpfr_set_str1 (x, "1@-1");
if (!mpfr_fits_ulong_p (x, (mpfr_rnd_t) r))
ERROR1 (19);
if (!mpfr_fits_slong_p (x, (mpfr_rnd_t) r))
ERROR1 (20);
if (!mpfr_fits_uint_p (x, (mpfr_rnd_t) r))
ERROR1 (21);
if (!mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (22);
if (!mpfr_fits_ushort_p (x, (mpfr_rnd_t) r))
ERROR1 (23);
if (!mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (24);
/* Check 17 */
mpfr_set_ui (x, 17, MPFR_RNDN);
if (!mpfr_fits_ulong_p (x, (mpfr_rnd_t) r))
ERROR1 (25);
if (!mpfr_fits_slong_p (x, (mpfr_rnd_t) r))
ERROR1 (26);
if (!mpfr_fits_uint_p (x, (mpfr_rnd_t) r))
ERROR1 (27);
if (!mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (28);
if (!mpfr_fits_ushort_p (x, (mpfr_rnd_t) r))
ERROR1 (29);
if (!mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (30);
/* Check all other values */
mpfr_set_ui (x, ULONG_MAX, MPFR_RNDN);
mpfr_mul_2exp (x, x, 1, MPFR_RNDN);
if (mpfr_fits_ulong_p (x, (mpfr_rnd_t) r))
ERROR1 (31);
if (mpfr_fits_slong_p (x, (mpfr_rnd_t) r))
ERROR1 (32);
mpfr_mul_2exp (x, x, 40, MPFR_RNDN);
if (mpfr_fits_ulong_p (x, (mpfr_rnd_t) r))
ERROR1 (33);
if (mpfr_fits_uint_p (x, (mpfr_rnd_t) r))
ERROR1 (34);
if (mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (35);
if (mpfr_fits_ushort_p (x, (mpfr_rnd_t) r))
ERROR1 (36);
if (mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (37);
mpfr_set_ui (x, ULONG_MAX, MPFR_RNDN);
if (!mpfr_fits_ulong_p (x, (mpfr_rnd_t) r))
ERROR1 (38);
mpfr_set_ui (x, LONG_MAX, MPFR_RNDN);
if (!mpfr_fits_slong_p (x, (mpfr_rnd_t) r))
ERROR1 (39);
mpfr_set_ui (x, UINT_MAX, MPFR_RNDN);
if (!mpfr_fits_uint_p (x, (mpfr_rnd_t) r))
ERROR1 (40);
mpfr_set_ui (x, INT_MAX, MPFR_RNDN);
if (!mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (41);
mpfr_set_ui (x, USHRT_MAX, MPFR_RNDN);
if (!mpfr_fits_ushort_p (x, (mpfr_rnd_t) r))
ERROR1 (42);
mpfr_set_ui (x, SHRT_MAX, MPFR_RNDN);
if (!mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (43);
mpfr_set_si (x, 1, MPFR_RNDN);
if (!mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (44);
if (!mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (45);
/* Check negative op */
for (i = 1; i <= 4; i++)
{
int inv;
mpfr_set_si_2exp (x, -i, -2, MPFR_RNDN);
mpfr_rint (y, x, (mpfr_rnd_t) r);
inv = MPFR_NOTZERO (y);
if (!mpfr_fits_ulong_p (x, (mpfr_rnd_t) r) ^ inv)
ERROR1 (46);
if (!mpfr_fits_slong_p (x, (mpfr_rnd_t) r))
ERROR1 (47);
if (!mpfr_fits_uint_p (x, (mpfr_rnd_t) r) ^ inv)
ERROR1 (48);
if (!mpfr_fits_sint_p (x, (mpfr_rnd_t) r))
ERROR1 (49);
if (!mpfr_fits_ushort_p (x, (mpfr_rnd_t) r) ^ inv)
ERROR1 (50);
if (!mpfr_fits_sshort_p (x, (mpfr_rnd_t) r))
ERROR1 (51);
}
}
mpfr_clear (x);
mpfr_clear (y);
check_intmax ();
tests_end_mpfr ();
return 0;
}