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