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.
373 lines
8.6 KiB
373 lines
8.6 KiB
|
|
#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
|
|
|