1 2#ifdef __cplusplus 3extern "C" { 4#endif 5 6/* Remove global namespace pollution */ 7#if !defined(SWIG_NO_R_NO_REMAP) 8# define R_NO_REMAP 9#endif 10#if !defined(SWIG_NO_STRICT_R_HEADERS) 11# define STRICT_R_HEADERS 12#endif 13 14#include <Rdefines.h> 15#include <Rversion.h> 16#include <stdlib.h> 17#include <assert.h> 18 19#if R_VERSION >= R_Version(2,6,0) 20#define VMAXTYPE void * 21#else 22#define VMAXTYPE char * 23#endif 24 25/* 26 This is mainly a way to avoid having lots of local variables that may 27 conflict with those in the routine. 28 29 Change name to R_SWIG_Callb.... 30*/ 31typedef struct RCallbackFunctionData { 32 33 SEXP fun; 34 SEXP userData; 35 36 37 SEXP expr; 38 SEXP retValue; 39 int errorOccurred; 40 41 SEXP el; /* Temporary pointer used in the construction of the expression to call the R function. */ 42 43 struct RCallbackFunctionData *previous; /* Stack */ 44 45} RCallbackFunctionData; 46 47static RCallbackFunctionData *callbackFunctionDataStack; 48 49 50SWIGRUNTIME SEXP 51R_SWIG_debug_getCallbackFunctionData() 52{ 53 int n, i; 54 SEXP ans; 55 RCallbackFunctionData *p = callbackFunctionDataStack; 56 57 n = 0; 58 while(p) { 59 n++; 60 p = p->previous; 61 } 62 63 Rf_protect(ans = Rf_allocVector(VECSXP, n)); 64 for(p = callbackFunctionDataStack, i = 0; i < n; p = p->previous, i++) 65 SET_VECTOR_ELT(ans, i, p->fun); 66 67 Rf_unprotect(1); 68 69 return(ans); 70} 71 72 73 74SWIGRUNTIME RCallbackFunctionData * 75R_SWIG_pushCallbackFunctionData(SEXP fun, SEXP userData) 76{ 77 RCallbackFunctionData *el; 78 el = (RCallbackFunctionData *) calloc(1, sizeof(RCallbackFunctionData)); 79 el->fun = fun; 80 el->userData = userData; 81 el->previous = callbackFunctionDataStack; 82 83 callbackFunctionDataStack = el; 84 85 return(el); 86} 87 88 89SWIGRUNTIME SEXP 90R_SWIG_R_pushCallbackFunctionData(SEXP fun, SEXP userData) 91{ 92 R_SWIG_pushCallbackFunctionData(fun, userData); 93 return R_NilValue; 94} 95 96SWIGRUNTIME RCallbackFunctionData * 97R_SWIG_getCallbackFunctionData() 98{ 99 if(!callbackFunctionDataStack) { 100 Rf_error("Supposedly impossible error occurred in the SWIG callback mechanism." 101 " No callback function data set."); 102 } 103 104 return callbackFunctionDataStack; 105} 106 107SWIGRUNTIME void 108R_SWIG_popCallbackFunctionData(int doFree) 109{ 110 RCallbackFunctionData *el = NULL; 111 if(!callbackFunctionDataStack) 112 return ; /* Error !!! */ 113 114 el = callbackFunctionDataStack ; 115 callbackFunctionDataStack = callbackFunctionDataStack->previous; 116 117 if(doFree) 118 free(el); 119} 120 121 122/* 123 Interface to S function 124 is(obj, type) 125 which is to be used to determine if an 126 external pointer inherits from the right class. 127 128 Ideally, we would like to be able to do this without an explicit call to the is() function. 129 When the S4 class system uses its own SEXP types, then we will hopefully be able to do this 130 in the C code. 131 132 Should we make the expression static and preserve it to avoid the overhead of 133 allocating each time. 134*/ 135SWIGRUNTIME int 136R_SWIG_checkInherits(SEXP obj, SEXP tag, const char *type) 137{ 138 SEXP e, val; 139 int check_err = 0; 140 141 Rf_protect(e = Rf_allocVector(LANGSXP, 3)); 142 SETCAR(e, Rf_install("extends")); 143 144 SETCAR(CDR(e), Rf_mkString(CHAR(PRINTNAME(tag)))); 145 SETCAR(CDR(CDR(e)), Rf_mkString(type)); 146 147 val = R_tryEval(e, R_GlobalEnv, &check_err); 148 Rf_unprotect(1); 149 if(check_err) 150 return(0); 151 152 153 return(LOGICAL(val)[0]); 154} 155 156 157SWIGRUNTIME void * 158R_SWIG_resolveExternalRef(SEXP arg, const char * const type, const char * const argName, Rboolean nullOk) 159{ 160 void *ptr; 161 SEXP orig = arg; 162 163 if(TYPEOF(arg) != EXTPTRSXP) 164 arg = GET_SLOT(arg, Rf_mkString("ref")); 165 166 167 if(TYPEOF(arg) != EXTPTRSXP) { 168 Rf_error("argument %s must be an external pointer (from an ExternalReference)", argName); 169 } 170 171 172 ptr = R_ExternalPtrAddr(arg); 173 174 if(ptr == NULL && nullOk == (Rboolean) FALSE) { 175 Rf_error("the external pointer (of type %s) for argument %s has value NULL", argName, type); 176 } 177 178 if(type[0] && R_ExternalPtrTag(arg) != Rf_install(type) && strcmp(type, "voidRef") 179 && !R_SWIG_checkInherits(orig, R_ExternalPtrTag(arg), type)) { 180 Rf_error("the external pointer for argument %s has tag %s, not the expected value %s", 181 argName, CHAR(PRINTNAME(R_ExternalPtrTag(arg))), type); 182 } 183 184 185 return(ptr); 186} 187 188SWIGRUNTIME void 189R_SWIG_ReferenceFinalizer(SEXP el) 190{ 191 void *ptr = R_SWIG_resolveExternalRef(el, "", "<finalizer>", (Rboolean) 1); 192 fprintf(stderr, "In R_SWIG_ReferenceFinalizer for %p\n", ptr); 193 Rf_PrintValue(el); 194 195 if(ptr) { 196 if(TYPEOF(el) != EXTPTRSXP) 197 el = GET_SLOT(el, Rf_mkString("ref")); 198 199 if(TYPEOF(el) == EXTPTRSXP) 200 R_ClearExternalPtr(el); 201 202 free(ptr); 203 } 204 205 return; 206} 207 208typedef enum {R_SWIG_EXTERNAL, R_SWIG_OWNER } R_SWIG_Owner; 209 210SWIGRUNTIME SEXP 211SWIG_MakePtr(void *ptr, const char *typeName, R_SWIG_Owner owner) 212{ 213 SEXP external, r_obj; 214 const char *p = typeName; 215 216 if(typeName[0] == '_') 217 p = typeName + 1; 218 219 Rf_protect(external = R_MakeExternalPtr(ptr, Rf_install(typeName), R_NilValue)); 220 Rf_protect(r_obj = NEW_OBJECT(MAKE_CLASS((char *) typeName))); 221 222 if(owner) 223 R_RegisterCFinalizer(external, R_SWIG_ReferenceFinalizer); 224 225 r_obj = SET_SLOT(r_obj, Rf_mkString((char *) "ref"), external); 226 SET_S4_OBJECT(r_obj); 227 Rf_unprotect(2); 228 229 return(r_obj); 230} 231 232 233SWIGRUNTIME SEXP 234R_SWIG_create_SWIG_R_Array(const char *typeName, SEXP ref, int len) 235{ 236 SEXP arr; 237 238/*XXX remove the char * cast when we can. MAKE_CLASS should be declared appropriately. */ 239 Rf_protect(arr = NEW_OBJECT(MAKE_CLASS((char *) typeName))); 240 Rf_protect(arr = R_do_slot_assign(arr, Rf_mkString("ref"), ref)); 241 Rf_protect(arr = R_do_slot_assign(arr, Rf_mkString("dims"), Rf_ScalarInteger(len))); 242 243 Rf_unprotect(3); 244 SET_S4_OBJECT(arr); 245 return arr; 246} 247 248#define ADD_OUTPUT_ARG(result, pos, value, name) r_ans = AddOutputArgToReturn(pos, value, name, OutputValues); 249 250SWIGRUNTIME SEXP 251AddOutputArgToReturn(int pos, SEXP value, const char *name, SEXP output) 252{ 253 SET_VECTOR_ELT(output, pos, value); 254 255 return(output); 256} 257 258/* Create a new pointer object */ 259SWIGRUNTIMEINLINE SEXP 260SWIG_R_NewPointerObj(void *ptr, swig_type_info *type, int flags) { 261 SEXP rptr = R_MakeExternalPtr(ptr, 262 R_MakeExternalPtr(type, R_NilValue, R_NilValue), R_NilValue); 263 SET_S4_OBJECT(rptr); 264// rptr = Rf_setAttrib(rptr, R_ClassSymbol, mkChar(SWIG_TypeName(type))); 265 return rptr; 266} 267 268/* Convert a pointer value */ 269SWIGRUNTIMEINLINE int 270SWIG_R_ConvertPtr(SEXP obj, void **ptr, swig_type_info *ty, int flags) { 271 void *vptr; 272 if (!obj) return SWIG_ERROR; 273 if (obj == R_NilValue) { 274 if (ptr) *ptr = NULL; 275 return SWIG_OK; 276 } 277 278 vptr = R_ExternalPtrAddr(obj); 279 if (ty) { 280 swig_type_info *to = (swig_type_info*) 281 R_ExternalPtrAddr(R_ExternalPtrTag(obj)); 282 if (to == ty) { 283 if (ptr) *ptr = vptr; 284 } else { 285 swig_cast_info *tc = SWIG_TypeCheck(to->name,ty); 286 int newmemory = 0; 287 if (ptr) *ptr = SWIG_TypeCast(tc,vptr,&newmemory); 288 assert(!newmemory); /* newmemory handling not yet implemented */ 289 } 290 } else { 291 if (ptr) *ptr = vptr; 292 } 293 return SWIG_OK; 294} 295 296SWIGRUNTIME swig_module_info * 297SWIG_GetModule(void *v) { 298 static void *type_pointer = (void *)0; 299 return (swig_module_info *) type_pointer; 300} 301 302SWIGRUNTIME void 303SWIG_SetModule(void *v, swig_module_info *swig_module) { 304} 305 306typedef struct { 307 void *pack; 308 swig_type_info *ty; 309 size_t size; 310} RSwigPacked; 311 312/* Create a new packed object */ 313 314SWIGRUNTIMEINLINE SEXP RSwigPacked_New(void *ptr, size_t sz, 315 swig_type_info *ty) { 316 SEXP rptr; 317 RSwigPacked *sobj = 318 (RSwigPacked*) malloc(sizeof(RSwigPacked)); 319 if (sobj) { 320 void *pack = malloc(sz); 321 if (pack) { 322 memcpy(pack, ptr, sz); 323 sobj->pack = pack; 324 sobj->ty = ty; 325 sobj->size = sz; 326 } else { 327 sobj = 0; 328 } 329 } 330 rptr = R_MakeExternalPtr(sobj, R_NilValue, R_NilValue); 331 return rptr; 332} 333 334SWIGRUNTIME swig_type_info * 335RSwigPacked_UnpackData(SEXP obj, void *ptr, size_t size) 336{ 337 RSwigPacked *sobj = 338 (RSwigPacked *)R_ExternalPtrAddr(obj); 339 if (sobj->size != size) return 0; 340 memcpy(ptr, sobj->pack, size); 341 return sobj->ty; 342} 343 344SWIGRUNTIMEINLINE SEXP 345SWIG_R_NewPackedObj(void *ptr, size_t sz, swig_type_info *type) { 346 return ptr ? RSwigPacked_New((void *) ptr, sz, type) : R_NilValue; 347} 348 349/* Convert a packed value value */ 350 351SWIGRUNTIME int 352SWIG_R_ConvertPacked(SEXP obj, void *ptr, size_t sz, swig_type_info *ty) { 353 swig_type_info *to = RSwigPacked_UnpackData(obj, ptr, sz); 354 if (!to) return SWIG_ERROR; 355 if (ty) { 356 if (to != ty) { 357 /* check type cast? */ 358 swig_cast_info *tc = SWIG_TypeCheck(to->name,ty); 359 if (!tc) return SWIG_ERROR; 360 } 361 } 362 return SWIG_OK; 363} 364 365#ifdef __cplusplus 366} 367#endif 368