SEXP print_mpc(SEXP ptr) {
mpc_ptr z = (mpc_ptr)R_ExternalPtrAddr(ptr);
SEXP retVal;
Rprintf("Rounding: %s\n",
CHAR(STRING_ELT(Rf_GetOption(Rf_install("mpc.rounding"),
R_BaseEnv), 0)));
if (z) {
char *mystring = mpc_get_str(10, 0, z, Rmpc_get_rounding());
PROTECT(retVal = Rf_mkString(mystring));
UNPROTECT(1);
return retVal;
}
return R_NilValue;
}
/* Rmpc_get_rounding - return the MPC rounding method based on R option.
*
* Args:
* None
* Return value:
* An MPC rounding mode, e.g. MPC_RNDNN.
*/
int Rmpc_get_rounding() {
const char *round_mode = CHAR(STRING_ELT(Rf_GetOption(
Rf_install("mpc.rounding"), R_BaseEnv), 0));
int real_round, imag_round;
if (strlen(round_mode) != 9) {
Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
return(MPC_RNDNN);
}
switch (round_mode[7]) {
case 'N':
real_round = GMP_RNDN;
break;
case 'Z':
real_round = GMP_RNDZ;
break;
case 'U':
real_round = GMP_RNDU;
break;
case 'D':
real_round = GMP_RNDD;
break;
default:
Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
return(MPC_RNDNN);
}
switch(round_mode[8]) {
case 'N':
imag_round = GMP_RNDN;
break;
case 'Z':
imag_round = GMP_RNDZ;
break;
case 'U':
imag_round = GMP_RNDU;
break;
case 'D':
imag_round = GMP_RNDD;
break;
default:
Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
return(MPC_RNDNN);
}
return (RNDC(real_round, imag_round));
}
SEXP getOption(const std::string& name)
{
return Rf_GetOption(Rf_install(name.c_str()), R_BaseEnv);
}
