path: root/Lib/r/rrun.swg

/* Not really used yet.  */

#ifdef __cplusplus
extern "C" {
#endif

#include <Rdefines.h>
#include <Rversion.h>
#include <stdlib.h>
#undef length
#define SWIGR 1

#if R_VERSION >= R_Version(2,6,0)
#warning "R Swig currently fails on runtime for 2.6 and higher."
#warning "Contact maintainer if you would like to help fix"
#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;
  }

  PROTECT(ans = Rf_allocVector(VECSXP, n));
  for(p = callbackFunctionDataStack, i = 0; i < n; p = p->previous, i++) 
      SET_VECTOR_ELT(ans, i, p->fun);

  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) {
    PROBLEM "Supposedly impossible error occurred in the SWIG callback mechanism."
            "  No callback function data set."  /* split across two strings to make more readable. */
    ERROR;
  }
  
  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;	

  PROTECT(e = Rf_allocVector(LANGSXP, 3));
  SETCAR(e, Rf_install("extends"));

  SETCAR(CDR(e), mkString(CHAR(PRINTNAME(tag))));
  SETCAR(CDR(CDR(e)), mkString(type));

  val = R_tryEval(e, R_GlobalEnv, &check_err);
  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, mkString("ref"));

  
  if(TYPEOF(arg) != EXTPTRSXP) {
    PROBLEM "argument %s must be an external pointer (from an ExternalReference)", argName
    ERROR;
  }


  ptr = R_ExternalPtrAddr(arg);

  if(ptr == NULL && nullOk == (Rboolean) FALSE) {
      PROBLEM "the external pointer (of type %s) for argument %s has value NULL",
              argName, type
      ERROR; 
  }

  if(type[0] && R_ExternalPtrTag(arg) != Rf_install(type) && strcmp(type, "voidRef")
       && !R_SWIG_checkInherits(orig,  R_ExternalPtrTag(arg), type)) {
      PROBLEM "the external pointer for argument %s has tag %s, not the expected value %s",
              argName, CHAR(PRINTNAME(R_ExternalPtrTag(arg))), type
      ERROR;
  }


  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, 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;

  PROTECT(external = R_MakeExternalPtr(ptr, Rf_install(typeName), R_NilValue));
  PROTECT(r_obj = NEW_OBJECT(MAKE_CLASS((char *) typeName)));

  if(owner)
    R_RegisterCFinalizer(external, R_SWIG_ReferenceFinalizer);

  r_obj = SET_SLOT(r_obj, mkString((char *) "ref"), external);
  
  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. */
   PROTECT(arr = NEW_OBJECT(MAKE_CLASS((char *) typeName)));
   PROTECT(arr = R_do_slot_assign(arr, mkString("ref"), ref));
   PROTECT(arr = R_do_slot_assign(arr, mkString("dims"), ScalarInteger(len)));

   UNPROTECT(3);  

   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); 
//  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);
      if (ptr) *ptr = SWIG_TypeCast(tc,vptr);
    }
  } 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