|
0
|
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
|
