You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
374 lines
8.6 KiB
374 lines
8.6 KiB
![]()
4 years ago
|
|
||
|
#ifdef __cplusplus
|
||
|
extern "C" {
|
||
|
#endif
|
||
|
|
||
|
/* Remove global namespace pollution */
|
||
|
#if !defined(SWIG_NO_R_NO_REMAP)
|
||
|
# define R_NO_REMAP
|
||
|
#endif
|
||
|
#if !defined(SWIG_NO_STRICT_R_HEADERS)
|
||
|
# define STRICT_R_HEADERS
|
||
|
#endif
|
||
|
|
||
|
#include <Rdefines.h>
|
||
|
#include <Rversion.h>
|
||
|
#include <stdlib.h>
|
||
|
#include <assert.h>
|
||
|
|
||
|
#define SWIGR 1
|
||
|
|
||
|
#if R_VERSION >= R_Version(2,6,0)
|
||
|
#define VMAXTYPE void *
|
||
|
#define RVERSION26(x) x
|
||
|
#define RVERSIONPRE26(x)
|
||
|
#else
|
||
|
#define VMAXTYPE char *
|
||
|
#define RVERSION26(x)
|
||
|
#define RVERSIONPRE26(x) x
|
||
|
#endif
|
||
|
|
||
|
/*
|
||
|
This is mainly a way to avoid having lots of local variables that may
|
||
|
conflict with those in the routine.
|
||
|
|
||
|
Change name to R_SWIG_Callb....
|
||
|
*/
|
||
|
typedef struct RCallbackFunctionData {
|
||
|
|
||
|
SEXP fun;
|
||
|
SEXP userData;
|
||
|
|
||
|
|
||
|
SEXP expr;
|
||
|
SEXP retValue;
|
||
|
int errorOccurred;
|
||
|
|
||
|
SEXP el; /* Temporary pointer used in the construction of the expression to call the R function. */
|
||
|
|
||
|
struct RCallbackFunctionData *previous; /* Stack */
|
||
|
|
||
|
} RCallbackFunctionData;
|
||
|
|
||
|
static RCallbackFunctionData *callbackFunctionDataStack;
|
||
|
|
||
|
|
||
|
SWIGRUNTIME SEXP
|
||
|
R_SWIG_debug_getCallbackFunctionData()
|
||
|
{
|
||
|
int n, i;
|
||
|
SEXP ans;
|
||
|
RCallbackFunctionData *p = callbackFunctionDataStack;
|
||
|
|
||
|
n = 0;
|
||
|
while(p) {
|
||
|
n++;
|
||
|
p = p->previous;
|
||
|
}
|
||
|
|
||
|
Rf_protect(ans = Rf_allocVector(VECSXP, n));
|
||
|
for(p = callbackFunctionDataStack, i = 0; i < n; p = p->previous, i++)
|
||
|
SET_VECTOR_ELT(ans, i, p->fun);
|
||
|
|
||
|
Rf_unprotect(1);
|
||
|
|
||
|
return(ans);
|
||
|
}
|
||
|
|
||
|
|
||
|
|
||
|
SWIGRUNTIME RCallbackFunctionData *
|
||
|
R_SWIG_pushCallbackFunctionData(SEXP fun, SEXP userData)
|
||
|
{
|
||
|
RCallbackFunctionData *el;
|
||
|
el = (RCallbackFunctionData *) calloc(1, sizeof(RCallbackFunctionData));
|
||
|
el->fun = fun;
|
||
|
el->userData = userData;
|
||
|
el->previous = callbackFunctionDataStack;
|
||
|
|
||
|
callbackFunctionDataStack = el;
|
||
|
|
||
|
return(el);
|
||
|
}
|
||
|
|
||
|
|
||
|
SWIGRUNTIME SEXP
|
||
|
R_SWIG_R_pushCallbackFunctionData(SEXP fun, SEXP userData)
|
||
|
{
|
||
|
R_SWIG_pushCallbackFunctionData(fun, userData);
|
||
|
return R_NilValue;
|
||
|
}
|
||
|
|
||
|
SWIGRUNTIME RCallbackFunctionData *
|
||
|
R_SWIG_getCallbackFunctionData()
|
||
|
{
|
||
|
if(!callbackFunctionDataStack) {
|
||
|
Rf_error("Supposedly impossible error occurred in the SWIG callback mechanism."
|
||
|
" No callback function data set.");
|
||
|
}
|
||
|
|
||
|
return callbackFunctionDataStack;
|
||
|
}
|
||
|
|
||
|
SWIGRUNTIME void
|
||
|
R_SWIG_popCallbackFunctionData(int doFree)
|
||
|
{
|
||
|
RCallbackFunctionData *el = NULL;
|
||
|
if(!callbackFunctionDataStack)
|
||
|
return ; /* Error !!! */
|
||
|
|
||
|
el = callbackFunctionDataStack ;
|
||
|
callbackFunctionDataStack = callbackFunctionDataStack->previous;
|
||
|
|
||
|
if(doFree)
|
||
|
free(el);
|
||
|
}
|
||
|
|
||
|
|
||
|
/*
|
||
|
Interface to S function
|
||
|
is(obj, type)
|
||
|
which is to be used to determine if an
|
||
|
external pointer inherits from the right class.
|
||
|
|
||
|
Ideally, we would like to be able to do this without an explicit call to the is() function.
|
||
|
When the S4 class system uses its own SEXP types, then we will hopefully be able to do this
|
||
|
in the C code.
|
||
|
|
||
|
Should we make the expression static and preserve it to avoid the overhead of
|
||
|
allocating each time.
|
||
|
*/
|
||
|
SWIGRUNTIME int
|
||
|
R_SWIG_checkInherits(SEXP obj, SEXP tag, const char *type)
|
||
|
{
|
||
|
SEXP e, val;
|
||
|
int check_err = 0;
|
||
|
|
||
|
Rf_protect(e = Rf_allocVector(LANGSXP, 3));
|
||
|
SETCAR(e, Rf_install("extends"));
|
||
|
|
||
|
SETCAR(CDR(e), Rf_mkString(CHAR(PRINTNAME(tag))));
|
||
|
SETCAR(CDR(CDR(e)), Rf_mkString(type));
|
||
|
|
||
|
val = R_tryEval(e, R_GlobalEnv, &check_err);
|
||
|
Rf_unprotect(1);
|
||
|
if(check_err)
|
||
|
return(0);
|
||
|
|
||
|
|
||
|
return(LOGICAL(val)[0]);
|
||
|
}
|
||
|
|
||
|
|
||
|
SWIGRUNTIME void *
|
||
|
R_SWIG_resolveExternalRef(SEXP arg, const char * const type, const char * const argName, Rboolean nullOk)
|
||
|
{
|
||
|
void *ptr;
|
||
|
SEXP orig = arg;
|
||
|
|
||
|
if(TYPEOF(arg) != EXTPTRSXP)
|
||
|
arg = GET_SLOT(arg, Rf_mkString("ref"));
|
||
|
|
||
|
|
||
|
if(TYPEOF(arg) != EXTPTRSXP) {
|
||
|
Rf_error("argument %s must be an external pointer (from an ExternalReference)", argName);
|
||
|
}
|
||
|
|
||
|
|
||
|
ptr = R_ExternalPtrAddr(arg);
|
||
|
|
||
|
if(ptr == NULL && nullOk == (Rboolean) FALSE) {
|
||
|
Rf_error("the external pointer (of type %s) for argument %s has value NULL", argName, type);
|
||
|
}
|
||
|
|
||
|
if(type[0] && R_ExternalPtrTag(arg) != Rf_install(type) && strcmp(type, "voidRef")
|
||
|
&& !R_SWIG_checkInherits(orig, R_ExternalPtrTag(arg), type)) {
|
||
|
Rf_error("the external pointer for argument %s has tag %s, not the expected value %s",
|
||
|
argName, CHAR(PRINTNAME(R_ExternalPtrTag(arg))), type);
|
||
|
}
|
||
|
|
||
|
|
||
|
return(ptr);
|
||
|
}
|
||
|
|
||
|
SWIGRUNTIME void
|
||
|
R_SWIG_ReferenceFinalizer(SEXP el)
|
||
|
{
|
||
|
void *ptr = R_SWIG_resolveExternalRef(el, "", "<finalizer>", (Rboolean) 1);
|
||
|
fprintf(stderr, "In R_SWIG_ReferenceFinalizer for %p\n", ptr);
|
||
|
Rf_PrintValue(el);
|
||
|
|
||
|
if(ptr) {
|
||
|
if(TYPEOF(el) != EXTPTRSXP)
|
||
|
el = GET_SLOT(el, Rf_mkString("ref"));
|
||
|
|
||
|
if(TYPEOF(el) == EXTPTRSXP)
|
||
|
R_ClearExternalPtr(el);
|
||
|
|
||
|
free(ptr);
|
||
|
}
|
||
|
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
typedef enum {R_SWIG_EXTERNAL, R_SWIG_OWNER } R_SWIG_Owner;
|
||
|
|
||
|
SWIGRUNTIME SEXP
|
||
|
SWIG_MakePtr(void *ptr, const char *typeName, R_SWIG_Owner owner)
|
||
|
{
|
||
|
SEXP external, r_obj;
|
||
|
const char *p = typeName;
|
||
|
|
||
|
if(typeName[0] == '_')
|
||
|
p = typeName + 1;
|
||
|
|
||
|
Rf_protect(external = R_MakeExternalPtr(ptr, Rf_install(typeName), R_NilValue));
|
||
|
Rf_protect(r_obj = NEW_OBJECT(MAKE_CLASS((char *) typeName)));
|
||
|
|
||
|
if(owner)
|
||
|
R_RegisterCFinalizer(external, R_SWIG_ReferenceFinalizer);
|
||
|
|
||
|
r_obj = SET_SLOT(r_obj, Rf_mkString((char *) "ref"), external);
|
||
|
SET_S4_OBJECT(r_obj);
|
||
|
Rf_unprotect(2);
|
||
|
|
||
|
return(r_obj);
|
||
|
}
|
||
|
|
||
|
|
||
|
SWIGRUNTIME SEXP
|
||
|
R_SWIG_create_SWIG_R_Array(const char *typeName, SEXP ref, int len)
|
||
|
{
|
||
|
SEXP arr;
|
||
|
|
||
|
/*XXX remove the char * cast when we can. MAKE_CLASS should be declared appropriately. */
|
||
|
Rf_protect(arr = NEW_OBJECT(MAKE_CLASS((char *) typeName)));
|
||
|
Rf_protect(arr = R_do_slot_assign(arr, Rf_mkString("ref"), ref));
|
||
|
Rf_protect(arr = R_do_slot_assign(arr, Rf_mkString("dims"), Rf_ScalarInteger(len)));
|
||
|
|
||
|
Rf_unprotect(3);
|
||
|
SET_S4_OBJECT(arr);
|
||
|
return arr;
|
||
|
}
|
||
|
|
||
|
#define ADD_OUTPUT_ARG(result, pos, value, name) r_ans = AddOutputArgToReturn(pos, value, name, OutputValues);
|
||
|
|
||
|
SWIGRUNTIME SEXP
|
||
|
AddOutputArgToReturn(int pos, SEXP value, const char *name, SEXP output)
|
||
|
{
|
||
|
SET_VECTOR_ELT(output, pos, value);
|
||
|
|
||
|
return(output);
|
||
|
}
|
||
|
|
||
|
/* Create a new pointer object */
|
||
|
SWIGRUNTIMEINLINE SEXP
|
||
|
SWIG_R_NewPointerObj(void *ptr, swig_type_info *type, int flags) {
|
||
|
SEXP rptr = R_MakeExternalPtr(ptr,
|
||
|
R_MakeExternalPtr(type, R_NilValue, R_NilValue), R_NilValue);
|
||
|
SET_S4_OBJECT(rptr);
|
||
|
// rptr = Rf_setAttrib(rptr, R_ClassSymbol, mkChar(SWIG_TypeName(type)));
|
||
|
return rptr;
|
||
|
}
|
||
|
|
||
|
/* Convert a pointer value */
|
||
|
SWIGRUNTIMEINLINE int
|
||
|
SWIG_R_ConvertPtr(SEXP obj, void **ptr, swig_type_info *ty, int flags) {
|
||
|
void *vptr;
|
||
|
if (!obj) return SWIG_ERROR;
|
||
|
if (obj == R_NilValue) {
|
||
|
if (ptr) *ptr = NULL;
|
||
|
return SWIG_OK;
|
||
|
}
|
||
|
|
||
|
vptr = R_ExternalPtrAddr(obj);
|
||
|
if (ty) {
|
||
|
swig_type_info *to = (swig_type_info*)
|
||
|
R_ExternalPtrAddr(R_ExternalPtrTag(obj));
|
||
|
if (to == ty) {
|
||
|
if (ptr) *ptr = vptr;
|
||
|
} else {
|
||
|
swig_cast_info *tc = SWIG_TypeCheck(to->name,ty);
|
||
|
int newmemory = 0;
|
||
|
if (ptr) *ptr = SWIG_TypeCast(tc,vptr,&newmemory);
|
||
|
assert(!newmemory); /* newmemory handling not yet implemented */
|
||
|
}
|
||
|
} else {
|
||
|
if (ptr) *ptr = vptr;
|
||
|
}
|
||
|
return SWIG_OK;
|
||
|
}
|
||
|
|
||
|
SWIGRUNTIME swig_module_info *
|
||
|
SWIG_GetModule(void *v) {
|
||
|
static void *type_pointer = (void *)0;
|
||
|
return (swig_module_info *) type_pointer;
|
||
|
}
|
||
|
|
||
|
SWIGRUNTIME void
|
||
|
SWIG_SetModule(void *v, swig_module_info *swig_module) {
|
||
|
}
|
||
|
|
||
|
typedef struct {
|
||
|
void *pack;
|
||
|
swig_type_info *ty;
|
||
|
size_t size;
|
||
|
} RSwigPacked;
|
||
|
|
||
|
/* Create a new packed object */
|
||
|
|
||
|
SWIGRUNTIMEINLINE SEXP RSwigPacked_New(void *ptr, size_t sz,
|
||
|
swig_type_info *ty) {
|
||
|
SEXP rptr;
|
||
|
RSwigPacked *sobj =
|
||
|
(RSwigPacked*) malloc(sizeof(RSwigPacked));
|
||
|
if (sobj) {
|
||
|
void *pack = malloc(sz);
|
||
|
if (pack) {
|
||
|
memcpy(pack, ptr, sz);
|
||
|
sobj->pack = pack;
|
||
|
sobj->ty = ty;
|
||
|
sobj->size = sz;
|
||
|
} else {
|
||
|
sobj = 0;
|
||
|
}
|
||
|
}
|
||
|
rptr = R_MakeExternalPtr(sobj, R_NilValue, R_NilValue);
|
||
|
return rptr;
|
||
|
}
|
||
|
|
||
|
SWIGRUNTIME swig_type_info *
|
||
|
RSwigPacked_UnpackData(SEXP obj, void *ptr, size_t size)
|
||
|
{
|
||
|
RSwigPacked *sobj =
|
||
|
(RSwigPacked *)R_ExternalPtrAddr(obj);
|
||
|
if (sobj->size != size) return 0;
|
||
|
memcpy(ptr, sobj->pack, size);
|
||
|
return sobj->ty;
|
||
|
}
|
||
|
|
||
|
SWIGRUNTIMEINLINE SEXP
|
||
|
SWIG_R_NewPackedObj(void *ptr, size_t sz, swig_type_info *type) {
|
||
|
return ptr ? RSwigPacked_New((void *) ptr, sz, type) : R_NilValue;
|
||
|
}
|
||
|
|
||
|
/* Convert a packed value value */
|
||
|
|
||
|
SWIGRUNTIME int
|
||
|
SWIG_R_ConvertPacked(SEXP obj, void *ptr, size_t sz, swig_type_info *ty) {
|
||
|
swig_type_info *to = RSwigPacked_UnpackData(obj, ptr, sz);
|
||
|
if (!to) return SWIG_ERROR;
|
||
|
if (ty) {
|
||
|
if (to != ty) {
|
||
|
/* check type cast? */
|
||
|
swig_cast_info *tc = SWIG_TypeCheck(to->name,ty);
|
||
|
if (!tc) return SWIG_ERROR;
|
||
|
}
|
||
|
}
|
||
|
return SWIG_OK;
|
||
|
}
|
||
|
|
||
|
#ifdef __cplusplus
|
||
|
}
|
||
|
#endif
|