/* R_mpc - Create an MPC S3 object for arbitrary precision complex numbers.
*
* We currently use external pointers for performance reasons, which
* means that we can't allocVector a list of length(n) MPC objects,
* and instead must instantiate them one at a time, that a caller can
* put into a list if they want, but not a vector.
*
* Args:
* n - An integer, numeric, or complex number to convert to an MPC.
* sprec - The number of bits of precision to use, e.g. 52 for doubles.
*/
SEXP R_mpc(SEXP n, SEXP sprec) {
/* TODO: INTEGER returns 32bit integer but mpfr_prec_t may be
* 64bit. This is based on how mpfr was compiled. Therefore we
* could add this as a configure check? */
mpfr_prec_t prec = INTEGER(sprec)[0];
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
mpc_init2(*z, prec);
if (Rf_isInteger(n)) {
mpc_set_d(*z, INTEGER(n)[0], Rmpc_get_rounding());
} else if (Rf_isNumeric(n)) {
mpc_set_d(*z, REAL(n)[0], Rmpc_get_rounding());
} else if (Rf_isComplex(n)) {
mpc_set_d_d(*z, COMPLEX(n)[0].r, COMPLEX(n)[0].i,
Rmpc_get_rounding());
} else if (Rf_isString(n)) {
mpc_set_str(*z, CHAR(STRING_ELT(n, 0)), 10,
Rmpc_get_rounding());
} else {
Rf_error("Unsupported type conversion to MPC.");
}
return(MakeMPC(z));
}
int
mpc_inp_str (mpc_ptr rop, FILE *stream, size_t *read, int base,
mpc_rnd_t rnd_mode)
{
size_t white, nread = 0;
int inex = -1;
int c;
char *str;
if (stream == NULL)
stream = stdin;
white = skip_whitespace (stream);
c = getc (stream);
if (c != EOF) {
if (c == '(') {
char *real_str;
char *imag_str;
size_t n;
int ret;
nread++; /* the opening parenthesis */
white = skip_whitespace (stream);
real_str = extract_string (stream);
nread += strlen(real_str);
c = getc (stream);
if (!isspace ((unsigned int) c)) {
if (c != EOF)
ungetc (c, stream);
mpc_free_str (real_str);
goto error;
}
else
ungetc (c, stream);
white += skip_whitespace (stream);
imag_str = extract_string (stream);
nread += strlen (imag_str);
str = mpc_alloc_str (nread + 2);
ret = sprintf (str, "(%s %s", real_str, imag_str);
MPC_ASSERT (ret >= 0);
n = (size_t) ret;
MPC_ASSERT (n == nread + 1);
mpc_free_str (real_str);
mpc_free_str (imag_str);
white += skip_whitespace (stream);
c = getc (stream);
if (c == ')') {
str = mpc_realloc_str (str, nread +2, nread + 3);
str [nread+1] = (char) c;
str [nread+2] = '\0';
nread++;
}
else if (c != EOF)
ungetc (c, stream);
}
else {
if (c != EOF)
ungetc (c, stream);
str = extract_string (stream);
nread += strlen (str);
}
inex = mpc_set_str (rop, str, base, rnd_mode);
mpc_free_str (str);
}
error:
if (inex == -1) {
mpfr_set_nan (MPC_RE(rop));
mpfr_set_nan (MPC_IM(rop));
}
if (read != NULL)
*read = white + nread;
return inex;
}
int Lib_Mpcr_Set_Str(MpcrPtr x, const char * str , int base, long rnd)
{
return mpc_set_str( (mpc_ptr) x, str, base, (mpc_rnd_t) rnd);
}
mpcomplex::mpcomplex( char* num, const mp_prec_t &p, const mp_rnd_t &r ) {
set_properties( r, p );
init();
mpc_set_str(mpc_val, num , 10, mpc_rnd);
}
static void
check_set_str (mpfr_exp_t exp_max)
{
mpc_t expected;
mpc_t got;
char *str;
mpfr_prec_t prec;
mpfr_exp_t exp_min;
int base;
mpc_init2 (expected, 1024);
mpc_init2 (got, 1024);
exp_min = mpfr_get_emin ();
if (exp_max <= 0)
exp_max = mpfr_get_emax ();
else if (exp_max > mpfr_get_emax ())
exp_max = mpfr_get_emax();
if (-exp_max > exp_min)
exp_min = - exp_max;
for (prec = 2; prec < 1024; prec += 7)
{
mpc_set_prec (got, prec);
mpc_set_prec (expected, prec);
base = 2 + (int) gmp_urandomm_ui (rands, 35);
/* uses external variable rands from random.c */
mpfr_set_nan (MPC_RE (expected));
mpfr_set_inf (MPC_IM (expected), prec % 2 - 1);
str = mpc_get_str (base, 0, expected, MPC_RNDNN);
if (mpfr_nan_p (MPC_RE (got)) == 0
|| mpfr_cmp (MPC_IM (got), MPC_IM (expected)) != 0)
{
printf ("Error: mpc_set_str o mpc_get_str != Id\n"
"in base %u with str=\"%s\"\n", base, str);
MPC_OUT (expected);
printf (" ");
MPC_OUT (got);
exit (1);
}
mpc_free_str (str);
test_default_random (expected, exp_min, exp_max, 128, 25);
str = mpc_get_str (base, 0, expected, MPC_RNDNN);
if (mpc_set_str (got, str, base, MPC_RNDNN) == -1
|| mpc_cmp (got, expected) != 0)
{
printf ("Error: mpc_set_str o mpc_get_str != Id\n"
"in base %u with str=\"%s\"\n", base, str);
MPC_OUT (expected);
printf (" ");
MPC_OUT (got);
exit (1);
}
mpc_free_str (str);
}
#ifdef HAVE_SETLOCALE
{
/* Check with ',' as a decimal point */
char *old_locale;
old_locale = setlocale (LC_ALL, "de_DE");
if (old_locale != NULL)
{
str = mpc_get_str (10, 0, expected, MPC_RNDNN);
if (mpc_set_str (got, str, 10, MPC_RNDNN) == -1
|| mpc_cmp (got, expected) != 0)
{
printf ("Error: mpc_set_str o mpc_get_str != Id\n"
"with str=\"%s\"\n", str);
MPC_OUT (expected);
printf (" ");
MPC_OUT (got);
exit (1);
}
mpc_free_str (str);
setlocale (LC_ALL, old_locale);
}
}
#endif /* HAVE_SETLOCALE */
/* the real part has a zero exponent in base ten (fixed in r439) */
mpc_set_prec (expected, 37);
mpc_set_prec (got, 37);
mpc_set_str (expected, "921FC04EDp-35 ", 16, GMP_RNDN);
str = mpc_get_str (10, 0, expected, MPC_RNDNN);
if (mpc_set_str (got, str, 10, MPC_RNDNN) == -1
|| mpc_cmp (got, expected) != 0)
{
printf ("Error: mpc_set_str o mpc_get_str != Id\n"
"with str=\"%s\"\n", str);
MPC_OUT (expected);
printf (" ");
MPC_OUT (got);
exit (1);
}
mpc_free_str (str);
str = mpc_get_str (1, 0, expected, MPC_RNDNN);
if (str != NULL)
{
printf ("Error: mpc_get_str with base==1 should fail\n");
exit (1);
}
mpc_clear (expected);
mpc_clear (got);
}