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