SEXP R_mpfr_fac (SEXP n_, SEXP prec, SEXP rnd_mode)
{
int n = length(n_), i, *nn;
SEXP n_t, val = PROTECT(allocVector(VECSXP, n)); int nprot = 1;
mpfr_rnd_t rnd = R_rnd2MP(rnd_mode);
mpfr_t r_i;
if(TYPEOF(n_) != INTSXP) {
PROTECT(n_t = coerceVector(n_, INTSXP)); nprot++;/* or bail out*/
nn = INTEGER(n_t);
} else {
nn = INTEGER(n_);
}
int i_p = asInteger(prec);
R_mpfr_check_prec(i_p);
mpfr_init2(r_i, i_p);
for(i=0; i < n; i++) {
// never happens when called from R:
if(nn[i] < 0) error("R_mpfr_fac(%d): negative n.", nn[i]);
mpfr_fac_ui(r_i, nn[i], rnd);
SET_VECTOR_ELT(val, i, MPFR_as_R(r_i));
}
mpfr_clear(r_i);
mpfr_free_cache();
UNPROTECT(nprot);
return val;
}
/* From the MPFR (2.3.2, 2008) doc :
-- Function:
int mpfr_set_str (mpfr_t ROP, const char *S, int BASE, mpfr_rnd_t RND)
Set ROP to the value of the whole string S in base BASE, rounded
in the direction RND. See the documentation of `mpfr_strtofr' for
a detailed description of the valid string formats. This function
returns 0 if the entire string up to the final null character is a
valid number in base BASE; otherwise it returns -1, and ROP may
have changed.
*/
SEXP str2mpfr1_list(SEXP x, SEXP prec, SEXP base, SEXP rnd_mode)
{
/* NB: Both x and prec are "recycled" to the longer one if needed */
int ibase = asInteger(base), *iprec,
nx = LENGTH(x), np = LENGTH(prec),
n = (nx == 0 || np == 0) ? 0 : imax2(nx, np),
nprot = 1;
SEXP val = PROTECT(allocVector(VECSXP, n));
mpfr_rnd_t rnd = R_rnd2MP(rnd_mode);
mpfr_t r_i;
mpfr_init(r_i);
if(!isString(x)) { PROTECT(x = coerceVector(x, STRSXP)); nprot++; }
if(!isInteger(prec)) { PROTECT(prec = coerceVector(prec, INTSXP)); nprot++; }
iprec = INTEGER(prec);
for(int i = 0; i < n; i++) {
int prec_i = iprec[i % np];
R_mpfr_check_prec(prec_i);
mpfr_set_prec(r_i, (mpfr_prec_t) prec_i);
int ierr = mpfr_set_str(r_i, CHAR(STRING_ELT(x, i % nx)), ibase, rnd);
if(ierr) {
if (!strcmp("NA", CHAR(STRING_ELT(x, i % nx))))
mpfr_set_nan(r_i); // "NA" <=> "NaN" (which *are* treated well, by mpfr_set_str)
else
error("str2mpfr1_list(x, *): x[%d] cannot be made into MPFR",
i+1);
}
/* FIXME: become more efficient by doing R_..._2R_init() only once*/
SET_VECTOR_ELT(val, i, MPFR_as_R(r_i));
}
mpfr_clear (r_i);
mpfr_free_cache();
UNPROTECT(nprot);
return val;
}
