static void
bug20080610 (void)
{
/* bug on icc found on June 10, 2008 */
/* this is not a bug but a different implementation choice: ISO C99 doesn't
specify the sign of a zero exponent (see note in random_double above). */
mpfr_t x;
double y;
int xi;
char *xs;
int yi;
char *ys;
mpfr_init2 (x, MPFR_LDBL_MANT_DIG);
y = -9.95645044213728791504536275169812142849e-01;
mpfr_set_d (x, y, MPFR_RNDN);
xi = mpfr_asprintf (&xs, "%- #0.*Re", 1, x);
yi = mpfr_asprintf (&ys, "%- #0.*e", 1, y);
if (xi != yi || strcmp (xs, ys) != 0)
{
printf ("Error in bug20080610\n");
printf ("expected: %s\n", ys);
printf (" got: %s\n", xs);
printf ("xi=%d yi=%d\n", xi, yi);
exit (1);
}
mpfr_free_str (xs);
mpfr_free_str (ys);
mpfr_clear (x);
}
static void
bug20081214 (void)
{
/* problem with glibc 2.3.6, December 14, 2008:
the system asprintf outputs "-1.0" instead of "-1.". */
mpfr_t x;
double y;
int xi;
char *xs;
int yi;
char *ys;
mpfr_init2 (x, MPFR_LDBL_MANT_DIG);
y = -9.90597761233942053494e-01;
mpfr_set_d (x, y, MPFR_RNDN);
xi = mpfr_asprintf (&xs, "%- #0.*RG", 1, x);
yi = mpfr_asprintf (&ys, "%- #0.*G", 1, y);
if (xi != yi || strcmp (xs, ys) != 0)
{
mpfr_printf ("Error in bug20081214\n"
"mpfr_asprintf(\"%- #0.*Re\", 1, %Re)\n", x);
printf ("expected: %s\n", ys);
printf (" got: %s\n", xs);
printf ("xi=%d yi=%d\n", xi, yi);
exit (1);
}
mpfr_free_str (xs);
mpfr_free_str (ys);
mpfr_clear (x);
}
static VALUE r_mpfi_matrix_to_strf_ary (VALUE self, VALUE format_str) {
MPFIMatrix *ptr_self;
char *tmp_str1, *tmp_str2, *format;
int i, j;
VALUE *ary, ret_ary;
r_mpfi_get_matrix_struct(ptr_self, self);
format = StringValuePtr(format_str);
ary = ALLOC_N(VALUE, ptr_self->row);
for (i = 0; i < ptr_self->row; i++) {
ary[i] = rb_ary_new();
}
for (i = 0; i < ptr_self->size; i += ptr_self->row) {
for (j = 0; j < ptr_self->row; j++) {
if (!mpfr_asprintf(&tmp_str1, format, r_mpfi_left_ptr((ptr_self->data + i + j)))) {
rb_raise(rb_eFatal, "Can not allocate a string by mpfr_asprintf.");
}
if (!mpfr_asprintf(&tmp_str2, format, r_mpfi_right_ptr(ptr_self->data + i + j))) {
rb_raise(rb_eFatal, "Can not allocate a string by mpfr_asprintf.");
}
rb_ary_push(ary[j], rb_ary_new3(2, rb_str_new2(tmp_str1), rb_str_new2(tmp_str2)));
mpfr_free_str(tmp_str1);
mpfr_free_str(tmp_str2);
}
}
ret_ary = rb_ary_new4(ptr_self->row, ary);
free(ary);
return ret_ary;
}
/* In particular, the following test makes sure that the rounding
* for %Ra and %Rb is not done on the MPFR number itself (as it
* would overflow). Note: it has been reported on comp.std.c that
* some C libraries behave differently on %a, but this is a bug.
*/
static void
check_emax_aux (mpfr_exp_t e)
{
mpfr_t x;
char *s1, s2[256];
int i;
mpfr_exp_t emax;
MPFR_ASSERTN (e <= LONG_MAX);
emax = mpfr_get_emax ();
set_emax (e);
mpfr_init2 (x, 16);
mpfr_set_inf (x, 1);
mpfr_nextbelow (x);
i = mpfr_asprintf (&s1, "%Ra %.2Ra", x, x);
MPFR_ASSERTN (i > 0);
mpfr_snprintf (s2, 256, "0x7.fff8p+%ld 0x8.00p+%ld", e-3, e-3);
if (strcmp (s1, s2) != 0)
{
printf ("Error in check_emax_aux for emax = ");
if (e > LONG_MAX)
printf ("(>LONG_MAX)\n");
else
printf ("%ld\n", (long) e);
printf ("Expected %s\n", s2);
printf ("Got %s\n", s1);
exit (1);
}
mpfr_free_str (s1);
i = mpfr_asprintf (&s1, "%Rb %.2Rb", x, x);
MPFR_ASSERTN (i > 0);
mpfr_snprintf (s2, 256, "1.111111111111111p+%ld 1.00p+%ld", e-1, e);
if (strcmp (s1, s2) != 0)
{
printf ("Error in check_emax_aux for emax = ");
if (e > LONG_MAX)
printf ("(>LONG_MAX)\n");
else
printf ("%ld\n", (long) e);
printf ("Expected %s\n", s2);
printf ("Got %s\n", s1);
exit (1);
}
mpfr_free_str (s1);
mpfr_clear (x);
set_emax (emax);
}
static void
check_emin_aux (mpfr_exp_t e)
{
mpfr_t x;
char *s1, s2[256];
int i;
mpfr_exp_t emin;
mpz_t ee;
MPFR_ASSERTN (e >= LONG_MIN);
emin = mpfr_get_emin ();
set_emin (e);
mpfr_init2 (x, 16);
mpz_init (ee);
mpfr_setmin (x, e);
mpz_set_si (ee, e);
mpz_sub_ui (ee, ee, 1);
i = mpfr_asprintf (&s1, "%Ra", x);
MPFR_ASSERTN (i > 0);
gmp_snprintf (s2, 256, "0x1p%Zd", ee);
if (strcmp (s1, s2) != 0)
{
printf ("Error in check_emin_aux for emin = %ld\n", (long) e);
printf ("Expected %s\n", s2);
printf ("Got %s\n", s1);
exit (1);
}
mpfr_free_str (s1);
i = mpfr_asprintf (&s1, "%Rb", x);
MPFR_ASSERTN (i > 0);
gmp_snprintf (s2, 256, "1p%Zd", ee);
if (strcmp (s1, s2) != 0)
{
printf ("Error in check_emin_aux for emin = %ld\n", (long) e);
printf ("Expected %s\n", s2);
printf ("Got %s\n", s1);
exit (1);
}
mpfr_free_str (s1);
mpfr_clear (x);
mpz_clear (ee);
set_emin (emin);
}
size_t
mpfr_out_string (char *outstr, int base, size_t n_digits, mpfr_srcptr op, mp_rnd_t rnd_mode)
{
char *instr, *instr0;
size_t len;
mp_exp_t expo;
if (outstr == NULL)
return 0;
instr = mpfr_get_str (NULL, &expo, base, n_digits, op, rnd_mode);
instr0 = instr;
len = strlen (instr) + 1;
if (*instr == '-')
* outstr ++ = *instr++;
if (strcmp(instr, "@NaN@") == 0 || strcmp(instr, "@Inf@") == 0)
{
instr++;
* outstr ++ = *instr++;
* outstr ++ = *instr++;
* outstr ++ = *instr++;
mpfr_free_str(instr0);
return len-3;
}
/* Copy leading digit of mantissa into result. */
* outstr ++ = *instr++;
expo--; /* leading digit */
/* There seems to be a bug with the decimal point recognition
* in the old MPFR version that comes with GMP 4.1.4.
* With my locale (de_DE.UTF-8), conversion sets any fractional
* part of a number to 0. This problem disappears after installing
* GMP (without its internal MPFR) and then installing MPFR 2.2.0
* in a separate run.
*/
/* Insert a decimal point with the proper locale. */
* outstr ++ = localeconv()->decimal_point[0];
while (*instr)
* outstr ++ = *instr++;
mpfr_free_str(instr0);
/* Copy exponent into result. */
if (expo)
len += sprintf (outstr, (base <= 10 ? "E%ld" : "@%ld"), (long) expo);
return len;
}
static void
check_bug_base2k (void)
{
/*
* -2.63b22b55697e800000000000@130
* +-0.1001100011101100100010101101010101011010010111111010000000000000000000000000+00000000000000000000001E522
*/
mpfr_t xx, yy, zz;
char *s;
mpfr_exp_t e;
mpfr_init2 (xx, 107);
mpfr_init2 (yy, 79);
mpfr_init2 (zz, 99);
mpfr_set_str (xx, "-1.90e8c3e525d7c0000000000000@-18", 16, MPFR_RNDN);
mpfr_set_str (yy, "-2.63b22b55697e8000000@130", 16, MPFR_RNDN);
mpfr_add (zz, xx, yy, MPFR_RNDD);
s = mpfr_get_str (NULL, &e, 16, 0, zz, MPFR_RNDN);
if (strcmp (s, "-263b22b55697e8000000000008"))
{
printf ("Error for get_str base 16\n"
"Got %s expected -263b22b55697e8000000000008\n", s);
exit (1);
}
mpfr_free_str (s);
mpfr_clears (xx, yy, zz, (mpfr_ptr) 0);
}
void StrPrinter::bvisit(const RealMPFR &x) {
mpfr_exp_t ex;
char* c = mpfr_get_str(nullptr, &ex, 10, 0, x.i.get_mpfr_t(), MPFR_RNDN);
std::ostringstream s;
str_ = std::string(c);
if (str_.at(0)== '-') {
s << '-';
str_ = str_.substr(1, str_.length() - 1);
}
if (ex > 6) {
s << str_.at(0) << '.' << str_.substr(1, str_.length() - 1) << 'e' << (ex - 1);
} else if (ex > 0) {
s << str_.substr(0, (unsigned long)ex) << ".";
s << str_.substr((unsigned long)ex, str_.length() - ex);
} else if (ex > -5) {
s << "0.";
for (int i = 0; i < -ex; ++i) {
s << '0';
}
s << str_;
} else {
s << str_.at(0) << '.' << str_.substr(1, str_.length() - 1) << 'e' << (ex - 1);
}
mpfr_free_str(c);
str_ = s.str();
}
void mexFunction( int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[] )
{
double *prec,*eout;
int mrows,ncols;
char *input_buf;
char *w1,*w2;
int buflen,status;
mpfr_t x,y,z;
mp_exp_t expptr;
/* Check for proper number of arguments. */
if(nrhs!=1) {
mexErrMsgTxt("1 inputs required.");
} else if(nlhs>2) {
mexErrMsgTxt("Too many output arguments");
}
/* The input must be a noncomplex scalar double.*/
mrows = mxGetM(prhs[0]);
ncols = mxGetN(prhs[0]);
if( !mxIsDouble(prhs[0]) || mxIsComplex(prhs[0]) ||
!(mrows==1 && ncols==1) ) {
mexErrMsgTxt("Input must be a noncomplex scalar double.");
}
/* Set precision and initialize mpfr variables */
prec = mxGetPr(prhs[0]);
mpfr_set_default_prec(*prec);
mpfr_init(x); mpfr_init(y); mpfr_init(z);
/* Mathematical operation */
mpfr_const_pi(z,GMP_RNDN);
/* Retrieve results */
input_buf=mpfr_get_str (NULL, &expptr, 10, 0, z, GMP_RNDN);
w1=malloc(strlen(input_buf)+20);
w2=malloc(strlen(input_buf)+20);
if (strncmp(input_buf, "-", 1)==0){
strcpy(w2,&input_buf[1]);
sprintf(w1,"-.%se%i",w2,expptr);
} else {
strcpy(w2,&input_buf[0]);
sprintf(w1,"+.%se%i",w2,expptr);
}
plhs[0] = mxCreateString(w1);
/* plhs[1] = mxCreateDoubleMatrix(mrows,ncols, mxREAL); */
/* eout=mxGetPr(plhs[1]); */
/* *eout=expptr; */
mpfr_clear(x);
mpfr_clear(y);
mpfr_clear(z);
mpfr_free_str(input_buf);
free(w1);
free(w2);
}
void printReal(Real real){
#ifdef USE_MPFR
char* shadowValStr;
mpfr_exp_t shadowValExpt;
shadowValStr = mpfr_get_str(NULL, &shadowValExpt, 10, longprint_len, real->mpfr_val, MPFR_RNDN);
VG_(printf)("%c.%se%ld", shadowValStr[0], shadowValStr+1, shadowValExpt-1);
mpfr_free_str(shadowValStr);
#else
tl_assert2(0, "Can't print GMP vals!\n");
#endif
}
int
mpfr_vprintf (const char *fmt, va_list ap)
{
char *str;
int ret;
GET_STR_VA (ret, str, fmt, ap);
ret = printf ("%s", str);
mpfr_free_str (str);
return ret;
}
int
mpfr_sprintf (char *buf, const char *fmt, ...)
{
char *str;
int ret;
GET_STR (ret, str, fmt);
ret = sprintf (buf, "%s", str);
mpfr_free_str (str);
return ret;
}
int
mpfr_vfprintf (FILE *fp, const char *fmt, va_list ap)
{
char *str;
int ret;
GET_STR_VA (ret, str, fmt, ap);
ret = fprintf (fp, "%s", str);
mpfr_free_str (str);
return ret;
}
int
mpfr_fprintf (FILE *fp, const char *fmt, ...)
{
char *str;
int ret;
GET_STR (ret, str, fmt);
ret = fprintf (fp, "%s", str);
mpfr_free_str (str);
return ret;
}
int
mpfr_printf (const char *fmt, ...)
{
char *str;
int ret;
GET_STR (ret, str, fmt);
ret = printf ("%s", str);
mpfr_free_str (str);
return ret;
}
/* Return one dimensinal array which has strings converted elements to. */
static VALUE r_mpfi_matrix_str_ary_for_inspect (VALUE self) {
MPFIMatrix *ptr_self;
char *tmp_str;
VALUE ret_ary;
int i;
r_mpfi_get_matrix_struct(ptr_self, self);
ret_ary = rb_ary_new2(ptr_self->size);
for (i = 0; i < ptr_self->size; i++) {
if (!mpfr_asprintf(&tmp_str, "%.Re %.Re",
r_mpfi_left_ptr((ptr_self->data + i)), r_mpfi_right_ptr(ptr_self->data + i))) {
rb_raise(rb_eFatal, "Can not allocate a string by mpfr_asprintf.");
}
rb_ary_store(ret_ary, i, rb_str_new2(tmp_str));
mpfr_free_str(tmp_str);
}
return ret_ary;
}
static char *
get_pretty_str (const int base, const size_t n, mpfr_srcptr x, mpfr_rnd_t rnd)
{
mp_exp_t expo;
char *ugly;
char *pretty;
if (mpfr_zero_p (x))
return pretty_zero (x);
ugly = mpfr_get_str (NULL, &expo, base, n, x, rnd);
MPC_ASSERT (ugly != NULL);
pretty = prettify (ugly, expo, base, !mpfr_number_p (x));
mpfr_free_str (ugly);
return pretty;
}
static void
check3 (const char *d, mpfr_rnd_t rnd, const char *res)
{
mpfr_t x;
char *str;
mpfr_exp_t e;
mpfr_init2 (x, 53);
mpfr_set_str (x, d, 10, rnd);
str = mpfr_get_str (NULL, &e, 10, 5, x, rnd);
if (strcmp (str, res))
{
printf ("Error in mpfr_get_str for x=%s\n", d);
printf ("got %s instead of %s\n", str, res);
exit (1);
}
mpfr_clear (x);
mpfr_free_str (str);
}
static VALUE r_mpfi_matrix_marshal_dump (VALUE self)
{
MPFIMatrix *ptr;
int i;
char *tmp_str;
VALUE ret_ary;
r_mpfi_get_matrix_struct(ptr, self);
ret_ary = rb_ary_new();
rb_ary_push(ret_ary, INT2FIX(ptr->row));
rb_ary_push(ret_ary, INT2FIX(ptr->column));
for (i = 0; i < ptr->size; i++) {
tmp_str = r_mpfi_dump_to_string(ptr->data + i);
rb_ary_push(ret_ary, rb_str_new2(tmp_str));
mpfr_free_str(tmp_str);
}
return ret_ary;
}
void
real_from_mpfr (REAL_VALUE_TYPE *r, mpfr_srcptr m, tree type, mp_rnd_t rndmode)
{
/* We use a string as an intermediate type. */
char buf[128], *rstr;
mp_exp_t exp;
/* Take care of Infinity and NaN. */
if (mpfr_inf_p (m))
{
real_inf (r);
if (mpfr_sgn (m) < 0)
*r = real_value_negate (r);
return;
}
if (mpfr_nan_p (m))
{
real_nan (r, "", 1, TYPE_MODE (type));
return;
}
rstr = mpfr_get_str (NULL, &exp, 16, 0, m, rndmode);
/* The additional 12 chars add space for the sprintf below. This
leaves 6 digits for the exponent which is supposedly enough. */
gcc_assert (rstr != NULL && strlen (rstr) < sizeof (buf) - 12);
/* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
for that. */
exp *= 4;
if (rstr[0] == '-')
sprintf (buf, "-0x.%sp%d", &rstr[1], (int) exp);
else
sprintf (buf, "0x.%sp%d", rstr, (int) exp);
mpfr_free_str (rstr);
real_from_string (r, buf);
}
int
mpfr_vsnprintf (char *buf, size_t size, const char *fmt, va_list ap)
{
char *str;
int ret;
int min_size;
GET_STR_VA (ret, str, fmt, ap);
/* C99 allows SIZE to be zero */
if (size != 0)
{
MPFR_ASSERTN (buf != NULL);
min_size = (size_t)ret < size ? (size_t)ret : size - 1;
strncpy (buf, str, min_size);
buf[min_size] = '\0';
}
mpfr_free_str (str);
return ret;
}
static void
check_reduced_exprange (void)
{
mpfr_t x;
char *s;
mpfr_exp_t emax, e;
emax = mpfr_get_emax ();
mpfr_init2 (x, 8);
mpfr_set_str (x, "0.11111111E0", 2, MPFR_RNDN);
set_emax (0);
s = mpfr_get_str (NULL, &e, 16, 0, x, MPFR_RNDN);
set_emax (emax);
if (strcmp (s, "ff0"))
{
printf ("Error for mpfr_get_str on 0.11111111E0 in base 16:\n"
"Got \"%s\" instead of \"ff0\".\n", s);
exit (1);
}
mpfr_free_str (s);
mpfr_clear (x);
}
/* Return two dimensinal array which has strings converted elements to. */
static VALUE r_mpfi_matrix_str_ary_for_inspect2 (VALUE self) {
MPFIMatrix *ptr_self;
char *tmp_str;
int i, j;
VALUE *ary, ret_ary;
r_mpfi_get_matrix_struct(ptr_self, self);
ary = ALLOC_N(VALUE, ptr_self->row);
for (i = 0; i < ptr_self->row; i++) {
ary[i] = rb_ary_new();
}
for (i = 0; i < ptr_self->size; i += ptr_self->row) {
for (j = 0; j < ptr_self->row; j++) {
if (!mpfr_asprintf(&tmp_str, "%.Re %.Re",
r_mpfi_left_ptr((ptr_self->data + i + j)), r_mpfi_right_ptr(ptr_self->data + i + j))) {
rb_raise(rb_eFatal, "Can not allocate a string by mpfr_asprintf.");
}
rb_ary_push(ary[j], rb_str_new2(tmp_str));
mpfr_free_str(tmp_str);
}
}
ret_ary = rb_ary_new4(ptr_self->row, ary);
free(ary);
return ret_ary;
}
/* check concordance between mpfr_asprintf result with a regular mpfr float
and with a regular double float */
static int
random_double (void)
{
mpfr_t x; /* random regular mpfr float */
double y; /* regular double float (equal to x) */
char flag[] =
{
'-',
'+',
' ',
'#',
'0', /* no ambiguity: first zeros are flag zero*/
'\''
};
/* no 'a': mpfr and glibc do not have the same semantic */
char specifier[] =
{
'e',
'f',
'g',
'E',
'f', /* SUSv2 doesn't accept %F, but %F and %f are the same for
regular numbers */
'G',
};
int spec; /* random index in specifier[] */
int prec; /* random value for precision field */
/* in the format string for mpfr_t variable, the maximum length is
reached by something like "%-+ #0'.*Rf", that is 12 characters. */
#define FMT_MPFR_SIZE 12
char fmt_mpfr[FMT_MPFR_SIZE];
char *ptr_mpfr;
/* in the format string for double variable, the maximum length is
reached by something like "%-+ #0'.*f", that is 11 characters. */
#define FMT_SIZE 11
char fmt[FMT_SIZE];
char *ptr;
int xi;
char *xs;
int yi;
char *ys;
int i, j, jmax;
mpfr_init2 (x, MPFR_LDBL_MANT_DIG);
for (i = 0; i < 1000; ++i)
{
/* 1. random double */
do
{
y = DBL_RAND ();
}
#ifdef HAVE_DENORMS
while (0);
#else
while (ABS(y) < DBL_MIN);
#endif
if (randlimb () % 2 == 0)
y = -y;
mpfr_set_d (x, y, MPFR_RNDN);
if (y != mpfr_get_d (x, MPFR_RNDN))
/* conversion error: skip this one */
continue;
/* 2. build random format strings fmt_mpfr and fmt */
ptr_mpfr = fmt_mpfr;
ptr = fmt;
*ptr_mpfr++ = *ptr++ = '%';
/* random specifier 'e', 'f', 'g', 'E', 'F', or 'G' */
spec = (int) (randlimb() % 6);
/* random flags, but no ' flag with %e */
jmax = (spec == 0 || spec == 3) ? 5 : 6;
for (j = 0; j < jmax; j++)
{
if (randlimb() % 3 == 0)
*ptr_mpfr++ = *ptr++ = flag[j];
}
*ptr_mpfr++ = *ptr++ = '.';
*ptr_mpfr++ = *ptr++ = '*';
*ptr_mpfr++ = 'R';
*ptr_mpfr++ = *ptr++ = specifier[spec];
*ptr_mpfr = *ptr = '\0';
MPFR_ASSERTN (ptr - fmt < FMT_SIZE);
MPFR_ASSERTN (ptr_mpfr - fmt_mpfr < FMT_MPFR_SIZE);
/* advantage small precision */
if (randlimb() % 2 == 0)
prec = (int) (randlimb() % 10);
else
prec = (int) (randlimb() % prec_max_printf);
/* 3. calls and checks */
/* the double float case is handled by the libc asprintf through
gmp_asprintf */
xi = mpfr_asprintf (&xs, fmt_mpfr, prec, x);
yi = mpfr_asprintf (&ys, fmt, prec, y);
/* test if XS and YS differ, beware that ISO C99 doesn't specify
the sign of a zero exponent (the C99 rationale says: "The sign
of a zero exponent in %e format is unspecified. The committee
knows of different implementations and choose not to require
implementations to document their behaviour in this case
(by making this be implementation defined behaviour). Most
implementations use a "+" sign, e.g., 1.2e+00; but there is at
least one implementation that uses the sign of the unlimited
precision result, e.g., the 0.987 would be 9.87e-01, so could
end up as 1e-00 after rounding to one digit of precision."),
while mpfr always uses '+' */
if (xi != yi
|| ((strcmp (xs, ys) != 0)
&& (spec == 1 || spec == 4
|| ((strstr (xs, "e+00") == NULL
|| strstr (ys, "e-00") == NULL)
&& (strstr (xs, "E+00") == NULL
|| strstr (ys, "E-00") == NULL)))))
{
mpfr_printf ("Error in mpfr_asprintf(\"%s\", %d, %Re)\n",
fmt_mpfr, prec, x);
printf ("expected: %s\n", ys);
printf (" got: %s\n", xs);
printf ("xi=%d yi=%d spec=%d\n", xi, yi, spec);
exit (1);
}
mpfr_free_str (xs);
mpfr_free_str (ys);
}
mpfr_clear (x);
return 0;
}
static PyObject *
GMPy_MPFR_Format(PyObject *self, PyObject *args)
{
PyObject *result = NULL, *mpfrstr = NULL;
char *buffer = 0, *newbuf = 0, *fmtcode = 0, *p1, *p2, *p3;
char mpfrfmt[100], fmt[30];
int buflen;
int seensign = 0, seenalign = 0, seendecimal = 0, seendigits = 0;
int seenround = 0, seenconv = 0;
if (!MPFR_Check(self)) {
TYPE_ERROR("requires mpfr type");
return NULL;
}
if (!PyArg_ParseTuple(args, "s", &fmtcode))
return NULL;
p2 = mpfrfmt;
p3 = fmt;
*(p2++) = '%';
for (p1 = fmtcode; *p1 != '\00'; p1++) {
if (*p1 == '<' || *p1 == '>' || *p1 == '^') {
if (seenalign || seensign || seendecimal || seendigits || seenround) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
*(p3++) = *p1;
seenalign = 1;
continue;
}
}
if (*p1 == '+' || *p1 == ' ') {
if (seensign || seendecimal || seendigits || seenround) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
*(p2++) = *p1;
seensign = 1;
continue;
}
}
if (*p1 == '-') {
if (seensign || seendecimal || seendigits || seenround) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
seensign = 1;
continue;
}
}
if (*p1 == '.') {
if (seendecimal || seendigits || seenround) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
*(p2++) = *p1;
seendecimal = 1;
continue;
}
}
if (isdigit(*p1)) {
if (seendigits || seenround) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else if (seendecimal) {
*(p2++) = *p1;
continue;
}
else {
if (p3 == fmt) {
*(p3++) = '>';
seenalign = 1;
}
*(p3++) = *p1;
continue;
}
}
if (!seendigits) {
seendigits = 1;
*(p2++) = 'R';
}
if (*p1 == 'U' || *p1 == 'D' || *p1 == 'Y' || *p1 == 'Z' ||
*p1 == 'N' ) {
if (seenround) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
*(p2++) = *p1;
seenround = 1;
continue;
}
}
if (*p1 == 'a' || *p1 == 'A' || *p1 == 'b' || *p1 == 'e' ||
*p1 == 'E' || *p1 == 'f' || *p1 == 'F' || *p1 == 'g' ||
*p1 == 'G' ) {
*(p2++) = *p1;
seenconv = 1;
break;
}
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
if (!seendigits)
*(p2++) = 'R';
if (!seenconv)
*(p2++) = 'f';
*(p2) = '\00';
*(p3) = '\00';
buflen = mpfr_asprintf(&buffer, mpfrfmt, MPFR(self));
/* If there isn't a decimal point in the output and the output
* only consists of digits, then append .0 */
if (strlen(buffer) == strspn(buffer, "+- 0123456789")) {
newbuf = GMPY_MALLOC(buflen + 3);
if (!newbuf) {
mpfr_free_str(buffer);
return PyErr_NoMemory();
}
*newbuf = '\0';
strcat(newbuf, buffer);
strcat(newbuf, ".0");
mpfr_free_str(buffer);
mpfrstr = Py_BuildValue("s", newbuf);
GMPY_FREE(newbuf);
}
else {
mpfrstr = Py_BuildValue("s", buffer);
mpfr_free_str(buffer);
}
if (!mpfrstr) {
return NULL;
}
result = PyObject_CallMethod(mpfrstr, "__format__", "(s)", fmt);
Py_DECREF(mpfrstr);
return result;
}
static PyObject *
GMPy_MPC_Format(PyObject *self, PyObject *args)
{
PyObject *result = NULL, *tempstr = NULL;
char *realbuf = 0, *imagbuf = 0, *tempbuf = 0, *fmtcode = 0;
char *p, *rfmtptr, *ifmtptr, *fmtptr;
char rfmt[100], ifmt[100], fmt[30];
int rbuflen, ibuflen;
int seensign = 0, seenalign = 0, seendecimal = 0, seendigits = 0;
int seenround = 0, seenconv = 0, seenstyle = 0, mpcstyle = 0;
if (!MPC_Check(self)) {
TYPE_ERROR("requires 'mpc' object");
return NULL;
}
if (!PyArg_ParseTuple(args, "s", &fmtcode)) {
return NULL;
}
rfmtptr = rfmt;
ifmtptr = ifmt;
fmtptr = fmt;
*(rfmtptr++) = '%';
*(ifmtptr++) = '%';
for (p = fmtcode; *p != '\00'; p++) {
if (*p == '<' || *p == '>' || *p == '^') {
if (seenalign || seensign || seendecimal || seendigits ||
seenround || seenstyle) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
*(fmtptr++) = *p;
seenalign = 1;
continue;
}
}
if (*p == '+' || *p == ' ' || *p == '-') {
if (seensign || seendecimal || seendigits || seenround ||
seenstyle) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
*(rfmtptr++) = *p;
*(ifmtptr++) = *p;
seensign = 1;
continue;
}
}
if (!seensign) {
*(rfmtptr++) = '-';
*(ifmtptr++) = '-';
seensign = 1;
}
if (*p == '.') {
if (seendecimal == 2 || seendigits || seenround || seenstyle) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
if (!seendecimal) {
*(rfmtptr++) = *p;
*(ifmtptr++) = *p;
}
seendecimal++;
if (seendecimal == 2) {
while (isdigit(*(ifmtptr-1)))
ifmtptr--;
}
continue;
}
}
if (isdigit(*p)) {
if (seendigits || seenround || seenstyle) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else if (seendecimal == 1) {
*(rfmtptr++) = *p;
*(ifmtptr++) = *p;
continue;
}
else if (seendecimal == 2) {
*(ifmtptr++) = *p;
continue;
}
else {
if (fmtptr == fmt) {
*(fmtptr++) = '>';
seenalign = 1;
}
*(fmtptr++) = *p;
continue;
}
}
if (!seendigits) {
seendigits = 1;
*(rfmtptr++) = 'R';
*(ifmtptr++) = 'R';
}
if (*p == 'U' || *p == 'D' || *p == 'Y' || *p == 'Z' ||
*p == 'N' ) {
if (seenround || seenstyle) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
*(rfmtptr++) = *p;
*(ifmtptr++) = *p;
seenround = 1;
continue;
}
}
if (*p == 'P' || *p == 'M') {
if (seenstyle) {
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
else {
if (*p == 'M')
mpcstyle = 1;
seenstyle = 1;
continue;
}
}
if (*p == 'a' || *p == 'A' || *p == 'b' || *p == 'e' ||
*p == 'E' || *p == 'f' || *p == 'F' || *p == 'g' ||
*p == 'G' ) {
*(rfmtptr++) = *p;
*(ifmtptr++) = *p;
seenconv = 1;
break;
}
VALUE_ERROR("Invalid conversion specification");
return NULL;
}
if (!seensign) {
*(rfmtptr++) = '-';
*(ifmtptr++) = '-';
}
if (!seendigits) {
*(rfmtptr++) = 'R';
*(ifmtptr++) = 'R';
}
if (!seenconv) {
*(rfmtptr++) = 'f';
*(ifmtptr++) = 'f';
}
*(rfmtptr) = '\00';
*(ifmtptr) = '\00';
*(fmtptr) = '\00';
/* Format the real part.... */
rbuflen = mpfr_asprintf(&realbuf, rfmt,
mpc_realref(MPC(self)));
if (rbuflen < 0) {
mpfr_free_str(realbuf);
SYSTEM_ERROR("Internal error in mpfr_asprintf");
return NULL;
}
/* Format the imaginary part. If Python style is wanted, convert the '-'
* or ' ' sign indicator to '+'. */
if (!mpcstyle) {
if (ifmt[1] == ' ' || ifmt[1] == '-' || ifmt[1] == '+') {
ifmt[1] = '+';
}
else {
mpfr_free_str(realbuf);
VALUE_ERROR("Invalid conversion specification for imag");
return NULL;
}
}
ibuflen = mpfr_asprintf(&imagbuf, ifmt,
mpc_imagref(MPC(self)));
if (ibuflen < 0) {
mpfr_free_str(realbuf);
mpfr_free_str(imagbuf);
SYSTEM_ERROR("Internal error in mpfr_asprintf");
return NULL;
}
/* Combine the real and imaginary components into a single buffer.
* Include space for '(', ' ', and 'j)' and possibly appending '.0' twice.
*/
tempbuf = GMPY_MALLOC(rbuflen + ibuflen + 10);
if (!tempbuf) {
mpfr_free_str(realbuf);
mpfr_free_str(imagbuf);
return PyErr_NoMemory();
}
tempbuf[0] = '\00';
if (mpcstyle)
strcat(tempbuf, "(");
strcat(tempbuf, realbuf);
/* If there isn't a decimal point in the output and the output
* is short and only consists of digits, then append .0 */
if (strlen(realbuf) < 50 &&
strlen(realbuf) == strspn(realbuf, "+- 0123456789")) {
strcat(tempbuf, ".0");
}
if (mpcstyle)
strcat(tempbuf, " ");
else {
/* Need to insert + if imag is nan or +inf. */
if (mpfr_nan_p(mpc_imagref(MPC(self))) ||
(mpfr_inf_p(mpc_imagref(MPC(self))) &&
mpfr_sgn(mpc_imagref(MPC(self))) > 0)) {
strcat(tempbuf, "+");
}
}
strcat(tempbuf, imagbuf);
if (strlen(imagbuf) < 50 &&
strlen(imagbuf) == strspn(imagbuf, "+- 0123456789")) {
strcat(tempbuf, ".0");
}
if (mpcstyle)
strcat(tempbuf, ")");
else
strcat(tempbuf, "j");
mpfr_free_str(realbuf);
mpfr_free_str(imagbuf);
tempstr = Py_BuildValue("s", tempbuf);
if (!tempstr) {
GMPY_FREE(tempbuf);
return NULL;
}
result = PyObject_CallMethod(tempstr, "__format__", "(s)", fmt);
Py_DECREF(tempstr);
return result;
}
static void
check_small (void)
{
mpfr_t x;
char *s;
mpfr_exp_t e;
mpfr_prec_t p;
mpfr_init (x);
mpfr_set_prec (x, 20);
mpfr_set_ui (x, 2, MPFR_RNDN);
mpfr_nexttozero (x);
s = mpfr_get_str (NULL, &e, 4, 2, x, MPFR_RNDU);
if (strcmp (s, "20") || (e != 1))
{
printf ("Error in mpfr_get_str: 2- rounded up with 2 digits"
" in base 4\n");
exit (1);
}
mpfr_free_str (s);
/* check n_digits=0 */
mpfr_set_prec (x, 5);
mpfr_set_ui (x, 17, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 3, 0, x, MPFR_RNDN);
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 36, 0, x, MPFR_RNDN);
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 62, 0, x, MPFR_RNDN);
mpfr_free_str (s);
mpfr_set_prec (x, 64);
mpfr_set_si (x, -1, MPFR_RNDN);
mpfr_div_2exp (x, x, 63, MPFR_RNDN); /* x = -2^(-63) */
mpfr_add_ui (x, x, 1, MPFR_RNDN); /* x = 1 - 2^(-63) */
mpfr_mul_2exp (x, x, 32, MPFR_RNDN); /* x = 2^32 - 2^(-31) */
s = mpfr_get_str (NULL, &e, 3, 21, x, MPFR_RNDU);
if (strcmp (s, "102002022201221111211") || (e != 21))
{
printf ("Error in mpfr_get_str: 2^32-2^(-31) rounded up with"
" 21 digits in base 3\n");
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 3, 20, x, MPFR_RNDU);
if (strcmp (s, "10200202220122111122") || (e != 21))
{
printf ("Error in mpfr_get_str: 2^32-2^(-31) rounded up with"
" 20 digits in base 3\n");
exit (1);
}
mpfr_free_str (s);
/* check corner case ret!=0, j0!=0 in mpfr_get_str_aux */
mpfr_set_prec (x, 100);
mpfr_set_str_binary (x, "0.1001011111010001101110010101010101111001010111111101101101100110100011110110000101110110001011110000E-9");
s = mpfr_get_str (NULL, &e, 3, 2, x, MPFR_RNDU);
if (strcmp (s, "22") || (e != -6))
{
printf ("Error in mpfr_get_str: 100-bit number rounded up with"
" 2 digits in base 3\n");
exit (1);
}
mpfr_free_str (s);
/* check corner case exact=0 in mpfr_get_str_aux */
mpfr_set_prec (x, 100);
mpfr_set_str_binary (x, "0.1001001111101101111000101000110111111010101100000110010001111111011001101011101100001100110000000000E8");
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDZ);
if (strcmp (s, "14") || (e != 3))
{
printf ("Error in mpfr_get_str: 100-bit number rounded to zero with"
" 2 digits in base 10\n");
exit (1);
}
mpfr_free_str (s);
for (p=4; p<=200; p++)
{
mpfr_set_prec (x, p);
mpfr_set_str (x, "6.5", 10, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 6, 2, x, MPFR_RNDN);
if (strcmp (s, "10") || (e != 2))
{
printf ("Error in mpfr_get_str: 6.5 rounded to nearest with"
" 2 digits in base 6\n");
exit (1);
}
mpfr_free_str (s);
mpfr_nexttoinf (x);
s = mpfr_get_str (NULL, &e, 6, 2, x, MPFR_RNDN);
if (strcmp (s, "11") || (e != 2))
{
printf ("Error in mpfr_get_str: 6.5+ rounded to nearest with"
" 2 digits in base 6\ngot %se%d instead of 11e2\n",
s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str (x, "6.5", 10, MPFR_RNDN);
mpfr_nexttozero (x);
s = mpfr_get_str (NULL, &e, 6, 2, x, MPFR_RNDN);
if (strcmp (s, "10") || (e != 2))
{
printf ("Error in mpfr_get_str: 6.5- rounded to nearest with"
" 2 digits in base 6\n");
exit (1);
}
mpfr_free_str (s);
}
mpfr_set_prec (x, 3);
mpfr_set_ui (x, 7, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 2, 2, x, MPFR_RNDU);
if (strcmp (s, "10") || (e != 4))
{
printf ("Error in mpfr_get_str: 7 rounded up with 2 bits should"
" give 0.10e3 instead of 0.%s*2^%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* problem found by Fabrice Rouillier */
mpfr_set_prec (x, 63);
mpfr_set_str (x, "5e14", 10, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 10, 18, x, MPFR_RNDU);
mpfr_free_str (s);
/* bug found by Johan Vervloet */
mpfr_set_prec (x, 6);
mpfr_set_str (x, "688.0", 10, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 2, 4, x, MPFR_RNDU);
if (strcmp (s, "1011") || (e != 10))
{
printf ("Error in mpfr_get_str: 688 printed up to 4 bits should"
" give 1.011e9\ninstead of ");
mpfr_out_str (stdout, 2, 4, x, MPFR_RNDU);
puts ("");
exit (1);
}
mpfr_free_str (s);
mpfr_set_prec (x, 38);
mpfr_set_str_binary (x, "1.0001110111110100011010100010010100110e-6");
s = mpfr_get_str (NULL, &e, 8, 10, x, MPFR_RNDU);
if (strcmp (s, "1073721522") || (e != -1))
{
printf ("Error in mpfr_get_str (3): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_prec (x, 53);
mpfr_set_str_binary (x, "0.11010111011101100010000100010101110001000000010111001E454");
s = mpfr_get_str (NULL, &e, 19, 12, x, MPFR_RNDU);
if (strcmp (s, "b1cgfa4gha0h") || (e != 107))
{
printf ("Error in mpfr_get_str (4): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_prec (x, 145);
mpfr_set_str_binary (x, "-0.1000110011000001011000010101101010110110101100101110100011111100011110011001001001010000100001000011000011000000010111011001000111101001110100110e6");
s = mpfr_get_str (NULL, &e, 4, 53, x, MPFR_RNDU);
if (strcmp (s, "-20303001120111222312230232203330132121021100201003003") || (e != 3))
{
printf ("Error in mpfr_get_str (5): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_prec (x, 45);
mpfr_set_str_binary (x, "-0.00100111010110010001011001110111010001010010010");
s = mpfr_get_str (NULL, &e, 32, 9, x, MPFR_RNDN);
if (strcmp (s, "-4tchctq54") || (e != 0))
{
printf ("Error in mpfr_get_str (6): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* worst case found by Vincent Lefe`vre */
mpfr_set_prec (x, 53);
mpfr_set_str_binary (x, "10011110111100000000001011011110101100010000011011111E164");
s = mpfr_get_str (NULL, &e, 10, 17, x, MPFR_RNDN);
if (strcmp (s, "13076622631878654") || (e != 66))
{
printf ("Error in mpfr_get_str (7): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10000001001001001100011101010011011011111000011000100E93");
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDU);
if (strcmp (s, "46") || e != 44)
{
printf ("Error in mpfr_get_str (8): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10010001111100000111001111010101001010000010111010101E55");
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDN);
if (strcmp (s, "19") || e != 33)
{
printf ("Error in mpfr_get_str (9): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11011001010010111110010101101100111110111000010110110E44");
s = mpfr_get_str (NULL, &e, 10, 3, x, MPFR_RNDN);
if (strcmp (s, "135") || e != 30)
{
printf ("Error in mpfr_get_str (10): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11101111101000001011100001111000011111101111011001100E72");
s = mpfr_get_str (NULL, &e, 10, 4, x, MPFR_RNDN);
if (strcmp (s, "3981") || e != 38)
{
printf ("Error in mpfr_get_str (11): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10011001001100100010111100001101110101001001111110000E46");
s = mpfr_get_str (NULL, &e, 10, 5, x, MPFR_RNDN);
if (strcmp (s, "37930") || e != 30)
{
printf ("Error in mpfr_get_str (12): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10001100110111001011011110011011011101100011010001011E-72");
s = mpfr_get_str (NULL, &e, 10, 6, x, MPFR_RNDN);
if (strcmp (s, "104950") || e != -5)
{
printf ("Error in mpfr_get_str (13): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10100100001011001000011001101101000110100110000010111E89");
s = mpfr_get_str (NULL, &e, 10, 7, x, MPFR_RNDN);
if (strcmp (s, "3575392") || e != 43)
{
printf ("Error in mpfr_get_str (14): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11000011011110110010100110001010000001010011001011001E-73");
s = mpfr_get_str (NULL, &e, 10, 8, x, MPFR_RNDN);
if (strcmp (s, "72822386") || e != -6)
{
printf ("Error in mpfr_get_str (15): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10101010001101000111001100001000100011100010010001010E78");
s = mpfr_get_str (NULL, &e, 10, 9, x, MPFR_RNDN);
if (strcmp (s, "180992873") || e != 40)
{
printf ("Error in mpfr_get_str (16): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10110111001000100000001101111001100101101110011011101E91");
s = mpfr_get_str (NULL, &e, 10, 10, x, MPFR_RNDN);
if (strcmp (s, "1595312255") || e != 44)
{
printf ("Error in mpfr_get_str (17): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10011101010111101111000100111011101011110100110110101E93");
s = mpfr_get_str (NULL, &e, 10, 11, x, MPFR_RNDN);
if (strcmp (s, "54835744350") || e != 44)
{
printf ("Error in mpfr_get_str (18): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10011101010111101111000100111011101011110100110110101E92");
s = mpfr_get_str (NULL, &e, 10, 12, x, MPFR_RNDN);
if (strcmp (s, "274178721752") || e != 44)
{
printf ("Error in mpfr_get_str (19): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10011101010111101111000100111011101011110100110110101E91");
s = mpfr_get_str (NULL, &e, 10, 13, x, MPFR_RNDN);
if (strcmp (s, "1370893608762") || e != 44)
{
printf ("Error in mpfr_get_str (20): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10010011010110011100010010100101100011101000011111111E92");
s = mpfr_get_str (NULL, &e, 10, 14, x, MPFR_RNDN);
if (strcmp (s, "25672105101864") || e != 44)
{
printf ("Error in mpfr_get_str (21): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "100110111110110001000101110100100101101000011111001E87");
s = mpfr_get_str (NULL, &e, 10, 15, x, MPFR_RNDN);
if (strcmp (s, "212231308858721") || e != 42)
{
printf ("Error in mpfr_get_str (22): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10111010110000111000101100101111001011011100101001111E-128");
s = mpfr_get_str (NULL, &e, 10, 15, x, MPFR_RNDN);
if (strcmp (s, "193109287087290") || e != -22)
{
printf ("Error in mpfr_get_str (22b): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10001101101011010001111110000111010111010000110101010E80");
s = mpfr_get_str (NULL, &e, 10, 16, x, MPFR_RNDN);
if (strcmp (s, "6026241735727920") || e != 40)
{
printf ("Error in mpfr_get_str (23): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "100010001011101001110101000110011001001000110001001E-81");
s = mpfr_get_str (NULL, &e, 10, 17, x, MPFR_RNDN);
if (strcmp (s, "49741483709103481") || e != -9)
{
printf ("Error in mpfr_get_str (24): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11000100001001001110111010011001111001001010110101111E-101");
s = mpfr_get_str (NULL, &e, 10, 7, x, MPFR_RNDN);
if (strcmp (s, "2722049") || e != -14)
{
printf ("Error in mpfr_get_str (25): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11111001010011100101000001111111110001001001110110001E-135");
s = mpfr_get_str (NULL, &e, 10, 8, x, MPFR_RNDN);
if (strcmp (s, "20138772") || e != -24)
{
printf ("Error in mpfr_get_str (26): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11111001010011100101000001111111110001001001110110001E-136");
s = mpfr_get_str (NULL, &e, 10, 9, x, MPFR_RNDN);
if (strcmp (s, "100693858") || e != -24)
{
printf ("Error in mpfr_get_str (27): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10001000001110010110001011111011111011011010000110001E-110");
s = mpfr_get_str (NULL, &e, 10, 14, x, MPFR_RNDN);
if (strcmp (s, "36923634350619") || e != -17)
{
printf ("Error in mpfr_get_str (28): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11001100010111000111100010000110011101110001000101111E-87");
s = mpfr_get_str (NULL, &e, 10, 16, x, MPFR_RNDN);
if (strcmp (s, "4646636036100804") || e != -10)
{
printf ("Error in mpfr_get_str (29): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "10011111001111110100001001010111111011010101111111000E-99");
s = mpfr_get_str (NULL, &e, 10, 17, x, MPFR_RNDN);
if (strcmp (s, "88399901882446712") || e != -14)
{
printf ("Error in mpfr_get_str (30): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 8116315218207718*2^(-293) ~ 0.5100000000000000000015*10^(-72) */
mpfr_set_str_binary (x, "11100110101011011111011100101011101110110001111100110E-293");
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDU);
if (strcmp (s, "52") || e != -72)
{
printf ("Error in mpfr_get_str (31u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDD);
if (strcmp (s, "51") || e != -72)
{
printf ("Error in mpfr_get_str (31d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 6712731423444934*2^536 ~ .151000000000000000000067*10^178 */
mpfr_set_str_binary (x, "10111110110010011000110010011111101111000111111000110E536");
s = mpfr_get_str (NULL, &e, 10, 3, x, MPFR_RNDU);
if (strcmp (s, "152") || e != 178)
{
printf ("Error in mpfr_get_str (32u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 3, x, MPFR_RNDD);
if (strcmp (s, "151") || e != 178)
{
printf ("Error in mpfr_get_str (32d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 3356365711722467*2^540 ~ .120800000000000000000054*10^179 */
mpfr_set_str_binary (x, "1011111011001001100011001001111110111100011111100011E540");
s = mpfr_get_str (NULL, &e, 10, 4, x, MPFR_RNDU);
if (strcmp (s, "1209") || e != 179)
{
printf ("Error in mpfr_get_str (33u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 4, x, MPFR_RNDD);
if (strcmp (s, "1208") || e != 179)
{
printf ("Error in mpfr_get_str (33d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 6475049196144587*2^100 ~ .8208099999999999999999988*10^46 */
mpfr_set_str_binary (x, "10111000000010000010111011111001111010100011111001011E100");
s = mpfr_get_str (NULL, &e, 10, 5, x, MPFR_RNDU);
if (strcmp (s, "82081") || e != 46)
{
printf ("Error in mpfr_get_str (34u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 5, x, MPFR_RNDD);
if (strcmp (s, "82080") || e != 46)
{
printf ("Error in mpfr_get_str (34d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 6722280709661868*2^364 ~ .25260100000000000000000012*10^126 */
mpfr_set_str_binary (x, "10111111000011110000011110001110001111010010010101100E364");
s = mpfr_get_str (NULL, &e, 10, 6, x, MPFR_RNDU);
if (strcmp (s, "252602") || e != 126)
{
printf ("Error in mpfr_get_str (35u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 6, x, MPFR_RNDD);
if (strcmp (s, "252601") || e != 126)
{
printf ("Error in mpfr_get_str (35d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 5381065484265332*2^(-455) ~ .578389299999999999999999982*10^(-121) */
mpfr_set_str_binary (x, "10011000111100000110011110000101100111110011101110100E-455");
s = mpfr_get_str (NULL, &e, 10, 7, x, MPFR_RNDU);
if (strcmp (s, "5783893") || e != -121)
{
printf ("Error in mpfr_get_str (36u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 7, x, MPFR_RNDD);
if (strcmp (s, "5783892") || e != -121)
{
printf ("Error in mpfr_get_str (36d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 8369123604277281*2^(-852) ~ .27869147000000000000000000056*10^(-240) */
mpfr_set_str_binary (x, "11101101110111010110001101111100000111010100000100001E-852");
s = mpfr_get_str (NULL, &e, 10, 8, x, MPFR_RNDU);
if (strcmp (s, "27869148") || e != -240)
{
printf ("Error in mpfr_get_str (37u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 8, x, MPFR_RNDD);
if (strcmp (s, "27869147") || e != -240)
{
printf ("Error in mpfr_get_str (37d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 7976538478610756*2^377 ~ .245540326999999999999999999982*10^130 */
mpfr_set_str_binary (x, "11100010101101001111010010110100011100000100101000100E377");
s = mpfr_get_str (NULL, &e, 10, 9, x, MPFR_RNDU);
if (strcmp (s, "245540327") || e != 130)
{
printf ("Error in mpfr_get_str (38u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 9, x, MPFR_RNDD);
if (strcmp (s, "245540326") || e != 130)
{
printf ("Error in mpfr_get_str (38d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 8942832835564782*2^(-382) ~ .9078555839000000000000000000038*10^(-99) */
mpfr_set_str_binary (x, "11111110001010111010110000110011100110001010011101110E-382");
s = mpfr_get_str (NULL, &e, 10, 10, x, MPFR_RNDU);
if (strcmp (s, "9078555840") || e != -99)
{
printf ("Error in mpfr_get_str (39u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 10, x, MPFR_RNDD);
if (strcmp (s, "9078555839") || e != -99)
{
printf ("Error in mpfr_get_str (39d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 4471416417782391*2^(-380) ~ .18157111678000000000000000000077*10^(-98) */
mpfr_set_str_binary (x, "1111111000101011101011000011001110011000101001110111E-380");
s = mpfr_get_str (NULL, &e, 10, 11, x, MPFR_RNDU);
if (strcmp (s, "18157111679") || e != -98)
{
printf ("Error in mpfr_get_str (40u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 11, x, MPFR_RNDD);
if (strcmp (s, "18157111678") || e != -98)
{
printf ("Error in mpfr_get_str (40d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 7225450889282194*2^711 ~ .778380362292999999999999999999971*10^230 */
mpfr_set_str_binary (x, "11001101010111000001001100001100110010000001010010010E711");
s = mpfr_get_str (NULL, &e, 10, 12, x, MPFR_RNDU);
if (strcmp (s, "778380362293") || e != 230)
{
printf ("Error in mpfr_get_str (41u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 12, x, MPFR_RNDD);
if (strcmp (s, "778380362292") || e != 230)
{
printf ("Error in mpfr_get_str (41d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 3612725444641097*2^713 ~ .1556760724585999999999999999999942*10^231 */
mpfr_set_str_binary (x, "1100110101011100000100110000110011001000000101001001E713");
s = mpfr_get_str (NULL, &e, 10, 13, x, MPFR_RNDU);
if (strcmp (s, "1556760724586") || e != 231)
{
printf ("Error in mpfr_get_str (42u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 13, x, MPFR_RNDD);
if (strcmp (s, "1556760724585") || e != 231)
{
printf ("Error in mpfr_get_str (42d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 6965949469487146*2^(-248) ~ .15400733123779000000000000000000016*10^(-58) */
mpfr_set_str_binary (x, "11000101111110111111001111111101001101111000000101010E-248");
s = mpfr_get_str (NULL, &e, 10, 14, x, MPFR_RNDU);
if (strcmp (s, "15400733123780") || e != -58)
{
printf ("Error in mpfr_get_str (43u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 14, x, MPFR_RNDD);
if (strcmp (s, "15400733123779") || e != -58)
{
printf ("Error in mpfr_get_str (43d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 3482974734743573*2^(-244) ~ .12320586499023200000000000000000013*10^(-57) */
mpfr_set_str_binary (x, "1100010111111011111100111111110100110111100000010101E-244");
s = mpfr_get_str (NULL, &e, 10, 15, x, MPFR_RNDU);
if (strcmp (s, "123205864990233") || e != -57)
{
printf ("Error in mpfr_get_str (44u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 15, x, MPFR_RNDD);
if (strcmp (s, "123205864990232") || e != -57)
{
printf ("Error in mpfr_get_str (44d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 7542952370752766*2^(-919) ~ .170206189963739699999999999999999974*10^(-260) */
mpfr_set_str_binary (x, "11010110011000100011001110100100111011100110011111110E-919");
s = mpfr_get_str (NULL, &e, 10, 16, x, MPFR_RNDU);
if (strcmp (s, "1702061899637397") || e != -260)
{
printf ("Error in mpfr_get_str (45u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 16, x, MPFR_RNDD);
if (strcmp (s, "1702061899637396") || e != -260)
{
printf ("Error in mpfr_get_str (45d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
/* 5592117679628511*2^165 ~ .26153245263757307000000000000000000074*10^66 */
mpfr_set_str_binary (x, "10011110111100000000001011011110101100010000011011111E165");
s = mpfr_get_str (NULL, &e, 10, 17, x, MPFR_RNDU);
if (strcmp (s, "26153245263757308") || e != 66)
{
printf ("Error in mpfr_get_str (46u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 17, x, MPFR_RNDD);
if (strcmp (s, "26153245263757307") || e != 66)
{
printf ("Error in mpfr_get_str (46d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11010010110111100001011010000110010000100001011011101E1223");
s = mpfr_get_str (NULL, &e, 10, 17, x, MPFR_RNDN);
if (strcmp (s, "10716284017294180") || e != 385)
{
printf ("Error in mpfr_get_str (47n): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 18, x, MPFR_RNDU);
if (strcmp (s, "107162840172941805") || e != 385)
{
printf ("Error in mpfr_get_str (47u): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 18, x, MPFR_RNDD);
if (strcmp (s, "107162840172941804") || e != 385)
{
printf ("Error in mpfr_get_str (47d): s=%s e=%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "11111101111011000001010100001101101000010010001111E122620");
s = mpfr_get_str (NULL, &e, 10, 17, x, MPFR_RNDN);
if (strcmp (s, "22183435284042374") || e != 36928)
{
printf ("Error in mpfr_get_str (48n): s=%s e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 18, x, MPFR_RNDU);
if (strcmp (s, "221834352840423736") || e != 36928)
{
printf ("Error in mpfr_get_str (48u): s=%s e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 18, x, MPFR_RNDD);
if (strcmp (s, "221834352840423735") || e != 36928)
{
printf ("Error in mpfr_get_str (48d): s=%s e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_prec (x, 45);
mpfr_set_str_binary (x, "1E45");
s = mpfr_get_str (NULL, &e, 32, 9, x, MPFR_RNDN);
mpfr_free_str (s);
mpfr_set_prec (x, 7);
mpfr_set_str_binary (x, "0.1010101E10");
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDU);
mpfr_free_str (s);
/* checks rounding of negative numbers */
mpfr_set_prec (x, 7);
mpfr_set_str (x, "-11.5", 10, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDD);
if (strcmp (s, "-12"))
{
printf ("Error in mpfr_get_str for x=-11.5 and rnd=MPFR_RNDD\n"
"got %s instead of -12\n", s);
exit (1);
}
mpfr_free_str (s);
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDU);
if (strcmp (s, "-11"))
{
printf ("Error in mpfr_get_str for x=-11.5 and rnd=MPFR_RNDU\n");
exit (1);
}
mpfr_free_str (s);
/* bug found by Jean-Pierre Merlet, produced error in mpfr_get_str */
mpfr_set_prec (x, 128);
mpfr_set_str_binary (x, "0.10111001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011001100110011010E3");
s = mpfr_get_str (NULL, &e, 10, 0, x, MPFR_RNDU);
mpfr_free_str (s);
mpfr_set_prec (x, 381);
mpfr_set_str_binary (x, "0.111111111111111111111111111111111111111111111111111111111111111111101110110000100110011101101101001010111000101111000100100011110101010110101110100000010100001000110100000100011111001000010010000010001010111001011110000001110010111101100001111000101101100000010110000101100100000101010110010110001010100111001111100011100101100000100100111001100010010011110011011010110000001000010");
s = mpfr_get_str (NULL, &e, 10, 0, x, MPFR_RNDD);
if (e != 0)
{
printf ("Error in mpfr_get_str for x=0.999999..., exponent is %d"
" instead of 0\n", (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_prec (x, 5);
mpfr_set_str_binary (x, "1101.1"); /* 13.5, or (16)_7 + 1/2 */
s = mpfr_get_str (NULL, &e, 7, 2, x, MPFR_RNDN);
/* we are in the tie case: both surrounding numbers are (16)_7 and
(20)_7: since (16)_7 = 13 is odd and (20)_7 = 14 is even,
we should have s = "20" and e = 2 */
if (e != 2 || strcmp (s, "20"))
{
printf ("Error in mpfr_get_str for x=13.5, base 7\n");
printf ("Expected s=20, e=2, got s=%s, e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
/* try the same example, with input just below or above 13.5 */
mpfr_set_prec (x, 1000);
mpfr_set_str_binary (x, "1101.1");
mpfr_nextabove (x);
s = mpfr_get_str (NULL, &e, 7, 2, x, MPFR_RNDN);
if (e != 2 || strcmp (s, "20"))
{
printf ("Error in mpfr_get_str for x=13.5+tiny, base 7\n");
printf ("Expected s=20, e=2, got s=%s, e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "1101.1");
mpfr_nextbelow (x);
s = mpfr_get_str (NULL, &e, 7, 2, x, MPFR_RNDN);
if (e != 2 || strcmp (s, "16"))
{
printf ("Error in mpfr_get_str for x=13.5-tiny, base 7\n");
printf ("Expected s=16, e=2, got s=%s, e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_prec (x, 7);
mpfr_set_str_binary (x, "110000.1"); /* 48.5, or (66)_7 + 1/2 */
s = mpfr_get_str (NULL, &e, 7, 2, x, MPFR_RNDN);
/* we are in the tie case: both surrounding numbers are (66)_7 and
(100)_7: since (66)_7 = 48 is even and (100)_7 is odd,
we should hase s = "66" and e = 2 */
if (e != 2 || strcmp (s, "66"))
{
printf ("Error in mpfr_get_str for x=48.5, base 7\n");
printf ("Expected s=66, e=2, got s=%s, e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
/* try the same example, with input just below or above 48.5 */
mpfr_set_prec (x, 1000);
mpfr_set_str_binary (x, "110000.1");
mpfr_nextabove (x);
s = mpfr_get_str (NULL, &e, 7, 2, x, MPFR_RNDN);
if (e != 3 || strcmp (s, "10"))
{
printf ("Error in mpfr_get_str for x=48.5+tiny, base 7\n");
printf ("Expected s=10, e=3, got s=%s, e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_str_binary (x, "110000.1");
mpfr_nextbelow (x);
s = mpfr_get_str (NULL, &e, 7, 2, x, MPFR_RNDN);
if (e != 2 || strcmp (s, "66"))
{
printf ("Error in mpfr_get_str for x=48.5-tiny, base 7\n");
printf ("Expected s=66, e=2, got s=%s, e=%ld\n", s, (long) e);
exit (1);
}
mpfr_free_str (s);
mpfr_clear (x);
}
/* Convert R "mpfr" object (list of "mpfr1") to R "character" vector,
* using precision 'prec' which can be NA/NULL in which case
* "full precision" (as long as necessary) is used : */
SEXP mpfr2str(SEXP x, SEXP digits, SEXP base) {
int n = length(x), i;
int n_dig = isNull(digits) ? 0 : asInteger(digits);
int dig_n_max = -1;
SEXP val = PROTECT(allocVector(VECSXP, 4)),
nms, str, exp, fini, zero;
int *i_exp, *is_fin, *is_0;
int B = asInteger(base); // = base for output
double p_fact = (B == 2) ? 1. : log(B) / M_LN2;
char *ch = NULL;
mpfr_t R_i;
if(n_dig < 0)
error("'digits' must be NULL or integer >= 0");
/* be "overprotective" for now ... */
SET_VECTOR_ELT(val, 0, str = PROTECT(allocVector(STRSXP, n)));
SET_VECTOR_ELT(val, 1, exp = PROTECT(allocVector(INTSXP, n)));
SET_VECTOR_ELT(val, 2, fini= PROTECT(allocVector(LGLSXP, n)));
SET_VECTOR_ELT(val, 3, zero= PROTECT(allocVector(LGLSXP, n)));
nms = PROTECT(allocVector(STRSXP, 4));
SET_STRING_ELT(nms, 0, mkChar("str"));
SET_STRING_ELT(nms, 1, mkChar("exp"));
SET_STRING_ELT(nms, 2, mkChar("finite"));
SET_STRING_ELT(nms, 3, mkChar("is.0"));
setAttrib(val, R_NamesSymbol, nms);
i_exp = INTEGER(exp);
is_fin= LOGICAL(fini);
is_0 = LOGICAL(zero);
mpfr_init(R_i); /* with default precision */
for(i=0; i < n; i++) {
mpfr_exp_t exp = (mpfr_exp_t) 0;
mpfr_exp_t *exp_ptr = &exp;
int dig_needed;
R_asMPFR(VECTOR_ELT(x, i), R_i);
#ifdef __Rmpfr_FIRST_TRY_FAILS__
/* Observing memory problems, e.g., see ../tests/00-bug.R.~3~
* Originally hoped it was solvable via R_alloc() etc, but it seems the problem is
* deeper and I currently suspect a problem/bug in MPFR library's mpfr_get_str(..) */
ch = mpfr_get_str(NULL, exp_ptr, B,
(size_t) n_dig, R_i, MPFR_RNDN);
#else
if(n_dig) {/* use it as desired precision */
dig_needed = n_dig;
} else { /* n_dig = 0 --> string will use "enough" digits */
dig_needed = p_fact * (int)R_i->_mpfr_prec;
}
if (i == 0) { /* first time */
dig_n_max = dig_needed;
ch = (char *) R_alloc(dig_needed + 2, sizeof(char));
}
else if(!n_dig && dig_needed > dig_n_max) {
ch = (char *) S_realloc(ch, dig_needed + 2, dig_n_max + 2,
sizeof(char));
dig_n_max = dig_needed;
}
/* char * mpfr_get_str (char *STR, mpfr_exp_t *EXPPTR, int B,
* size_t N, mpfr_t OP, mpfr_rnd_t RND) */
mpfr_get_str(ch, exp_ptr, B,
(size_t) n_dig, R_i, MPFR_RNDN);
#endif
SET_STRING_ELT(str, i, mkChar(ch));
i_exp[i] = (int) exp_ptr[0];
is_fin[i]= mpfr_number_p(R_i);
is_0 [i] = mpfr_zero_p(R_i);
#ifdef __Rmpfr_FIRST_TRY_FAILS__
mpfr_free_str(ch);
#endif
}
mpfr_clear (R_i);
mpfr_free_cache();
UNPROTECT(6);
return val;
}
/* bugs found by Alain Delplanque */
static void
check_large (void)
{
mpfr_t x;
char *s, s1[7];
const char xm[] = { '1', '1', '9', '1', '3', '2', '9', '3', '7', '3',
'5', '8', '4', '4', '5', '4', '9', '0', '2', '9',
'6', '3', '4', '4', '6', '9', '9', '1', '9', '5',
'5', '7', '2', '0', '1', '7', '5', '2', '8', '6',
'1', '2', '5', '2', '5', '2', '7', '4', '0', '2',
'7', '9', '1', '1', '7', '4', '5', '6', '7', '5',
'9', '3', '1', '4', '2', '5', '5', '6', '6', '6',
'1', '6', '4', '3', '8', '1', '2', '8', '7', '6',
'2', '9', '2', '0', '8', '8', '9', '4', '3', '9',
'6', '2', '8', '4', '1', '1', '8', '1', '0', '6',
'2', '3', '7', '6', '3', '8', '1', '5', '1', '7',
'3', '4', '6', '1', '2', '4', '0', '1', '3', '0',
'8', '4', '1', '3', '9', '3', '2', '0', '1', '6',
'3', '6', '7', '1', '5', '1', '7', '5', '0', '1',
'9', '8', '4', '0', '8', '2', '7', '9', '1', '3',
'2', '2', '8', '3', '4', '1', '6', '2', '3', '9',
'6', '2', '0', '7', '3', '5', '5', '5', '3', '4',
'2', '1', '7', '0', '9', '7', '6', '2', '1', '0',
'3', '3', '5', '4', '7', '6', '0', '9', '7', '6',
'9', '3', '5', '1', '7', '8', '6', '8', '8', '2',
'8', '1', '4', '3', '7', '4', '3', '3', '2', '4',
'1', '5', '4', '7', '8', '1', '1', '4', '2', '1',
'2', '4', '2', '7', '6', '5', '9', '5', '4', '5',
'2', '6', '7', '3', '0', '3', '4', '0', '6', '9',
'1', '8', '9', '9', '9', '8', '0', '5', '7', '0',
'9', '3', '8', '7', '6', '2', '4', '6', '1', '6',
'7', '2', '0', '3', '5', '9', '3', '5', '8', '8',
'9', '7', '7', '9', '2', '7', '0', '8', '1', '6',
'8', '7', '4', '8', '5', '3', '0', '8', '4', '3',
'5', '6', '5', '1', '6', '6', '0', '9', '7', '9',
'8', '9', '2', '7', '2', '6', '8', '5', '9', '4',
'5', '8', '1', '3', '7', '2', '9', '3', '8', '3',
'7', '9', '1', '7', '9', '9', '7', '7', '2', '8',
'4', '6', '5', '5', '7', '3', '3', '8', '3', '6',
'6', '9', '7', '1', '4', '3', '3', '7', '1', '4',
'9', '4', '1', '2', '4', '9', '5', '1', '4', '7',
'2', '6', '4', '4', '8', '0', '6', '2', '6', '0',
'6', '9', '8', '1', '1', '7', '9', '9', '3', '9',
'3', '8', '4', '7', '3', '1', '9', '0', '2', '3',
'5', '3', '5', '4', '2', '1', '1', '7', '6', '7',
'4', '3', '2', '2', '0', '6', '5', '9', '9', '3',
'2', '6', '7', '1', '2', '0', '0', '3', '7', '3',
'8', '7', '4', '3', '3', '3', '3', '3', '2', '3',
'8', '2', '8', '6', '3', '1', '5', '5', '2', '2',
'5', '9', '3', '3', '7', '0', '6', '2', '8', '1',
'0', '3', '6', '7', '6', '9', '6', '5', '9', '0',
'6', '6', '6', '3', '6', '9', '9', '3', '8', '7',
'6', '5', '4', '5', '3', '5', '9', '4', '0', '0',
'7', '5', '8', '5', '4', '1', '4', '3', '1', '5',
'7', '6', '6', '3', '4', '4', '5', '0', '8', '7',
'5', '7', '5', '0', '1', '0', '1', '8', '4', '7',
'3', '1', '9', '9', '2', '7', '1', '1', '1', '2',
'3', '9', '9', '6', '5', '9', '2', '3', '2', '8',
'1', '5', '5', '1', '2', '6', '4', '9', '6', '6',
'4', '5', '1', '1', '6', '0', '0', '3', '2', '8',
'4', '8', '7', '1', '4', '9', '6', '8', '1', '6',
'5', '9', '8', '3', '4', '2', '9', '7', '0', '1',
'9', '2', '6', '6', '9', '1', '3', '5', '9', '3',
'2', '9', '6', '2', '3', '0', '6', '0', '1', '1',
'6', '5', '1', '7', '9', '0', '7', '5', '8', '6',
'8', '4', '2', '1', '0', '3', '8', '6', '6', '4',
'4', '9', '9', '7', '5', '8', '1', '7', '5', '7',
'9', '6', '6', '8', '8', '5', '8', '6', '7', '4',
'0', '7', '2', '0', '2', '9', '9', '4', '4', '1',
'9', '5', '8', '6', '5', '0', '6', '7', '4', '2',
'7', '3', '2', '3', '2', '7', '0', '2', '1', '3',
'0', '5', '9', '0', '3', '9', '1', '4', '5', '3',
'7', '2', '7', '0', '8', '5', '5', '4', '6', '1',
'1', '0', '0', '9', '2', '0', '4', '1', '6', '6',
'4', '6', '9', '1', '3', '2', '8', '5', '0', '3',
'3', '8', '9', '8', '7', '8', '5', '9', '5', '5',
'9', '1', '9', '3', '6', '5', '4', '1', '7', '4',
'0', '2', '4', '7', '2', '9', '7', '1', '2', '4',
'5', '8', '1', '4', '4', '6', '1', '8', '5', '8',
'7', '6', '9', '7', '2', '1', '2', '0', '8', '9',
'5', '9', '5', '5', '3', '8', '1', '2', '5', '4',
'3', '0', '7', '6', '5', '1', '7', '8', '2', '0',
'0', '7', '6', '7', '4', '8', '1', '0', '6', '3',
'2', '3', '0', '5', '2', '5', '0', '1', '1', '4',
'3', '8', '4', '5', '2', '3', '9', '5', '0', '9',
'8', '2', '6', '4', '7', '4', '8', '0', '1', '1',
'7', '1', '5', '4', '9', '0', '9', '2', '2', '3',
'8', '1', '6', '9', '0', '4', '6', '4', '5', '4',
'6', '3', '8', '7', '3', '6', '1', '7', '2', '3',
'4', '5', '5', '2', '0', '2', '5', '8', '1', '4',
'9', '3', '0', '7', '4', '1', '6', '8', '7', '8',
'2', '6', '2', '5', '1', '0', '7', '4', '7', '3',
'6', '6', '4', '5', '6', '6', '6', '6', '8', '5',
'1', '3', '5', '7', '1', '6', '2', '0', '9', '2',
'3', '2', '6', '0', '7', '9', '8', '1', '6', '2',
'0', '3', '8', '8', '0', '2', '8', '7', '7', '5',
'9', '3', '1', '0', '6', '7', '5', '7', '3', '1',
'2', '7', '7', '2', '0', '0', '4', '1', '2', '8',
'2', '0', '8', '4', '0', '5', '0', '5', '0', '1',
'9', '3', '3', '6', '3', '6', '9', '6', '2', '8',
'2', '9', '7', '5', '3', '8', '8', '9', '1', '1',
'4', '5', '7', '7', '5', '6', '0', '2', '7', '9',
'7', '2', '1', '7', '4', '3', '0', '3', '6', '7',
'3', '7', '2', '2', '7', '5', '6', '2', '3', '1',
'2', '1', '3', '1', '4', '2', '6', '9', '2', '3',
'\0' };
mpfr_exp_t e;
mpfr_init2 (x, 3322);
mpfr_set_str (x, xm, 10, MPFR_RNDN);
mpfr_div_2exp (x, x, 4343, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 10, 1000, x, MPFR_RNDN);
if (s[999] != '1') /* s must be 5.04383...689071e-309 */
{
printf ("Error in check_large: expected '689071', got '%s'\n",
s + 994);
exit (1);
}
mpfr_free_str (s);
mpfr_mul_2exp (x, x, 4343, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDN);
if (strcmp (s, "12") || (e != 1000))
{
printf ("Error in check_large: expected 0.12e1000\n");
printf ("got %se%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_set_nan (x);
mpfr_clear_flags ();
s = mpfr_get_str (NULL, &e, 10, 1000, x, MPFR_RNDN);
if (strcmp (s, "@NaN@"))
{
printf ("Error for NaN (incorrect string)\n");
exit (1);
}
if (__gmpfr_flags != MPFR_FLAGS_NAN)
{
printf ("Error for NaN (incorrect flags)\n");
exit (1);
}
mpfr_free_str (s);
mpfr_get_str (s1, &e, 10, 1000, x, MPFR_RNDN);
mpfr_set_inf (x, 1);
s = mpfr_get_str (NULL, &e, 10, 1000, x, MPFR_RNDN);
if (strcmp (s, "@Inf@"))
{
printf ("Error for Inf\n");
exit (1);
}
mpfr_free_str (s);
mpfr_get_str (s1, &e, 10, 1000, x, MPFR_RNDN);
mpfr_set_inf (x, -1);
s = mpfr_get_str (NULL, &e, 10, 1000, x, MPFR_RNDN);
if (strcmp (s, "-@Inf@"))
{
printf ("Error for -Inf\n");
exit (1);
}
mpfr_free_str (s);
mpfr_get_str (s1, &e, 10, 1000, x, MPFR_RNDN);
mpfr_set_ui (x, 0, MPFR_RNDN);
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDN);
if (e != 0 || strcmp (s, "00"))
{
printf ("Error for 0.0\n");
exit (1);
}
mpfr_free_str (s);
mpfr_get_str (s1, &e, 10, 2, x, MPFR_RNDN);
mpfr_neg (x, x, MPFR_RNDN); /* -0.0 */
s = mpfr_get_str (NULL, &e, 10, 2, x, MPFR_RNDN);
if (e != 0 || strcmp (s, "-00"))
{
printf ("Error for -0.0\ngot %se%d\n", s, (int) e);
exit (1);
}
mpfr_free_str (s);
mpfr_get_str (s1, &e, 10, 2, x, MPFR_RNDN);
mpfr_clear (x);
}
void mexFunction( int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[] )
{
double *prec,*eoutr,*eouti;
int mrows,ncols;
char *input_buf;
char *w1,*w2;
int buflen,status;
mpfr_t xr,xi,yr,yi,zr,zi,temp,temp1;
mp_exp_t expptr;
/* Check for proper number of arguments. */
if(nrhs!=5) {
mexErrMsgTxt("5 inputs required.");
} else if(nlhs>4) {
mexErrMsgTxt("Too many output arguments");
}
/* The input must be a noncomplex scalar double.*/
mrows = mxGetM(prhs[0]);
ncols = mxGetN(prhs[0]);
if( !mxIsDouble(prhs[0]) || mxIsComplex(prhs[0]) ||
!(mrows==1 && ncols==1) ) {
mexErrMsgTxt("Input must be a noncomplex scalar double.");
}
/* Set precision and initialize mpfr variables */
prec = mxGetPr(prhs[0]);
mpfr_set_default_prec(*prec);
mpfr_init(xr); mpfr_init(xi);
mpfr_init(yr); mpfr_init(yi);
mpfr_init(zr); mpfr_init(zi);
mpfr_init(temp); mpfr_init(temp1);
/* Read the input strings into mpfr x real */
buflen = (mxGetM(prhs[1]) * mxGetN(prhs[1])) + 1;
input_buf=mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[1], input_buf, buflen);
mpfr_set_str(xr,input_buf,10,GMP_RNDN);
/* Read the input strings into mpfr x imag */
buflen = (mxGetM(prhs[2]) * mxGetN(prhs[2])) + 1;
input_buf=mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[2], input_buf, buflen);
mpfr_set_str(xi,input_buf,10,GMP_RNDN);
/* Read the input strings into mpfr y real */
buflen = (mxGetM(prhs[3]) * mxGetN(prhs[3])) + 1;
input_buf=mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[3], input_buf, buflen);
mpfr_set_str(yr,input_buf,10,GMP_RNDN);
/* Read the input strings into mpfr y imag */
buflen = (mxGetM(prhs[4]) * mxGetN(prhs[4])) + 1;
input_buf=mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[4], input_buf, buflen);
mpfr_set_str(yi,input_buf,10,GMP_RNDN);
/* Mathematical operation */
/* denominator */
mpfr_mul(temp,yr,yr,GMP_RNDN);
mpfr_mul(temp1,yi,yi,GMP_RNDN);
mpfr_add(temp,temp,temp1,GMP_RNDN);
/* real part */
mpfr_mul(temp1,xr,yr,GMP_RNDN);
mpfr_mul(zr,xi,yi,GMP_RNDN);
mpfr_add(zr,temp1,zr,GMP_RNDN);
/* imag part */
mpfr_mul(temp1,xi,yr,GMP_RNDN);
mpfr_mul(zi,xr,yi,GMP_RNDN);
mpfr_sub(zi,temp1,zi,GMP_RNDN);
/* divide by denominator */
mpfr_div(zr,zr,temp,GMP_RNDN);
mpfr_div(zi,zi,temp,GMP_RNDN);
/* Retrieve results */
mxFree(input_buf);
input_buf=mpfr_get_str (NULL, &expptr, 10, 0, zr, GMP_RNDN);
w1=malloc(strlen(input_buf)+20);
w2=malloc(strlen(input_buf)+20);
if (strncmp(input_buf, "-", 1)==0){
strcpy(w2,&input_buf[1]);
sprintf(w1,"-.%se%i",w2,expptr);
} else {
strcpy(w2,&input_buf[0]);
sprintf(w1,"+.%se%i",w2,expptr);
}
plhs[0] = mxCreateString(w1);
/* plhs[1] = mxCreateDoubleMatrix(mrows,ncols, mxREAL); */
/* eoutr=mxGetPr(plhs[1]); */
/* *eoutr=expptr; */
mpfr_free_str(input_buf);
input_buf=mpfr_get_str (NULL, &expptr, 10, 0, zi, GMP_RNDN);
free(w1);
free(w2);
w1=malloc(strlen(input_buf)+20);
w2=malloc(strlen(input_buf)+20);
if (strncmp(input_buf, "-", 1)==0){
strcpy(w2,&input_buf[1]);
sprintf(w1,"-.%se%i",w2,expptr);
} else {
strcpy(w2,&input_buf[0]);
sprintf(w1,"+.%se%i",w2,expptr);
}
plhs[1] = mxCreateString(w1);
/* plhs[3] = mxCreateDoubleMatrix(mrows,ncols, mxREAL); */
/* eouti=mxGetPr(plhs[3]); */
/* *eouti=expptr; */
mpfr_clear(xr); mpfr_clear(xi);
mpfr_clear(yr); mpfr_clear(yi);
mpfr_clear(zr); mpfr_clear(zi);
mpfr_clear(temp); mpfr_clear(temp1);
mpfr_free_str(input_buf);
free(w1);
free(w2);
}
