+R is a GPL'ed open source statistical and plotting environment.
+Information about R can be found at www.r-project.org.
+
+The R binding are under active development and are extremely
+experimental. Not all features have been implemented and the API is
+not stable.
+
+
+
+To use R and SWIG in C mode, execute the following commands where
+example_func.c is the name of the file with the functions in them
+
+The commands produce two files. A dynamic shared object file called
+example.so and an R wrapper file called example_wrap.S. To load these
+files, start up R and type in the following commands
+
+
+dyn.load('example.so')
+source('example_wrap.S')
+
+These two files can be loaded in any order
+
+
+
General policy
+The general policy of the module is to treat the C/C++ as a basic
+wrapping over the underlying functions and rely on the R type system
+to provide R syntax.
+
+
Language conventions
+getitem and setitem use C++ conventions (i.e. zero based indices). [<-
+and [ are overloaded to allow for R syntax (one based indices and
+slices)
+
+
C++ classes
+C++ objects are implemented as external pointer objects with the class
+being the mangled name of the class. The C++ classes are encapsulated
+as an SEXP with an external pointer type. The class is the mangled
+name of the class. The nice thing about R is that is allows you to
+keep track of the pointer object which removes the necessity for a lot
+of the proxy class baggage you see in other languages.
+
+
Enumerations
+enumerations are characters which are then converted back and forth to
+ints before calling the C routines. All of the enumeration code is
+done in R.
+
+
diff --git a/Doc/Manual/chapters b/Doc/Manual/chapters
index 64cb026c1..2c84281e7 100644
--- a/Doc/Manual/chapters
+++ b/Doc/Manual/chapters
@@ -29,4 +29,5 @@ Pike.html
Python.html
Ruby.html
Tcl.html
+R.html
Extending.html
diff --git a/Examples/Makefile.in b/Examples/Makefile.in
index ae5985760..268fcc5d6 100644
--- a/Examples/Makefile.in
+++ b/Examples/Makefile.in
@@ -1017,3 +1017,26 @@ uffi_clean:
rm -f core @EXTRA_CLEAN@
rm -f *.@OBJEXT@ *@SO@
+##################################################################
+##### R ######
+##################################################################
+
+R = R
+RSRCS = $(INTERFACE:.i=_wrap.c) #special code for R build system
+RCXXSRCS = $(INTERFACE:.i=_wrap.cpp) #special code for R build system
+
+r: $(SRCS)
+ $(SWIG) -r $(SWIGOPT) -o $(RSRCS) $(INTERFACE)
+ PKG_LIBS="$(SRCS)" PKG_CPPFLAGS="$(INCLUDES)" \
+ $(R) CMD SHLIB $(RSRCS)
+
+r_cpp: $(CXXSRCS)
+ $(SWIG) -c++ -r $(SWIGOPT) -o $(RCXXSRCS) $(INTERFACE)
+ PKG_LIBS="$(CXXSRCS)" PKG_CPPFLAGS="$(INCLUDES)" \
+ $(R) CMD SHLIB $(RCXXSRCS)
+
+r_clean:
+ rm -f *_wrap* *~ .~* $(RSRCS) $(RCXXSRCS)
+ rm -f core @EXTRA_CLEAN@
+ rm -f *.@OBJEXT@ *@SO@
+
diff --git a/Examples/r/class/Makefile b/Examples/r/class/Makefile
new file mode 100644
index 000000000..6bed3ce53
--- /dev/null
+++ b/Examples/r/class/Makefile
@@ -0,0 +1,18 @@
+TOP = ../..
+SWIG = $(TOP)/../preinst-swig
+CXXSRCS = example.cxx
+TARGET = example
+INTERFACE = example.i
+LIBS = -lm
+ARGS = SRCS='$(SRCS)' SWIG='$(SWIG)' \
+ TARGET='$(TARGET)' INTERFACE='$(INTERFACE)'
+
+all::
+ $(MAKE) -f $(TOP)/Makefile CXXSRCS='$(CXXSRCS)' SWIG='$(SWIG)' \
+ TARGET='$(TARGET)' INTERFACE='$(INTERFACE)' r_cpp
+
+clean::
+ $(MAKE) -f $(TOP)/Makefile $(ARGS) r_clean
+
+check: all
+ R CMD BATCH runme.R
diff --git a/Examples/r/class/example.cxx b/Examples/r/class/example.cxx
new file mode 100644
index 000000000..1e8e203dd
--- /dev/null
+++ b/Examples/r/class/example.cxx
@@ -0,0 +1,28 @@
+/* File : example.c */
+
+#include "example.h"
+#define M_PI 3.14159265358979323846
+
+/* Move the shape to a new location */
+void Shape::move(double dx, double dy) {
+ x += dx;
+ y += dy;
+}
+
+int Shape::nshapes = 0;
+
+double Circle::area(void) {
+ return M_PI*radius*radius;
+}
+
+double Circle::perimeter(void) {
+ return 2*M_PI*radius;
+}
+
+double Square::area(void) {
+ return width*width;
+}
+
+double Square::perimeter(void) {
+ return 4*width;
+}
diff --git a/Examples/r/class/example.h b/Examples/r/class/example.h
new file mode 100644
index 000000000..46d901361
--- /dev/null
+++ b/Examples/r/class/example.h
@@ -0,0 +1,39 @@
+/* File : example.h */
+
+class Shape {
+public:
+ Shape() {
+ nshapes++;
+ }
+ virtual ~Shape() {
+ nshapes--;
+ };
+ double x, y;
+ void move(double dx, double dy);
+ virtual double area(void) = 0;
+ virtual double perimeter(void) = 0;
+ static int nshapes;
+};
+
+class Circle : public Shape {
+private:
+ double radius;
+public:
+ Circle(double r) : radius(r) { };
+ virtual double area(void);
+ virtual double perimeter(void);
+};
+
+class Square : public Shape {
+private:
+ double width;
+public:
+ Square(double w) : width(w) { };
+ virtual double area(void);
+ virtual double perimeter(void);
+};
+
+
+
+
+
diff --git a/Examples/r/class/example.i b/Examples/r/class/example.i
new file mode 100644
index 000000000..4654d269f
--- /dev/null
+++ b/Examples/r/class/example.i
@@ -0,0 +1,9 @@
+/* File : example.i */
+%module example
+
+%inline %{
+#include "example.h"
+%}
+%include "example.h"
+
+
diff --git a/Examples/r/class/runme.R b/Examples/r/class/runme.R
new file mode 100644
index 000000000..1bbe4c20e
--- /dev/null
+++ b/Examples/r/class/runme.R
@@ -0,0 +1,49 @@
+# This file illustrates the shadow-class C++ interface generated
+# by SWIG.
+
+dyn.load('example_wrap.so')
+source('example_wrap.R')
+cacheMetaData(1)
+
+# ----- Object creation -----
+
+print("Creating some objects:")
+circle <- Circle(10)
+print (" Created circle")
+square <- Square(10)
+print (" Created square")
+
+# ----- Access a static member -----
+
+sprintf("A total of %d shapes were created", Shape_nshapes())
+
+# ----- Member data access -----
+
+# Set the location of the object
+
+circle$x <- 20
+circle$y <- 30
+
+square$x <- -10
+square$y <- 5
+
+print("Here is their current position:")
+sprintf(" Circle = (%f, %f)", circle$x,circle$y)
+sprintf(" Square = (%f, %f)", square$x,square$y)
+
+# ----- Call some methods -----
+
+print ("Here are some properties of the shapes:")
+
+sapply(c(circle, square),
+ function(o) {
+sprintf(" area = %f perimeter = %f", o$area(), o$perimeter())
+})
+
+print("Guess I'll clean up now")
+delete(circle)
+delete(square)
+
+sprintf("%d shapes remain", Shape_nshapes())
+print ("Goodbye");
+
diff --git a/Examples/r/simple/Makefile b/Examples/r/simple/Makefile
new file mode 100644
index 000000000..e01d35925
--- /dev/null
+++ b/Examples/r/simple/Makefile
@@ -0,0 +1,16 @@
+TOP = ../..
+SWIG = $(TOP)/../preinst-swig
+SRCS = example.c
+TARGET = example
+INTERFACE = example.i
+ARGS = SRCS='$(SRCS)' SWIG='$(SWIG)' \
+ TARGET='$(TARGET)' INTERFACE='$(INTERFACE)'
+
+all::
+ $(MAKE) -f $(TOP)/Makefile $(ARGS) r
+
+clean::
+ $(MAKE) -f $(TOP)/Makefile $(ARGS) r_clean
+
+check: all
+ R CMD BATCH runme.R
diff --git a/Examples/r/simple/example.c b/Examples/r/simple/example.c
new file mode 100644
index 000000000..1c2af789c
--- /dev/null
+++ b/Examples/r/simple/example.c
@@ -0,0 +1,18 @@
+/* File : example.c */
+
+/* A global variable */
+double Foo = 3.0;
+
+/* Compute the greatest common divisor of positive integers */
+int gcd(int x, int y) {
+ int g;
+ g = y;
+ while (x > 0) {
+ g = x;
+ x = y % x;
+ y = g;
+ }
+ return g;
+}
+
+
diff --git a/Examples/r/simple/example.i b/Examples/r/simple/example.i
new file mode 100644
index 000000000..24093b9bf
--- /dev/null
+++ b/Examples/r/simple/example.i
@@ -0,0 +1,7 @@
+/* File : example.i */
+%module example
+
+%inline %{
+extern int gcd(int x, int y);
+extern double Foo;
+%}
diff --git a/Examples/r/simple/runme.R b/Examples/r/simple/runme.R
new file mode 100644
index 000000000..775b520b3
--- /dev/null
+++ b/Examples/r/simple/runme.R
@@ -0,0 +1,24 @@
+# file: runme.R
+
+dyn.load('example_wrap.so')
+source('example_wrap.R')
+cacheMetaData(1)
+
+# Call our gcd() function
+
+x <- 42
+y <- 105
+g <- gcd(x,y)
+sprintf("The gcd of %d and %d is %d", x, y, g)
+
+# Manipulate the Foo global variable
+
+# Output its current value
+Foo()
+
+# Change its value
+Foo(3.1415926)
+
+# See if the change took effect
+Foo()
+
diff --git a/Examples/test-suite/common.mk b/Examples/test-suite/common.mk
index 26035fbfd..044c20bb2 100644
--- a/Examples/test-suite/common.mk
+++ b/Examples/test-suite/common.mk
@@ -35,7 +35,7 @@ CXXSRCS =
CSRCS =
TARGETPREFIX =
TARGETSUFFIX =
-SWIGOPT = -I$(top_srcdir)/$(EXAMPLES)/$(TEST_SUITE)/$(LANGUAGE) -I$(top_srcdir)/$(EXAMPLES)/$(TEST_SUITE)
+SWIGOPT = -I$(top_srcdir)/$(EXAMPLES)/$(TEST_SUITE)/$(LANGUAGE) -I$(top_srcdir)/$(EXAMPLES)/$(TEST_SUITE) -DSWIG_NOEXTRA_QUALIFICATION
INCLUDES = -I$(top_srcdir)/$(EXAMPLES)/$(TEST_SUITE)/$(LANGUAGE) -I$(top_srcdir)/$(EXAMPLES)/$(TEST_SUITE)
LIBS = -L.
LIBPREFIX = lib
diff --git a/Examples/test-suite/constructor_copy.i b/Examples/test-suite/constructor_copy.i
index 929a49cb6..f2b44dbd0 100644
--- a/Examples/test-suite/constructor_copy.i
+++ b/Examples/test-suite/constructor_copy.i
@@ -77,7 +77,7 @@ public:
SWIG_STD_VECTOR_SPECIALIZE_MINIMUM(Flow, Space::Flow)
#endif
-#if defined(SWIGJAVA) || defined(SWIGCSHARP) || defined(SWIGPYTHON)
+#if defined(SWIGJAVA) || defined(SWIGCSHARP) || defined(SWIGPYTHON)||defined(SWIGR)
#define SWIG_GOOD_VECTOR
%ignore std::vector
::vector(size_type);
%ignore std::vector::resize(size_type);
diff --git a/Examples/test-suite/global_vars.i b/Examples/test-suite/global_vars.i
index ca387a4b5..01968c744 100644
--- a/Examples/test-suite/global_vars.i
+++ b/Examples/test-suite/global_vars.i
@@ -19,7 +19,11 @@
int x;
int *xp;
+#ifdef SWIGR
+ int& c_member = x;
+#else
int& c = x;
+#endif
void *vp;
diff --git a/Examples/test-suite/name_warnings.i b/Examples/test-suite/name_warnings.i
index f691ba628..a9cb35686 100644
--- a/Examples/test-suite/name_warnings.i
+++ b/Examples/test-suite/name_warnings.i
@@ -61,7 +61,10 @@ namespace std
%inline {
/* silently rename the parameter names in csharp/java */
-
+#ifdef SWIGR
+ double foo(double inparam, double out) { return 1.0; }
+#else
double foo(double in, double out) { return 1.0; }
+#endif
double bar(double native, bool boolean) { return 1.0; }
}
diff --git a/Examples/test-suite/r/Makefile.in b/Examples/test-suite/r/Makefile.in
new file mode 100644
index 000000000..142bc25a2
--- /dev/null
+++ b/Examples/test-suite/r/Makefile.in
@@ -0,0 +1,54 @@
+#######################################################################
+# $Header$
+# Makefile for mzscheme test-suite
+#######################################################################
+
+LANGUAGE = r
+SCRIPTSUFFIX = _runme.R
+WRAPSUFFIX = _wrap.R
+RUNR = R CMD BATCH --no-save --no-restore
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+top_builddir = @top_builddir@
+
+C_TEST_CASES = copyStruct simpleArray legacy
+CPP_TEST_CASES = funcptr double_delete
+
+include $(srcdir)/../common.mk
+
+# Overridden variables here
+
+# Rules for the different types of tests
+%.cpptest:
+ $(setup) \
+ ($(swig_and_compile_cpp); ) && \
+ $(run_testcase)
+
+%.ctest:
+ $(setup) \
+ ($(swig_and_compile_c); ) && \
+ $(run_testcase)
+
+%.multicpptest:
+ $(setup) \
+ ($(swig_and_compile_multi_cpp); ) && \
+ $(run_testcase)
+
+# Runs the testcase.
+#
+# Run the runme if it exists. If not just load the R wrapper to
+# check for syntactic correctness
+run_testcase = \
+ if [ -f $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX) ]; then ( \
+ env LD_LIBRARY_PATH=.:$$LD_LIBRARY_PATH \
+ $(RUNR) $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX) ;) \
+ else \
+ ($(RUNR) $(srcdir)/$(SCRIPTPREFIX)$*$(WRAPSUFFIX);) \
+ fi;
+
+# Clean
+clean:
+ $(MAKE) -f $(top_builddir)/$(EXAMPLES)/Makefile r_clean
+
+%.clean:
+ @rm -f $*_wrap.R $*_wrap.so $*_wrap.cpp $*_wrap.c $*_runme.Rout
diff --git a/Examples/test-suite/r/copyStruct_runme.R b/Examples/test-suite/r/copyStruct_runme.R
new file mode 100644
index 000000000..8c9b2c52f
--- /dev/null
+++ b/Examples/test-suite/r/copyStruct_runme.R
@@ -0,0 +1,55 @@
+source('unittest.R')
+dyn.load('copyStruct_wrap.so')
+source('copyStruct_wrap.R')
+cacheMetaData(1)
+
+a <- getA()
+
+r = getARef()
+
+unittest(A_d_get(r), 42)
+unittest(r$d, 42)
+unittest(r$i, 20)
+
+# An error in trying to access a field that doesn't exist.
+try(r$foo)
+
+r$d <- pi
+unittesttol(r$d, 3.141593, 0.0001)
+r$i <- -100
+
+r$ui
+r$ui <- 10
+
+ # An error since i is unsigned and so must be positive.
+try(r$ui <- -10)
+
+
+a = A()
+unittest(a$i,0)
+unittest(a$d,0)
+unittest(a$ui,0)
+a$ui <- 100
+unittest(a$ui,100)
+a$d = 1
+unittest(a$d,1)
+
+d <- bar()
+unittest(class(d), "_p_D")
+unittest(d$x, 1)
+unittest(d$u, 0)
+
+
+la <- new("A");
+la@ui <- 5
+
+other = A()
+foo <- copyToC(la, other)
+
+aa = A()
+aa$i = 201
+aa$d = pi
+aa$str = 'foo'
+copyToR(aa)
+
+
diff --git a/Examples/test-suite/r/double_delete.i b/Examples/test-suite/r/double_delete.i
new file mode 100644
index 000000000..4f2d1e0a2
--- /dev/null
+++ b/Examples/test-suite/r/double_delete.i
@@ -0,0 +1,15 @@
+/* File : example.i */
+%module double_delete
+
+%inline %{
+
+class Foo {
+private:
+ double r;
+public:
+ Foo(double rin) : r(rin) {};
+};
+%}
+
+
+
diff --git a/Examples/test-suite/r/double_delete_runme.R b/Examples/test-suite/r/double_delete_runme.R
new file mode 100644
index 000000000..789692dfe
--- /dev/null
+++ b/Examples/test-suite/r/double_delete_runme.R
@@ -0,0 +1,12 @@
+# This file illustrates the shadow-class C++ interface generated
+# by SWIG.
+
+dyn.load('double_delete_wrap.so')
+source('double_delete_wrap.R')
+cacheMetaData(1)
+
+# ----- Object creation -----
+
+f <- Foo(2.0)
+delete(f);
+delete(f);
\ No newline at end of file
diff --git a/Examples/test-suite/r/funcptr_runme.R b/Examples/test-suite/r/funcptr_runme.R
new file mode 100644
index 000000000..4989ed669
--- /dev/null
+++ b/Examples/test-suite/r/funcptr_runme.R
@@ -0,0 +1,7 @@
+source('unittest.R')
+dyn.load('funcptr_wrap.so')
+source('funcptr_wrap.R')
+cacheMetaData(1)
+unittest(do_op(1, 3, add), 4)
+unittest(do_op(2, 3, mul), 6)
+unittest(do_op(2, 3, funcvar()), 5)
\ No newline at end of file
diff --git a/Examples/test-suite/r/ignore_parameter_runme.R b/Examples/test-suite/r/ignore_parameter_runme.R
new file mode 100644
index 000000000..ff406b49c
--- /dev/null
+++ b/Examples/test-suite/r/ignore_parameter_runme.R
@@ -0,0 +1,10 @@
+source('unittest.R')
+dyn.load('ignore_parameter_wrap.so')
+source('ignore_parameter_wrap.R')
+cacheMetaData(1)
+
+unittest(jaguar(1, 1.0), "hello")
+q(save='no')
+
+
+
diff --git a/Examples/test-suite/r/legacy_runme.R b/Examples/test-suite/r/legacy_runme.R
new file mode 100644
index 000000000..6cd88922f
--- /dev/null
+++ b/Examples/test-suite/r/legacy_runme.R
@@ -0,0 +1,30 @@
+source('unittest.R')
+dyn.load('legacy_wrap.so')
+source('legacy_wrap.R')
+cacheMetaData(1)
+
+obj <- getObject(1,3)
+unittest(class(obj), "_p_Obj")
+unittest(obj$i, 1)
+unittesttol(obj$d, 3, 0.001)
+unittest(obj$str, "a test string")
+obj$i <- 2
+unittest(obj$i, 2)
+obj$d <- 4
+unittesttol(obj$d, 4, 0.001)
+obj$str <- "a new string"
+unittest(obj$str, "a new string")
+
+unittest(getInt(), 42)
+unittesttol(getDouble(),3.14159, 0.001)
+unittesttol(getFloat(),3.14159/2.0, 0.001)
+unittest(getLong(), -321313)
+unittest(getUnsignedLong(), 23123)
+unittest(getChar(), "A")
+
+q(save='no')
+
+
+
+
+
diff --git a/Examples/test-suite/r/simpleArray_runme.R b/Examples/test-suite/r/simpleArray_runme.R
new file mode 100644
index 000000000..025f8f04d
--- /dev/null
+++ b/Examples/test-suite/r/simpleArray_runme.R
@@ -0,0 +1,9 @@
+source('unittest.R')
+dyn.load('simpleArray_wrap.so')
+source('simpleArray_wrap.R')
+cacheMetaData(1)
+initArray()
+
+q(save='no')
+
+
diff --git a/Examples/test-suite/r/unions_runme.R b/Examples/test-suite/r/unions_runme.R
new file mode 100644
index 000000000..c4238cdd6
--- /dev/null
+++ b/Examples/test-suite/r/unions_runme.R
@@ -0,0 +1,12 @@
+source('unittest.R')
+dyn.load('unions_wrap.so')
+source('unions_wrap.R')
+cacheMetaData(1)
+
+ss <- SmallStruct()
+
+bstruct <- BigStruct()
+
+q(save='no')
+
+
diff --git a/Examples/test-suite/r/unittest.R b/Examples/test-suite/r/unittest.R
new file mode 100644
index 000000000..81c590a3f
--- /dev/null
+++ b/Examples/test-suite/r/unittest.R
@@ -0,0 +1,9 @@
+unittest <- function (x,y) {
+if (x==y) print("PASS")
+else print("FAIL")
+}
+
+unittesttol <- function(x,y,z) {
+if (abs(x-y) < z) print("PASS")
+else print("FAIL")
+}
\ No newline at end of file
diff --git a/Lib/r/cdata.i b/Lib/r/cdata.i
new file mode 100644
index 000000000..367965990
--- /dev/null
+++ b/Lib/r/cdata.i
@@ -0,0 +1 @@
+%include
diff --git a/Lib/r/exception.i b/Lib/r/exception.i
new file mode 100644
index 000000000..39cb09594
--- /dev/null
+++ b/Lib/r/exception.i
@@ -0,0 +1,8 @@
+%include
+
+
+%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;} ))
+}
+
diff --git a/Lib/r/r.swg b/Lib/r/r.swg
new file mode 100644
index 000000000..0c6dadd7d
--- /dev/null
+++ b/Lib/r/r.swg
@@ -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
+%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
+%include
+%include
+%include
+%include
+%include
+
+%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"))})
+%}
+
+
+
diff --git a/Lib/r/rcontainer.swg b/Lib/r/rcontainer.swg
new file mode 100644
index 000000000..d6d54d715
--- /dev/null
+++ b/Lib/r/rcontainer.swg
@@ -0,0 +1,198 @@
+
+//
+// Common fragments
+//
+
+
+/**** The python container methods ****/
+
+
+
+%fragment("RSequence_Base","header")
+{
+%#include
+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
+ 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
+ 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
+ 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
+ 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
+ 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
diff --git a/Lib/r/rfragments.swg b/Lib/r/rfragments.swg
new file mode 100644
index 000000000..1dd31802f
--- /dev/null
+++ b/Lib/r/rfragments.swg
@@ -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;
+}
+}
+
diff --git a/Lib/r/ropers.swg b/Lib/r/ropers.swg
new file mode 100644
index 000000000..a71f5ba72
--- /dev/null
+++ b/Lib/r/ropers.swg
@@ -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
diff --git a/Lib/r/rrun.swg b/Lib/r/rrun.swg
new file mode 100644
index 000000000..cf81c82ad
--- /dev/null
+++ b/Lib/r/rrun.swg
@@ -0,0 +1,355 @@
+
+/* Not really used yet. */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include
+#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, "", "", (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
diff --git a/Lib/r/rstdcommon.swg b/Lib/r/rstdcommon.swg
new file mode 100644
index 000000000..223203773
--- /dev/null
+++ b/Lib/r/rstdcommon.swg
@@ -0,0 +1,216 @@
+%fragment("StdTraits","header",fragment="StdTraitsCommon")
+{
+namespace swig {
+ /*
+ Traits that provides the from method
+ */
+
+ template struct traits_from_ptr {
+ static SWIG_Object from(Type *val, int owner = 0) {
+ return SWIG_NewPointerObj(val, type_info(), owner);
+ }
+ };
+
+ template struct traits_from {
+ static SWIG_Object from(const Type& val) {
+ return traits_from_ptr::from(new Type(val), 1);
+ }
+ };
+
+ template struct traits_from {
+ static SWIG_Object from(Type* val) {
+ return traits_from_ptr::from(val, 0);
+ }
+ };
+
+ template
+ inline SWIG_Object from(const Type& val) {
+ return traits_from::from(val);
+ }
+
+ template
+ inline SWIG_Object from_ptr(Type* val, int owner) {
+ return traits_from_ptr::from(val, owner);
+ }
+
+ /*
+ Traits that provides the asval/as/check method
+ */
+ template
+ struct traits_asptr {
+ static int asptr(SWIG_Object obj, Type **val) {
+ Type *p;
+ int res = (SWIG_ConvertPtr(obj, (void**)&p, type_info(), 0) == SWIG_OK) ? SWIG_OLDOBJ : 0;
+ if (SWIG_IsOK(res)) {
+ if (val) *val = p;
+ }
+ return res;
+ }
+ };
+
+ template
+ inline int asptr(SWIG_Object obj, Type **vptr) {
+ return traits_asptr::asptr(obj, vptr);
+ }
+
+ template
+ struct traits_asval {
+ static int asval(SWIG_Object obj, Type *val) {
+ if (val) {
+ Type *p = 0;
+ int res = traits_asptr::asptr(obj, &p);
+ if (!SWIG_IsOK(res)) return res;
+ if (p) {
+ typedef typename noconst_traits::noconst_type noconst_type;
+ *(const_cast(val)) = *p;
+ if (SWIG_IsNewObj(res)){
+ %delete(p);
+ res = SWIG_DelNewMask(res);
+ }
+ return res;
+ } else {
+ return SWIG_ERROR;
+ }
+ } else {
+ return traits_asptr::asptr(obj, (Type **)(0));
+ }
+ }
+ };
+
+ template struct traits_asval {
+ static int asval(SWIG_Object obj, Type **val) {
+ if (val) {
+ typedef typename noconst_traits::noconst_type noconst_type;
+ noconst_type *p = 0;
+ int res = traits_asptr::asptr(obj, &p);
+ if (SWIG_IsOK(res)) {
+ *(const_cast(val)) = p;
+ }
+ return res;
+ } else {
+ return traits_asptr::asptr(obj, (Type **)(0));
+ }
+ }
+ };
+
+ template
+ inline int asval(SWIG_Object obj, Type *val) {
+ return traits_asval::asval(obj, val);
+ }
+
+ template
+ struct traits_as {
+ 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());
+// }
+ if (throw_error) throw std::invalid_argument("bad type");
+ }
+ return v;
+ }
+ };
+
+ template
+ struct traits_as {
+ static Type as(SWIG_Object obj, bool throw_error) {
+ Type *v = 0;
+ int res = (obj ? traits_asptr::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());
+// }
+ if (throw_error) throw std::invalid_argument("bad type");
+ memset(v_def,0,sizeof(Type));
+ return *v_def;
+ }
+ }
+ };
+
+ template
+ struct traits_as {
+ static Type* as(SWIG_Object obj, bool throw_error) {
+ Type *v = 0;
+ int res = (obj ? traits_asptr::asptr(obj, &v) : SWIG_ERROR);
+ if (SWIG_IsOK(res)) {
+ return v;
+ } else {
+// if (!PyErr_Occurred()) {
+// %type_error(swig::type_name());
+// }
+ if (throw_error) throw std::invalid_argument("bad type");
+ return 0;
+ }
+ }
+ };
+
+ template
+ inline Type as(SWIG_Object obj, bool te = false) {
+ return traits_as::category>::as(obj, te);
+ }
+
+ template
+ struct traits_check {
+ static bool check(SWIG_Object obj) {
+ int res = obj ? asval(obj, (Type *)(0)) : SWIG_ERROR;
+ return SWIG_IsOK(res) ? true : false;
+ }
+ };
+
+ template
+ struct traits_check {
+ static bool check(SWIG_Object obj) {
+ int res = obj ? asptr(obj, (Type **)(0)) : SWIG_ERROR;
+ return SWIG_IsOK(res) ? true : false;
+ }
+ };
+
+ template
+ inline bool check(SWIG_Object obj) {
+ return traits_check::category>::check(obj);
+ }
+}
+}
+
+%define %specialize_std_container(Type,Check,As,From)
+%{
+namespace swig {
+ template <> struct traits_asval {
+ 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 {
+ typedef Type value_type;
+ static SWIG_Object from(const value_type& val) {
+ return From(val);
+ }
+ };
+
+ template <>
+ struct traits_check {
+ static int check(SWIG_Object obj) {
+ int res = Check(obj);
+ return obj && res ? res : 0;
+ }
+ };
+}
+%}
+%enddef
diff --git a/Lib/r/rtype.swg b/Lib/r/rtype.swg
new file mode 100644
index 000000000..6479a0d64
--- /dev/null
+++ b/Lib/r/rtype.swg
@@ -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
+
+
diff --git a/Lib/r/srun.swg b/Lib/r/srun.swg
new file mode 100644
index 000000000..71a508d49
--- /dev/null
+++ b/Lib/r/srun.swg
@@ -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)
+}
+
+
+#######################################################################
\ No newline at end of file
diff --git a/Lib/r/std_alloc.i b/Lib/r/std_alloc.i
new file mode 100644
index 000000000..87fa8d4a8
--- /dev/null
+++ b/Lib/r/std_alloc.i
@@ -0,0 +1 @@
+%include
\ No newline at end of file
diff --git a/Lib/r/std_common.i b/Lib/r/std_common.i
new file mode 100644
index 000000000..fec0efe51
--- /dev/null
+++ b/Lib/r/std_common.i
@@ -0,0 +1,2 @@
+%include
+%include
diff --git a/Lib/r/std_container.i b/Lib/r/std_container.i
new file mode 100644
index 000000000..076c1c6a4
--- /dev/null
+++ b/Lib/r/std_container.i
@@ -0,0 +1,2 @@
+%include
+%include
diff --git a/Lib/r/std_deque.i b/Lib/r/std_deque.i
new file mode 100644
index 000000000..0c757ab04
--- /dev/null
+++ b/Lib/r/std_deque.i
@@ -0,0 +1 @@
+%include
\ No newline at end of file
diff --git a/Lib/r/std_except.i b/Lib/r/std_except.i
new file mode 100644
index 000000000..af98428f6
--- /dev/null
+++ b/Lib/r/std_except.i
@@ -0,0 +1 @@
+%include
diff --git a/Lib/r/std_pair.i b/Lib/r/std_pair.i
new file mode 100644
index 000000000..3ac795704
--- /dev/null
+++ b/Lib/r/std_pair.i
@@ -0,0 +1 @@
+%include
\ No newline at end of file
diff --git a/Lib/r/std_string.i b/Lib/r/std_string.i
new file mode 100644
index 000000000..dc1378ae6
--- /dev/null
+++ b/Lib/r/std_string.i
@@ -0,0 +1 @@
+%include
diff --git a/Lib/r/std_vector.i b/Lib/r/std_vector.i
new file mode 100644
index 000000000..03364822d
--- /dev/null
+++ b/Lib/r/std_vector.i
@@ -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
\ No newline at end of file
diff --git a/Lib/r/stl.i b/Lib/r/stl.i
new file mode 100644
index 000000000..9656ee6d4
--- /dev/null
+++ b/Lib/r/stl.i
@@ -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
+
+
+
+
diff --git a/Lib/r/typemaps.i b/Lib/r/typemaps.i
new file mode 100644
index 000000000..1f9b9c432
--- /dev/null
+++ b/Lib/r/typemaps.i
@@ -0,0 +1 @@
+%include
diff --git a/Makefile.in b/Makefile.in
index 27037266c..db9da7467 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -51,6 +51,7 @@ skip-allegrocl = test -n "@SKIP_ALLEGROCL@"
skip-clisp = test -n "@SKIP_CLISP@"
skip-cffi = test -n "@SKIP_CFFI@"
skip-uffi = test -n "@SKIP_UFFI@"
+skip-r = test -n "@SKIP_R@"
# Additional dependencies for some tests
skip-gcj = test -n "@SKIP_GCJ@"
@@ -85,6 +86,7 @@ check-aliveness:
@$(skip-csharp) || ./$(TARGET) -csharp -help
@$(skip-modula3) || ./$(TARGET) -modula3 -help
@$(skip-lua) || ./$(TARGET) -lua -help
+ @$(skip-r) || ./$(TARGET) -lua -help
# Checks examples for compilation (does not run them)
check-examples: \
@@ -105,7 +107,8 @@ check-examples: \
check-allegrocl-examples \
check-clisp-examples \
check-uffi-examples \
- check-cffi-examples
+ check-cffi-examples \
+ check-r-examples
check-%-examples:
@passed=true; \
@@ -186,7 +189,8 @@ check-test-suite: \
check-clisp-test-suite \
check-uffi-test-suite \
check-cffi-test-suite \
- check-chicken-test-suite
+ check-chicken-test-suite \
+ check-r-test-suite
check-%-test-suite:
@passed=true; \
@@ -224,7 +228,8 @@ all-test-suite: \
all-clisp-test-suite \
all-uffi-test-suite \
all-cffi-test-suite \
- all-chicken-test-suite
+ all-chicken-test-suite \
+ all-r-test-suite
all-%-test-suite:
@$(MAKE) -k -s check-$*-test-suite ACTION=all
@@ -249,7 +254,8 @@ broken-test-suite: \
broken-clisp-test-suite \
broken-uffi-test-suite \
broken-cffi-test-suite \
- broken-chicken-test-suite
+ broken-chicken-test-suite \
+ broken-r-test-suite
broken-%-test-suite:
@$(MAKE) -k -s check-$*-test-suite ACTION=broken
@@ -329,7 +335,8 @@ noskip-test-suite: \
noskip-clisp-test-suite \
noskip-uffi-test-suite \
noskip-cffi-test-suite \
- noskip-chicken-test-suite
+ noskip-chicken-test-suite \
+ noskip-r-test-suite
noskip-%-test-suite:
dir="Examples/test-suite/$*"; \
@@ -375,7 +382,7 @@ install-main:
@$(INSTALL_PROGRAM) $(TARGET) $(DESTDIR)$(BIN_DIR)/`echo $(TARGET_NOEXE) | sed '$(transform)'`@EXEEXT@
lib-languages = gcj typemaps tcl perl5 python guile java mzscheme ruby php4 ocaml \
- pike chicken csharp modula3 allegrocl clisp lua cffi uffi
+ pike chicken csharp modula3 allegrocl clisp lua cffi uffi r
lib-modules = std
diff --git a/Source/Makefile.am b/Source/Makefile.am
index af7999e6b..efbad1ffd 100644
--- a/Source/Makefile.am
+++ b/Source/Makefile.am
@@ -59,6 +59,7 @@ eswig_SOURCES = CParse/cscanner.c \
Modules/php4.cxx \
Modules/pike.cxx \
Modules/python.cxx \
+ Modules/r.cxx \
Modules/ruby.cxx \
Modules/s-exp.cxx \
Modules/swigmain.cxx \
diff --git a/Source/Modules/r.cxx b/Source/Modules/r.cxx
new file mode 100644
index 000000000..69f76f62b
--- /dev/null
+++ b/Source/Modules/r.cxx
@@ -0,0 +1,3035 @@
+/* -----------------------------------------------------------------------------
+ * See the LICENSE file for information on copyright, usage and redistribution
+ * of SWIG, and the README file for authors - http://www.swig.org/release.html.
+ *
+ * r.cxx
+ *
+ * R language module for SWIG.
+ * ----------------------------------------------------------------------------- */
+
+// Derived from an implementation of SWIG for R by Duncan Temple Lang
+
+#include "swigmod.h"
+
+#define UNUSED(a) (void)a
+
+static const double DEFAULT_NUMBER = .0000123456712312312323;
+static const int MAX_OVERLOAD_ARGS = 5;
+
+
+static String * getRTypeName(SwigType *t, int *outCount = NULL) {
+ String *b = SwigType_base(t);
+ List *els = SwigType_split(t);
+ int count = 0, i;
+
+ if(Strncmp(b, "struct ", 7) == 0)
+ Replace(b, "struct ", "", DOH_REPLACE_FIRST);
+
+ /* Printf(stderr, " %s,base = %s\n", t, b);
+ for(i = 0; i < Len(els); i++)
+ Printf(stderr, "%d) %s, ", i, Getitem(els,i));
+ Printf(stderr, "\n"); */
+
+ for(i = 0; i < Len(els); i++) {
+ String *el = Getitem(els, i);
+ if(Strcmp(el, "p.") == 0 || Strncmp(el, "a(", 2) == 0) {
+ count++;
+ Append(b, "Ref");
+ }
+ }
+ if(outCount)
+ *outCount = count;
+
+ String *tmp = NewString("");
+ char *retName = Char(SwigType_manglestr(t));
+ Insert(tmp, 0, retName);
+ return tmp;
+
+ if(count)
+ return(b);
+
+ Delete(b);
+ return(NewString(""));
+}
+
+#if 0
+static String * getRType(Node *n) {
+ SwigType *elType = Getattr(n, "type");
+ SwigType *elDecl = Getattr(n, "decl");
+ //XXX How can we tell if this is already done.
+ SwigType_push(elType, elDecl);
+ String *ans;
+
+ String *rtype = Swig_typemap_lookup_new("rtype", n, "", 0);
+ String *i = getRTypeName(elType);
+
+ if(Len(i) == 0) {
+ SwigType *td = SwigType_typedef_resolve(elType);
+ if(td) {
+ // Printf(stderr, "Resolving typedef %s -> %s\n", elType, td);
+ i = getRTypeName(td);
+ }
+ }
+ // Printf(stderr, " i = %s, rtype = %s (for %s)\n",
+ // i, rtype, elType);
+ if(rtype) {
+ ans = NewString("");
+ Printf(ans, "%s", rtype);
+ Replaceall(ans, "$R_class", Char(i));
+ // Printf(stderr, "Found r type in typemap for %s (for %s) => %s (%s) => %s\n",
+ // SwigType_str(elType, 0), Getattr(n, "name"), rtype, i, ans);
+ } else {
+ ans = i;
+ }
+
+ return(ans);
+}
+#endif
+
+/*********************
+ Tries to get the name of the R class corresponding to the given type
+ e.g. struct A * is ARef, struct A** is ARefRef.
+ Now handles arrays, i.e. struct A[2]
+****************/
+
+static String *getRClassName(String *retType, int addRef = 1, int upRef=0) {
+ String *tmp = NewString("");
+ SwigType *resolved = SwigType_typedef_resolve_all(retType);
+ char *retName = Char(SwigType_manglestr(resolved));
+ if (upRef) {
+ Printf(tmp, "_p%s", retName);
+ } else{
+ Insert(tmp, 0, retName);
+ }
+
+ return tmp;
+#if 1
+ List *l = SwigType_split(retType);
+ int n = Len(l);
+ if(!l || n == 0) {
+#ifdef R_SWIG_VERBOSE
+ if (debugMode)
+ Printf(stderr, "SwigType_split return an empty list for %s\n",
+ retType);
+#endif
+ return(tmp);
+ }
+
+
+ String *el = Getitem(l, n-1);
+ char *ptr = Char(el);
+ if(strncmp(ptr, "struct ", 7) == 0)
+ ptr += 7;
+
+ Printf(tmp, "%s", ptr);
+
+ if(addRef) {
+ for(int i = 0; i < n; i++) {
+ if(Strcmp(Getitem(l, i), "p.") == 0 ||
+ Strncmp(Getitem(l, i), "a(", 2) == 0)
+ Printf(tmp, "Ref");
+ }
+ }
+
+#else
+ char *retName = Char(SwigType_manglestr(retType));
+ if(!retName)
+ return(tmp);
+
+ if(addRef) {
+ while(retName && strlen(retName) > 1 && strncmp(retName, "_p", 2) == 0) {
+ retName += 2;
+ Printf(tmp, "Ref");
+ }
+ }
+ if(retName[0] == '_')
+ retName ++;
+ Insert(tmp, 0, retName);
+#endif
+
+ return tmp;
+}
+
+/*********************
+ Tries to get the name of the R class corresponding to the given type
+ e.g. struct A * is ARef, struct A** is ARefRef.
+ Now handles arrays, i.e. struct A[2]
+****************/
+
+static String * getRClassNameCopyStruct(String *retType, int addRef) {
+ String *tmp = NewString("");
+
+#if 1
+ List *l = SwigType_split(retType);
+ int n = Len(l);
+ if(!l || n == 0) {
+#ifdef R_SWIG_VERBOSE
+ Printf(stderr, "SwigType_split return an empty list for %s\n", retType);
+#endif
+ return(tmp);
+ }
+
+
+ String *el = Getitem(l, n-1);
+ char *ptr = Char(el);
+ if(strncmp(ptr, "struct ", 7) == 0)
+ ptr += 7;
+
+ Printf(tmp, "%s", ptr);
+
+ if(addRef) {
+ for(int i = 0; i < n; i++) {
+ if(Strcmp(Getitem(l, i), "p.") == 0 ||
+ Strncmp(Getitem(l, i), "a(", 2) == 0)
+ Printf(tmp, "Ref");
+ }
+ }
+
+#else
+ char *retName = Char(SwigType_manglestr(retType));
+ if(!retName)
+ return(tmp);
+
+ if(addRef) {
+ while(retName && strlen(retName) > 1 &&
+ strncmp(retName, "_p", 2) == 0) {
+ retName += 2;
+ Printf(tmp, "Ref");
+ }
+ }
+
+ if(retName[0] == '_')
+ retName ++;
+ Insert(tmp, 0, retName);
+#endif
+
+ return tmp;
+}
+
+
+/*********************************
+ Write the elements of a list to the File*, one element per line.
+ If quote is true, surround the element with "element".
+ This takes care of inserting a tab in front of each line and also
+ a comma after each element, except the last one.
+**********************************/
+
+static void writeListByLine(List *l, File *out, bool quote = 0) {
+ int i, n = Len(l);
+ for(i = 0; i < n; i++)
+ Printf(out, "%s%s%s%s%s\n", tab8,
+ quote ? "\"" :"",
+ Getitem(l, i),
+ quote ? "\"" :"", i < n-1 ? "," : "");
+}
+
+
+static const char *usage = (char *)"\
+R Options (available with -r)\n\
+ -dll - the name of the DLL (withouth the .dll or .so) included in the PACKAGE argument of the R .Call() invocations\n\
+ -package - (not currently used). Typically, same as dll.\n\
+ -no-init-code - turn off the generation of the R_init__wrap code. (Registration information still generated.)\n\
+ -namespace - output NAMESPACE file.\n\
+ -copystruct - emit R code to copy C structs (on by default)\n\
+ -cppcast - Enable C++ casting operators (default) \n\
+ -debug - output debug\n\
+ -memoryprof - add memory profile\n\
+ -gc - aggressive garbage collection\n\
+";
+
+
+
+/************
+ Display the help for this module on the screen/console.
+*************/
+static void showUsage() {
+ fputs(usage, stdout);
+}
+
+static bool expandTypedef(SwigType *t) {
+ if (SwigType_isenum(t)) return false;
+ String *prefix = SwigType_prefix(t);
+ if (Strncmp(prefix, "f", 1)) return false;
+ if (Strncmp(prefix, "p.f", 3)) return false;
+ return true;
+}
+
+
+/*****
+ Determine whether we should add a .copy argument to the S function
+ that wraps/interfaces to the routine that returns the given type.
+*****/
+static int addCopyParameter(SwigType *type) {
+ int ok = 0;
+ ok = Strncmp(type, "struct ", 7) == 0 || Strncmp(type, "p.struct ", 9) == 0;
+ if(!ok) {
+ ok = Strncmp(type, "p.", 2);
+ }
+
+ return(ok);
+}
+
+static void replaceRClass(String *tm, SwigType *type) {
+ String *tmp = getRClassName(type);
+ String *tmp_base = getRClassName(type, 0);
+ String *tmp_ref = getRClassName(type, 1, 1);
+ Replaceall(tm, "$R_class", tmp);
+ Replaceall(tm, "$*R_class", tmp_base);
+ Replaceall(tm, "$&R_class", tmp_ref);
+ Delete(tmp); Delete(tmp_base); Delete(tmp_ref);
+}
+
+static double getNumber(String *value, String *type) {
+ UNUSED(type);
+
+ double d = DEFAULT_NUMBER;
+ if(Char(value)) {
+ // Printf(stderr, "getNumber %s %s\n", Char(value), type);
+ if(sscanf(Char(value), "%lf", &d) != 1)
+ return(DEFAULT_NUMBER);
+ }
+ return(d);
+}
+
+class R : public Language {
+public:
+ void registerClass(Node *n);
+ void main(int argc, char *argv[]);
+ int top(Node *n);
+
+ void dispatchFunction(Node *n);
+ int functionWrapper(Node *n);
+ int variableWrapper(Node *n);
+
+ int classDeclaration(Node *n);
+ int enumDeclaration(Node *n);
+
+ int membervariableHandler(Node *n);
+
+ int typedefHandler(Node *n);
+
+ int memberfunctionHandler(Node *n) {
+ if (debugMode)
+ Printf(stderr, " %s %s\n",
+ Getattr(n, "name"),
+ Getattr(n, "type"));
+ member_name = Getattr(n, "name");
+ processing_class_member_function = 1;
+ int status = Language::memberfunctionHandler(n);
+ processing_class_member_function = 0;
+ return status;
+ }
+
+
+ // Grab the name of the current class being processed so that we can
+ // deal with members of that class.
+ int classHandler(Node *n){
+ if(!ClassMemberTable)
+ ClassMemberTable = NewHash();
+
+ class_name = Getattr(n, "name");
+ int status = Language::classHandler(n);
+
+ class_name = NULL;
+ return status;
+ };
+ // Not used:
+ String *runtimeCode();
+
+protected:
+ bool debugMode;
+ bool copyStruct;
+ bool memoryProfile;
+ bool aggressiveGc;
+ int addRegistrationRoutine(String *rname, int nargs);
+ int outputRegistrationRoutines(File *out);
+
+ int outputCommandLineArguments(File *out);
+ int generateCopyRoutinesObsolete(Node *n);
+ int generateCopyRoutines(Node *n);
+ int DumpCode(Node *n, String *module);
+
+ int OutputMemberReferenceMethod(String *className, int isSet, List *el, File *out);
+ int OutputArrayMethod(String *className, List *el, File *out);
+ int OutputClassMemberTable(Hash *tb, File *out);
+ int OutputClassMethodsTable(File *out);
+ int OutputClassAccessInfo(Hash *tb, File *out);
+
+ int defineArrayAccessors(SwigType *type);
+
+ void addNamespaceFunction(String *name) {
+ if(!namespaceFunctions)
+ namespaceFunctions = NewList();
+ Append(namespaceFunctions, name);
+ }
+ void addNamespaceMethod(String *name) {
+ if(!namespaceMethods)
+ namespaceMethods = NewList();
+ Append(namespaceMethods, name);
+ }
+
+ String* processType(SwigType *t, Node *n, int *nargs = NULL);
+ String *createFunctionPointerHandler(SwigType *t, Node *n, int *nargs);
+ int addFunctionPointerProxy(String *name, Node *n, SwigType *t, String *s_paramTypes) {
+ /*XXX Do we need to put the t in there to get the return type later. */
+ if(!functionPointerProxyTable)
+ functionPointerProxyTable = NewHash();
+
+ Setattr(functionPointerProxyTable, name, n);
+
+ Setattr(SClassDefs, name, name);
+ Printv(s_classes, "setClass('",
+ name,
+ "',\n", tab8,
+ "prototype = list(parameterTypes = c(", s_paramTypes, "),\n",
+ tab8, tab8, tab8,
+ "returnType = '", SwigType_manglestr(t), "'),\n", tab8,
+ "contains = 'CRoutinePointer')\n\n##\n", NIL);
+
+ return SWIG_OK;
+ };
+
+
+ void addSMethodInfo(String *name,
+ String *argType, int nargs);
+ // Simple initialization such as constant strings that can be reused.
+ void init();
+
+
+ void addAccessor(String *memberName, Wrapper *f,
+ String *name, int isSet = -1);
+
+protected:
+ // Strings into which we cumulate the generated code that is to be written
+ //vto the files.
+ String *sfile,
+ *f_init,
+ *s_classes,
+ *f_runtime,
+ *f_wrapper,
+ *s_header,
+ *f_wrappers,
+ *s_init,
+ *s_init_routine,
+ *s_namespace;
+
+ // State variables that carry information across calls to functionWrapper()
+ // from member accessors and class declarations.
+ String *opaqueClassDeclaration;
+ int processing_variable;
+ int processing_member_access_function;
+ String *member_name;
+ String *class_name;
+
+
+ int processing_class_member_function;
+ List *class_member_functions, *class_member_set_functions;
+
+ /* */
+ Hash *ClassMemberTable;
+ Hash *ClassMethodsTable;
+ Hash *SClassDefs;
+ Hash *SMethodInfo;
+
+ // Information about routines that are generated and to be registered with
+ // R for dynamic lookup.
+ Hash *registrationTable;
+ Hash *functionPointerProxyTable;
+
+ List *namespaceFunctions;
+ List *namespaceMethods;
+ List *namespaceClasses; // Probably can do this from ClassMemberTable.
+
+
+ // Store a copy of the command line.
+ // Need only keep a string that has it formatted.
+ char **argv;
+ int argc;
+ bool inCPlusMode;
+
+ // State variables that we remember from the command line settings
+ // potentially that govern the code we generate.
+ String *DllName;
+ String *Rpackage;
+ bool noInitializationCode;
+ bool outputNamespaceInfo;
+
+ String *UnProtectWrapupCode;
+};
+
+
+static int getFunctionPointerNumArgs(Node *n, SwigType *tt) {
+ (void) tt;
+ n = Getattr(n, "type");
+ Printf(stderr, "type: %s\n", n);
+#if 0
+ SwigType *tmp = SwigType_typedef_resolve(tt);
+
+ n = SwigType_typedef_resolve(tt);
+#endif
+
+ ParmList *parms(Getattr(n, "parms"));
+ Printf(stderr, "parms = %p\n", parms);
+ return ParmList_len(parms);
+}
+
+
+void
+R::addSMethodInfo(String *name, String *argType, int nargs) {
+ (void) argType;
+
+ if(!SMethodInfo)
+ SMethodInfo = NewHash();
+ if (debugMode)
+ Printf(stderr, "[addMethodInfo] %s\n", name);
+
+ Hash *tb = Getattr(SMethodInfo, name);
+
+ if(!tb) {
+ tb = NewHash();
+ Setattr(SMethodInfo, name, tb);
+ }
+
+ String *str = Getattr(tb, "max");
+ int max = -1;
+ if(str)
+ max = atoi(Char(str));
+ if(max < nargs) {
+ if(str) Delete(str);
+ str = NewStringf("%d", max);
+ Setattr(tb, "max", str);
+ }
+}
+
+/*
+
+Returns the name of the new routine.
+*/
+String * R::createFunctionPointerHandler(SwigType *t, Node *n, int *numArgs) {
+ String *funName = SwigType_manglestr(t);
+
+ /* See if we have already processed this one. */
+ if(functionPointerProxyTable && Getattr(functionPointerProxyTable, funName))
+ return funName;
+
+ SwigType *base = SwigType_base(t);
+ if (debugMode)
+ Printf(stderr, " Defining %s\n", t);
+
+ int isVoidType = 0;
+
+ // ParmList *parms = Getattr(n, "parms");
+ // memory leak
+ ParmList *parms =
+ SwigType_function_parms(SwigType_del_pointer(Copy(t)));
+ if (debugMode) {
+ Printf(stderr, "Type: %s\n", t);
+ Printf(stderr, "Return type: %s\n", SwigType_base(t));
+ }
+
+ isVoidType = Strcmp(base, "void") == 0;
+ if (debugMode)
+ Printf(stderr, "%s is void ? %s (%s)\n", funName, isVoidType ? "yes" : "no", base);
+
+ Wrapper *f = NewWrapper();
+
+
+ Parm *ppp = parms;
+ int i = 0;
+ while(ppp) {
+ String *name = Getattr(ppp, "name");
+ if(Len(name) == 0) {
+ name = NewStringf("s_arg%d", i+1);
+ Setattr(ppp, "name", Copy(name));
+ }
+ if (debugMode) {
+ Printf(stderr, "Parm : %s\n", name);
+ }
+ Setattr(ppp, "lname", Copy(Getattr(ppp, "name")));
+ ppp = nextSibling(ppp);
+ i++;
+ }
+
+ Swig_typemap_attach_parms("in", parms, f);
+ Swig_typemap_attach_parms("out", parms, f);
+ Swig_typemap_attach_parms("scoercein", parms, f);
+ Swig_typemap_attach_parms("scoerceout", parms, f);
+ Swig_typemap_attach_parms("scheck", parms, f);
+
+ emit_args(base, parms, f);// should this be t or base. base puts the correct return type variable.
+ emit_attach_parmmaps(parms,f);
+
+ /* Using weird name and struct to avoid potential conflicts. */
+ Wrapper_add_local(f, "__r_swig_cb_data",
+ "RCallbackFunctionData *__r_swig_cb_data = R_SWIG_getCallbackFunctionData()");
+ String *lvar = NewString("__r_swig_cb_data");
+
+ Wrapper_add_local(f, "__tmp", "SEXP __tmp"); // for use in converting arguments to R objects for call.
+ Wrapper_add_local(f, "__r_nprotect", "int __r_nprotect = 0"); // for use in converting arguments to R objects for call.
+ Wrapper_add_local(f, "r_vmax", "char * r_vmax= 0"); // for use in converting arguments to R objects for call.
+
+ // Add local for error code in return value. This is not in emit_args because that assumes an out typemap
+ // whereas the type makes are reverse
+ Wrapper_add_local(f, "ecode", "int ecode = 0");
+
+ Printf(f->def, "%s\n%s(", SwigType_base(t), funName);
+
+ Parm *p = parms;
+ int nargs = ParmList_len(parms);
+ if(numArgs) {
+ *numArgs = nargs;
+ if (debugMode)
+ Printf(stderr, "Setting number of parameters to %d\n", *numArgs);
+ }
+ String *setExprElements = NewString("");
+
+ String *s_paramTypes = NewString("");
+ for(int i = 0; p; i++) {
+ SwigType *tt = Getattr(p, "type");
+ SwigType *name = Getattr(p, "name");
+ // String *lname = Getattr(p,"lname");
+ Printf(f->def, "%s %s", SwigType_str(tt, 0), name);
+ String *tm = Getattr(p, "tmap:out");
+ if(tm) {
+ Replaceall(tm, "$1", name);
+ Replaceall(tm, "$result", "__tmp");
+ replaceRClass(tm, Getattr(p,"type"));
+ Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
+ }
+
+ Printf(setExprElements, "%s\n", tm);
+ Printf(setExprElements, "SETCAR(__r_swig_cb_data->el, %s);\n", "__tmp");
+ Printf(setExprElements, "__r_swig_cb_data->el = CDR(__r_swig_cb_data->el);\n\n");
+
+ Printf(s_paramTypes, "'%s'", SwigType_manglestr(tt));
+
+
+ p = nextSibling(p);
+ if(p) {
+ Printf(f->def, ", ", i, tt, name);
+ Printf(s_paramTypes, ", ");
+ }
+ }
+
+ Printf(f->def, ")\n{\n");
+
+ Printf(f->code, "PROTECT(%s->expr = allocVector(LANGSXP, %d));\n", lvar, nargs + 1);
+ Printf(f->code, "__r_nprotect++;\n");
+ Printf(f->code, "__r_swig_cb_data->el = __r_swig_cb_data->expr;\n\n");
+
+ Printf(f->code, "SETCAR(__r_swig_cb_data->el, __r_swig_cb_data->fun);\n");
+ Printf(f->code, "__r_swig_cb_data->el = CDR(__r_swig_cb_data->el);\n\n");
+
+ Printf(f->code, "%s\n\n", setExprElements);
+
+ Printv(f->code, "__r_swig_cb_data->retValue = R_tryEval(",
+ "__r_swig_cb_data->expr,",
+ " R_GlobalEnv,",
+ " &__r_swig_cb_data->errorOccurred",
+ ");\n",
+ NIL);
+
+ Printv(f->code, "\n",
+ "if(__r_swig_cb_data->errorOccurred) {\n",
+ "R_SWIG_popCallbackFunctionData(1);\n",
+ "PROBLEM \"error in calling R function as a function pointer (",
+ funName,
+ "\"\n",
+ "ERROR;\n",
+ "}\n",
+ NIL);
+
+
+
+ if(!isVoidType) {
+ /* Need to deal with the return type of the function pointer, not the function pointer itself.
+ So build a new node that has the relevant pieces.
+ XXX Have to be a little more clever so that we can deal with struct A * - the * is getting lost.
+ Is this still true? If so, will a SwigType_push() solve things?
+ */
+ Node *bbase = NewHash();
+
+ Setattr(bbase, "type", base);
+ Setattr(bbase, "name", NewString("result"));
+ String *returnTM = Swig_typemap_lookup_new("in", bbase, "result", 0);
+ if(returnTM) {
+ String *tm = returnTM;
+ SwigType *retType = base; // Getattr(n, "type");
+
+ Replaceall(tm,"$input", "__r_swig_cb_data->retValue");
+ Replaceall(tm,"$target", "result");
+ replaceRClass(tm, retType);
+ Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
+ Printf(f->code, "%s\n", tm);
+ }
+ Delete(bbase);
+ }
+
+ Printv(f->code, "R_SWIG_popCallbackFunctionData(1);\n", NIL);
+ Printv(f->code, "\n", UnProtectWrapupCode, NIL);
+
+ if(!isVoidType)
+ Printv(f->code, "return result;\n", NIL);
+
+ Printv(f->code, "\n}\n", NIL);
+
+ /* To coerce correctly in S, we really want to have an extra/intermediate
+ function that handles the scoerceout.
+ We need to check if any of the argument types have an entry in
+ that map. If none do, the ignore and call the function straight.
+ Otherwise, generate the a marshalling function.
+ Need to be able to find it in S. Or use an entirely generic one
+ that evaluates the expressions.
+ Handle errors in the evaluation of the function by restoring
+ the stack, if there is one in use for this function (i.e. no
+ userData).
+ */
+
+ Wrapper_print(f, f_wrapper);
+
+
+ addFunctionPointerProxy(funName, n, t, s_paramTypes);
+ Delete(s_paramTypes);
+
+ return funName;
+}
+
+void R::init() {
+ UnProtectWrapupCode =
+ NewStringf("%s", "vmaxset(r_vmax);\nif(__r_nprotect) UNPROTECT(__r_nprotect);\n\n");
+
+ SClassDefs = NewHash();
+
+ sfile = NewString("");
+ f_init = NewString("");
+ s_header = NewString("");
+ f_runtime = NewString("");
+ f_wrapper = NewString("");
+ s_classes = NewString("");
+ s_init = NewString("");
+ s_init_routine = NewString("");
+}
+
+
+
+#if 0
+int R::cDeclaration(Node *n) {
+ SwigType *t = Getattr(n, "type");
+ SwigType *name = Getattr(n, "name");
+ if (debugMode)
+ Printf(stderr, "cDeclaration (%s): %s\n", name, SwigType_lstr(t, 0));
+ return Language::cDeclaration(n);
+}
+#endif
+
+
+/**
+ Method from Language that is called to start the entire
+ processing off, i.e. the generation of the code.
+ It is called after the input has been read and parsed.
+ Here we open the output streams and generate the code.
+***/
+int R::top(Node *n) {
+ String *module = Getattr(n, "name");
+ if(!Rpackage)
+ Rpackage = Copy(module);
+ if(!DllName)
+ DllName = Copy(module);
+ Append(DllName, "_wrap");
+
+
+ if(outputNamespaceInfo) {
+ s_namespace = NewString("");
+ Swig_register_filebyname("snamespace", s_namespace);
+ Printf(s_namespace, "useDynLib(%s)\n", DllName);
+ } else {
+ String *dev = NewString("/dev/null");
+ File *devnull = NewFile(dev, "w+");
+ Delete(dev);
+ if(!devnull) {
+ FileErrorDisplay(dev);
+ SWIG_exit(EXIT_FAILURE);
+ }
+ Swig_register_filebyname("snamespace", devnull);
+ }
+
+
+ /* Associate the different streams with names so that they can be used in %insert directives by the
+ typemap code. */
+ Swig_register_filebyname("sinit", s_init);
+ Swig_register_filebyname("sinitroutine", s_init_routine);
+
+ Swig_register_filebyname("runtime", f_runtime);
+ Swig_register_filebyname("init", f_init);
+ Swig_register_filebyname("header", s_header);
+ Swig_register_filebyname("wrapper", f_wrapper);
+ Swig_register_filebyname("s", sfile);
+
+ Swig_register_filebyname("sclasses", s_classes);
+
+
+ Printf(s_init, "# This is an automatically generate file by the R module for SWIG.\n\n");
+ outputCommandLineArguments(s_init);
+
+ Language::top(n);
+
+ String *type_table = NewString("");
+ SwigType_emit_type_table(f_runtime,f_wrapper);
+ Delete(type_table);
+
+ if(ClassMemberTable) {
+ //XXX OutputClassAccessInfo(ClassMemberTable, sfile);
+ Delete(ClassMemberTable);
+ ClassMemberTable = NULL;
+ }
+
+ Printf(f_init,"}\n");
+ if(registrationTable)
+ outputRegistrationRoutines(f_init);
+
+
+ /* Now arrange to write the 2 files - .S and .c. */
+
+ DumpCode(n, module);
+
+ Delete(sfile);
+ Delete(s_classes);
+ Delete(s_init);
+ Delete(f_wrapper);
+ Delete(f_init);
+
+ Delete(s_header);
+ Delete(f_runtime);
+
+ return SWIG_OK;
+}
+
+
+/*****************************************************
+ Write the generated code to the .S and the .c files.
+****************************************************/
+int R::DumpCode(Node *n, String *module) {
+ String *output_filename = NewString("");
+
+
+ /* The name of the file in which we will generate the S code. */
+ Printf(output_filename, "%s%s_wrap.R", SWIG_output_directory(), module);
+
+#ifdef R_SWIG_VERBOSE
+ Printf(stderr, "Writing S code to %s\n", output_filename);
+#endif
+
+ File *scode = NewFile(output_filename, "w");
+ if (!scode) {
+ FileErrorDisplay(output_filename);
+ SWIG_exit(EXIT_FAILURE);
+ }
+ Delete(output_filename);
+
+
+ Printf(scode, "%s\n\n", s_init);
+ Printf(scode, "%s\n\n", s_classes);
+ Printf(scode, "%s\n", sfile);
+
+ Close(scode);
+ // Delete(scode);
+ String *outfile = Getattr(n,"outfile");
+ File *runtime = NewFile(outfile,"w");
+ if (!runtime) {
+ FileErrorDisplay(outfile);
+ SWIG_exit(EXIT_FAILURE);
+ }
+
+ Swig_banner(runtime);
+
+
+ Printf(runtime, "/* Runtime */\n");
+ Printf(runtime, "%s\n", f_runtime);
+
+ Printf(runtime, "/* Header */\n");
+ Printf(runtime, "%s\n", s_header);
+
+ Printf(runtime, "/* Wrapper */\n");
+ Printf(runtime, "%s\n", f_wrapper);
+
+ Printf(runtime, "/* Init code */\n");
+ Printf(runtime, "%s\n", f_init);
+
+ Close(runtime);
+ Delete(runtime);
+
+ if(outputNamespaceInfo) {
+ output_filename = NewString("");
+ Printf(output_filename, "%sNAMESPACE", SWIG_output_directory());
+ File *ns = NewFile(output_filename, "w");
+ if (!ns) {
+ FileErrorDisplay(output_filename);
+ SWIG_exit(EXIT_FAILURE);
+ }
+ Delete(output_filename);
+
+ Printf(ns, "%s\n", s_namespace);
+
+ Printf(ns, "\nexport(\n");
+ writeListByLine(namespaceFunctions, ns);
+ Printf(ns, ")\n");
+ Printf(ns, "\nexportMethods(\n");
+ writeListByLine(namespaceFunctions, ns, 1);
+ Printf(ns, ")\n");
+ Close(ns);
+ Delete(ns);
+ Delete(s_namespace);
+ }
+
+ return SWIG_OK;
+}
+
+
+
+/*
+ We may need to do more.... so this is left as a
+ stub for the moment.
+*/
+int R::OutputClassAccessInfo(Hash *tb, File *out) {
+ int n = OutputClassMemberTable(tb, out);
+ OutputClassMethodsTable(out);
+ return n;
+}
+
+/************************************************************************
+ Currently this just writes the information collected about the
+ different methods of the C++ classes that have been processed
+ to the console.
+ This will be used later to define S4 generics and methods.
+**************************************************************************/
+int R::OutputClassMethodsTable(File *) {
+ Hash *tb = ClassMethodsTable;
+
+ if(!tb)
+ return SWIG_OK;
+
+ List *keys = Keys(tb);
+ String *key;
+ int i, n = Len(keys);
+ if (debugMode) {
+ for(i = 0; i < n ; i++ ) {
+ key = Getitem(keys, i);
+ Printf(stderr, "%d) %s\n", i, key);
+ List *els = Getattr(tb, key);
+ int nels = Len(els);
+ Printf(stderr, "\t");
+ for(int j = 0; j < nels; j+=2) {
+ Printf(stderr, "%s%s", Getitem(els, j), j < nels - 1 ? ", " : "");
+ Printf(stderr, "%s\n", Getitem(els, j+1));
+ }
+ Printf(stderr, "\n");
+ }
+ }
+
+ return SWIG_OK;
+}
+
+
+/*
+ Iterate over the _set and <>_get
+ elements and generate the $ and $<- functions
+ that provide constrained access to the member
+ fields in these elements.
+
+ tb - a hash table that is built up in functionWrapper
+ as we process each membervalueHandler.
+ The entries are indexed by _set and
+ _get. Each entry is a List *.
+
+ out - the stram where the code is to be written. This is the S
+ code stream as we generate only S code here..
+*/
+int R::OutputClassMemberTable(Hash *tb, File *out) {
+ List *keys = Keys(tb), *el;
+
+ String *key;
+ int i, n = Len(keys);
+ /* Loop over all the _set and _get entries in the table. */
+
+ if(n && outputNamespaceInfo) {
+ Printf(s_namespace, "exportClasses(");
+ }
+ for(i = 0; i < n; i++) {
+ key = Getitem(keys, i);
+ el = Getattr(tb, key);
+
+ String *className = Getitem(el, 0);
+ char *ptr = Char(key);
+ ptr = &ptr[Len(key) - 3];
+ int isSet = strcmp(ptr, "set") == 0;
+
+ // OutputArrayMethod(className, el, out);
+ OutputMemberReferenceMethod(className, isSet, el, out);
+
+ if(outputNamespaceInfo)
+ Printf(s_namespace, "\"%s\"%s", className, i < n-1 ? "," : "");
+ }
+ if(n && outputNamespaceInfo) {
+ Printf(s_namespace, ")\n");
+ }
+
+ return n;
+}
+
+/*******************************************************************
+ Write the methods for $ or $<- for accessing a member field in an
+ struct or union (or class).
+ className - the name of the struct or union (e.g. Bar for struct Bar)
+ isSet - a logical value indicating whether the method is for
+ modifying ($<-) or accessing ($) the member field.
+ el - a list of length 2 * # accessible member elements + 1.
+ The first element is the name of the class.
+ The other pairs are member name and the name of the R function to access it.
+ out - the stream where we write the code.
+********************************************************************/
+int R::OutputMemberReferenceMethod(String *className, int isSet,
+ List *el, File *out) {
+ int numMems = Len(el), j;
+ int has_getitem = 0, has_setitem = 0, has_str = 0;
+ int varaccessor = 0;
+ if (numMems == 0)
+ return SWIG_OK;
+
+ Wrapper *f = NewWrapper(), *attr = NewWrapper();
+
+ Printf(f->def, "function(x, name%s)", isSet ? ", value" : "");
+ Printf(attr->def, "function(x, i, j, ...%s)", isSet ? ", value" : "");
+
+ Printf(f->code, "{\n");
+ Printf(f->code, "%saccessorFuns = list(", tab8);
+
+ for(j = 0; j < numMems; j+=3) {
+ String *item = Getitem(el, j);
+ if (!Strcmp(item, "__getitem__")) has_getitem = 1;
+ if (!Strcmp(item, "__setitem__")) has_setitem = 1;
+ if (!Strcmp(item, "__str__")) has_str = 1;
+
+ String *dup = Getitem(el, j + 1);
+ char *ptr = Char(dup);
+ ptr = &ptr[Len(dup) - 3];
+
+ if (!strcmp(ptr, "get"))
+ varaccessor++;
+ Printf(f->code, "'%s' = %s%s", item, dup, j < numMems - 3 ? ", " : "");
+ }
+ Printf(f->code, ")\n");
+
+ if (!isSet && varaccessor > 0) {
+ Printf(f->code, "%svaccessors = c(", tab8);
+ int vcount = 0;
+ for(j = 0; j < numMems; j+=3) {
+ String *item = Getitem(el, j);
+ String *dup = Getitem(el, j + 1);
+ char *ptr = Char(dup);
+ ptr = &ptr[Len(dup) - 3];
+
+ if (!strcmp(ptr, "get")) {
+ vcount++;
+ Printf(f->code, "'%s'%s", item, vcount < varaccessor ? ", " : "");
+ }
+ }
+ Printf(f->code, ")\n");
+ }
+
+
+ /* Printv(f->code, tab8,
+ "idx = pmatch(name, names(accessorFuns))\n",
+ tab8,
+ "if(is.na(idx)) {\n",
+ tab8, tab4,
+ "stop(\"No ", (isSet ? "modifiable" : "accessible"), " field named \", name, \" in ", className,
+ ": fields are \", paste(names(accessorFuns), sep = \", \")",
+ ")", "\n}\n", NIL); */
+ Printv(f->code, tab8,
+ "idx = pmatch(name, names(accessorFuns))\n",
+ tab8,
+ "if(is.na(idx)) \n",
+ tab8, tab4, NIL);
+ Printf(f->code, "return(callNextMethod(x, name%s))\n",
+ isSet ? ", value" : "");
+ Printv(f->code, tab8, "f = accessorFuns[[idx]]\n", NIL);
+ if(isSet) {
+ Printv(f->code, tab8, "f(x, value)\n", NIL);
+ Printv(f->code, tab8, "x\n", NIL); // make certain to return the S value.
+ } else {
+ Printv(f->code, tab8, "formals(f)[[1]] = x\n", NIL);
+ if (varaccessor) {
+ Printv(f->code, tab8,
+ "if (is.na(match(name, vaccessors))) f else f(x)\n", NIL);
+ } else {
+ Printv(f->code, tab8, "f\n", NIL);
+ }
+ }
+ Printf(f->code, "}\n");
+
+
+ Printf(out, "# Start of accessor method for %s\n", className);
+ Printf(out, "setMethod('$%s', '_p%s', ",
+ isSet ? "<-" : "",
+ getRClassName(className));
+ Wrapper_print(f, out);
+ Printf(out, ")\n");
+
+ if(isSet) {
+ Printf(out, "setMethod('[[<-', c('_p%s', 'character'),",
+ getRClassName(className));
+ Insert(f->code, 2, "name = i\n");
+ Printf(attr->code, "%s", f->code);
+ Wrapper_print(attr, out);
+ Printf(out, ")\n");
+ }
+
+ DelWrapper(attr);
+ DelWrapper(f);
+
+ Printf(out, "# end of accessor method for %s\n", className);
+
+ return SWIG_OK;
+}
+
+/*******************************************************************
+ Write the methods for [ or [<- for accessing a member field in an
+ struct or union (or class).
+ className - the name of the struct or union (e.g. Bar for struct Bar)
+ el - a list of length 2 * # accessible member elements + 1.
+ The first element is the name of the class.
+ The other pairs are member name and the name of the R function to access it.
+ out - the stream where we write the code.
+********************************************************************/
+int R::OutputArrayMethod(String *className, List *el, File *out) {
+ int numMems = Len(el), j;
+
+ if(!el || numMems == 0)
+ return(0);
+
+ Printf(out, "# start of array methods for %s\n", className);
+ for(j = 0; j < numMems; j+=3) {
+ String *item = Getitem(el, j);
+ String *dup = Getitem(el, j + 1);
+ if (!Strcmp(item, "__getitem__")) {
+ Printf(out,
+ "setMethod('[', '_p%s', function(x, i, j, ..., drop =TRUE) ",
+ getRClassName(className));
+ Printf(out, " sapply(i, function (n) %s(x, as.integer(n-1))))\n\n", dup);
+ }
+ if (!Strcmp(item, "__setitem__")) {
+ Printf(out, "setMethod('[<-', '_p%s', function(x, i, j, ..., value)",
+ getRClassName(className));
+ Printf(out, " sapply(1:length(i), function(n) %s(x, as.integer(i[n]-1), value[n])))\n\n", dup);
+ }
+
+ }
+
+ Printf(out, "# end of array methods for %s\n", className);
+
+ return SWIG_OK;
+}
+
+
+/************************************************************
+ Called when a enumeration is to be processed.
+ We want to call the R function defineEnumeration().
+ tdname is the typedef of the enumeration, i.e. giving its name.
+*************************************************************/
+int R::enumDeclaration(Node *n) {
+ String *name = Getattr(n, "name");
+ String *tdname = Getattr(n, "tdname");
+
+ /* Using name if tdname is empty. */
+
+ if(Len(tdname) == 0)
+ tdname = name;
+
+
+ if(!tdname || Strcmp(tdname, "") == 0) {
+ Language::enumDeclaration(n);
+ return SWIG_OK;
+ }
+
+ String *mangled_tdname = SwigType_manglestr(tdname);
+ String *scode = NewString("");
+
+ Printv(scode, "defineEnumeration('", mangled_tdname, "'",
+ ",\n", tab8, tab8, tab4, ".values = c(\n", NIL);
+
+ Node *c;
+ int value = -1; // First number is zero
+ for (c = firstChild(n); c; c = nextSibling(c)) {
+ // const char *tag = Char(nodeType(c));
+ // if (Strcmp(tag,"cdecl") == 0) {
+ name = Getattr(c, "name");
+ String *type = Getattr(c, "type");
+ String *val = Getattr(c, "enumvalue");
+ if(val && Char(val)) {
+ int inval = (int) getNumber(val, type);
+ if(inval == DEFAULT_NUMBER)
+ value++;
+ else
+ value = inval;
+ } else
+ value++;
+
+ Printf(scode, "%s%s%s'%s' = %d%s\n", tab8, tab8, tab8, name, value,
+ nextSibling(c) ? ", " : "");
+ // }
+ }
+
+ Printv(scode, "))", NIL);
+ Printf(sfile, "%s\n", scode);
+
+ Delete(scode);
+ Delete(mangled_tdname);
+
+ return SWIG_OK;
+}
+
+
+/*************************************************************
+**************************************************************/
+int R::variableWrapper(Node *n) {
+ String *name = Getattr(n, "sym:name");
+
+ processing_variable = 1;
+ Language::variableWrapper(n); // Force the emission of the _set and _get function wrappers.
+ processing_variable = 0;
+
+
+ SwigType *ty = Getattr(n, "type");
+ int addCopyParam = addCopyParameter(ty);
+
+ //XXX
+ processType(ty, n);
+
+ if(!SwigType_isconst(ty)) {
+ Wrapper *f = NewWrapper();
+ Printf(f->def, "%s = \nfunction(value%s)\n{\n",
+ name, addCopyParam ? ", .copy = FALSE" : "");
+ Printv(f->code, "if(missing(value)) {\n",
+ name, "_get(", addCopyParam ? ".copy" : "", ")\n}", NIL);
+ Printv(f->code, " else {\n",
+ name, "_set(value)\n}\n}", NIL);
+
+ Wrapper_print(f, sfile);
+ DelWrapper(f);
+ } else {
+ Printf(sfile, "%s = %s_get\n", name, name);
+ }
+
+ return SWIG_OK;
+}
+
+
+void R::addAccessor(String *memberName, Wrapper *wrapper, String *name,
+ int isSet) {
+ if(isSet < 0) {
+ int n = Len(name);
+ char *ptr = Char(name);
+ isSet = Strcmp(NewString(&ptr[n-3]), "set") == 0;
+ }
+
+ List *l = isSet ? class_member_set_functions : class_member_functions;
+
+ if(!l) {
+ l = NewList();
+ if(isSet)
+ class_member_set_functions = l;
+ else
+ class_member_functions = l;
+ }
+
+ Append(l, memberName);
+ Append(l, name);
+
+ String *tmp = NewString("");
+ Wrapper_print(wrapper, tmp);
+ Append(l, tmp);
+ // if we could put the wrapper in directly: Append(l, Copy(sfun));
+ if (debugMode)
+ Printf(stderr, "Adding accessor: %s (%s) => %s\n", memberName, name, tmp);
+}
+
+#define MAX_OVERLOAD 256
+
+struct Overloaded {
+ Node *n; /* Node */
+ int argc; /* Argument count */
+ ParmList *parms; /* Parameters used for overload check */
+ int error; /* Ambiguity error */
+};
+
+
+static List * Swig_overload_rank(Node *n,
+ bool script_lang_wrapping) {
+ Overloaded nodes[MAX_OVERLOAD];
+ int nnodes = 0;
+ Node *o = Getattr(n,"sym:overloaded");
+
+
+ if (!o) return 0;
+
+ Node *c = o;
+ while (c) {
+ if (Getattr(c,"error")) {
+ c = Getattr(c,"sym:nextSibling");
+ continue;
+ }
+ /* if (SmartPointer && Getattr(c,"cplus:staticbase")) {
+ c = Getattr(c,"sym:nextSibling");
+ continue;
+ } */
+
+ /* Make a list of all the declarations (methods) that are overloaded with
+ * this one particular method name */
+
+ if (Getattr(c,"wrap:name")) {
+ nodes[nnodes].n = c;
+ nodes[nnodes].parms = Getattr(c,"wrap:parms");
+ nodes[nnodes].argc = emit_num_required(nodes[nnodes].parms);
+ nodes[nnodes].error = 0;
+ nnodes++;
+ }
+ c = Getattr(c,"sym:nextSibling");
+ }
+
+ /* Sort the declarations by required argument count */
+ {
+ int i,j;
+ for (i = 0; i < nnodes; i++) {
+ for (j = i+1; j < nnodes; j++) {
+ if (nodes[i].argc > nodes[j].argc) {
+ Overloaded t = nodes[i];
+ nodes[i] = nodes[j];
+ nodes[j] = t;
+ }
+ }
+ }
+ }
+
+ /* Sort the declarations by argument types */
+ {
+ int i,j;
+ for (i = 0; i < nnodes-1; i++) {
+ if (nodes[i].argc == nodes[i+1].argc) {
+ for (j = i+1; (j < nnodes) && (nodes[j].argc == nodes[i].argc); j++) {
+ Parm *p1 = nodes[i].parms;
+ Parm *p2 = nodes[j].parms;
+ int differ = 0;
+ int num_checked = 0;
+ while (p1 && p2 && (num_checked < nodes[i].argc)) {
+ // Printf(stdout,"p1 = '%s', p2 = '%s'\n", Getattr(p1,"type"), Getattr(p2,"type"));
+ if (checkAttribute(p1,"tmap:in:numinputs","0")) {
+ p1 = Getattr(p1,"tmap:in:next");
+ continue;
+ }
+ if (checkAttribute(p2,"tmap:in:numinputs","0")) {
+ p2 = Getattr(p2,"tmap:in:next");
+ continue;
+ }
+ String *t1 = Getattr(p1,"tmap:typecheck:precedence");
+ String *t2 = Getattr(p2,"tmap:typecheck:precedence");
+ if ((!t1) && (!nodes[i].error)) {
+ Swig_warning(WARN_TYPEMAP_TYPECHECK, Getfile(nodes[i].n), Getline(nodes[i].n),
+ "Overloaded %s(%s) not supported (no type checking rule for '%s').\n",
+ Getattr(nodes[i].n,"name"),ParmList_str_defaultargs(Getattr(nodes[i].n,"parms")),
+ SwigType_str(Getattr(p1,"type"),0));
+ nodes[i].error = 1;
+ } else if ((!t2) && (!nodes[j].error)) {
+ Swig_warning(WARN_TYPEMAP_TYPECHECK, Getfile(nodes[j].n), Getline(nodes[j].n),
+ "Overloaded %s(%s) not supported (no type checking rule for '%s').\n",
+ Getattr(nodes[j].n,"name"),ParmList_str_defaultargs(Getattr(nodes[j].n,"parms")),
+ SwigType_str(Getattr(p2,"type"),0));
+ nodes[j].error = 1;
+ }
+ if (t1 && t2) {
+ int t1v, t2v;
+ t1v = atoi(Char(t1));
+ t2v = atoi(Char(t2));
+ differ = t1v-t2v;
+ }
+ else if (!t1 && t2) differ = 1;
+ else if (t2 && !t1) differ = -1;
+ else if (!t1 && !t2) differ = -1;
+ num_checked++;
+ if (differ > 0) {
+ Overloaded t = nodes[i];
+ nodes[i] = nodes[j];
+ nodes[j] = t;
+ break;
+ } else if ((differ == 0) && (Strcmp(t1,"0") == 0)) {
+ t1 = Getattr(p1,"ltype");
+ if (!t1) {
+ t1 = SwigType_ltype(Getattr(p1,"type"));
+ if (Getattr(p1,"tmap:typecheck:SWIGTYPE")) {
+ SwigType_add_pointer(t1);
+ }
+ Setattr(p1,"ltype",t1);
+ }
+ t2 = Getattr(p2,"ltype");
+ if (!t2) {
+ t2 = SwigType_ltype(Getattr(p2,"type"));
+ if (Getattr(p2,"tmap:typecheck:SWIGTYPE")) {
+ SwigType_add_pointer(t2);
+ }
+ Setattr(p2,"ltype",t2);
+ }
+
+ /* Need subtype check here. If t2 is a subtype of t1, then we need to change the
+ order */
+
+ if (SwigType_issubtype(t2,t1)) {
+ Overloaded t = nodes[i];
+ nodes[i] = nodes[j];
+ nodes[j] = t;
+ }
+
+ if (Strcmp(t1,t2) != 0) {
+ differ = 1;
+ break;
+ }
+ } else if (differ) {
+ break;
+ }
+ if (Getattr(p1,"tmap:in:next")) {
+ p1 = Getattr(p1,"tmap:in:next");
+ } else {
+ p1 = nextSibling(p1);
+ }
+ if (Getattr(p2,"tmap:in:next")) {
+ p2 = Getattr(p2,"tmap:in:next");
+ } else {
+ p2 = nextSibling(p2);
+ }
+ }
+ if (!differ) {
+ /* See if declarations differ by const only */
+ String *d1 = Getattr(nodes[i].n,"decl");
+ String *d2 = Getattr(nodes[j].n,"decl");
+ if (d1 && d2) {
+ String *dq1 = Copy(d1);
+ String *dq2 = Copy(d2);
+ if (SwigType_isconst(d1)) {
+ Delete(SwigType_pop(dq1));
+ }
+ if (SwigType_isconst(d2)) {
+ Delete(SwigType_pop(dq2));
+ }
+ if (Strcmp(dq1,dq2) == 0) {
+
+ if (SwigType_isconst(d1) && !SwigType_isconst(d2)) {
+ if (script_lang_wrapping) {
+ // Swap nodes so that the const method gets ignored (shadowed by the non-const method)
+ Overloaded t = nodes[i];
+ nodes[i] = nodes[j];
+ nodes[j] = t;
+ }
+ differ = 1;
+ if (!nodes[j].error) {
+ if (script_lang_wrapping) {
+ Swig_warning(WARN_LANG_OVERLOAD_CONST, Getfile(nodes[j].n), Getline(nodes[j].n),
+ "Overloaded %s(%s) const ignored. Non-const method at %s:%d used.\n",
+ Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
+ Getfile(nodes[i].n), Getline(nodes[i].n));
+ } else {
+ if (!Getattr(nodes[j].n, "overload:ignore"))
+ Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n),
+ "Overloaded method %s(%s) ignored. Method %s(%s) const at %s:%d used.\n",
+ Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
+ Getattr(nodes[i].n,"name"), ParmList_protostr(nodes[i].parms),
+ Getfile(nodes[i].n), Getline(nodes[i].n));
+ }
+ }
+ nodes[j].error = 1;
+ } else if (!SwigType_isconst(d1) && SwigType_isconst(d2)) {
+ differ = 1;
+ if (!nodes[j].error) {
+ if (script_lang_wrapping) {
+ Swig_warning(WARN_LANG_OVERLOAD_CONST, Getfile(nodes[j].n), Getline(nodes[j].n),
+ "Overloaded %s(%s) const ignored. Non-const method at %s:%d used.\n",
+ Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
+ Getfile(nodes[i].n), Getline(nodes[i].n));
+ } else {
+ if (!Getattr(nodes[j].n, "overload:ignore"))
+ Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n),
+ "Overloaded method %s(%s) const ignored. Method %s(%s) at %s:%d used.\n",
+ Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
+ Getattr(nodes[i].n,"name"), ParmList_protostr(nodes[i].parms),
+ Getfile(nodes[i].n), Getline(nodes[i].n));
+ }
+ }
+ nodes[j].error = 1;
+ }
+ }
+ Delete(dq1);
+ Delete(dq2);
+ }
+ }
+ if (!differ) {
+ if (!nodes[j].error) {
+ if (script_lang_wrapping) {
+ Swig_warning(WARN_LANG_OVERLOAD_SHADOW, Getfile(nodes[j].n), Getline(nodes[j].n),
+ "Overloaded %s(%s)%s is shadowed by %s(%s)%s at %s:%d.\n",
+ Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
+ SwigType_isconst(Getattr(nodes[j].n,"decl")) ? " const" : "",
+ Getattr(nodes[i].n,"name"), ParmList_protostr(nodes[i].parms),
+ SwigType_isconst(Getattr(nodes[i].n,"decl")) ? " const" : "",
+ Getfile(nodes[i].n),Getline(nodes[i].n));
+ } else {
+ if (!Getattr(nodes[j].n, "overload:ignore"))
+ Swig_warning(WARN_LANG_OVERLOAD_IGNORED, Getfile(nodes[j].n), Getline(nodes[j].n),
+ "Overloaded method %s(%s)%s ignored. Method %s(%s)%s at %s:%d used.\n",
+ Getattr(nodes[j].n,"name"), ParmList_protostr(nodes[j].parms),
+ SwigType_isconst(Getattr(nodes[j].n,"decl")) ? " const" : "",
+ Getattr(nodes[i].n,"name"), ParmList_protostr(nodes[i].parms),
+ SwigType_isconst(Getattr(nodes[i].n,"decl")) ? " const" : "",
+ Getfile(nodes[i].n),Getline(nodes[i].n));
+ }
+ nodes[j].error = 1;
+ }
+ }
+ }
+ }
+ }
+ }
+ List *result = NewList();
+ {
+ int i;
+ for (i = 0; i < nnodes; i++) {
+ if (nodes[i].error)
+ Setattr(nodes[i].n, "overload:ignore", "1");
+ Append(result,nodes[i].n);
+ // Printf(stdout,"[ %d ] %s\n", i, ParmList_protostr(nodes[i].parms));
+ // Swig_print_node(nodes[i].n);
+ }
+ }
+ return result;
+}
+
+void R::dispatchFunction(Node *n) {
+ Wrapper *f = NewWrapper();
+ String *symname = Getattr(n, "sym:name");
+ String *nodeType = Getattr(n, "nodeType");
+ bool constructor = (!Cmp(nodeType, "constructor"));
+
+ String *sfname = NewString(symname);
+
+ if (constructor)
+ Replace(sfname, "new_", "", DOH_REPLACE_FIRST);
+
+ Printf(f->def,
+ "`%s` <- function(...) {", sfname);
+ List *dispatch = Swig_overload_rank(n, true);
+ int nfunc = Len(dispatch);
+ Printv(f->code,
+ "argtypes <- mapply(class, list(...))\n",
+ "argc <- length(argtypes)\n", NIL );
+
+ Printf(f->code, "# dispatch functions %d\n", nfunc);
+ int cur_args = -1;
+ bool first_compare = true;
+ for (int i=0; i < nfunc; i++) {
+ Node *ni = Getitem(dispatch,i);
+ Parm *pi = Getattr(ni,"wrap:parms");
+ int num_arguments = emit_num_arguments(pi);
+
+ String *overname = Getattr(ni,"sym:overname");
+ if (cur_args != num_arguments) {
+ if (cur_args != -1) {
+ Printv(f->code, "} else ", NIL);
+ }
+ Printf(f->code, "if (argc == %d) {", num_arguments);
+ cur_args = num_arguments;
+ first_compare = true;
+ }
+ Parm *p;
+ int j;
+ if (num_arguments > 0) {
+ if (!first_compare) {
+ Printv(f->code, " else ", NIL);
+ } else {
+ first_compare = false;
+ }
+ Printv(f->code, "if (", NIL);
+ for (p =pi, j = 0 ; j < num_arguments ; j++) {
+ String *tm = Swig_typemap_lookup_new("rtype", p, "", 0);
+ if(tm) {
+ replaceRClass(tm, Getattr(p, "type"));
+ }
+ Printf(f->code, "%sextends(argtypes[%d], '%s')",
+ j == 0 ? "" : " && ",
+ j+1,
+ tm);
+ p = Getattr(p, "tmap:in:next");
+ }
+ Printf(f->code, ") { f <- %s%s }\n", sfname, overname);
+ } else {
+ Printf(f->code, "f <- %s%s", sfname, overname);
+ }
+ }
+ if (cur_args != -1) {
+ Printv(f->code, "}", NIL);
+ }
+ Printv(f->code, "\nf(...)", NIL);
+ Printv(f->code, "\n}", NIL);
+ Wrapper_print(f, sfile);
+ Printv(sfile, "# Dispatch function\n", NIL);
+}
+
+/******************************************************************
+
+*******************************************************************/
+int R::functionWrapper(Node *n) {
+ String *fname = Getattr(n, "name");
+ String *iname = Getattr(n, "sym:name");
+ String *type = Getattr(n, "type");
+
+ if (debugMode) {
+ Printf(stderr,
+ " %s %s %s\n", fname, iname, type);
+ }
+ String *overname = 0;
+ String *nodeType = Getattr(n, "nodeType");
+ bool constructor = (!Cmp(nodeType, "constructor"));
+ bool destructor = (!Cmp(nodeType, "destructor"));
+
+ String *sfname = NewString(iname);
+
+ if (constructor)
+ Replace(sfname, "new_", "", DOH_REPLACE_FIRST);
+
+ if (Getattr(n,"sym:overloaded")) {
+ overname = Getattr(n,"sym:overname");
+ Append(sfname, overname);
+ }
+
+ if (debugMode)
+ Printf(stderr,
+ " processing parameters\n");
+
+
+ ParmList *l = Getattr(n, "parms");
+ Parm *p;
+ String *returnTM = NULL;
+ String *tm;
+
+ p = l;
+ while(p) {
+ SwigType *resultType = Getattr(p, "type");
+ if (expandTypedef(resultType) &&
+ SwigType_istypedef(resultType)) {
+ SwigType *resolved =
+ SwigType_typedef_resolve_all(resultType);
+ if (expandTypedef(resolved)) {
+ Setattr(p, "type", Copy(resolved));
+ }
+ }
+ p = nextSibling(p);
+ }
+
+ String *unresolved_return_type =
+ Copy(type);
+ if (expandTypedef(type) &&
+ SwigType_istypedef(type)) {
+ SwigType *resolved =
+ SwigType_typedef_resolve_all(type);
+ if (expandTypedef(resolved)) {
+ type = Copy(resolved);
+ Setattr(n, "type", type);
+ }
+ }
+ if (debugMode)
+ Printf(stderr, " unresolved_return_type %s\n",
+ unresolved_return_type);
+ if(processing_member_access_function) {
+ if (debugMode)
+ Printf(stderr, " '%s' '%s' '%s' '%s'\n",
+ fname, iname, member_name, class_name);
+
+ if(opaqueClassDeclaration)
+ return SWIG_OK;
+
+
+ /* Add the name of this member to a list for this class_name.
+ We will dump all these at the end. */
+
+ int n = Len(iname);
+ char *ptr = Char(iname);
+ bool isSet(Strcmp(NewString(&ptr[n-3]), "set") == 0);
+
+
+ String *tmp = NewString("");
+ Printf(tmp, "%s_%s", class_name, isSet ? "set" : "get");
+
+ List *memList = Getattr(ClassMemberTable, tmp);
+ if(!memList) {
+ memList = NewList();
+ Append(memList, class_name);
+ Setattr(ClassMemberTable, tmp, memList);
+ }
+ Delete(tmp);
+ Append(memList, member_name);
+ Append(memList, iname);
+ }
+
+ int i;
+ int nargs, num_required, varargs;
+ UNUSED(varargs);
+
+ String *wname = Swig_name_wrapper(iname);
+ Replace(wname, "_wrap", "R_swig", DOH_REPLACE_FIRST);
+ if(overname)
+ Append(wname, overname);
+ Setattr(n,"wrap:name", wname);
+
+ Wrapper *f = NewWrapper();
+ Wrapper *sfun = NewWrapper();
+
+
+ int isVoidReturnType = 0;
+ returnTM = Swig_typemap_lookup_new("out", n, "result",0);
+ if(returnTM)
+ isVoidReturnType = (Strcmp(type, "void") == 0);
+
+ SwigType *rtype = Getattr(n, "type");
+ int addCopyParam = 0;
+
+ if(!isVoidReturnType)
+ addCopyParam = addCopyParameter(rtype);
+
+
+ // Can we get the nodeType() of the type node! and see if it is a struct.
+ // int addCopyParam = SwigType_isclass(rtype);
+
+ // if(addCopyParam)
+ if (debugMode)
+ Printf(stderr, "Adding a .copy argument to %s for %s = %s\n",
+ iname, type, addCopyParam ? "yes" : "no");
+ if (inCPlusMode)
+ Printv(f->def, "extern \"C\" ", NIL);
+
+ Printv(f->def, "SWIGINTERN SEXP\n", wname, " ( ", NIL);
+
+ Printf(sfun->def, "# Start of %s\n", iname);
+ Printv(sfun->def, "\n`", sfname, "` = function(", NIL);
+
+ if(outputNamespaceInfo) //XXX Need to be a little more discriminating
+ addNamespaceFunction(iname);
+
+ Swig_typemap_attach_parms("scoercein", l, f);
+ Swig_typemap_attach_parms("scoerceout", l, f);
+ Swig_typemap_attach_parms("scheck", l, f);
+
+ // Need to use the unresolved return type since
+ // typedef resolution removes the const which causes a
+ // mismatch with the function action
+ emit_args(unresolved_return_type, l, f);
+ emit_attach_parmmaps(l,f);
+ Setattr(n,"wrap:parms",l);
+
+ nargs = emit_num_arguments(l);
+ num_required = emit_num_required(l);
+ varargs = emit_isvarargs(l);
+
+ Wrapper_add_local(f, "__r_nprotect", "unsigned int __r_nprotect = 0");
+ Wrapper_add_localv(f, "r_ans", "SEXP", "r_ans = R_NilValue", NIL);
+ Wrapper_add_localv(f, "r_vmax", "char *", "r_vmax = vmaxget()", NIL);
+
+ String *sargs = NewString("");
+
+
+ String *s_inputTypes = NewString("");
+ String *s_inputMap = NewString("");
+ bool inFirstArg = true;
+ Parm *curP;
+ for (p =l, i = 0 ; i < nargs ; i++) {
+
+ while (checkAttribute(p, "tmap:in:numinputs", "0")) {
+ p = Getattr(p, "tmap:in:next");
+ }
+
+ SwigType *tt = Getattr(p, "type");
+ int nargs = -1;
+ String *funcptr_name = processType(tt, p, &nargs);
+
+ // SwigType *tp = Getattr(p, "type");
+ String *name = Getattr(p,"name");
+ String *lname = Getattr(p,"lname");
+
+
+ /* If we have a :: in the parameter name because we are accessing a static member of a class, say, then
+ we need to remove that prefix. */
+ while (Strstr(name, "::")) {
+ //XXX need to free.
+ name = NewStringf("%s", Strchr(name, ':') + 2);
+ if (debugMode)
+ Printf(stderr, "+++ parameter name with :: in it %s\n", name);
+ }
+ if (Len(name) == 0)
+ name = NewStringf("s_arg%d", i+1);
+
+ if (!Strncmp(name, "_", 1)) {
+ name = Copy(name);
+ Insert(name, 0, "s");
+ }
+
+ if (!Strncmp(name, "arg", 3)) {
+ name = Copy(name);
+ Insert(name, 0, "s_");
+ }
+
+ if(processing_variable) {
+ name = Copy(name);
+ Insert(name, 0, "s_");
+ }
+
+ if(!Strcmp(name, fname)) {
+ name = Copy(name);
+ Insert(name, 0, "s_");
+ }
+
+ Printf(sargs, "%s, ", name);
+
+ String *tm;
+ if((tm = Getattr(p, "tmap:scoercein"))) {
+ Replaceall(tm, "$input", name);
+ replaceRClass(tm, Getattr(p, "type"));
+
+ if(funcptr_name) {
+ //XXX need to get this to return non-zero
+ if(nargs == -1)
+ nargs = getFunctionPointerNumArgs(p, tt);
+
+ String *snargs = NewStringf("%d", nargs);
+ Printv(sfun->code, "if(is.function(", name, ")) {", "\n",
+ "assert('...' %in% names(formals(", name,
+ ")) || length(formals(", name, ")) >= ", snargs, ")\n} ", NIL);
+ Delete(snargs);
+
+ Printv(sfun->code, "else {\n",
+ "if(is.character(", name, ")) {\n",
+ name, " = getNativeSymbolInfo(", name, ")",
+ "\n}\n",
+ "if(is(", name, ", \"NativeSymbolInfo\")) {\n",
+ name, " = ", name, "$address", "\n}\n",
+ "}\n",
+ NIL);
+ } else {
+ Printf(sfun->code, "%s\n", tm);
+ }
+ }
+
+ Printv(sfun->def, inFirstArg ? "" : ", ", name, NIL);
+
+ if ((tm = Getattr(p,"tmap:scheck"))) {
+
+ Replaceall(tm,"$target", lname);
+ Replaceall(tm,"$source", name);
+ Replaceall(tm,"$input", name);
+ replaceRClass(tm, Getattr(p, "type"));
+ Printf(sfun->code,"%s\n",tm);
+ }
+
+
+
+ curP = p;
+ if ((tm = Getattr(p,"tmap:in"))) {
+
+ Replaceall(tm,"$target", lname);
+ Replaceall(tm,"$source", name);
+ Replaceall(tm,"$input", name);
+
+ if (Getattr(p,"wrap:disown") || (Getattr(p,"tmap:in:disown"))) {
+ Replaceall(tm,"$disown","SWIG_POINTER_DISOWN");
+ } else {
+ Replaceall(tm,"$disown","0");
+ }
+
+ if(funcptr_name) {
+ /* have us a function pointer */
+ Printf(f->code, "if(TYPEOF(%s) != CLOSXP) {\n", name);
+ Replaceall(tm,"$R_class", "");
+ } else {
+ replaceRClass(tm, Getattr(p, "type"));
+ }
+
+
+ Printf(f->code,"%s\n",tm);
+ if(funcptr_name)
+ Printf(f->code, "} else {\n%s = %s;\nR_SWIG_pushCallbackFunctionData(%s, NULL);\n}\n",
+ lname, funcptr_name, name);
+ Printv(f->def, inFirstArg ? "" : ", ", "SEXP ", name, NIL);
+ if (Len(name) != 0)
+ inFirstArg = false;
+ p = Getattr(p,"tmap:in:next");
+
+ } else {
+ p = nextSibling(p);
+ }
+
+
+ tm = Swig_typemap_lookup_new("rtype", curP, "", 0);
+ if(tm) {
+ replaceRClass(tm, Getattr(curP, "type"));
+ }
+ Printf(s_inputTypes, "'%s'%s", tm, p ? ", " : "");
+ Printf(s_inputMap, "%s='%s'%s", name, tm, p ? ", " : "");
+
+ if(funcptr_name)
+ Delete(funcptr_name);
+ } /* end of looping over parameters. */
+
+ if(addCopyParam) {
+ Printf(sfun->def, "%s.copy = FALSE", nargs > 0 ? ", " : "");
+ Printf(f->def, "%sSEXP s_swig_copy", nargs > 0 ? ", " : "");
+
+ Printf(sargs, "as.logical(.copy), ");
+ }
+
+ Printv(f->def, ")\n{\n", NIL);
+ Printv(sfun->def, ")\n{\n", NIL);
+
+ emit_action(n, f);
+
+
+
+
+ String *outargs = NewString("");
+ int numOutArgs = isVoidReturnType ? -1 : 0;
+ for(p = l, i = 0; p; i++) {
+ String *tm;
+ if((tm = Getattr(p, "tmap:argout"))) {
+ // String *lname = Getattr(p, "lname");
+ numOutArgs++;
+ String *pos = NewStringf("%d", numOutArgs);
+ Replaceall(tm,"$source", Getattr(p, "lname"));
+ Replaceall(tm,"$result", "r_ans");
+ Replaceall(tm,"$n", pos); // The position into which to store the answer.
+ Replaceall(tm,"$arg", Getattr(p, "emit:input"));
+ Replaceall(tm,"$input", Getattr(p, "emit:input"));
+ Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
+
+
+ Printf(outargs, "%s\n", tm);
+ p = Getattr(p,"tmap:argout:next");
+ } else
+ p = nextSibling(p);
+ }
+
+ /* Deal with the explicit return value. */
+ if (returnTM) {
+ String *tm = returnTM;
+ SwigType *retType = Getattr(n, "type");
+ //Printf(stderr, "Return Value for %s, array? %s\n", retType, SwigType_isarray(retType) ? "yes" : "no");
+ /* if(SwigType_isarray(retType)) {
+ defineArrayAccessors(retType);
+ } */
+
+
+ Replaceall(tm,"$1", "result");
+ Replaceall(tm,"$result", "r_ans");
+ replaceRClass(tm, retType);
+
+ if (GetFlag(n,"feature:new")) {
+ Replaceall(tm, "$owner", "R_SWIG_OWNER");
+ } else {
+ Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
+ }
+
+ if(0 && addCopyParam) {
+ Printf(f->code, "if(LOGICAL(s_swig_copy)[0]) {\n");
+ Printf(f->code, "/* Deal with returning a reference. */\nr_ans = R_NilValue;\n");
+ Printf(f->code, "}\n else {\n");
+ }
+ Printf(f->code, "%s\n", tm);
+ if(0 && addCopyParam)
+ Printf(f->code, "}\n"); /* end of if(s_swig_copy) ... else { ... } */
+
+ } else {
+ Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number,
+ "Unable to use return type %s in function %s.\n", SwigType_str(type, 0), fname);
+ }
+
+
+ if(Len(outargs)) {
+ Wrapper_add_local(f, "R_OutputValues", "SEXP R_OutputValues");
+
+ String *tmp = NewString("");
+ if(!isVoidReturnType)
+ Printf(tmp, "PROTECT(r_ans);\n");
+
+ Printf(tmp, "PROTECT(R_OutputValues = NEW_LIST(%d));\n__r_nprotect += %d;\n",
+ numOutArgs + !isVoidReturnType,
+ isVoidReturnType ? 1 : 2);
+
+ if(!isVoidReturnType)
+ Printf(tmp, "SET_VECTOR_ELT(R_OutputValues, 0, r_ans);\n");
+ Printf(tmp, "r_ans = R_OutputValues;\n");
+
+ Insert(outargs, 0, tmp);
+ Delete(tmp);
+
+ Printf(f->code, "%s", outargs);
+ Delete(outargs);
+ }
+
+
+
+ Printv(f->code, UnProtectWrapupCode, NIL);
+
+ /*If the user gave us something to convert the result in */
+ if ((tm = Swig_typemap_lookup_new("scoerceout", n,
+ "result", sfun))) {
+ Replaceall(tm,"$source","ans");
+ Replaceall(tm,"$result","ans");
+ replaceRClass(tm, Getattr(n, "type"));
+ Chop(tm);
+ }
+
+
+ Printv(sfun->code, (Len(tm) ? "ans = " : ""), ".Call('", wname,
+ "', ", sargs, "PACKAGE='", DllName, "')\n", NIL);
+ if(Len(tm))
+ Printf(sfun->code, "%s\n\nans\n", tm);
+ if (destructor)
+ Printv(f->code, "R_ClearExternalPtr(self);\n", NIL);
+
+ Printv(f->code, "return r_ans;\n}\n", NIL);
+ Printv(sfun->code, "\n}", NIL);
+
+ Wrapper_print(f, f_wrapper);
+ Wrapper_print(sfun, sfile);
+
+ Printf(sfun->code, "\n# End of %s\n", iname);
+ tm = Swig_typemap_lookup_new("rtype", n, "", 0);
+ if(tm) {
+ SwigType *retType = Getattr(n, "type");
+ replaceRClass(tm, retType);
+ }
+
+ Printv(sfile, "attr(`", sfname, "`, 'returnType') = '",
+ isVoidReturnType ? "void" : (tm ? tm : ""),
+ "'\n", NIL);
+
+ if(nargs > 0)
+ Printv(sfile, "attr(`", sfname, "`, \"inputTypes\") = c(",
+ s_inputTypes, ")\n", NIL);
+ Printv(sfile, "class(`", sfname, "`) = c(\"SWIGFunction\", class('",
+ sfname, "'))\n\n", NIL);
+
+ if (memoryProfile) {
+ Printv(sfile, "memory.profile()\n", NIL);
+ }
+ if (aggressiveGc) {
+ Printv(sfile, "gc()\n", NIL);
+ }
+
+ // Printv(sfile, "setMethod('", name, "', '", name, "', ", iname, ")\n\n\n");
+
+
+
+ /* If we are dealing with a method in an C++ class, then
+ add the name of the R function and its definition.
+ XXX need to figure out how to store the Wrapper if possible in the hash/list.
+ Would like to be able to do this so that we can potentialy insert
+ */
+ if(processing_member_access_function || processing_class_member_function) {
+ String *tmp;
+ if(member_name)
+ tmp = member_name;
+ else
+ tmp = Getattr(n, "memberfunctionHandler:name");
+ addAccessor(member_name, sfun, iname);
+ }
+
+ if (Getattr(n, "sym:overloaded") &&
+ !Getattr(n, "sym:nextSibling")) {
+ dispatchFunction(n);
+ }
+
+ addRegistrationRoutine(wname, addCopyParam ? nargs +1 : nargs);
+
+ DelWrapper(f);
+ DelWrapper(sfun);
+
+ Delete(sargs);
+ Delete(sfname);
+ return SWIG_OK;
+}
+
+
+int R::defineArrayAccessors(SwigType *type) {
+
+ SwigType *base = SwigType_base(type);
+ String *rclass = NewStringf("%sArray", base);
+ char *prclassName = Char(rclass);
+ if(strncmp(prclassName, "struct ", 7) == 0)
+ prclassName += 7;
+
+ Node *n = NewHash();
+ Setattr(n, "type", base);
+ String *tm;
+ String *rclassName = getRClassName(base);
+ String *rclassBase = getRClassName(base, 0);
+
+ String *cGetName = NewStringf("R_SWIG_%s_get_item_", prclassName);
+ String *cSetName = NewStringf("R_SWIG_%s_set_item_", prclassName);
+
+ Wrapper *cGetItem = NewWrapper();
+
+ String *getItem = NewString(""),
+ *setItem = NewString("");
+
+ Printf(getItem, "function(x, i, j, ..., drop = TRUE) {\n");
+
+ Printf(getItem, "%sif(i < 1 || i > x@dims[1])\n%sstop('index must be between 1 and ', x@dims[1])\n", tab4, tab8);
+ Printf(getItem, "%s.Call('%s', x@ref, as.integer(i-1), PACKAGE = '%s')\n", tab4, cGetName, DllName);
+ Printf(getItem, "}\n");
+
+
+
+ Printf(setItem, "function(x, i, j, ..., value) {\n");
+
+ Printf(setItem, "%sif(i < 1 || i > x@dims[1])\n%sstop('index must be between 1 and ', x@dims[1])\n", tab4, tab8);
+
+ /* Do the SCOERCEIN and the SCHECK here */
+ tm = Swig_typemap_lookup_new("scoercein", n, "value", 0);
+ if(tm) {
+ Replaceall(tm, "$input", "s_value");
+ Replaceall(tm, "$R_class", rclassName);
+ Replaceall(tm, "$*R_class", rclassBase);
+
+ Printf(setItem, "%s%s\n", tab4, tm);
+ }
+
+ tm = Swig_typemap_lookup_new("scheck", n, "value", 0);
+ if(tm) {
+ Replaceall(tm, "$input", "s_value");
+ Replaceall(tm, "$R_class", rclassName);
+ Replaceall(tm, "$*R_class", rclassBase);
+
+ Printf(setItem, "%s%s\n", tab4, tm);
+ }
+
+
+
+ Printf(setItem, "%s.Call('%s', x@ref, as.integer(i-1), value, PACKAGE = '%s')\n", tab4, cSetName, DllName);
+ Printf(setItem, "%sx\n}\n", tab4);
+
+
+
+ Printf(cGetItem->def, "SEXP\n%s(SEXP s_x, SEXP s_i)\n{\n", cGetName);
+
+ String *tmp = NewStringf("%s *ptr", SwigType_lstr(base, 0));
+ String *tmp1 = NewStringf("%s result", SwigType_lstr(base, 0));
+
+ Wrapper_add_localv(cGetItem, "r_vmax", "char *", "r_vmax = vmaxget()", NIL);
+ Wrapper_add_local(cGetItem, "ptr", tmp);
+ Wrapper_add_local(cGetItem, "r_ans", "SEXP r_ans");
+ Wrapper_add_local(cGetItem, "result", tmp1);
+ Wrapper_add_local(cGetItem, "__r_nprotect", "int __r_nprotect = 0");
+
+ Printf(cGetItem->code, "ptr = (%s *) R_SWIG_resolveExternalRef(s_x, \"\", \"s_x\", 0);\n", SwigType_lstr(base, 0));
+ Printf(cGetItem->code, "result = ptr[INTEGER(s_i)[0]];\n", tmp);
+
+
+ tm = Swig_typemap_lookup_new("out", n, "result", 0);
+ if(tm) {
+ Replaceall(tm, "$result", "r_ans");
+ Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
+ Printf(cGetItem->code, "%s\n", tm);
+ }
+
+ Delete(tmp); Delete(tmp1);
+
+ Printf(cGetItem->code, "%s\nreturn r_ans;\n}\n\n", UnProtectWrapupCode);
+
+
+ /******************************/
+ /*
+ R_SWIG_..._set_item(SEXP x, SEXP s_i, SEXP s_value) {
+ char *r_vmax = vmaxget();
+ int __r_nprotect = 0;
+ type *ptr, *el, value;
+
+ ptr = (type *) R_SWIG_resolveExternalRef(s_x, "", "s_x", 0);
+
+ ptr[INTEGER(s_i)[0]] = *el;
+
+ cleanup
+ return
+ }
+ */
+ Wrapper *cSetItem = NewWrapper();
+ {
+
+ Printf(cSetItem->def, "SEXP\n%s(SEXP s_x, SEXP s_i, SEXP s_value)\n{\n", cSetName);
+
+ tmp = NewStringf("%s *ptr", SwigType_lstr(base, 0));
+ tmp1 = NewStringf("%s value", SwigType_lstr(base, 0));
+
+ Wrapper_add_localv(cSetItem, "r_vmax", "char *", "r_vmax = vmaxget()", NIL);
+ Wrapper_add_local(cSetItem, "__r_nprotect", "int __r_nprotect = 0");
+
+ Wrapper_add_local(cSetItem, "ptr", tmp);
+ Wrapper_add_local(cSetItem, "value", tmp1);
+ Replaceall(tmp, "*ptr", "*el = &value");
+ Wrapper_add_local(cSetItem, "el", tmp);
+
+ Printf(cSetItem->code,
+ "ptr = (%s *) R_SWIG_resolveExternalRef(s_x, \"\", \"s_x\", 0);\n",
+ SwigType_lstr(base, 0));
+
+
+ String *tm = Swig_typemap_lookup_new("in", n, "value", 0);
+ if(tm) {
+ String *rclassName = getRClassName(base);
+ String *rclassBase = getRClassName(base, 0);
+ Replaceall(tm, "$input", "s_value");
+ Replaceall(tm, "$*1", "value");
+ //XXX think about what we really mean here.
+ Replaceall(tm, "$1", "el");
+
+ Replaceall(tm, "$R_class", rclassName);
+ Replaceall(tm, "$*R_class", rclassBase);
+
+ Printf(cSetItem->code, "%s\n", tm);
+
+ Delete(rclassName); Delete(rclassBase);
+ }
+ Printf(cSetItem->code, "ptr[INTEGER(s_i)[0]] = *el;\n", tmp);
+ }
+ Printf(cSetItem->code, "%s\nreturn R_NilValue;\n}\n\n", UnProtectWrapupCode);
+
+ /*************************/
+
+
+ Wrapper_print(cGetItem, f_wrapper);
+ Wrapper_print(cSetItem, f_wrapper);
+
+ String *elClass = NewStringf("_p%s", SwigType_manglestr(base));
+ if(!Getattr(SClassDefs, elClass)) {
+ if (debugMode)
+ Printf(stderr, " Defining class %s\n", elClass);
+ Printf(s_classes, "setClass('%s', contains = 'ExternalReference')\n", elClass);
+ //Add to namespace
+ Setattr(SClassDefs, elClass, elClass);
+ }
+ Delete(elClass);
+
+ if(!Getattr(SClassDefs, rclassName)) {
+ Setattr(SClassDefs, rclassName, rclassName);
+ Printf(s_classes, "setClass('%s', contains = 'SWIGArray')\n", rclassName);
+ }
+
+ Printf(s_classes, "setMethod('[', '%s',\n%s)\n", rclassName, getItem);
+ Printf(s_classes, "setMethod('[<-', '%s',\n%s)\n", rclassName, setItem);
+
+
+ Delete(n);
+ DelWrapper(cGetItem);
+ DelWrapper(cSetItem);
+ Delete(rclass);
+ Delete(cGetName);
+
+ return SWIG_OK;
+}
+
+
+/*****************************************************
+ Add the specified routine name to the collection of
+ generated routines that are called from R functions.
+ This is used to register the routines with R for
+ resolving symbols.
+
+ rname - the name of the routine
+ nargs - the number of arguments it expects.
+******************************************************/
+int R::addRegistrationRoutine(String *rname, int nargs) {
+ if(!registrationTable)
+ registrationTable = NewHash();
+
+ String *el =
+ NewStringf("{\"%s\", (DL_FUNC) &%s, %d}", rname, rname, nargs);
+
+ Setattr(registrationTable, rname, el);
+
+ return SWIG_OK;
+}
+
+/*****************************************************
+ Write the registration information to an array and
+ create the initialization routine for registering
+ these.
+******************************************************/
+int R::outputRegistrationRoutines(File *out) {
+ int i, n;
+ if(!registrationTable)
+ return(0);
+ if(inCPlusMode)
+ Printf(out, "#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n");
+
+ Printf(out, "#include \n\n");
+ if(inCPlusMode)
+ Printf(out, "#ifdef __cplusplus\n}\n#endif\n\n");
+
+ Printf(out, "SWIGINTERN R_CallMethodDef CallEntries[] = {\n");
+
+ List *keys = Keys(registrationTable);
+ n = Len(keys);
+ for(i = 0; i < n; i++)
+ Printf(out, " %s,\n", Getattr(registrationTable, Getitem(keys, i)));
+
+ Printf(out, " {NULL, NULL, 0}\n};\n\n");
+
+ if(!noInitializationCode) {
+ if (inCPlusMode)
+ Printv(out, "extern \"C\" ", NIL);
+ Printf(out, "SWIGEXPORT void R_init_%s_wrap(DllInfo *dll) {\n", Rpackage);
+ Printf(out, "%sR_registerRoutines(dll, NULL, CallEntries, NULL, NULL);\n", tab4);
+ if(Len(s_init_routine)) {
+ Printf(out, "\n%s\n", s_init_routine);
+ }
+ Printf(out, "}\n");
+ }
+
+ return n;
+}
+
+
+
+/****************************************************************************
+ Process a struct, union or class declaration in the source code,
+ or an anonymous typedef struct
+
+*****************************************************************************/
+//XXX What do we need to do here -
+// Define an S4 class to refer to this.
+
+void R::registerClass(Node *n) {
+ String *name = Getattr(n, "name");
+ String *kind = Getattr(n, "kind");
+
+ if (debugMode)
+ Swig_print_node(n);
+ String *sname = NewStringf("_p%s", SwigType_manglestr(name));
+ if(!Getattr(SClassDefs, sname)) {
+ Setattr(SClassDefs, sname, sname);
+ String *base;
+
+ if(Strcmp(kind, "class") == 0) {
+ base = NewString("");
+ List *l = Getattr(n, "bases");
+ if(Len(l)) {
+ Printf(base, "c(");
+ for(int i = 0; i < Len(l); i++) {
+ registerClass(Getitem(l, i));
+ Printf(base, "'_p%s'%s",
+ SwigType_manglestr(Getattr(Getitem(l, i), "name")),
+ i < Len(l)-1 ? ", " : "");
+ }
+ Printf(base, ")");
+ } else {
+ base = NewString("'C++Reference'");
+ }
+ } else
+ base = NewString("'ExternalReference'");
+
+ Printf(s_classes, "setClass('%s', contains = %s)\n", sname, base);
+ Delete(base);
+ }
+
+}
+
+int R::classDeclaration(Node *n) {
+
+ String *name = Getattr(n, "name");
+ String *kind = Getattr(n, "kind");
+
+ if (debugMode)
+ Swig_print_node(n);
+ registerClass(n);
+
+
+ /* If we have a typedef union { ... } U, then we never get to see the typedef
+ via a regular call to typedefHandler. Instead, */
+ if(Getattr(n, "unnamed") && Strcmp(Getattr(n, "storage"), "typedef") == 0
+ && Getattr(n, "tdname") && Strcmp(Getattr(n, "tdname"), name) == 0) {
+ if (debugMode)
+ Printf(stderr, "Typedef in the class declaration for %s\n", name);
+ // typedefHandler(n);
+ }
+
+ bool opaque = GetFlag(n, "feature:opaque");
+
+ if(opaque)
+ opaqueClassDeclaration = name;
+
+ int status = Language::classDeclaration(n);
+
+ opaqueClassDeclaration = NULL;
+
+
+ // OutputArrayMethod(name, class_member_functions, sfile);
+ OutputMemberReferenceMethod(name, 0, class_member_functions, sfile);
+ OutputMemberReferenceMethod(name, 1, class_member_set_functions, sfile);
+
+ if(class_member_functions) {
+ Delete(class_member_functions);
+ class_member_functions = NULL;
+ }
+ if(class_member_set_functions) {
+ Delete(class_member_set_functions);
+ class_member_set_functions = NULL;
+ }
+ if (Getattr(n, "has_destructor")) {
+ Printf(sfile, "setMethod('delete', '_p%s', function(obj) {delete%s(obj)})\n",
+ getRClassName(Getattr(n, "name")),
+ getRClassName(Getattr(n, "name")));
+
+ }
+ if(!opaque && !Strcmp(kind, "struct") && copyStruct) {
+
+ String *def =
+ NewStringf("setClass(\"%s\",\n%srepresentation(\n", name, tab4);
+ bool firstItem = true;
+
+ for(Node *c = firstChild(n); c; ) {
+ String *elName;
+ String *tp;
+
+ elName = Getattr(c, "name");
+ String *elKind = Getattr(c, "kind");
+ if (Strcmp(elKind, "variable") != 0) {
+ c = nextSibling(c);
+ continue;
+ }
+ if (!Len(elName)) {
+ c = nextSibling(c);
+ continue;
+ }
+#if 0
+ tp = getRType(c);
+#else
+ tp = Swig_typemap_lookup_new("rtype", c, "", 0);
+ if(!tp) {
+ c = nextSibling(c);
+ continue;
+ }
+ if (Strstr(tp, "R_class")) {
+ c = nextSibling(c);
+ continue;
+ }
+ if (Strcmp(tp, "character") &&
+ Strstr(Getattr(c, "decl"), "p.")) {
+ c = nextSibling(c);
+ continue;
+ }
+
+ if (!firstItem) {
+ Printf(def, ",\n");
+ }
+ // else
+ //XXX How can we tell if this is already done.
+ // SwigType_push(elType, elDecl);
+
+
+ // returns "" tp = processType(elType, c, NULL);
+ // Printf(stderr, " elType %p\n", elType);
+ // tp = getRClassNameCopyStruct(Getattr(c, "type"), 1);
+#endif
+
+ Printf(def, "%s%s = \"%s\"", tab8, elName, tp);
+ firstItem = false;
+ Delete(tp);
+ c = nextSibling(c);
+ }
+ Printf(def, "),\n%scontains = \"RSWIGStruct\")\n", tab8);
+ Printf(s_classes, "%s\n\n# End class %s\n\n", def, name);
+
+ generateCopyRoutines(n);
+
+ Delete(def);
+ }
+
+ return status;
+}
+
+
+
+/***************************************************************
+ Create the C routines that copy an S object of the class given
+ by the given struct definition in Node *n to the C value
+ and also the routine that goes from the C routine to an object
+ of this S class.
+****************************************************************/
+/*XXX
+ Clean up the toCRef - make certain the names are correct for the types, etc.
+ in all cases.
+*/
+
+// This procedure is for reference
+int R::generateCopyRoutinesObsolete(Node *n) {
+ Wrapper *toC = NewWrapper();
+ Wrapper *toCRef = NewWrapper();
+ Wrapper *toR = NewWrapper();
+
+ Wrapper *copyToR = NewWrapper();
+ Wrapper *copyToC = NewWrapper();
+
+
+ String *name = Getattr(n, "name");
+ String *tdname = Getattr(n, "tdname");
+ String *kind = Getattr(n, "kind");
+ String *type;
+
+ if(Len(tdname)) {
+ type = Copy(tdname);
+ } else {
+ type = NewStringf("%s %s", kind, name);
+ }
+
+
+#ifdef R_SWIG_VERBOSE
+ if (debugMode)
+ Printf(stderr, "generateCopyRoutines: name = %s, %s\n", name, type);
+#endif
+
+ String *rclassNameRef = getRClassName(type, 1);
+ String *copyRefRefName = NewStringf("R_swig_copy_%sRef_%sRef", rclassNameRef, rclassNameRef);
+ String *toCName = NewStringf("R_swig_copy_%sRef_to_C", name);
+ String *toRName = NewStringf("R_swig_copy_%sRef_to_R", name);
+
+ addRegistrationRoutine(copyRefRefName, 2);
+ addRegistrationRoutine(toCName, 2);
+ addRegistrationRoutine(toRName, 1);
+
+ Printf(toC->def, "int\n%s(SEXP sobj, %s *value)", toCName, type);
+ Printf(toR->def, "SEXP\n%s(%s *value)", toRName, type);
+ Printf(toCRef->def, "SEXP\n%s(SEXP s_src, SEXP s_dest) {", copyRefRefName, type, type);
+
+ Delete(toCName);
+ Delete(toRName);
+
+ String *tmp = NewStringf("%s *src", type);
+ Wrapper_add_local(toCRef, "src", tmp);
+ Delete(tmp);
+ tmp = NewStringf("%s *dest", type);
+ Wrapper_add_local(toCRef, "dest", tmp);
+ Delete(tmp);
+
+ Printf(toCRef->code, "src = (%s *) R_SWIG_resolveExternalRef(s_src, \"%sRef\", \"s_src\", (Rboolean) FALSE);\n",
+ type, rclassNameRef);
+ Printf(toCRef->code, "dest = (%s *) R_SWIG_resolveExternalRef(s_dest, \"%sRef\", \"s_dest\", (Rboolean) FALSE);\n",
+ type, rclassNameRef);
+ Printf(toCRef->code, "memcpy(dest, src, sizeof(*src));\nreturn R_NilValue;\n}\n\n");
+
+
+
+ Wrapper_add_localv(toR, "r_obj", "SEXP", "r_obj", NIL);
+ Wrapper_add_localv(toR, "r_vmax", "char *", "r_vmax = vmaxget()", NIL);
+ Wrapper_add_localv(toR, "_tmp_sexp", "SEXP", "_tmp_sexp", NIL);
+ Wrapper_add_local(toR, "__r_nprotect", "int __r_nprotect = 0");
+ Wrapper_add_local(toC, "ecode", "int ecode = 0");
+
+ Printf(copyToR->def, "%sCopyToR = function(value, obj = new(\"%s\"))\n{\n", name, name);
+ Printf(copyToC->def, "%sCopyToC = function(value, obj)\n{\n", name);
+
+
+ Printf(toR->code, "PROTECT(r_obj = NEW_OBJECT(MAKE_CLASS(\"%s\")));\n__r_nprotect++;\n\n", name);
+
+ Wrapper_add_localv(toC, "_tmp_sexp", "SEXP", "_tmp_sexp", NIL);
+
+ Node *c = firstChild(n);
+ // Swig_typemap_attach_parms("in", c, toR);
+ // Swig_typemap_attach_parms("out", c, toR);
+
+ for(; c; c = nextSibling(c)) {
+ String *elName = Getattr(c, "name");
+ if (!Len(elName)) {
+ continue;
+ }
+ String *tp = Swig_typemap_lookup_new("rtype", c, "", 0);
+ if(!tp) {
+ continue;
+ }
+ /* The S functions to get and set the member value. */
+ String *symname = Getattr(c, "sym:name");
+ String *ClassPrefix = Getattr(n, "sym:name");
+ String *get = Swig_name_get(Swig_name_member(Char(ClassPrefix), symname));
+ String *set = Swig_name_set(Swig_name_member(Char(ClassPrefix), symname));
+
+
+#if 0
+ This is already done now in getRType().
+ If that for some reason no longer gets called, this had better go back.
+ SwigType *elTT = Getattr(c, "type");
+ SwigType *decl = Getattr(c, "decl");
+ SwigType_push(elTT, decl);
+#endif
+
+
+ Printf(copyToR->code, "obj@%s = %s(value)\n", elName, get);
+ Printf(copyToC->code, "%s(obj, value@%s)\n", set, elName);
+
+
+ String *field = NewStringf("value->%s", elName);
+ SwigType *elType = Getattr(c, "type");
+
+
+ String *tm = Swig_typemap_lookup_new("out", c, field, 0);
+ if(tm) {
+#ifdef R_SWIG_VERBOSE
+ if (debugMode)
+ Printf(stderr, "Got conversion to R for '%s': '%s' '%s' -> '%s'\n", elName, elType, elTT, tm);
+#endif
+
+ //XXX Get the field in as the rhs.
+ // What about looking in the "memberin"/"memberout" typemaps.
+ Replaceall(tm, "$1", Char(field));
+ Replaceall(tm, "$result", "_tmp_sexp");
+ Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
+ replaceRClass(tm,elType);
+
+
+ Printf(toR->code, "%s\nPROTECT(_tmp_sexp);\n__r_nprotect++;\n", tm);
+ Printf(toR->code, "PROTECT(r_obj = R_do_slot_assign(r_obj, mkString(\"%s\"), _tmp_sexp));\n__r_nprotect++;\n\n", elName);
+ } else {
+ Printf(stderr, "*** Can't convert field %s in \n", elName);
+ }
+
+
+
+ char *field_p = Char(field);
+ tm = Swig_typemap_lookup_new("in", c, field_p, 0);
+ if(tm && !GetFlag(c, "feature:immutable")) {
+ replaceRClass(tm,elType);
+ if (debugMode)
+ Printf(stderr, "typemap (in) for %s => %s\n",
+ SwigType_str(elType, 0), tm);
+ String *tmp1 =
+ NewStringf("%s val", SwigType_lstr(elType, 0));
+ Wrapper_add_local(toC, "val", tmp1);
+ Replaceall(tm, "$input", "_tmp_sexp");
+ if (debugMode)
+ Printf(stderr, "Got conversion to C for %s: %s. %s\n",
+ elName, tm, field);
+#ifdef R_SWIG_VERBOSE
+#endif
+ Printf(toC->code, "_tmp_sexp = GET_SLOT(sobj, mkString(\"%s\"));\n%s\n\n", elName, tm);
+ Delete(field);
+ }
+ /*
+
+ Replaceall(conversion, "$1", field);
+ Printf(toC->code, "value->%s = ;\n", name);
+ */
+ }
+
+ Printv(toR->code, UnProtectWrapupCode,
+ "\nreturn(r_obj);\n}\n", NIL);
+
+ Printf(toC->code, "\nreturn(1);\n}\n");
+
+
+ Printf(f_wrapper, "%s;\n", toR->def);
+ Printf(f_wrapper, "%s;\n", toC->def);
+
+ Printf(toR->def, "\n{\n");
+ Printf(toC->def, "\n{\n");
+
+ String *rclassName = getRClassName(type, 0); // without the Ref.
+
+ Printf(copyToR->code, "obj\n}\n\n");
+
+ Printf(sfile, "# Start definition of copy functions & methods for %s\n", rclassName);
+
+ Wrapper_print(copyToR, sfile);
+ Printf(copyToC->code, "obj\n}\n\n");
+ Wrapper_print(copyToC, sfile);
+
+
+ Printf(sfile, "# Start definition of copy methods for %s\n", rclassName);
+ Printf(sfile, "setMethod('copyToR', '%sRef', %sCopyToR)\n", rclassName, name);
+ Printf(sfile, "setMethod('copyToC', '%s', %sCopyToC)\n\n", rclassName, name);
+ Printv(sfile, "setMethod('copyToC', c('", rclassName, "Ref', '", rclassName, "Ref'),",
+ " function(value, obj) {\n",
+ tab4, ".Call(\"", copyRefRefName, "\", value, obj, PACKAGE = \"",
+ DllName, "\")\n})\n\n", NIL);
+ Printf(sfile, "# End definition of copy methods for %s\n", rclassName);
+ Printf(sfile, "# End definition of copy functions & methods for %s\n", rclassName);
+
+ String *m = NewStringf("%sCopyToR", name);
+ addNamespaceMethod(m);
+ char *tt = Char(m); tt[Len(m)-1] = 'C';
+ addNamespaceMethod(m);
+ Delete(m);
+
+
+ Delete(rclassName);
+
+ DelWrapper(copyToR);
+ DelWrapper(copyToC);
+
+ Wrapper_print(toR, f_wrapper);
+ Wrapper_print(toC, f_wrapper);
+ Wrapper_print(toCRef, f_wrapper);
+
+ DelWrapper(toR);
+ DelWrapper(toC);
+ DelWrapper(toCRef);
+
+ return SWIG_OK;
+}
+
+int R::generateCopyRoutines(Node *n) {
+ Wrapper *copyToR = NewWrapper();
+ Wrapper *copyToC = NewWrapper();
+
+ String *name = Getattr(n, "name");
+ String *tdname = Getattr(n, "tdname");
+ String *kind = Getattr(n, "kind");
+ String *type;
+
+ if(Len(tdname)) {
+ type = Copy(tdname);
+ } else {
+ type = NewStringf("%s %s", kind, name);
+ }
+
+ String *mangledName = SwigType_manglestr(name);
+
+ if (debugMode)
+ Printf(stderr, "generateCopyRoutines: name = %s, %s\n", name, type);
+
+ Printf(copyToR->def, "CopyToR%s = function(value, obj = new(\"%s\"))\n{\n",
+ mangledName, name);
+ Printf(copyToC->def, "CopyToC%s = function(value, obj)\n{\n",
+ mangledName);
+
+ Node *c = firstChild(n);
+
+ for(; c; c = nextSibling(c)) {
+ String *elName = Getattr(c, "name");
+ if (!Len(elName)) {
+ continue;
+ }
+ String *elKind = Getattr(c, "kind");
+ if (Strcmp(elKind, "variable") != 0) {
+ Delete(elKind);
+ continue;
+ }
+
+ String *tp = Swig_typemap_lookup_new("rtype", c, "", 0);
+ if(!tp) {
+ continue;
+ }
+ if (Strstr(tp, "R_class")) {
+ continue;
+ }
+ if (Strcmp(tp, "character") &&
+ Strstr(Getattr(c, "decl"), "p.")) {
+ continue;
+ }
+
+
+ /* The S functions to get and set the member value. */
+ Printf(copyToR->code, "obj@%s = value$%s\n", elName, elName);
+ Printf(copyToC->code, "obj$%s = value@%s\n", elName, elName);
+ }
+ Printf(copyToR->code, "obj\n}\n\n");
+ String *rclassName = getRClassNameCopyStruct(type, 0); // without the Ref.
+ Printf(sfile, "# Start definition of copy functions & methods for %s\n", rclassName);
+
+ Wrapper_print(copyToR, sfile);
+ Printf(copyToC->code, "obj\n}\n\n");
+ Wrapper_print(copyToC, sfile);
+
+
+ Printf(sfile, "# Start definition of copy methods for %s\n", rclassName);
+ Printf(sfile, "setMethod('copyToR', '_p_%s', CopyToR%s)\n", rclassName,
+ mangledName);
+ Printf(sfile, "setMethod('copyToC', '%s', CopyToC%s)\n\n", rclassName,
+ mangledName);
+
+ Printf(sfile, "# End definition of copy methods for %s\n", rclassName);
+ Printf(sfile, "# End definition of copy functions & methods for %s\n", rclassName);
+
+ String *m = NewStringf("%sCopyToR", name);
+ addNamespaceMethod(m);
+ char *tt = Char(m); tt[Len(m)-1] = 'C';
+ addNamespaceMethod(m);
+ Delete(m);
+ Delete(rclassName);
+ Delete(mangledName);
+ DelWrapper(copyToR);
+ DelWrapper(copyToC);
+
+ return SWIG_OK;
+}
+
+
+
+/*****
+ Called when there is a typedef to be invoked.
+
+ XXX Needs to be enhanced or split to handle the case where we have a
+ typedef within a classDeclaration emission because the struct/union/etc.
+ is anonymous.
+******/
+int R::typedefHandler(Node *n) {
+ SwigType *tp = Getattr(n, "type");
+ String *type = Getattr(n, "type");
+ if (debugMode)
+ Printf(stderr, " %s\n", Getattr(n, "name"));
+
+ processType(tp, n);
+
+ if(Strncmp(type, "struct ", 7) == 0) {
+ String *name = Getattr(n, "name");
+ char *trueName = Char(type);
+ trueName += 7;
+ if (debugMode)
+ Printf(stderr, " Defining S class %s\n", trueName);
+ Printf(s_classes, "setClass('_p%s', contains = 'ExternalReference')\n",
+ SwigType_manglestr(name));
+ }
+
+ return Language::typedefHandler(n);
+}
+
+
+
+/*********************
+ Called when processing a field in a "class", i.e. struct, union or
+ actual class. We set a state variable so that we can correctly
+ interpret the resulting functionWrapper() call and understand that
+ it is for a field element.
+**********************/
+int R::membervariableHandler(Node *n) {
+ SwigType *t(Getattr(n, "type"));
+ processType(t, n, NULL);
+ processing_member_access_function = 1;
+ member_name = Getattr(n,"sym:name");
+ if (debugMode)
+ Printf(stderr, " name = %s, sym:name = %s\n",
+ Getattr(n, "name"), member_name);
+
+ int status(Language::membervariableHandler(n));
+
+ if(opaqueClassDeclaration == NULL && debugMode)
+ Printf(stderr, " %s %s\n", Getattr(n, "name"), Getattr(n, "type"));
+
+ processing_member_access_function = 0;
+ member_name = NULL;
+
+ return status;
+}
+
+
+/*
+ This doesn't seem to get used so leave it out for the moment.
+*/
+String * R::runtimeCode() {
+ String *s = Swig_include_sys("rrun.swg");
+ if (!s) {
+ Printf(stderr, "*** Unable to open 'rrun.swg'\n");
+ s = NewString("");
+ }
+ return s;
+}
+
+
+/**
+ Called when SWIG wants to initialize this
+ We initialize anythin we want here.
+ Most importantly, tell SWIG where to find the files (e.g. r.swg) for this module.
+ Use Swig_mark_arg() to tell SWIG that it is understood and not to throw an error.
+**/
+void R::main(int argc, char *argv[]) {
+ bool cppcast = true;
+ init();
+ SWIG_library_directory("r");
+ SWIG_config_file("r.swg");
+ Preprocessor_define("SWIGR 1", 0);
+ debugMode = false;
+ copyStruct = true;
+ memoryProfile = false;
+ aggressiveGc = false;
+ inCPlusMode = false;
+ outputNamespaceInfo = false;
+ noInitializationCode = false;
+
+ this->argc = argc;
+ this->argv = argv;
+
+ allow_overloading();// can we support this?
+
+ for(int i = 0; i < argc; i++) {
+ if(strcmp(argv[i], "-package") == 0) {
+ Swig_mark_arg(i);
+ i++;
+ Swig_mark_arg(i);
+ Rpackage = argv[i];
+ DllName = argv[i];
+ } else if(strcmp(argv[i], "-dll") == 0) {
+ Swig_mark_arg(i);
+ i++;
+ Swig_mark_arg(i);
+ DllName = argv[i];
+ } else if(strcmp(argv[i], "-help") == 0) {
+ showUsage();
+ } else if(strcmp(argv[i], "-namespace") == 0) {
+ outputNamespaceInfo = true;
+ Swig_mark_arg(i);
+ } else if(!strcmp(argv[i], "-no-init-code")) {
+ noInitializationCode = true;
+ Swig_mark_arg(i);
+ } else if(!strcmp(argv[i], "-c++")) {
+ inCPlusMode = true;
+ Swig_mark_arg(i);
+ Printf(s_classes, "setClass('C++Reference', contains = 'ExternalReference')\n");
+ } else if(!strcmp(argv[i], "-debug")) {
+ debugMode = true;
+ Swig_mark_arg(i);
+ } else if (!strcmp(argv[i],"-cppcast")) {
+ cppcast = true;
+ Swig_mark_arg(i);
+ } else if (!strcmp(argv[i],"-nocppcast")) {
+ cppcast = false;
+ Swig_mark_arg(i);
+ } else if (!strcmp(argv[i],"-copystruct")) {
+ copyStruct = true;
+ Swig_mark_arg(i);
+ } else if (!strcmp(argv[i], "-nocopystruct")) {
+ copyStruct = false;
+ Swig_mark_arg(i);
+ } else if (!strcmp(argv[i], "-memoryprof")) {
+ memoryProfile = true;
+ Swig_mark_arg(i);
+ } else if (!strcmp(argv[i], "-nomemoryprof")) {
+ memoryProfile = false;
+ Swig_mark_arg(i);
+ } else if (!strcmp(argv[i], "-aggressivegc")) {
+ aggressiveGc = true;
+ Swig_mark_arg(i);
+ } else if (!strcmp(argv[i], "-noaggressivegc")) {
+ aggressiveGc = false;
+ Swig_mark_arg(i);
+ }
+
+ if (cppcast) {
+ Preprocessor_define((DOH *) "SWIG_CPLUSPLUS_CAST", 0);
+ }
+ /// copyToR copyToC functions.
+
+ }
+}
+
+/*
+ Could make this work for String or File and then just store the resulting string
+ rather than the collection of arguments and argc.
+*/
+int
+R::outputCommandLineArguments(File *out)
+{
+ if(argc < 1 || !argv || !argv[0])
+ return(-1);
+
+ Printf(out, "## Generated via the command line invocation:\n##\t");
+ for(int i = 0; i < argc ; i++) {
+ Printf(out, " %s", argv[i]);
+ }
+ Printf(out, "\n\n\n");
+
+ return argc;
+}
+
+
+
+/* How SWIG instantiates an object from this module.
+ See swigmain.cxx */
+extern "C"
+Language *swig_r(void)
+{
+ return new R();
+}
+
+
+
+/*************************************************************************************/
+
+/*
+ Needs to be reworked.
+*/
+String * R::processType(SwigType *t, Node *n, int *nargs) {
+ //XXX Need to handle typedefs, e.g.
+ // a type which is a typedef to a function pointer.
+
+ SwigType *tmp = Getattr(n, "tdname");
+ if (debugMode)
+ Printf(stderr, "processType %s (tdname = %s)\n", Getattr(n, "name"), tmp);
+
+ SwigType *td = t;
+ if (expandTypedef(t) &&
+ SwigType_istypedef(t)) {
+ SwigType *resolved =
+ SwigType_typedef_resolve_all(t);
+ if (expandTypedef(resolved)) {
+ td = Copy(resolved);
+ }
+ }
+
+ if(!td) {
+ int count = 0;
+ String *b = getRTypeName(t, &count);
+ if(count && b && !Getattr(SClassDefs, b)) {
+ if (debugMode)
+ Printf(stderr, " Defining class %s\n", b);
+
+ Printf(s_classes, "setClass('%s', contains = 'ExternalReference')\n", b);
+ Setattr(SClassDefs, b, b);
+ }
+
+ }
+
+
+ if(td)
+ t = td;
+
+ String *prefix = SwigType_prefix(t);
+ // String *base = SwigType_base(t);
+
+ if(Strncmp(prefix, "p.f", 3) == 0) {
+ if (debugMode)
+ Printf(stderr,
+ " Defining pointer handler %s\n", t);
+
+ String *tmp = createFunctionPointerHandler(t, n, nargs);
+ return tmp;
+ }
+
+#if 0
+ SwigType_isfunction(t) && SwigType_ispointer(t)
+#endif
+
+ return NULL;
+}
+
+
+
+
+
+
+
+
+
+/*************************************************************************************/
+
+
+
+
+
diff --git a/Source/Modules/swigmain.cxx b/Source/Modules/swigmain.cxx
index a5ba0cecc..47f4a46b0 100644
--- a/Source/Modules/swigmain.cxx
+++ b/Source/Modules/swigmain.cxx
@@ -45,6 +45,7 @@ extern "C" {
Language *swig_clisp(void);
Language *swig_cffi(void);
Language *swig_uffi(void);
+ Language *swig_r(void);
}
struct swig_module {
@@ -82,6 +83,7 @@ static swig_module modules[] = {
{"-tcl8", swig_tcl, 0},
{"-uffi", swig_uffi, "Common Lisp / UFFI"},
{"-xml", swig_xml, "XML"},
+ {"-r", swig_r, "R (aka GNU S)"},
{NULL, NULL, NULL}
};
diff --git a/configure.in b/configure.in
index 14c13d349..0ce8cb7b0 100644
--- a/configure.in
+++ b/configure.in
@@ -1923,6 +1923,7 @@ AC_CONFIG_FILES([ \
Examples/test-suite/clisp/Makefile \
Examples/test-suite/cffi/Makefile \
Examples/test-suite/uffi/Makefile \
+ Examples/test-suite/r/Makefile
])
AC_CONFIG_FILES([preinst-swig], [chmod +x preinst-swig])
AC_OUTPUT