Error registerReplaceHook(const std::string& name,
CCODE hook,
CCODE* pOriginal)
{
// ensure a name was passed
if (name.empty())
return Error(errc::SymbolNotFoundError, ERROR_LOCATION);
// find SEXP for function
SEXP symbolSEXP = Rf_install(name.c_str());
SEXP functionSEXP = INTERNAL(symbolSEXP) ;
if (functionSEXP == R_NilValue || functionSEXP == R_UnboundValue)
{
functionSEXP = SYMVALUE(symbolSEXP);
if (functionSEXP == R_NilValue || functionSEXP == R_UnboundValue)
{
Error error = Error(errc::SymbolNotFoundError, ERROR_LOCATION);
error.addProperty("symbol", name);
return error;
}
}
// provide the original to the caller if requested
if (pOriginal != NULL)
*pOriginal = PRIMFUN(functionSEXP);
// add the hook
SET_PRIMFUN(functionSEXP, hook);
return Success();
}
SEXP setOption(SEXP tag, SEXP value)
{
SEXP opt, old, t;
t = opt = SYMVALUE(Rf_install(".Options"));
if (!Rf_isList(opt))
Rf_error("corrupted options list");
opt = FindTaggedItem(opt, tag);
/* The option is being removed. */
if (value == R_NilValue) {
for ( ; t != R_NilValue ; t = CDR(t))
if (TAG(CDR(t)) == tag) {
old = CAR(t);
SETCDR(t, CDDR(t));
return old;
}
return R_NilValue;
}
/* If the option is new, a new slot */
/* is added to the end of .Options */
if (opt == R_NilValue) {
while (CDR(t) != R_NilValue)
t = CDR(t);
PROTECT(value);
SETCDR(t, Rf_allocList(1));
UNPROTECT(1);
opt = CDR(t);
SET_TAG(opt, tag);
}
old = CAR(opt);
SETCAR(opt, value);
return old;
}
SEXP setErrorOption(SEXP value)
{
SEXP errorTag = Rf_install("error");
SEXP option = SYMVALUE(Rf_install(".Options"));
while (option != R_NilValue)
{
// is this the error option?
if (TAG(option) == errorTag)
{
// set and return previous value
SEXP previous = CAR(option);
SETCAR(option, value);
return previous;
}
// next option
option = CDR(option);
}
return R_NilValue;
}
/** Returns the value of a symbol.
*
* @param sexp An R value of sexptype SYMSXP.
* @return The value of the R symbol.
*/
CAMLprim value ocamlr_inspect_symsxp_value (value sexp) {
return(Val_sexp(SYMVALUE(Sexp_val(sexp))));
}
