|
0
|
1 /** ===========================================================================
|
|
|
2 ** R-Package: rdyncall
|
|
|
3 ** File: src/rdyncall.c
|
|
|
4 ** Description: R bindings to dyncall
|
|
|
5 **/
|
|
|
6
|
|
|
7 #include <Rinternals.h>
|
|
|
8 #include "dyncall.h"
|
|
|
9 #include "rdyncall_signature.h"
|
|
|
10 #include <string.h>
|
|
|
11 #include <ctype.h>
|
|
|
12
|
|
|
13 /** ---------------------------------------------------------------------------
|
|
|
14 ** C-Function: new_callvm
|
|
|
15 ** R-Interface: .Call
|
|
|
16 **/
|
|
|
17
|
|
|
18 SEXP r_new_callvm(SEXP mode_x, SEXP size_x)
|
|
|
19 {
|
|
|
20 /* default call mode is "cdecl" */
|
|
|
21 int size_i = INTEGER(size_x)[0];
|
|
|
22
|
|
|
23 const char* mode_S = CHAR( STRING_ELT( mode_x, 0 ) );
|
|
|
24
|
|
|
25 int mode_i = DC_CALL_C_DEFAULT;
|
|
|
26 if (strcmp(mode_S,"default") == 0 || strcmp(mode_S,"cdecl") == 0) mode_i = DC_CALL_C_DEFAULT;
|
|
|
27 #if WIN32
|
|
|
28 else if (strcmp(mode_S,"stdcall") == 0) mode_i = DC_CALL_C_X86_WIN32_STD;
|
|
|
29 else if (strcmp(mode_S,"thiscall") == 0) mode_i = DC_CALL_C_X86_WIN32_THIS_GNU;
|
|
|
30 else if (strcmp(mode_S,"thiscall.gcc") == 0) mode_i = DC_CALL_C_X86_WIN32_THIS_GNU;
|
|
|
31 else if (strcmp(mode_S,"thiscall.msvc") == 0) mode_i = DC_CALL_C_X86_WIN32_THIS_MS;
|
|
|
32 else if (strcmp(mode_S,"fastcall") == 0) mode_i = DC_CALL_C_X86_WIN32_FAST_GNU;
|
|
|
33 else if (strcmp(mode_S,"fastcall.msvc") == 0) mode_i = DC_CALL_C_X86_WIN32_FAST_MS;
|
|
|
34 else if (strcmp(mode_S,"fastcall.gcc") == 0) mode_i = DC_CALL_C_X86_WIN32_FAST_GNU;
|
|
|
35 #endif
|
|
|
36 /*
|
|
|
37 else { error("invalid 'callmode'"); return R_NilValue; }
|
|
|
38 */
|
|
|
39
|
|
|
40 DCCallVM* pvm = dcNewCallVM(size_i);
|
|
|
41 dcMode( pvm, mode_i );
|
|
|
42 return R_MakeExternalPtr( pvm, R_NilValue, R_NilValue );
|
|
|
43 }
|
|
|
44
|
|
|
45 /** ---------------------------------------------------------------------------
|
|
|
46 ** C-Function: free_callvm
|
|
|
47 ** R-Interface: .Call
|
|
|
48 **/
|
|
|
49
|
|
|
50 SEXP r_free_callvm(SEXP callvm_x)
|
|
|
51 {
|
|
|
52 DCCallVM* callvm_p = (DCCallVM*) R_ExternalPtrAddr( callvm_x );
|
|
|
53 dcFree( callvm_p );
|
|
|
54 return R_NilValue;
|
|
|
55 }
|
|
|
56
|
|
|
57 /** ---------------------------------------------------------------------------
|
|
|
58 ** C-Function: r_dyncall
|
|
|
59 ** R-Interface: .External
|
|
|
60 **/
|
|
|
61
|
|
|
62 SEXP r_dyncall(SEXP args) /* callvm, address, signature, args ... */
|
|
|
63 {
|
|
|
64 DCCallVM* pvm;
|
|
|
65 void* addr;
|
|
|
66 const char* signature;
|
|
|
67 const char* sig;
|
|
|
68 SEXP arg;
|
|
|
69 int ptrcnt;
|
|
|
70 int argpos;
|
|
|
71
|
|
|
72 args = CDR(args);
|
|
|
73
|
|
|
74 /* extract CallVM reference, address and signature */
|
|
|
75
|
|
|
76 pvm = (DCCallVM*) R_ExternalPtrAddr( CAR(args) ); args = CDR(args);
|
|
|
77
|
|
|
78 switch(TYPEOF(CAR(args))) {
|
|
|
79 case EXTPTRSXP:
|
|
|
80 addr = R_ExternalPtrAddr( CAR(args) ); args = CDR(args);
|
|
|
81 if (!addr) {
|
|
|
82 error("Target address is null-pointer.");
|
|
|
83 return R_NilValue; /* dummy */
|
|
|
84 }
|
|
|
85 break;
|
|
|
86 default:
|
|
|
87 error("Target address must be external pointer.");
|
|
|
88 return R_NilValue; /* dummy */
|
|
|
89 }
|
|
|
90 signature = CHAR( STRING_ELT( CAR(args), 0 ) ); args = CDR(args);
|
|
|
91 sig = signature;
|
|
|
92
|
|
|
93 if (!pvm) {
|
|
|
94 error("Argument 'callvm' is null");
|
|
|
95 /* dummy */ return R_NilValue;
|
|
|
96 }
|
|
|
97 if (!addr) {
|
|
|
98 error("Argument 'addr' is null");
|
|
|
99 /* dummy */ return R_NilValue;
|
|
|
100 }
|
|
|
101 /* reset CallVM to initial state */
|
|
|
102
|
|
|
103 dcReset(pvm);
|
|
|
104 ptrcnt = 0;
|
|
|
105 argpos = 0;
|
|
|
106
|
|
|
107 /* function calling convention prefix '_' */
|
|
|
108 if (*sig == DC_SIGCHAR_CC_PREFIX) {
|
|
|
109 /* specify calling convention by signature prefix hint */
|
|
|
110 ++sig;
|
|
|
111 char ch = *sig++;
|
|
|
112 int mode = DC_CALL_C_DEFAULT;
|
|
|
113 switch(ch)
|
|
|
114 {
|
|
|
115 case DC_SIGCHAR_CC_STDCALL:
|
|
|
116 mode = DC_CALL_C_X86_WIN32_STD; break;
|
|
|
117 case DC_SIGCHAR_CC_FASTCALL_GNU:
|
|
|
118 mode = DC_CALL_C_X86_WIN32_FAST_GNU; break;
|
|
|
119 case DC_SIGCHAR_CC_FASTCALL_MS:
|
|
|
120 mode = DC_CALL_C_X86_WIN32_FAST_MS; break;
|
|
|
121 default:
|
|
|
122 error("Unknown calling convention prefix hint signature character '%c'", ch );
|
|
|
123 /* dummy */ return R_NilValue;
|
|
|
124 }
|
|
|
125 dcMode(pvm, mode);
|
|
|
126 }
|
|
|
127
|
|
|
128 /* load arguments */
|
|
|
129 for(;;) {
|
|
|
130
|
|
|
131 char ch = *sig++;
|
|
|
132
|
|
|
133 if (ch == '\0') {
|
|
|
134 error("Function-call signature '%s' is invalid - missing argument terminator character ')' and return type signature.", signature);
|
|
|
135 /* dummy */ return R_NilValue;
|
|
|
136 }
|
|
|
137 /* argument terminator */
|
|
|
138 if (ch == ')') break;
|
|
|
139
|
|
|
140 /* end of arguments? */
|
|
|
141 if (args == R_NilValue) {
|
|
|
142 error("Not enough arguments for function-call signature '%s'.", signature);
|
|
|
143 /* dummy */ return R_NilValue;
|
|
|
144 }
|
|
|
145 /* pointer counter */
|
|
|
146 else if (ch == '*') { ptrcnt++; continue; }
|
|
|
147
|
|
|
148 /* unpack next argument */
|
|
|
149 arg = CAR(args); args = CDR(args);
|
|
|
150 argpos++;
|
|
|
151
|
|
|
152 int type_id = TYPEOF(arg);
|
|
|
153
|
|
|
154 if (ptrcnt == 0) { /* base types */
|
|
|
155
|
|
|
156 /* 'x' signature for passing language objects 'as-is' */
|
|
|
157 if (ch == DC_SIGCHAR_SEXP) {
|
|
|
158 dcArgPointer(pvm, (void*)arg);
|
|
|
159 continue;
|
|
|
160 }
|
|
|
161
|
|
|
162 if ( type_id != NILSXP && type_id != EXTPTRSXP && LENGTH(arg) == 0 ) {
|
|
|
163 error("Argument type mismatch at position %d: expected length greater zero.", argpos);
|
|
|
164 /* dummy */ return R_NilValue;
|
|
|
165 }
|
|
|
166 switch(ch) {
|
|
|
167 case DC_SIGCHAR_BOOL:
|
|
|
168 {
|
|
|
169 DCbool boolValue;
|
|
|
170 switch(type_id)
|
|
|
171 {
|
|
|
172 case LGLSXP: boolValue = ( LOGICAL(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE; break;
|
|
|
173 case INTSXP: boolValue = ( INTEGER(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE; break;
|
|
|
174 case REALSXP: boolValue = ( REAL(arg)[0] == 0.0 ) ? DC_FALSE : DC_TRUE; break;
|
|
|
175 case RAWSXP: boolValue = ( RAW(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE; break;
|
|
|
176 default: error("Argument type mismatch at position %d: expected C bool convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
177 }
|
|
|
178 dcArgBool(pvm, boolValue );
|
|
|
179 }
|
|
|
180 break;
|
|
|
181 case DC_SIGCHAR_CHAR:
|
|
|
182 {
|
|
|
183 char charValue;
|
|
|
184 switch(type_id)
|
|
|
185 {
|
|
|
186 case LGLSXP: charValue = (char) LOGICAL(arg)[0]; break;
|
|
|
187 case INTSXP: charValue = (char) INTEGER(arg)[0]; break;
|
|
|
188 case REALSXP: charValue = (char) REAL(arg)[0]; break;
|
|
|
189 case RAWSXP: charValue = (char) RAW(arg)[0]; break;
|
|
|
190 default: error("Argument type mismatch at position %d: expected C char convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
191 }
|
|
|
192 dcArgChar(pvm, charValue);
|
|
|
193 }
|
|
|
194 break;
|
|
|
195 case DC_SIGCHAR_UCHAR:
|
|
|
196 {
|
|
|
197 unsigned char charValue;
|
|
|
198 switch(type_id)
|
|
|
199 {
|
|
|
200 case LGLSXP: charValue = (unsigned char) LOGICAL(arg)[0]; break;
|
|
|
201 case INTSXP: charValue = (unsigned char) INTEGER(arg)[0]; break;
|
|
|
202 case REALSXP: charValue = (unsigned char) REAL(arg)[0]; break;
|
|
|
203 case RAWSXP: charValue = (unsigned char) RAW(arg)[0]; break;
|
|
|
204 default: error("Argument type mismatch at position %d: expected C unsigned char convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
205 }
|
|
|
206 dcArgChar(pvm, *( (char*) &charValue ));
|
|
|
207 }
|
|
|
208 break;
|
|
|
209 case DC_SIGCHAR_SHORT:
|
|
|
210 {
|
|
|
211 short shortValue;
|
|
|
212 switch(type_id)
|
|
|
213 {
|
|
|
214 case LGLSXP: shortValue = (short) LOGICAL(arg)[0]; break;
|
|
|
215 case INTSXP: shortValue = (short) INTEGER(arg)[0]; break;
|
|
|
216 case REALSXP: shortValue = (short) REAL(arg)[0]; break;
|
|
|
217 case RAWSXP: shortValue = (short) RAW(arg)[0]; break;
|
|
|
218 default: error("Argument type mismatch at position %d: expected C short convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
219 }
|
|
|
220 dcArgShort(pvm, shortValue);
|
|
|
221 }
|
|
|
222 break;
|
|
|
223 case DC_SIGCHAR_USHORT:
|
|
|
224 {
|
|
|
225 unsigned short shortValue;
|
|
|
226 switch(type_id)
|
|
|
227 {
|
|
|
228 case LGLSXP: shortValue = (unsigned short) LOGICAL(arg)[0]; break;
|
|
|
229 case INTSXP: shortValue = (unsigned short) INTEGER(arg)[0]; break;
|
|
|
230 case REALSXP: shortValue = (unsigned short) REAL(arg)[0]; break;
|
|
|
231 case RAWSXP: shortValue = (unsigned short) RAW(arg)[0]; break;
|
|
|
232 default: error("Argument type mismatch at position %d: expected C unsigned short convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
233 }
|
|
|
234 dcArgShort(pvm, *( (short*) &shortValue ) );
|
|
|
235 }
|
|
|
236 break;
|
|
|
237 case DC_SIGCHAR_LONG:
|
|
|
238 {
|
|
|
239 long longValue;
|
|
|
240 switch(type_id)
|
|
|
241 {
|
|
|
242 case LGLSXP: longValue = (long) LOGICAL(arg)[0]; break;
|
|
|
243 case INTSXP: longValue = (long) INTEGER(arg)[0]; break;
|
|
|
244 case REALSXP: longValue = (long) REAL(arg)[0]; break;
|
|
|
245 case RAWSXP: longValue = (long) RAW(arg)[0]; break;
|
|
|
246 default: error("Argument type mismatch at position %d: expected C long convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
247 }
|
|
|
248 dcArgLong(pvm, longValue);
|
|
|
249 }
|
|
|
250 break;
|
|
|
251 case DC_SIGCHAR_ULONG:
|
|
|
252 {
|
|
|
253 unsigned long ulongValue;
|
|
|
254 switch(type_id)
|
|
|
255 {
|
|
|
256 case LGLSXP: ulongValue = (unsigned long) LOGICAL(arg)[0]; break;
|
|
|
257 case INTSXP: ulongValue = (unsigned long) INTEGER(arg)[0]; break;
|
|
|
258 case REALSXP: ulongValue = (unsigned long) REAL(arg)[0]; break;
|
|
|
259 case RAWSXP: ulongValue = (unsigned long) RAW(arg)[0]; break;
|
|
|
260 default: error("Argument type mismatch at position %d: expected C unsigned long convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
261 }
|
|
|
262 dcArgLong(pvm, (unsigned long) ulongValue);
|
|
|
263 }
|
|
|
264 break;
|
|
|
265 case DC_SIGCHAR_INT:
|
|
|
266 {
|
|
|
267 int intValue;
|
|
|
268 switch(type_id)
|
|
|
269 {
|
|
|
270 case LGLSXP: intValue = (int) LOGICAL(arg)[0]; break;
|
|
|
271 case INTSXP: intValue = INTEGER(arg)[0]; break;
|
|
|
272 case REALSXP: intValue = (int) REAL(arg)[0]; break;
|
|
|
273 case RAWSXP: intValue = (int) RAW(arg)[0]; break;
|
|
|
274 default: error("Argument type mismatch at position %d: expected C int convertable value", argpos); /*dummy*/ return R_NilValue;
|
|
|
275 }
|
|
|
276 dcArgInt(pvm, intValue);
|
|
|
277 }
|
|
|
278 break;
|
|
|
279 case DC_SIGCHAR_UINT:
|
|
|
280 {
|
|
|
281 unsigned int intValue;
|
|
|
282 switch(type_id)
|
|
|
283 {
|
|
|
284 case LGLSXP: intValue = (unsigned int) LOGICAL(arg)[0]; break;
|
|
|
285 case INTSXP: intValue = (unsigned int) INTEGER(arg)[0]; break;
|
|
|
286 case REALSXP: intValue = (unsigned int) REAL(arg)[0]; break;
|
|
|
287 case RAWSXP: intValue = (unsigned int) RAW(arg)[0]; break;
|
|
|
288 default: error("Argument type mismatch at position %d: expected C unsigned int convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
289 }
|
|
|
290 dcArgInt(pvm, * (int*) &intValue);
|
|
|
291 }
|
|
|
292 break;
|
|
|
293 case DC_SIGCHAR_FLOAT:
|
|
|
294 {
|
|
|
295 float floatValue;
|
|
|
296 switch(type_id)
|
|
|
297 {
|
|
|
298 case LGLSXP: floatValue = (float) LOGICAL(arg)[0]; break;
|
|
|
299 case INTSXP: floatValue = (float) INTEGER(arg)[0]; break;
|
|
|
300 case REALSXP: floatValue = (float) REAL(arg)[0]; break;
|
|
|
301 case RAWSXP: floatValue = (float) RAW(arg)[0]; break;
|
|
|
302 default: error("Argument type mismatch at position %d: expected C float convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
303 }
|
|
|
304 dcArgFloat( pvm, floatValue );
|
|
|
305 }
|
|
|
306 break;
|
|
|
307 case DC_SIGCHAR_DOUBLE:
|
|
|
308 {
|
|
|
309 DCdouble doubleValue;
|
|
|
310 switch(type_id)
|
|
|
311 {
|
|
|
312 case LGLSXP: doubleValue = (double) LOGICAL(arg)[0]; break;
|
|
|
313 case INTSXP: doubleValue = (double) INTEGER(arg)[0]; break;
|
|
|
314 case REALSXP: doubleValue = REAL(arg)[0]; break;
|
|
|
315 case RAWSXP: doubleValue = (double) RAW(arg)[0]; break;
|
|
|
316 default: error("Argument type mismatch at position %d: expected C double convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
317 }
|
|
|
318 dcArgDouble( pvm, doubleValue );
|
|
|
319 }
|
|
|
320 break;
|
|
|
321 case DC_SIGCHAR_LONGLONG:
|
|
|
322 {
|
|
|
323 DClonglong longlongValue;
|
|
|
324 switch(type_id)
|
|
|
325 {
|
|
|
326 case LGLSXP: longlongValue = (DClonglong) LOGICAL(arg)[0]; break;
|
|
|
327 case INTSXP: longlongValue = (DClonglong) INTEGER(arg)[0]; break;
|
|
|
328 case REALSXP: longlongValue = (DClonglong) REAL(arg)[0]; break;
|
|
|
329 case RAWSXP: longlongValue = (DClonglong) RAW(arg)[0]; break;
|
|
|
330 default: error("Argument type mismatch at position %d: expected C long long (int64_t) convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
331 }
|
|
|
332 dcArgLongLong( pvm, longlongValue );
|
|
|
333 }
|
|
|
334 break;
|
|
|
335 case DC_SIGCHAR_ULONGLONG:
|
|
|
336 {
|
|
|
337 DCulonglong ulonglongValue;
|
|
|
338 switch(type_id)
|
|
|
339 {
|
|
|
340 case LGLSXP: ulonglongValue = (DCulonglong) LOGICAL(arg)[0]; break;
|
|
|
341 case INTSXP: ulonglongValue = (DCulonglong) INTEGER(arg)[0]; break;
|
|
|
342 case REALSXP: ulonglongValue = (DCulonglong) REAL(arg)[0]; break;
|
|
|
343 case RAWSXP: ulonglongValue = (DCulonglong) RAW(arg)[0]; break;
|
|
|
344 default: error("Argument type mismatch at position %d: expected C unsigned long long (uint64_t) convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
345 }
|
|
|
346 dcArgLongLong( pvm, *( (DClonglong*)&ulonglongValue ) );
|
|
|
347 }
|
|
|
348 break;
|
|
|
349 case DC_SIGCHAR_POINTER:
|
|
|
350 {
|
|
|
351 DCpointer ptrValue;
|
|
|
352 switch(type_id)
|
|
|
353 {
|
|
|
354 case NILSXP: ptrValue = (DCpointer) 0; break;
|
|
|
355 case CHARSXP: ptrValue = (DCpointer) CHAR(arg); break;
|
|
|
356 case SYMSXP: ptrValue = (DCpointer) PRINTNAME(arg); break;
|
|
|
357 case STRSXP: ptrValue = (DCpointer) CHAR(STRING_ELT(arg,0)); break;
|
|
|
358 case LGLSXP: ptrValue = (DCpointer) LOGICAL(arg); break;
|
|
|
359 case INTSXP: ptrValue = (DCpointer) INTEGER(arg); break;
|
|
|
360 case REALSXP: ptrValue = (DCpointer) REAL(arg); break;
|
|
|
361 case CPLXSXP: ptrValue = (DCpointer) COMPLEX(arg); break;
|
|
|
362 case RAWSXP: ptrValue = (DCpointer) RAW(arg); break;
|
|
|
363 case EXTPTRSXP: ptrValue = R_ExternalPtrAddr(arg); break;
|
|
|
364 // case ENVSXP: ptrValue = (DCpointer) arg; break;
|
|
|
365 default: error("Argument type mismatch at position %d: expected C pointer convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
366 }
|
|
|
367 dcArgPointer(pvm, ptrValue);
|
|
|
368 }
|
|
|
369 break;
|
|
|
370 case DC_SIGCHAR_STRING:
|
|
|
371 {
|
|
|
372 DCpointer cstringValue;
|
|
|
373 switch(type_id)
|
|
|
374 {
|
|
|
375 case NILSXP: cstringValue = (DCpointer) 0; break;
|
|
|
376 case CHARSXP: cstringValue = (DCpointer) CHAR(arg); break;
|
|
|
377 case SYMSXP: cstringValue = (DCpointer) PRINTNAME(arg); break;
|
|
|
378 case STRSXP: cstringValue = (DCpointer) CHAR( STRING_ELT(arg,0) ); break;
|
|
|
379 case EXTPTRSXP: cstringValue = R_ExternalPtrAddr(arg); break;
|
|
|
380 default: error("Argument type mismatch at position %d: expected C string pointer convertable value", argpos); /* dummy */ return R_NilValue;
|
|
|
381 }
|
|
|
382 dcArgPointer(pvm, cstringValue);
|
|
|
383 }
|
|
|
384 break;
|
|
|
385 default: error("Signature type mismatch at position %d: Unknown token '%c' at argument %d.", ch, argpos); /* dummy */ return R_NilValue;
|
|
|
386 }
|
|
|
387 } else { /* ptrcnt > 0 */
|
|
|
388 DCpointer ptrValue;
|
|
|
389 if (ch == '<') { /* typed high-level struct/union pointer */
|
|
|
390 char const * e;
|
|
|
391 char const * b;
|
|
|
392 char const * n;
|
|
|
393 int l;
|
|
|
394 b = sig;
|
|
|
395 while( isalnum(*sig) || *sig == '_' ) sig++;
|
|
|
396 if (*sig != '>') {
|
|
|
397 error("Invalid signature '%s' - missing '>' marker for structure at argument %d.", signature, argpos);
|
|
|
398 return R_NilValue; /* Dummy */
|
|
|
399 }
|
|
|
400 sig++;
|
|
|
401 /* check pointer type */
|
|
|
402 if (type_id != NILSXP) {
|
|
|
403 SEXP structName = getAttrib(arg, install("struct"));
|
|
|
404 if (structName == R_NilValue) {
|
|
|
405 error("typed pointer needed here");
|
|
|
406 return R_NilValue; /* Dummy */
|
|
|
407 }
|
|
|
408 e = sig-1;
|
|
|
409 l = e - b;
|
|
|
410 n = CHAR(STRING_ELT(structName,0));
|
|
|
411 if ( (strlen(n) != l) || (strncmp(b,n,l) != 0) ) {
|
|
|
412 error("incompatible pointer types");
|
|
|
413 return R_NilValue; /* Dummy */
|
|
|
414 }
|
|
|
415 }
|
|
|
416 switch(type_id) {
|
|
|
417 case NILSXP: ptrValue = (DCpointer) 0; break;
|
|
|
418 case EXTPTRSXP: ptrValue = R_ExternalPtrAddr(arg); break;
|
|
|
419 case RAWSXP: ptrValue = (DCpointer) RAW(arg); break;
|
|
|
420 default: error("internal error: typed-pointer can be external pointers or raw only.");
|
|
|
421 return R_NilValue; /* Dummy */
|
|
|
422 }
|
|
|
423 dcArgPointer(pvm, ptrValue);
|
|
|
424 ptrcnt = 0;
|
|
|
425 } else { /* typed low-level pointers */
|
|
|
426 switch(ch) {
|
|
|
427 case DC_SIGCHAR_VOID:
|
|
|
428 switch(type_id)
|
|
|
429 {
|
|
|
430 case NILSXP: ptrValue = (DCpointer) 0; break;
|
|
|
431 case STRSXP: ptrValue = (DCpointer) CHAR(STRING_ELT(arg,0)); break;
|
|
|
432 case LGLSXP: ptrValue = (DCpointer) LOGICAL(arg); break;
|
|
|
433 case INTSXP: ptrValue = (DCpointer) INTEGER(arg); break;
|
|
|
434 case REALSXP: ptrValue = (DCpointer) REAL(arg); break;
|
|
|
435 case CPLXSXP: ptrValue = (DCpointer) COMPLEX(arg); break;
|
|
|
436 case RAWSXP: ptrValue = (DCpointer) RAW(arg); break;
|
|
|
437 case EXTPTRSXP: ptrValue = R_ExternalPtrAddr(arg); break;
|
|
|
438 default: error("Argument type mismatch at position %d: expected pointer convertable value", argpos);
|
|
|
439 return R_NilValue; /* dummy */
|
|
|
440 }
|
|
|
441 break;
|
|
|
442 case DC_SIGCHAR_CHAR:
|
|
|
443 case DC_SIGCHAR_UCHAR:
|
|
|
444 switch(type_id)
|
|
|
445 {
|
|
|
446 case NILSXP: ptrValue = (DCpointer) 0; break;
|
|
|
447 case STRSXP:
|
|
|
448 if (ptrcnt == 1) {
|
|
|
449 ptrValue = (DCpointer) CHAR( STRING_ELT(arg,0) );
|
|
|
450 } else {
|
|
|
451 error("Argument type mismatch at position %d: expected 'C string' convertable value", argpos);
|
|
|
452 return R_NilValue; /* dummy */
|
|
|
453 }
|
|
|
454 break;
|
|
|
455 case RAWSXP:
|
|
|
456 if (ptrcnt == 1) {
|
|
|
457 ptrValue = RAW(arg);
|
|
|
458 } else {
|
|
|
459 error("Argument type mismatch at position %d: expected 'C string' convertable value", argpos);
|
|
|
460 return R_NilValue; /* dummy */
|
|
|
461 }
|
|
|
462 break;
|
|
|
463 case EXTPTRSXP: ptrValue = R_ExternalPtrAddr(arg); break;
|
|
|
464 default:
|
|
|
465 error("Argument type mismatch at position %d: expected 'C string' convertable value", argpos);
|
|
|
466 return R_NilValue; /* dummy */
|
|
|
467 }
|
|
|
468 break;
|
|
|
469 case DC_SIGCHAR_USHORT:
|
|
|
470 case DC_SIGCHAR_SHORT:
|
|
|
471 error("Signature '*[sS]' not implemented");
|
|
|
472 return R_NilValue; /* dummy */
|
|
|
473 case DC_SIGCHAR_UINT:
|
|
|
474 case DC_SIGCHAR_INT:
|
|
|
475 switch(type_id)
|
|
|
476 {
|
|
|
477 case NILSXP: ptrValue = (DCpointer) 0; break;
|
|
|
478 case INTSXP: ptrValue = (DCpointer) INTEGER(arg); break;
|
|
|
479 default: error("Argument type mismatch at position %d: expected 'pointer to C integer' convertable value", argpos);
|
|
|
480 return R_NilValue; /* dummy */
|
|
|
481 }
|
|
|
482 break;
|
|
|
483 case DC_SIGCHAR_ULONG:
|
|
|
484 case DC_SIGCHAR_LONG:
|
|
|
485 error("Signature '*[jJ]' not implemented");
|
|
|
486 return R_NilValue; /* dummy */
|
|
|
487 case DC_SIGCHAR_ULONGLONG:
|
|
|
488 case DC_SIGCHAR_LONGLONG:
|
|
|
489 error("Signature '*[lJ]' not implemented");
|
|
|
490 return R_NilValue; /* dummy */
|
|
|
491 case DC_SIGCHAR_FLOAT:
|
|
|
492 switch(type_id)
|
|
|
493 {
|
|
|
494 case NILSXP: ptrValue = (DCpointer) 0; break;
|
|
|
495 case RAWSXP:
|
|
|
496 if ( strcmp( CHAR(STRING_ELT(getAttrib(arg, install("class")),0)),"floatraw") == 0 ) {
|
|
|
497 ptrValue = (DCpointer) RAW(arg);
|
|
|
498 } else {
|
|
|
499 error("Argument type mismatch at position %d: expected 'pointer to C double' convertable value", argpos);
|
|
|
500 return R_NilValue; /* dummy */
|
|
|
501 }
|
|
|
502 break;
|
|
|
503 default: error("Argument type mismatch at position %d: expected 'pointer to C double' convertable value", argpos);
|
|
|
504 return R_NilValue; /* dummy */
|
|
|
505 }
|
|
|
506 break;
|
|
|
507 case DC_SIGCHAR_DOUBLE:
|
|
|
508 switch(type_id)
|
|
|
509 {
|
|
|
510 case NILSXP: ptrValue = (DCpointer) 0; break;
|
|
|
511 case REALSXP: ptrValue = (DCpointer) REAL(arg); break;
|
|
|
512 default: error("Argument type mismatch at position %d: expected 'pointer to C double' convertable value", argpos);
|
|
|
513 return R_NilValue; /* dummy */
|
|
|
514 }
|
|
|
515 break;
|
|
|
516 case DC_SIGCHAR_POINTER:
|
|
|
517 case DC_SIGCHAR_STRING:
|
|
|
518 switch(type_id)
|
|
|
519 {
|
|
|
520 case EXTPTRSXP:
|
|
|
521 ptrValue = R_ExternalPtrAddr( arg ); break;
|
|
|
522 default: error("low-level typed pointer on pointer not implemented");
|
|
|
523 return R_NilValue; /* dummy */
|
|
|
524 }
|
|
|
525 break;
|
|
|
526 default:
|
|
|
527 error("low-level typed pointer on C char pointer not implemented");
|
|
|
528 return R_NilValue; /* dummy */
|
|
|
529 }
|
|
|
530 dcArgPointer(pvm, ptrValue);
|
|
|
531 ptrcnt = 0;
|
|
|
532 }
|
|
|
533 }
|
|
|
534 }
|
|
|
535
|
|
|
536
|
|
|
537 if (args != R_NilValue) {
|
|
|
538 error ("Too many arguments for signature '%s'.", signature);
|
|
|
539 return R_NilValue; /* dummy */
|
|
|
540 }
|
|
|
541 /* process return type, invoke call and return R value */
|
|
|
542
|
|
|
543 switch(*sig++) {
|
|
|
544 case DC_SIGCHAR_BOOL: return ScalarLogical( ( dcCallBool(pvm, addr) == DC_FALSE ) ? FALSE : TRUE );
|
|
|
545
|
|
|
546 case DC_SIGCHAR_CHAR: return ScalarInteger( (int) dcCallChar(pvm, addr) );
|
|
|
547 case DC_SIGCHAR_UCHAR: return ScalarInteger( (int) ( (unsigned char) dcCallChar(pvm, addr ) ) );
|
|
|
548
|
|
|
549 case DC_SIGCHAR_SHORT: return ScalarInteger( (int) dcCallShort(pvm,addr) );
|
|
|
550 case DC_SIGCHAR_USHORT: return ScalarInteger( (int) ( (unsigned short) dcCallShort(pvm,addr) ) );
|
|
|
551
|
|
|
552 case DC_SIGCHAR_INT: return ScalarInteger( dcCallInt(pvm,addr) );
|
|
|
553 case DC_SIGCHAR_UINT: return ScalarReal( (double) (unsigned int) dcCallInt(pvm, addr) );
|
|
|
554
|
|
|
555 case DC_SIGCHAR_LONG: return ScalarReal( (double) dcCallLong(pvm, addr) );
|
|
|
556 case DC_SIGCHAR_ULONG: return ScalarReal( (double) ( (unsigned long) dcCallLong(pvm, addr) ) );
|
|
|
557
|
|
|
558 case DC_SIGCHAR_LONGLONG: return ScalarReal( (double) dcCallLongLong(pvm, addr) );
|
|
|
559 case DC_SIGCHAR_ULONGLONG: return ScalarReal( (double) dcCallLongLong(pvm, addr) );
|
|
|
560
|
|
|
561 case DC_SIGCHAR_FLOAT: return ScalarReal( (double) dcCallFloat(pvm,addr) );
|
|
|
562 case DC_SIGCHAR_DOUBLE: return ScalarReal( dcCallDouble(pvm,addr) );
|
|
|
563 case DC_SIGCHAR_POINTER: return R_MakeExternalPtr( dcCallPointer(pvm,addr), R_NilValue, R_NilValue );
|
|
|
564 case DC_SIGCHAR_STRING: return mkString( dcCallPointer(pvm, addr) );
|
|
|
565 case DC_SIGCHAR_VOID: dcCallVoid(pvm,addr); /* TODO: return invisible */ return R_NilValue;
|
|
|
566 case '*':
|
|
|
567 {
|
|
|
568 SEXP ans;
|
|
|
569 ptrcnt = 1;
|
|
|
570 while (*sig == '*') { ptrcnt++; sig++; }
|
|
|
571 switch(*sig) {
|
|
|
572 case '<': {
|
|
|
573 /* struct/union pointers */
|
|
|
574 PROTECT(ans = R_MakeExternalPtr( dcCallPointer(pvm, addr), R_NilValue, R_NilValue ) );
|
|
|
575 char buf[128];
|
|
|
576 const char* begin = ++sig;
|
|
|
577 const char* end = strchr(sig, '>');
|
|
|
578 size_t n = end - begin;
|
|
|
579 strncpy(buf, begin, n);
|
|
|
580 buf[n] = '\0';
|
|
|
581 setAttrib(ans, install("struct"), mkString(buf) );
|
|
|
582 setAttrib(ans, install("class"), mkString("struct") );
|
|
|
583 } break;
|
|
|
584 case 'C':
|
|
|
585 case 'c': {
|
|
|
586 PROTECT(ans = mkString( dcCallPointer(pvm, addr) ) );
|
|
|
587 } break;
|
|
|
588 case 'v': {
|
|
|
589 PROTECT(ans = R_MakeExternalPtr( dcCallPointer(pvm, addr), R_NilValue, R_NilValue ) );
|
|
|
590 } break;
|
|
|
591 default: error("Unsupported return type signature"); return R_NilValue;
|
|
|
592 }
|
|
|
593 UNPROTECT(1);
|
|
|
594 return(ans);
|
|
|
595 }
|
|
|
596 default: error("Unknown return type specification for signature '%s'.", signature);
|
|
|
597 return R_NilValue; /* dummy */
|
|
|
598 }
|
|
|
599
|
|
|
600 }
|
|
|
601
|
