Mercurial > pub > dyncall > bindings

comparison R/rdyncall/src/rdyncall.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/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