r.swg 6.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272
  1. /* */
  2. %insert("header") "swiglabels.swg"
  3. %insert("header") "swigerrors.swg"
  4. %insert("init") "swiginit.swg"
  5. %insert("runtime") "swigrun.swg"
  6. %insert("runtime") "rrun.swg"
  7. %init %{
  8. SWIGEXPORT void SWIG_init(void) {
  9. %}
  10. %include <rkw.swg>
  11. #define %Rruntime %insert("s")
  12. #define SWIG_Object SEXP
  13. #define VOID_Object R_NilValue
  14. #define %append_output(obj) SET_VECTOR_ELT($result, $n, obj)
  15. %define %set_constant(name, obj) %begin_block
  16. SEXP _obj = obj;
  17. assign(name, _obj);
  18. %end_block %enddef
  19. %define %raise(obj,type,desc)
  20. return R_NilValue;
  21. %enddef
  22. %insert("sinit") "srun.swg"
  23. %insert("sinitroutine") %{
  24. SWIG_init();
  25. SWIG_InitializeModule(0);
  26. %}
  27. %include <typemaps/swigmacros.swg>
  28. %typemap(in) (double *x, int len) %{
  29. $1 = REAL(x);
  30. $2 = Rf_length(x);
  31. %}
  32. /* XXX
  33. Need to worry about inheritance, e.g. if B extends A
  34. and we are looking for an A[], then B elements are okay.
  35. */
  36. %typemap(scheck) SWIGTYPE[ANY]
  37. %{
  38. # assert(length($input) > $1_dim0)
  39. assert(all(sapply($input, class) == "$R_class"));
  40. %}
  41. %typemap(out) void "";
  42. %typemap(in) int *, int[ANY],
  43. signed int *, signed int[ANY],
  44. unsigned int *, unsigned int[ANY],
  45. short *, short[ANY],
  46. signed short *, signed short[ANY],
  47. unsigned short *, unsigned short[ANY],
  48. long *, long[ANY],
  49. signed long *, signed long[ANY],
  50. unsigned long *, unsigned long[ANY],
  51. long long *, long long[ANY],
  52. signed long long *, signed long long[ANY],
  53. unsigned long long *, unsigned long long[ANY]
  54. {
  55. { int _rswigi;
  56. int _rswiglen = LENGTH($input);
  57. $1 = %static_cast(calloc(sizeof($1_basetype), _rswiglen), $1_ltype);
  58. for (_rswigi=0; _rswigi< _rswiglen; _rswigi++) {
  59. $1[_rswigi] = INTEGER($input)[_rswigi];
  60. }
  61. }
  62. }
  63. %typemap(in) float *, float[ANY],
  64. double *, double[ANY]
  65. {
  66. { int _rswigi;
  67. int _rswiglen = LENGTH($input);
  68. $1 = %static_cast(calloc(sizeof($1_basetype), _rswiglen), $1_ltype);
  69. for (_rswigi=0; _rswigi<_rswiglen; _rswigi++) {
  70. $1[_rswigi] = REAL($input)[_rswigi];
  71. }
  72. }
  73. }
  74. %typemap(freearg,noblock=1) int *, int[ANY],
  75. signed int *, signed int[ANY],
  76. unsigned int *, unsigned int[ANY],
  77. short *, short[ANY],
  78. signed short *, signed short[ANY],
  79. unsigned short *, unsigned short[ANY],
  80. long *, long[ANY],
  81. signed long *, signed long[ANY],
  82. unsigned long *, unsigned long[ANY],
  83. long long *, long long[ANY],
  84. signed long long *, signed long long[ANY],
  85. unsigned long long *, unsigned long long[ANY],
  86. float *, float[ANY],
  87. double *, double[ANY]
  88. %{
  89. free($1);
  90. %}
  91. %typemap(freearg, noblock=1) int *OUTPUT,
  92. signed int *OUTPUT,
  93. unsigned int *OUTPUT,
  94. short *OUTPUT,
  95. signed short *OUTPUT,
  96. unsigned short *OUTPUT,
  97. long *OUTPUT,
  98. signed long *OUTPUT,
  99. unsigned long *OUTPUT,
  100. long long *OUTPUT,
  101. signed long long *OUTPUT,
  102. unsigned long long *OUTPUT,
  103. float *OUTPUT,
  104. double *OUTPUT,
  105. char *OUTPUT,
  106. signed char *OUTPUT,
  107. unsigned char *OUTPUT
  108. {}
  109. /* Should we recycle to make the length correct.
  110. And warn if length() > the dimension.
  111. */
  112. %typemap(scheck) SWIGTYPE [ANY] %{
  113. # assert(length($input) >= $1_dim0)
  114. %}
  115. /* Handling vector case to avoid warnings,
  116. although we just use the first one. */
  117. %typemap(scheck) unsigned int %{
  118. assert(length($input) == 1 && $input >= 0, "All values must be non-negative");
  119. %}
  120. %typemap(scheck) int, long %{
  121. if(length($input) > 1) {
  122. warning("using only the first element of $input");
  123. };
  124. %}
  125. %include <typemaps/fragments.swg>
  126. %include <rfragments.swg>
  127. %include <ropers.swg>
  128. %include <typemaps/swigtypemaps.swg>
  129. %include <rtype.swg>
  130. %typemap(in,noblock=1) enum SWIGTYPE[ANY] {
  131. $1 = %reinterpret_cast(INTEGER($input), $1_ltype);
  132. }
  133. %typemap(in,noblock=1,fragment="SWIG_strdup") char * {
  134. $1 = %reinterpret_cast(SWIG_strdup(CHAR(STRING_ELT($input, 0))), $1_ltype);
  135. }
  136. %typemap(freearg,noblock=1) char * {
  137. free($1);
  138. }
  139. %typemap(in,noblock=1,fragment="SWIG_strdup") char *[ANY] {
  140. $1 = %reinterpret_cast(SWIG_strdup(CHAR(STRING_ELT($input, 0))), $1_ltype);
  141. }
  142. %typemap(freearg,noblock=1) char *[ANY] {
  143. free($1);
  144. }
  145. %typemap(in,noblock=1,fragment="SWIG_strdup") char[ANY] {
  146. $1 = SWIG_strdup(CHAR(STRING_ELT($input, 0)));
  147. }
  148. %typemap(freearg,noblock=1) char[ANY] {
  149. free($1);
  150. }
  151. %typemap(in,noblock=1,fragment="SWIG_strdup") char[] {
  152. $1 = SWIG_strdup(CHAR(STRING_ELT($input, 0)));
  153. }
  154. %typemap(freearg,noblock=1) char[] {
  155. free($1);
  156. }
  157. %typemap(memberin) char[] %{
  158. if ($input) strcpy($1, $input);
  159. else
  160. strcpy($1, "");
  161. %}
  162. %typemap(globalin) char[] %{
  163. if ($input) strcpy($1, $input);
  164. else
  165. strcpy($1, "");
  166. %}
  167. %typemap(out,noblock=1) char *
  168. { $result = $1 ? Rf_mkString(%reinterpret_cast($1,char *)) : R_NilValue; }
  169. %typemap(in,noblock=1) char {
  170. $1 = %static_cast(CHAR(STRING_ELT($input, 0))[0],$1_ltype);
  171. }
  172. %typemap(out) char
  173. {
  174. char tmp[2] = "x";
  175. tmp[0] = $1;
  176. $result = Rf_mkString(tmp);
  177. }
  178. %typemap(in,noblock=1) int, long
  179. {
  180. $1 = %static_cast(INTEGER($input)[0], $1_ltype);
  181. }
  182. %typemap(out,noblock=1) int, long
  183. "$result = Rf_ScalarInteger($1);";
  184. %typemap(in,noblock=1) bool
  185. "$1 = LOGICAL($input)[0] ? true : false;";
  186. %typemap(out,noblock=1) bool
  187. "$result = Rf_ScalarLogical($1);";
  188. %typemap(in,noblock=1)
  189. float,
  190. double
  191. {
  192. $1 = %static_cast(REAL($input)[0], $1_ltype);
  193. }
  194. /* Why is this here ? */
  195. /* %typemap(out,noblock=1) unsigned int *
  196. "$result = ScalarReal(*($1));"; */
  197. %Rruntime %{
  198. setMethod('[', "ExternalReference",
  199. function(x,i,j, ..., drop=TRUE)
  200. if (!is.null(x$"__getitem__"))
  201. sapply(i, function(n) x$"__getitem__"(i=as.integer(n-1))))
  202. setMethod('[<-' , "ExternalReference",
  203. function(x,i,j, ..., value)
  204. if (!is.null(x$"__setitem__")) {
  205. sapply(1:length(i), function(n)
  206. x$"__setitem__"(i=as.integer(i[n]-1), x=value[n]))
  207. x
  208. })
  209. setAs('ExternalReference', 'character',
  210. function(from) {if (!is.null(from$"__str__")) from$"__str__"()})
  211. suppressWarnings(setMethod('print', 'ExternalReference',
  212. function(x) {print(as(x, "character"))}))
  213. %}