jyapayne/swig
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Committing R-SWIG

Browse source 
git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@9175 626c5289-ae23-0410-ae9c-e8d60b6d4f22
This commit is contained in:
Joseph Wang 2006-06-29 03:01:18 +00:00
commit ef80a4f59a
51 changed files with 5154 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Lib/r/cdata.i Normal file
View file

@ -0,0 +1 @@
%include <typemaps/cdata.swg>

8
Lib/r/exception.i Normal file
View file

@ -0,0 +1,8 @@
%include <typemaps/exception.swg>
%insert("runtime") {
%define_as(SWIG_exception(code, msg),
%block(switch (code) {case SWIG_IndexError: return Rf_ScalarLogical(NA_LOGICAL); default: %error(code, msg); SWIG_fail;} ))
}

189
Lib/r/r.swg Normal file
View file

@ -0,0 +1,189 @@
/* */
%insert("header") "swiglabels.swg"
%insert("header") "swigerrors.swg"
%insert("init") "swiginit.swg"
%insert("runtime") "swigrun.swg"
%insert("runtime") "rrun.swg"
%init %{
SWIGEXPORT void SWIG_init(void) {
%}
#define %Rruntime %insert("s")
#define SWIG_Object SEXP
#define VOID_Object R_NilValue
#define %append_output(obj) SET_VECTOR_ELT($result, $n, obj)
%define %set_constant(name, obj) %begin_block
SEXP _obj = obj;
assign(name, _obj);
%end_block %enddef
%define %raise(obj,type,desc)
return R_NilValue;
%enddef
%insert("sinit") "srun.swg"
%insert("sinitroutine") %{
SWIG_init();
SWIG_InitializeModule(0);
%}
%include <typemaps/swigmacros.swg>
%typemap(in) (double *x, int len) %{
$1 = REAL(x);
$2 = Rf_length(x);
%}
/* XXX
Need to worry about inheritance, e.g. if B extends A
and we are looking for an A[], then B elements are okay.
*/
%typemap(scheck) SWIGTYPE[ANY]
%{
# assert(length($input) > $1_dim0)
assert(all(sapply($input, class) == "$R_class"))
%}
%typemap(out) void "";
%typemap(in) int *, int[ANY] %{
$1 = INTEGER($input);
%}
%typemap(in) double *, double[ANY] %{
$1 = REAL($input);
%}
/* Shoul dwe recycle to make the length correct.
And warn if length() > the dimension.
*/
%typemap(scheck) SWIGTYPE [ANY] %{
# assert(length($input) >= $1_dim0)
%}
/* Handling vector case to avoid warnings,
although we just use the first one. */
%typemap(scheck) unsigned int %{
assert(length($input) == 1 && $input >= 0, "All values must be non-negative")
%}
%typemap(scheck) int %{
if(length($input) > 1) {
warning("using only the first element of $input")
}
%}
%include <typemaps/swigmacros.swg>
%include <typemaps/fragments.swg>
%include <rfragments.swg>
%include <ropers.swg>
%include <typemaps/swigtypemaps.swg>
%include <rtype.swg>
%apply int[ANY] { enum SWIGTYPE[ANY] };
%typemap(in,noblock=1) enum SWIGTYPE[ANY] {
$1 = %reinterpret_cast(INTEGER($input), $1_ltype);
}
%typemap(in,noblock=1) char* {
$1 = %reinterpret_cast(CHAR(STRING_ELT($input, 0)), $1_ltype);
}
%typemap(in,noblock=1) char *[ANY] {
$1 = %reinterpret_cast(CHAR(STRING_ELT($input, 0)), $1_ltype);
}
%typemap(in,noblock=1) char[ANY]
"$1 = CHAR(STRING_ELT($input, 0));";
%typemap(in,noblock=1) char[]
"$1 = CHAR(STRING_ELT($input, 0));";
%typemap(memberin) char[] %{
if ($input) strcpy($1, $input);
else
strcpy($1, "");
%}
%typemap(globalin) char[] %{
if ($input) strcpy($1, $input);
else
strcpy($1, "");
%}
%typemap(out,noblock=1) char*
{ $result = $1 ? mkString(%reinterpret_cast($1,char *)) : R_NilValue; }
%typemap(in,noblock=1) char {
$1 = %static_cast(CHAR(STRING_ELT($input, 0))[0],$1_ltype);
}
%typemap(out,noblock=1) char
{
char tmp[2] = "x";
tmp[0] = $1;
$result = mkString(tmp);
}
%typemap(in,noblock=1) int {
$1 = %static_cast(INTEGER($input)[0], $1_ltype);
}
%typemap(out,noblock=1) int
"$result = ScalarInteger($1);";
%typemap(in,noblock=1) bool
"$1 = LOGICAL($input)[0];";
%typemap(out,noblock=1) bool
"$result = ScalarLogical($1);";
%typemap(in,noblock=1) unsigned int,
unsigned long,
float,
double,
long
{
$1 = %static_cast(REAL($input)[0], $1_ltype);
}
%typemap(out,noblock=1) unsigned int *
"$result = ScalarReal(*($1));";
%Rruntime %{
setMethod('[', "ExternalReference",
function(x,i,j, ..., drop=TRUE)
if (!is.null(x$"__getitem__"))
sapply(i, function(n) x$"__getitem__"(i=as.integer(n-1))))
setMethod('[<-' , "ExternalReference",
function(x,i,j, ..., value)
if (!is.null(x$"__setitem__")) {
sapply(1:length(i), function(n)
x$"__setitem__"(i=as.integer(i[n]-1), x=value[n]))
x
})
setAs('ExternalReference', 'character',
function(from) {if (!is.null(from$"__str__")) from$"__str__"()})
setMethod('print', 'ExternalReference',
function(x) {print(as(x, "character"))})
%}

198
Lib/r/rcontainer.swg Normal file
View file

@ -0,0 +1,198 @@
//
// Common fragments
//
/**** The python container methods ****/
%fragment("RSequence_Base","header")
{
%#include <functional>
namespace swig {
inline size_t
check_index(ptrdiff_t i, size_t size, bool insert = false) {
if ( i < 0 ) {
if ((size_t) (-i) <= size)
return (size_t) (i + size);
} else if ( (size_t) i < size ) {
return (size_t) i;
} else if (insert && ((size_t) i == size)) {
return size;
}
throw std::out_of_range("index out of range");
}
inline size_t
slice_index(ptrdiff_t i, size_t size) {
if ( i < 0 ) {
if ((size_t) (-i) <= size) {
return (size_t) (i + size);
} else {
throw std::out_of_range("index out of range");
}
} else {
return ( (size_t) i < size ) ? ((size_t) i) : size;
}
}
template <class Sequence, class Difference>
inline typename Sequence::iterator
getpos(Sequence* self, Difference i) {
typename Sequence::iterator pos = self->begin();
std::advance(pos, check_index(i,self->size()));
return pos;
}
template <class Sequence, class Difference>
inline typename Sequence::const_iterator
cgetpos(const Sequence* self, Difference i) {
typename Sequence::const_iterator pos = self->begin();
std::advance(pos, check_index(i,self->size()));
return pos;
}
template <class Sequence, class Difference>
inline Sequence*
getslice(const Sequence* self, Difference i, Difference j) {
typename Sequence::size_type size = self->size();
typename Sequence::size_type ii = swig::check_index(i, size);
typename Sequence::size_type jj = swig::slice_index(j, size);
if (jj > ii) {
typename Sequence::const_iterator vb = self->begin();
typename Sequence::const_iterator ve = self->begin();
std::advance(vb,ii);
std::advance(ve,jj);
return new Sequence(vb, ve);
} else {
return new Sequence();
}
}
template <class Sequence, class Difference, class InputSeq>
inline void
setslice(Sequence* self, Difference i, Difference j, const InputSeq& v) {
typename Sequence::size_type size = self->size();
typename Sequence::size_type ii = swig::check_index(i, size, true);
typename Sequence::size_type jj = swig::slice_index(j, size);
if (jj < ii) jj = ii;
size_t ssize = jj - ii;
if (ssize <= v.size()) {
typename Sequence::iterator sb = self->begin();
typename InputSeq::const_iterator vmid = v.begin();
std::advance(sb,ii);
std::advance(vmid, jj - ii);
self->insert(std::copy(v.begin(), vmid, sb), vmid, v.end());
} else {
typename Sequence::iterator sb = self->begin();
typename Sequence::iterator se = self->begin();
std::advance(sb,ii);
std::advance(se,jj);
self->erase(sb,se);
self->insert(sb, v.begin(), v.end());
}
}
template <class Sequence, class Difference>
inline void
delslice(Sequence* self, Difference i, Difference j) {
typename Sequence::size_type size = self->size();
typename Sequence::size_type ii = swig::check_index(i, size, true);
typename Sequence::size_type jj = swig::slice_index(j, size);
if (jj > ii) {
typename Sequence::iterator sb = self->begin();
typename Sequence::iterator se = self->begin();
std::advance(sb,ii);
std::advance(se,jj);
self->erase(sb,se);
}
}
}
}
%define %swig_container_methods(Container...)
%newobject __getslice__;
%extend {
bool __nonzero__() const {
return !(self->empty());
}
size_type __len__() const {
return self->size();
}
}
%enddef
%define %swig_sequence_methods_common(Sequence...)
// %swig_sequence_iterator(%arg(Sequence))
%swig_container_methods(%arg(Sequence))
%fragment("RSequence_Base");
%extend {
value_type pop() throw (std::out_of_range) {
if (self->size() == 0)
throw std::out_of_range("pop from empty container");
Sequence::value_type x = self->back();
self->pop_back();
return x;
}
Sequence* __getslice__(difference_type i, difference_type j) throw (std::out_of_range) {
return swig::getslice(self, i, j);
}
void __setslice__(difference_type i, difference_type j, const Sequence& v)
throw (std::out_of_range, std::invalid_argument) {
swig::setslice(self, i, j, v);
}
void __delslice__(difference_type i, difference_type j) throw (std::out_of_range) {
swig::delslice(self, i, j);
}
void __delitem__(difference_type i) throw (std::out_of_range) {
self->erase(swig::getpos(self,i));
}
}
%enddef
%define %swig_sequence_methods(Sequence...)
%swig_sequence_methods_common(%arg(Sequence))
%extend {
const value_type& __getitem__(difference_type i) const throw (std::out_of_range) {
return *(swig::cgetpos(self, i));
}
void __setitem__(difference_type i, const value_type& x) throw (std::out_of_range) {
*(swig::getpos(self,i)) = x;
}
void append(const value_type& x) {
self->push_back(x);
}
}
%enddef
%define %swig_sequence_methods_val(Sequence...)
%swig_sequence_methods_common(%arg(Sequence))
%extend {
value_type __getitem__(difference_type i) throw (std::out_of_range) {
return *(swig::cgetpos(self, i));
}
void __setitem__(difference_type i, value_type x) throw (std::out_of_range) {
*(swig::getpos(self,i)) = x;
}
void append(value_type x) {
self->push_back(x);
}
}
%enddef

167
Lib/r/rfragments.swg Normal file
View file

@ -0,0 +1,167 @@
#define SWIG_Error(code, msg) warning(msg); return Rf_ScalarLogical(NA_LOGICAL)
#define SWIG_fail return Rf_ScalarLogical(NA_LOGICAL)
/* for raw pointers */
#define SWIG_ConvertPtr(oc, ptr, ty, flags) SWIG_R_ConvertPtr(oc, ptr, ty, flags)
#define SWIG_ConvertFunctionPtr(oc, ptr, ty) SWIG_R_ConvertPtr(oc, ptr, ty, 0)
#define SWIG_NewPointerObj(ptr, ty, flags) SWIG_R_NewPointerObj(ptr, ty, flags)
#define SWIG_NewFunctionPtrObj(ptr, ty) SWIG_R_NewPointerObj(ptr, ty, 0)
/* for raw packed data */
#define SWIG_ConvertPacked(obj, ptr, sz, ty) SWIG_R_ConvertPacked(obj, ptr, sz, ty)
#define SWIG_NewPackedObj(ptr, sz, ty) SWIG_R_NewPackedObj(ptr, sz, ty)
/* for class or struct pointers */
#define SWIG_ConvertInstance(obj, pptr, ty, flags) SWIG_ConvertPtr(obj, pptr, ty, flags)
#define SWIG_NewInstanceObj(ptr, ty, flags) SWIG_NewPointerObj(ptr, ty, flags)
/* for C++ member pointers, ie, member methods */
#define SWIG_ConvertMember(obj, ptr, sz, ty) SWIG_R_ConvertPacked(obj, ptr, sz, ty)
#define SWIG_NewMemberObj(ptr, sz, ty) SWIG_R_NewPackedObj(ptr, sz, ty)
/* Runtime API */
#define SWIG_GetModule(clientdata) SWIG_R_GetModule()
#define SWIG_SetModule(clientdata, pointer) SWIG_R_SetModule(pointer)
%fragment(SWIG_From_frag(long),"header") {
SWIGINTERNINLINE SEXP
SWIG_From_dec(long)(long value)
{
return Rf_ScalarInteger((int)value);
}
}
%fragment(SWIG_AsVal_frag(long),"header") {
SWIGINTERNINLINE int
SWIG_AsVal_dec(long)(SEXP obj, long *val)
{
if (val) *val = Rf_asInteger(obj);
return SWIG_OK;
}
}
%fragment(SWIG_From_frag(long long),"header") {
SWIGINTERNINLINE SEXP
SWIG_From_dec(long long)(long long value)
{
return Rf_ScalarInteger((int)value);
}
}
%fragment(SWIG_AsVal_frag(long long),"header") {
SWIGINTERNINLINE int
SWIG_AsVal_dec(long long)(SEXP obj, long long *val)
{
if (val) *val = Rf_asInteger(obj);
return SWIG_OK;
}
}
%fragment(SWIG_From_frag(unsigned long),"header") {
SWIGINTERNINLINE SEXP
SWIG_From_dec(unsigned long)(unsigned long value)
{
return Rf_ScalarInteger((int)value);
}
}
%fragment(SWIG_AsVal_frag(unsigned long),"header") {
SWIGINTERNINLINE int
SWIG_AsVal_dec(unsigned long)(SEXP obj, unsigned long *val)
{
if (val) *val = Rf_asInteger(obj);
return SWIG_OK;
}
}
%fragment(SWIG_From_frag(unsigned long long),"header") {
SWIGINTERNINLINE SEXP
SWIG_From_dec(unsigned long long)(unsigned long long value)
{
return Rf_ScalarInteger((int)value);
}
}
%fragment(SWIG_AsVal_frag(unsigned long long),"header") {
SWIGINTERNINLINE int
SWIG_AsVal_dec(unsigned long long)(SEXP obj, unsigned long long *val)
{
if (val) *val = Rf_asInteger(obj);
return SWIG_OK;
}
}
%fragment(SWIG_From_frag(double),"header") {
SWIGINTERNINLINE SEXP
SWIG_From_dec(double)(double value)
{
return Rf_ScalarReal(value);
}
}
%fragment(SWIG_AsVal_frag(double),"header") {
SWIGINTERNINLINE int
SWIG_AsVal_dec(double)(SEXP obj, double *val)
{
if (val) *val = Rf_asReal(obj);
return SWIG_OK;
}
}
%fragment("SWIG_AsCharPtrAndSize", "header")
{
SWIGINTERN int
SWIG_AsCharPtrAndSize(SEXP obj, char** cptr, size_t* psize, int *alloc)
{
if (!cptr) return SWIG_TypeError;
if (!Rf_isString(obj)) return SWIG_TypeError;
char *cstr; int len;
cstr = CHAR(STRING_ELT(obj, 0));
len = strlen(cstr);
if (cptr) {
if (alloc) {
if (*alloc == SWIG_NEWOBJ)
{
*cptr = %new_copy_array(cstr, len + 1, char);
*alloc = SWIG_NEWOBJ;
}
else {
*cptr = cstr;
*alloc = SWIG_OLDOBJ;
}
} else {
*cptr = strdup(cstr);
}
}
if (psize) *psize = len + 1;
return SWIG_OK;
}
}
# This is modified from the R header files
%fragment("SWIG_FromCharPtrAndSize","header")
{
SWIGINTERN SEXP
SWIG_FromCharPtrAndSize(const char* carray, size_t size)
{
SEXP t, c;
if (!carray) return R_NilValue;
PROTECT(t = allocVector(STRSXP, 1));
c = allocString(size);
strncpy(CHAR(c), carray, size);
SET_STRING_ELT(t, 0, c);
UNPROTECT(1);
return t;
}
}

44
Lib/r/ropers.swg Normal file
View file

@ -0,0 +1,44 @@
#ifdef __cplusplus
// These are auto-supported by the Perl-module
%rename(__plusplus__) *::operator++;
%rename(__minmin__) *::operator--;
%rename(__add__) *::operator+;
%rename(__sub__) *::operator-;
%rename(__neg__) *::operator-();
%rename(__neg__) *::operator-() const;
%rename(__mul__) *::operator*;
%rename(__div__) *::operator/;
%rename(__eq__) *::operator==;
%rename(__ne__) *::operator!=;
%rename(__mod__) *::operator%;
%rename(__gt__) *::operator>;
%rename(__lt__) *::operator<;
%rename(__not__) *::operator!;
// These are renamed, but no 'use overload...' is added
%rename(__lshift__) *::operator<<;
%rename(__rshift__) *::operator>>;
%rename(__and__) *::operator&;
%rename(__or__) *::operator|;
%rename(__xor__) *::operator^;
%rename(__invert__) *::operator~;
%rename(__le__) *::operator<=;
%rename(__ge__) *::operator>=;
%rename(__call__) *::operator();
%rename(__getitem__) *::operator[];
%rename(__seteq__) *::operator=;
/* Ignored operators */
%ignoreoperator(LNOT) operator!;
%ignoreoperator(LAND) operator&&;
%ignoreoperator(LOR) operator||;
%ignoreoperator(EQ) *::operator=;
%ignoreoperator(PLUSPLUS) *::operator++;
%ignoreoperator(MINUSMINUS) *::operator--;
%ignoreoperator(ARROWSTAR) *::operator->*;
%ignoreoperator(INDEX) *::operator[];
#endif

355
Lib/r/rrun.swg Normal file
View file

@ -0,0 +1,355 @@
/* Not really used yet. */
#ifdef __cplusplus
extern "C" {
#endif
#include <Rdefines.h>
#undef length
#define SWIGR 1
/*
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) {
if (!obj) return SWIG_ERROR;
if (obj == R_NilValue) {
if (ptr) *ptr = NULL;
return SWIG_OK;
}
void *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

216
Lib/r/rstdcommon.swg Normal file
View file

@ -0,0 +1,216 @@
%fragment("StdTraits","header",fragment="StdTraitsCommon")
{
namespace swig {
/*
Traits that provides the from method
*/
template <class Type> struct traits_from_ptr {
static SWIG_Object from(Type *val, int owner = 0) {
return SWIG_NewPointerObj(val, type_info<Type>(), owner);
}
};
template <class Type> struct traits_from {
static SWIG_Object from(const Type& val) {
return traits_from_ptr<Type>::from(new Type(val), 1);
}
};
template <class Type> struct traits_from<Type *> {
static SWIG_Object from(Type* val) {
return traits_from_ptr<Type>::from(val, 0);
}
};
template <class Type>
inline SWIG_Object from(const Type& val) {
return traits_from<Type>::from(val);
}
template <class Type>
inline SWIG_Object from_ptr(Type* val, int owner) {
return traits_from_ptr<Type>::from(val, owner);
}
/*
Traits that provides the asval/as/check method
*/
template <class Type>
struct traits_asptr {
static int asptr(SWIG_Object obj, Type **val) {
Type *p;
int res = (SWIG_ConvertPtr(obj, (void**)&p, type_info<Type>(), 0) == SWIG_OK) ? SWIG_OLDOBJ : 0;
if (SWIG_IsOK(res)) {
if (val) *val = p;
}
return res;
}
};
template <class Type>
inline int asptr(SWIG_Object obj, Type **vptr) {
return traits_asptr<Type>::asptr(obj, vptr);
}
template <class Type>
struct traits_asval {
static int asval(SWIG_Object obj, Type *val) {
if (val) {
Type *p = 0;
int res = traits_asptr<Type>::asptr(obj, &p);
if (!SWIG_IsOK(res)) return res;
if (p) {
typedef typename noconst_traits<Type>::noconst_type noconst_type;
*(const_cast<noconst_type*>(val)) = *p;
if (SWIG_IsNewObj(res)){
%delete(p);
res = SWIG_DelNewMask(res);
}
return res;
} else {
return SWIG_ERROR;
}
} else {
return traits_asptr<Type>::asptr(obj, (Type **)(0));
}
}
};
template <class Type> struct traits_asval<Type*> {
static int asval(SWIG_Object obj, Type **val) {
if (val) {
typedef typename noconst_traits<Type>::noconst_type noconst_type;
noconst_type *p = 0;
int res = traits_asptr<noconst_type>::asptr(obj, &p);
if (SWIG_IsOK(res)) {
*(const_cast<noconst_type**>(val)) = p;
}
return res;
} else {
return traits_asptr<Type>::asptr(obj, (Type **)(0));
}
}
};
template <class Type>
inline int asval(SWIG_Object obj, Type *val) {
return traits_asval<Type>::asval(obj, val);
}
template <class Type>
struct traits_as<Type, value_category> {
static Type as(SWIG_Object obj, bool throw_error) {
Type v;
int res = asval(obj, &v);
if (!obj || !SWIG_IsOK(res)) {
// if (!PyErr_Occurred()) {
// %type_error(swig::type_name<Type>());
// }
if (throw_error) throw std::invalid_argument("bad type");
}
return v;
}
};
template <class Type>
struct traits_as<Type, pointer_category> {
static Type as(SWIG_Object obj, bool throw_error) {
Type *v = 0;
int res = (obj ? traits_asptr<Type>::asptr(obj, &v) : SWIG_ERROR);
if (SWIG_IsOK(res) && v) {
if (SWIG_IsNewObj(res)) {
Type r(*v);
%delete(v);
return r;
} else {
return *v;
}
} else {
// Uninitialized return value, no Type() constructor required.
static Type *v_def = (Type*) malloc(sizeof(Type));
// if (!PyErr_Occurred()) {
// %type_error(swig::type_name<Type>());
// }
if (throw_error) throw std::invalid_argument("bad type");
memset(v_def,0,sizeof(Type));
return *v_def;
}
}
};
template <class Type>
struct traits_as<Type*, pointer_category> {
static Type* as(SWIG_Object obj, bool throw_error) {
Type *v = 0;
int res = (obj ? traits_asptr<Type>::asptr(obj, &v) : SWIG_ERROR);
if (SWIG_IsOK(res)) {
return v;
} else {
// if (!PyErr_Occurred()) {
// %type_error(swig::type_name<Type>());
// }
if (throw_error) throw std::invalid_argument("bad type");
return 0;
}
}
};
template <class Type>
inline Type as(SWIG_Object obj, bool te = false) {
return traits_as<Type, typename traits<Type>::category>::as(obj, te);
}
template <class Type>
struct traits_check<Type, value_category> {
static bool check(SWIG_Object obj) {
int res = obj ? asval(obj, (Type *)(0)) : SWIG_ERROR;
return SWIG_IsOK(res) ? true : false;
}
};
template <class Type>
struct traits_check<Type, pointer_category> {
static bool check(SWIG_Object obj) {
int res = obj ? asptr(obj, (Type **)(0)) : SWIG_ERROR;
return SWIG_IsOK(res) ? true : false;
}
};
template <class Type>
inline bool check(SWIG_Object obj) {
return traits_check<Type, typename traits<Type>::category>::check(obj);
}
}
}
%define %specialize_std_container(Type,Check,As,From)
%{
namespace swig {
template <> struct traits_asval<Type > {
typedef Type value_type;
static int asval(SWIG_Object obj, value_type *val) {
if (Check(obj)) {
if (val) *val = As(obj);
return SWIG_OK;
}
return SWIG_ERROR;
}
};
template <> struct traits_from<Type > {
typedef Type value_type;
static SWIG_Object from(const value_type& val) {
return From(val);
}
};
template <>
struct traits_check<Type, value_category> {
static int check(SWIG_Object obj) {
int res = Check(obj);
return obj && res ? res : 0;
}
};
}
%}
%enddef

200
Lib/r/rtype.swg Normal file
View file

@ -0,0 +1,200 @@
/* These map the primitive C types to the appropriate R type
for use in class representations.
*/
%typemap("rtype") int, int *, int & "numeric";
%apply int {size_t}
%apply int {std::size_t}
%apply int {ptrdiff_t}
%apply int {std::ptrdiff_t}
%typemap("rtype") long, long * "numeric";
%typemap("rtype") unsigned long,
unsigned long * "numeric";
%typemap("rtype") unsigned int,
unsigned int * "numeric";
%typemap("rtype") double, double*, double & "numeric";
%typemap("rtype") float, float *, float & "numeric";
%typemap("rtype") char *, char ** "character";
%typemap("rtype") char "character";
%typemap("rtype") string, string *, string & "character";
%typemap("rtype") std::string, std::string *, std::string & "character";
%typemap("rtype") bool, bool * "logical";
%typemap("rtype") enum SWIGTYPE "character";
%typemap("rtype") enum SWIGTYPE * "character";
%typemap("rtype") enum SWIGTYPE & "character";
%typemap("rtype") SWIGTYPE * "$R_class";
%typemap("rtype") SWIGTYPE & "$R_class";
%typemap("rtype") SWIGTYPE "$&R_class";
/* Have to be careful that as(x, "numeric") is different from as.numeric(x).
The latter makes a REALSXP, whereas the former leaves an INTSXP as an
INTSXP.
*/
%typemap(scoercein) int, int *, int &
%{ $input = as($input, "integer"); %}
%typemap(scoercein) ptrdiff_t, ptrdiff_t *, ptrdiff_t &
%{ $input = as($input, "integer"); %}
%typemap(scoercein) unsigned long, unsigned long *, unsigned long &
%{ $input = as($input, "integer"); %}
%typemap(scoercein) unsigned int, unsigned int *, unsigned int &
%{ $input = as($input, "integer"); %}
%typemap(scoercein) double, double *, double &
%{ $input = as($input, "numeric"); %}
%typemap(scoercein) float, float *, float &
%{ $input = as($input, "numeric"); %}
%typemap(scoercein) char, char *, char &
%{ $input = as($input, "character"); %}
%typemap(scoercein) string, string *, string &
%{ $input = as($input, "character"); %}
%typemap(scoercein) std::string, std::string *, std::string &
%{ $input = as($input, "character"); %}
%typemap(scoercein) enum SWIGTYPE
%{ $input = enumToInteger($input, "$R_class") %}
%typemap(scoercein) enum SWIGTYPE &
%{ $input = enumToInteger($input, "$R_class") %}
%typemap(scoercein) enum SWIGTYPE *
%{ $input = enumToInteger($input, "$R_class") %}
%typemap(scoercein) SWIGTYPE *
%{ $input = coerceIfNotSubclass($input, "$R_class") %}
%typemap(scoercein) SWIGTYPE &
%{ $input = coerceIfNotSubclass($input, "$R_class") %}
%typemap(scoercein) SWIGTYPE
%{ $input = coerceIfNotSubclass($input, "$&R_class") %}
%typemap(scoercein) SWIGTYPE[ANY]
%{
if(is.list($input))
assert(all(sapply($input, class) == "$R_class"))
%}
/* **************************************************************** */
%typemap(scoercein) bool, bool *, bool &
"$input = as.logical($input) ";
%typemap(scoercein) int,
int *,
int &,
int[ANY],
size_t,
std::size_t,
size_t &,
std::size_t &
"$input = as.integer($input) ";
%typemap(scoercein) unsigned int,
unsigned long,
double,
float,
long,
long long,
unsigned int[],
unsigned long[],
double[],
float[],
long[],
long long[],
unsigned int[ANY],
unsigned long[ANY],
double[ANY],
float[ANY],
long[ANY],
long long[ANY],
unsigned int *,
unsigned long *,
double*,
float*,
long*,
long long *
%{ $input = as.numeric($input) %}
%typemap(scoercein) char *, string, std::string,
string &, std::string &
%{ $input = as($input, "character") %}
%typemap(scoerceout) enum SWIGTYPE
%{ $result = enumFromInteger($result, "$R_class") %}
%typemap(scoerceout) enum SWIGTYPE &
%{ $result = enumFromInteger($result, "$R_class") %}
%typemap(scoerceout) enum SWIGTYPE *
%{ $result = enumToInteger($result, "$R_class") %}
%typemap(scoerceout) SWIGTYPE
%{ class($result) <- "$&R_class" %}
%typemap(scoerceout) SWIGTYPE &
%{ class($result) <- "$R_class" %}
%typemap(scoerceout) SWIGTYPE *
%{ class($result) <- "$R_class" %}
/* Override the SWIGTYPE * above. */
%typemap(scoerceout) char,
char *,
char &,
unsigned int,
unsigned int &,
unsigned long,
unsigned long &,
double,
double &,
float,
float &,
long,
long &,
long long,
long long &,
int,
int &,
bool,
bool &,
string,
std::string,
string &,
std::string &,
size_t,
std::size_t,
size_t &,
std::size_t &,
void
%{ %}
#if 0
Just examining the values for a SWIGTYPE.
%typemap(scoerceout) SWIGTYPE %{
name = $1_name
type = $1_type
ltype = $1_ltype
mangle = $1_mangle
descriptor = $1_descriptor
pointer type = $*1_type
pointer ltype = $*1_ltype
pointer descriptor = $*1_descriptor
basetype = $*_basetype
%}
#endif

150
Lib/r/srun.swg Normal file
View file

@ -0,0 +1,150 @@
# srun.swg #
#
# This is the basic code that is needed at run time within R to
# provide and define the relevant classes. It is included
# automatically in the generated code by copying the contents of
# srun.swg into the newly created binding code.
# This could be provided as a separate run-time library but this
# approach allows the code to to be included directly into the
# generated bindings and so removes the need to have and install an
# additional library. We may however end up with multiple copies of
# this and some confusion at run-time as to which class to use. This
# is an issue when we use NAMESPACES as we may need to export certain
# classes.
######################################################################
if(length(getClassDef("RSWIGStruct")) == 0)
setClass("RSWIGStruct", representation("VIRTUAL"))
if(length(getClassDef("ExternalReference")) == 0)
# Should be virtual but this means it loses its slots currently
#representation("VIRTUAL")
setClass("ExternalReference", representation( ref = "externalptr"))
if(length(getClassDef("NativeRoutinePointer")) == 0)
setClass("NativeRoutinePointer",
representation(parameterTypes = "character",
returnType = "character",
"VIRTUAL"),
contains = "ExternalReference")
if(length(getClassDef("CRoutinePointer")) == 0)
setClass("CRoutinePointer", contains = "NativeRoutinePointer")
if(length(getClassDef("EnumerationValue")) == 0)
setClass("EnumerationValue", contains = "integer")
if(!isGeneric("copyToR"))
setGeneric("copyToR",
function(value, obj = new(gsub("Ref$", "", class(value))))
standardGeneric("copyToR"
))
setGeneric("delete", function(obj) standardGeneric("delete"))
SWIG_createNewRef =
function(className, ..., append = TRUE)
{
f = get(paste("new", className, sep = "_"), mode = "function")
f(...)
}
if(!isGeneric("copyToC"))
setGeneric("copyToC",
function(value, obj = RSWIG_createNewRef(class(value)))
standardGeneric("copyToC"
))
#
defineEnumeration =
function(name, .values, where = topenv(parent.frame()), suffix = "Value")
{
# Mirror the class definitions via the E analogous to .__C__
defName = paste(".__E__", name, sep = "")
assign(defName, .values, envir = where)
if(nchar(suffix))
name = paste(name, suffix, sep = "")
setClass(name, contains = "EnumerationValue", where = where)
}
enumToInteger <- function(name,type)
{
if (is.character(name)) {
ans <- as.integer(get(paste(".__E__", type, sep = ""))[name])
if (is.na(ans)) {warning("enum not found ", name, " ", type)}
ans
}
}
enumFromInteger =
function(i,type)
{
itemlist <- get(paste(".__E__", type, sep=""))
names(itemlist)[match(i, itemlist)]
}
coerceIfNotSubclass =
function(obj, type)
{
if(!is(obj, type)) {as(obj, type)} else obj
}
setClass("SWIGArray", representation(dims = "integer"), contains = "ExternalReference")
setMethod("length", "SWIGArray", function(x) x@dims[1])
defineEnumeration("SCopyReferences",
.values = c( "FALSE" = 0, "TRUE" = 1, "DEEP" = 2))
assert =
function(condition, message = "")
{
if(!condition)
stop(message)
TRUE
}
if(FALSE) {
print.SWIGFunction =
function(x, ...)
{
}
}
#######################################################################
R_SWIG_getCallbackFunctionStack =
function()
{
# No PACKAGE argument as we don't know what the DLL is.
.Call("R_SWIG_debug_getCallbackFunctionData")
}
R_SWIG_addCallbackFunctionStack =
function(fun, userData = NULL)
{
# No PACKAGE argument as we don't know what the DLL is.
.Call("R_SWIG_R_pushCallbackFunctionData", fun, userData)
}
#######################################################################

1
Lib/r/std_alloc.i Normal file
View file

@ -0,0 +1 @@
%include <std/std_alloc.i>

2
Lib/r/std_common.i Normal file
View file

@ -0,0 +1,2 @@
%include <rstdcommon.swg>
%include <std/std_common.i>

2
Lib/r/std_container.i Normal file
View file

@ -0,0 +1,2 @@
%include <rcontainer.swg>
%include <std/std_container.i>

1
Lib/r/std_deque.i Normal file
View file

@ -0,0 +1 @@
%include<std/std_deque.i>

1
Lib/r/std_except.i Normal file
View file

@ -0,0 +1 @@
%include <typemaps/std_except.swg>

1
Lib/r/std_pair.i Normal file
View file

@ -0,0 +1 @@
%include<std/std_pair.i>

1
Lib/r/std_string.i Normal file
View file

@ -0,0 +1 @@
%include <typemaps/std_string.swg>

10
Lib/r/std_vector.i Normal file
View file

@ -0,0 +1,10 @@
%fragment("StdVectorTraits","header")
%{
%}
#define %swig_vector_methods(Type...) %swig_sequence_methods(Type)
#define %swig_vector_methods_val(Type...) %swig_sequence_methods_val(Type);
%include <std/std_vector.i>

8
Lib/r/stl.i Normal file
View file

@ -0,0 +1,8 @@
/* initial STL definition. extended as needed in each language */
%include std_common.i
%include std_vector.i
%include std_string.i

1
Lib/r/typemaps.i Normal file
View file

@ -0,0 +1 @@
%include <typemaps/typemaps.swg>