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