Mercurial > pub > dyncall > bindings

comparison R/rdyncall/src/rcallback.c @ 0:0cfcc391201f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
initial from svn dyncall-1745
author Daniel Adler
date Thu, 19 Mar 2015 22:26:28 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:0cfcc391201f
1 /** ===========================================================================
2 ** R-Package: rdyncall
3 ** File: src/rcallback.c
4 ** Description: dyncall callback R backend
5 **/
6
7 #include "Rinternals.h"
8 #include "Rdefines.h"
9 #include "dyncall_callback.h"
10
11 typedef struct
12 {
13 int disabled;
14 SEXP fun;
15 SEXP rho;
16 int nargs;
17 const char* signature; /* argument signature without call mode prefix */
18 } R_Callback;
19
20 char dcCallbackHandler_R( DCCallback* pcb, DCArgs* args, DCValue* result, void* userdata )
21 {
22 R_Callback* rdata;
23 const char* ptr;
24 int i,n;
25 SEXP s, x, ans, item;
26 char ch;
27
28 rdata = (R_Callback*) userdata;
29
30 if (rdata->disabled) return DC_SIGCHAR_VOID;
31
32 ptr = rdata->signature;
33
34 // allocate an nargs + 1 'call' language object
35 // first argument is function
36 // rest is arguments from callback
37 n = 1 + rdata->nargs;
38
39 PROTECT( s = allocList(n) );
40 SET_TYPEOF(s, LANGSXP);
41 SETCAR( s, rdata->fun ); x = CDR(s);
42
43 // fill up call object
44
45 i = 1;
46 for( ;; ++i) {
47 ch = *ptr++;
48 if (ch == ')') break;
49 if (i >= n) {
50 warning("invalid signature.");
51 rdata->disabled = 1;
52 UNPROTECT(1);
53 return DC_SIGCHAR_VOID;
54 }
55 switch(ch) {
56 case DC_SIGCHAR_BOOL: item = ScalarLogical( ( dcbArgBool(args) == DC_FALSE ) ? FALSE : TRUE ); break;
57 case DC_SIGCHAR_CHAR: item = ScalarInteger( (int) dcbArgChar(args) ); break;
58 case DC_SIGCHAR_UCHAR: item = ScalarInteger( (int) dcbArgUChar(args) ); break;
59 case DC_SIGCHAR_SHORT: item = ScalarInteger( (int) dcbArgShort(args) ); break;
60 case DC_SIGCHAR_USHORT: item = ScalarInteger( (int) dcbArgUShort(args) ); break;
61 case DC_SIGCHAR_INT: item = ScalarInteger( (int) dcbArgInt(args) ); break;
62 case DC_SIGCHAR_UINT: item = ScalarReal( (double) dcbArgUInt(args) ); break;
63 case DC_SIGCHAR_LONG: item = ScalarReal( (double) dcbArgLong(args) ); break;
64 case DC_SIGCHAR_ULONG: item = ScalarReal( (double) dcbArgULong(args) ); break;
65 case DC_SIGCHAR_LONGLONG: item = ScalarReal( (double) dcbArgLongLong(args) ); break;
66 case DC_SIGCHAR_ULONGLONG: item = ScalarReal( (double) dcbArgULongLong(args) ); break;
67 case DC_SIGCHAR_FLOAT: item = ScalarReal( (double) dcbArgFloat(args) ); break;
68 case DC_SIGCHAR_DOUBLE: item = ScalarReal( dcbArgDouble(args) ); break;
69 case DC_SIGCHAR_POINTER: item = R_MakeExternalPtr( dcbArgPointer(args), R_NilValue, R_NilValue ); break;
70 case DC_SIGCHAR_STRING: item = mkString( dcbArgPointer(args) ); break;
71 default:
72 case '\0':
73 warning("invalid signature");
74 rdata->disabled = 1;
75 UNPROTECT(1);
76 return DC_SIGCHAR_VOID;
77 }
78 SETCAR( x, item);
79 x = CDR(x);
80 }
81
82 /* evaluate expression */
83
84 int error = 0;
85
86 PROTECT( ans = R_tryEval( s, rdata->rho, &error ) );
87
88 if (error)
89 {
90 warning("an error occurred during callback invocation in R. Callback disabled.");
91 rdata->disabled = 1;
92 UNPROTECT(2);
93 return DC_SIGCHAR_VOID;
94 }
95
96 /* propagate return value */
97
98 ch = *ptr; /* scan return value type character */
99
100 /* handle NULL and len(x) == 0 expressions special */
101 if ( (ans == R_NilValue) || (LENGTH(ans) == 0) )
102 {
103 /* handle NULL */
104 result->L = 0;
105 }
106 else
107 {
108 switch(ch)
109 {
110 case DC_SIGCHAR_VOID:
111 break;
112 case DC_SIGCHAR_BOOL:
113 switch( TYPEOF(ans) )
114 {
115 case INTSXP: result->B = (INTEGER(ans)[0] == 0 ) ? DC_FALSE : DC_TRUE; break;
116 case LGLSXP: result->B = (LOGICAL(ans)[0] == FALSE ) ? DC_FALSE : DC_TRUE; break;
117 default: result->B = DC_FALSE; break;
118 }
119 break;
120 case DC_SIGCHAR_CHAR:
121 case DC_SIGCHAR_UCHAR:
122 case DC_SIGCHAR_SHORT:
123 case DC_SIGCHAR_USHORT:
124 case DC_SIGCHAR_INT:
125 case DC_SIGCHAR_UINT:
126 case DC_SIGCHAR_LONG:
127 case DC_SIGCHAR_ULONG:
128 switch( TYPEOF(ans) )
129 {
130 case INTSXP: result->i = INTEGER(ans)[0]; break;
131 case REALSXP: result->i = (int) REAL(ans)[0]; break;
132 default: result->i = 0; break;
133 }
134 break;
135 case DC_SIGCHAR_ULONGLONG:
136 case DC_SIGCHAR_LONGLONG:
137 switch( TYPEOF(ans) )
138 {
139 case INTSXP: result->L = (long long) INTEGER(ans)[0]; break;
140 case REALSXP: result->L = (long long) REAL(ans)[0]; break;
141 default: result->L = 0; break;
142 }
143 break;
144 case DC_SIGCHAR_FLOAT:
145 switch( TYPEOF(ans) )
146 {
147 case INTSXP: result->f = (float) INTEGER(ans)[0]; break;
148 case REALSXP: result->f = (float) REAL(ans)[0]; break;
149 default: result->f = 0.0f; break;
150 }
151 break;
152 case DC_SIGCHAR_DOUBLE:
153 switch( TYPEOF(ans) )
154 {
155 case INTSXP: result->d = (double) INTEGER(ans)[0]; break;
156 case REALSXP: result->d = REAL(ans)[0]; break;
157 default: result->d = 0.0; break;
158 }
159 break;
160 case DC_SIGCHAR_POINTER:
161 switch( TYPEOF(ans) )
162 {
163 case EXTPTRSXP: result->p = R_ExternalPtrAddr(ans); break;
164 case INTSXP : result->p = (DCpointer) (ptrdiff_t) (unsigned long long int) INTEGER(ans)[0]; break;
165 case REALSXP : result->p = (DCpointer) (ptrdiff_t) (unsigned long long int) REAL(ans)[0]; break;
166 default: result->p = NULL; break;
167 }
168 break;
169 case DC_SIGCHAR_STRING:
170 warning("not implemented");
171 rdata->disabled = 1;
172 break;
173 }
174 }
175 UNPROTECT(2);
176 return ch;
177 }
178
179 void R_callback_finalizer(SEXP x);
180
181 SEXP r_new_callback(SEXP sig_x, SEXP fun_x, SEXP rho_x)
182 {
183 const char* signature;
184 R_Callback* rdata;
185 const char* ptr;
186 char ch;
187 signature = CHAR( STRING_ELT( sig_x, 0 ) );
188 rdata = Calloc(1, R_Callback);
189 rdata->disabled = 0;
190 rdata->fun = fun_x;
191 rdata->rho = rho_x;
192 R_PreserveObject(rdata->fun);
193 R_PreserveObject(rdata->rho);
194 ptr = signature;
195 // skip call mode signature
196 if ( (ch=*ptr) == '_') {
197 ptr += 2;
198 ch=*ptr;
199 }
200 rdata->signature = ptr++;
201 int nargs = 0;
202 while( ch != ')') {
203 nargs ++;
204 ch = *ptr++;
205 }
206 rdata->nargs = nargs;
207 DCCallback* cb = dcbNewCallback( signature, dcCallbackHandler_R, rdata);
208 SEXP ans = R_MakeExternalPtr( cb, R_NilValue, R_NilValue );
209 R_RegisterCFinalizerEx(ans, R_callback_finalizer, TRUE);
210 return ans;
211 }
212
213 void R_callback_finalizer(SEXP x)
214 {
215 DCCallback* cb = R_ExternalPtrAddr(x);
216 R_Callback* rdata = dcbGetUserData(cb);
217 R_ReleaseObject(rdata->fun);
218 R_ReleaseObject(rdata->rho);
219 Free(rdata);
220 dcbFreeCallback(cb);
221 }
222