Exemple #1
0
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();
}
Exemple #2
0
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;
}
Exemple #3
0
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;
}
Exemple #4
0
/**  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))));
}