PageRenderTime 63ms CodeModel.GetById 15ms RepoModel.GetById 0ms app.codeStats 0ms

/trunk/Lib/r/r.swg

#
Unknown | 265 lines | 206 code | 59 blank | 0 comment | 0 complexity | e234595d291758b10a7404a342408278 MD5 | raw file
Possible License(s): LGPL-2.1, Cube, GPL-3.0, 0BSD, GPL-2.0
  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. long *OUTPUT,
  97. signed long *OUTPUT,
  98. long long *OUTPUT,
  99. unsigned long long *OUTPUT,
  100. float *OUTPUT,
  101. double *OUTPUT {}
  102. /* Should we recycle to make the length correct.
  103. And warn if length() > the dimension.
  104. */
  105. %typemap(scheck) SWIGTYPE [ANY] %{
  106. # assert(length($input) >= $1_dim0)
  107. %}
  108. /* Handling vector case to avoid warnings,
  109. although we just use the first one. */
  110. %typemap(scheck) unsigned int %{
  111. assert(length($input) == 1 && $input >= 0, "All values must be non-negative");
  112. %}
  113. %typemap(scheck) int, long %{
  114. if(length($input) > 1) {
  115. warning("using only the first element of $input");
  116. };
  117. %}
  118. %include <typemaps/fragments.swg>
  119. %include <rfragments.swg>
  120. %include <ropers.swg>
  121. %include <typemaps/swigtypemaps.swg>
  122. %include <rtype.swg>
  123. %typemap(in,noblock=1) enum SWIGTYPE[ANY] {
  124. $1 = %reinterpret_cast(INTEGER($input), $1_ltype);
  125. }
  126. %typemap(in,noblock=1,fragment="SWIG_strdup") char * {
  127. $1 = %reinterpret_cast(SWIG_strdup(CHAR(STRING_ELT($input, 0))), $1_ltype);
  128. }
  129. %typemap(freearg,noblock=1) char * {
  130. free($1);
  131. }
  132. %typemap(in,noblock=1,fragment="SWIG_strdup") char *[ANY] {
  133. $1 = %reinterpret_cast(SWIG_strdup(CHAR(STRING_ELT($input, 0))), $1_ltype);
  134. }
  135. %typemap(freearg,noblock=1) char *[ANY] {
  136. free($1);
  137. }
  138. %typemap(in,noblock=1,fragment="SWIG_strdup") char[ANY] {
  139. $1 = SWIG_strdup(CHAR(STRING_ELT($input, 0)));
  140. }
  141. %typemap(freearg,noblock=1) char[ANY] {
  142. free($1);
  143. }
  144. %typemap(in,noblock=1,fragment="SWIG_strdup") char[] {
  145. $1 = SWIG_strdup(CHAR(STRING_ELT($input, 0)));
  146. }
  147. %typemap(freearg,noblock=1) char[] {
  148. free($1);
  149. }
  150. %typemap(memberin) char[] %{
  151. if ($input) strcpy($1, $input);
  152. else
  153. strcpy($1, "");
  154. %}
  155. %typemap(globalin) char[] %{
  156. if ($input) strcpy($1, $input);
  157. else
  158. strcpy($1, "");
  159. %}
  160. %typemap(out,noblock=1) char *
  161. { $result = $1 ? Rf_mkString(%reinterpret_cast($1,char *)) : R_NilValue; }
  162. %typemap(in,noblock=1) char {
  163. $1 = %static_cast(CHAR(STRING_ELT($input, 0))[0],$1_ltype);
  164. }
  165. %typemap(out) char
  166. {
  167. char tmp[2] = "x";
  168. tmp[0] = $1;
  169. $result = Rf_mkString(tmp);
  170. }
  171. %typemap(in,noblock=1) int, long
  172. {
  173. $1 = %static_cast(INTEGER($input)[0], $1_ltype);
  174. }
  175. %typemap(out,noblock=1) int, long
  176. "$result = Rf_ScalarInteger($1);";
  177. %typemap(in,noblock=1) bool
  178. "$1 = LOGICAL($input)[0] ? true : false;";
  179. %typemap(out,noblock=1) bool
  180. "$result = Rf_ScalarLogical($1);";
  181. %typemap(in,noblock=1)
  182. float,
  183. double
  184. {
  185. $1 = %static_cast(REAL($input)[0], $1_ltype);
  186. }
  187. /* Why is this here ? */
  188. /* %typemap(out,noblock=1) unsigned int *
  189. "$result = ScalarReal(*($1));"; */
  190. %Rruntime %{
  191. setMethod('[', "ExternalReference",
  192. function(x,i,j, ..., drop=TRUE)
  193. if (!is.null(x$"__getitem__"))
  194. sapply(i, function(n) x$"__getitem__"(i=as.integer(n-1))))
  195. setMethod('[<-' , "ExternalReference",
  196. function(x,i,j, ..., value)
  197. if (!is.null(x$"__setitem__")) {
  198. sapply(1:length(i), function(n)
  199. x$"__setitem__"(i=as.integer(i[n]-1), x=value[n]))
  200. x
  201. })
  202. setAs('ExternalReference', 'character',
  203. function(from) {if (!is.null(from$"__str__")) from$"__str__"()})
  204. setMethod('print', 'ExternalReference',
  205. function(x) {print(as(x, "character"))})
  206. %}