void R_RegisterCCallable(const char *package, const char *name, DL_FUNC fptr)
{
SEXP penv = get_package_CEntry_table(package);
SEXP eptr = R_MakeExternalPtrFn(fptr, R_NilValue, R_NilValue);
PROTECT(eptr);
defineVar(install(name), eptr, penv);
UNPROTECT(1);
}
void rlang_register_pointer(const char* ns, const char* ptr_name, DL_FUNC fn) {
SEXP ptr = PROTECT(R_MakeExternalPtrFn(fn, R_NilValue, R_NilValue));
SEXP ptr_obj = PROTECT(Rf_allocVector(VECSXP, 1));
SET_VECTOR_ELT(ptr_obj, 0, ptr);
Rf_setAttrib(ptr_obj, R_ClassSymbol, Rf_mkString("fn_pointer"));
Rf_defineVar(Rf_install(ptr_name), ptr_obj, rlang_namespace(ns));
UNPROTECT(2);
}
/**
Creates an R object representing the value of the
function pointer given by `f'. This object has class
NativeSymbol and can be used to relay symbols from
one DLL to another.
*/
static SEXP
Rf_MakeNativeSymbolRef(DL_FUNC f)
{
SEXP ref, klass;
PROTECT(ref = R_MakeExternalPtrFn(f, install("native symbol"),
R_NilValue));
PROTECT(klass = mkString("NativeSymbol"));
setAttrib(ref, R_ClassSymbol, klass);
UNPROTECT(2);
return(ref);
}
// returns either the R function or the address of the native routine
// on return, use_native tells whether to use the native or the R function
SEXP pomp_fun_handler (SEXP pfun, SEXP gnsi, pompfunmode *mode)
{
int nprotect = 0;
SEXP f = R_NilValue;
*mode = *(INTEGER(GET_SLOT(pfun,install("mode"))));
switch (*mode) {
case Rfun: // R function
PROTECT(f = GET_SLOT(pfun,install("R.fun"))); nprotect++;
break;
case native: case regNative: // native code
if (*(INTEGER(gnsi))) { // get native symbol information?
SEXP nf, pack;
PROTECT(nf = GET_SLOT(pfun,install("native.fun"))); nprotect++;
PROTECT(pack = GET_SLOT(pfun,install("PACKAGE"))); nprotect++;
if (LENGTH(pack) < 1) {
PROTECT(pack = mkString("")); nprotect++;
}
switch (*mode) {
case native:
{
SEXP nsi;
PROTECT(nsi = eval(PROTECT(lang3(install("getNativeSymbolInfo"),nf,pack)),R_BaseEnv)); nprotect += 2;
PROTECT(f = getListElement(nsi,"address")); nprotect++;
}
break;
case regNative:
{
// Before version 3.4.0, R_MakeExternalPtrFn is not part of the R API.
// Therefore, we must use some trickery to avoid the ISO C proscription of
// (void *) <-> (function *) conversion.
const char *fname, *pkg;
fname = (const char *) CHAR(STRING_ELT(nf,0));
pkg = (const char *) CHAR(STRING_ELT(pack,0));
#if (R_VERSION < 197632) // before 3.4.0
// This is cadged from 'R_MakeExternalPtrFn'.
union {void *p; DL_FUNC fn;} trick;
trick.fn = R_GetCCallable(pkg,fname);
PROTECT(f = R_MakeExternalPtr(trick.p,R_NilValue,R_NilValue)); nprotect++;
#else
DL_FUNC fn;
fn = R_GetCCallable(pkg,fname);
PROTECT(f = R_MakeExternalPtrFn(fn,R_NilValue,R_NilValue)); nprotect++;
#endif
}
break;
case Rfun: case undef: default:
break; // # nocov
}
SET_SLOT(pfun,install("address"),f);
} else { // native symbol info is stored
PROTECT(f = GET_SLOT(pfun,install("address"))); nprotect++;
}
*mode = native;
break;
case undef: default:
{
const char *purp = (const char *) CHAR(STRING_ELT(GET_SLOT(pfun,install("purpose")),0));
errorcall(R_NilValue,"operation cannot be completed: %s has not been specified",purp);
}
}
UNPROTECT(nprotect);
return f;
}
SEXP R_externalptr_prototype_object()
{
return R_MakeExternalPtrFn((DL_FUNC) R_dummy_extern_place, R_NilValue,
R_NilValue);
}
