0
+ − 1 #include <R.h>
+ − 2 #define USE_RINTERNALS
+ − 3 #include <Rinternals.h>
+ − 4 #include <R_ext/Rdynload.h>
+ − 5 #include "dynload.h"
+ − 6 #include "dyncall.h"
+ − 7 #include "dyncall_signature.h"
+ − 8
+ − 9
+ − 10 /* rdcLoad */
+ − 11
+ − 12 SEXP rdcLoad(SEXP sLibPath)
+ − 13 {
+ − 14 void* libHandle;
+ − 15 const char* libPath;
+ − 16 SEXP r;
+ − 17 libPath = CHAR(STRING_ELT(sLibPath,0));
+ − 18
+ − 19 libHandle = dlLoadLibrary(libPath);
+ − 20
+ − 21 if (!libHandle) {
+ − 22 error("rdcLoad failed on path %s", libPath );
+ − 23 }
+ − 24
+ − 25 r = R_NilValue;
+ − 26
+ − 27 PROTECT( r = R_MakeExternalPtr(libHandle, R_NilValue, R_NilValue) );
+ − 28 UNPROTECT(1);
+ − 29
+ − 30 return r;
+ − 31 }
+ − 32
+ − 33 /* rdcFree */
+ − 34
+ − 35 SEXP rdcFree(SEXP sLibHandle)
+ − 36 {
+ − 37 void* libHandle;
+ − 38
+ − 39 libHandle = R_ExternalPtrAddr(sLibHandle);
+ − 40 dlFreeLibrary( libHandle );
+ − 41
+ − 42 R_SetExternalPtrAddr(sLibHandle, 0);
+ − 43 return R_NilValue;
+ − 44 }
+ − 45
+ − 46 /* rdcFind */
+ − 47
+ − 48 SEXP rdcFind(SEXP sLibHandle, SEXP sSymbol)
+ − 49 {
+ − 50 void* libHandle;
+ − 51 const char* symbol;
+ − 52 void* addr;
+ − 53 SEXP r;
+ − 54 libHandle = R_ExternalPtrAddr(sLibHandle);
+ − 55 symbol = CHAR(STRING_ELT(sSymbol,0) );
+ − 56 addr = dlFindSymbol( libHandle, symbol );
+ − 57
+ − 58 r = R_NilValue;
+ − 59
+ − 60 PROTECT( r = R_MakeExternalPtr(addr, R_NilValue, R_NilValue) );
+ − 61 UNPROTECT(1);
+ − 62
+ − 63 return r;
+ − 64 }
+ − 65
+ − 66 SEXP r_dcCall(SEXP sCallVM, SEXP sFuncPtr, SEXP sSignature, SEXP sArgs)
+ − 67 {
+ − 68 DCCallVM* pvm;
+ − 69 void* funcPtr;
+ − 70 const char* signature;
+ − 71 const char* ptr;
+ − 72 int i,l,protect_count;
+ − 73 SEXP r;
+ − 74
+ − 75 pvm = R_ExternalPtrAddr(sCallVM);
+ − 76 if (!pvm) error("callvm is null");
+ − 77
+ − 78 funcPtr = R_ExternalPtrAddr(sFuncPtr);
+ − 79 if (!funcPtr) error("funcptr is null");
+ − 80
+ − 81 signature = CHAR(STRING_ELT(sSignature,0) );
+ − 82 if (!signature) error("signature is null");
+ − 83
+ − 84 dcReset(pvm);
+ − 85 ptr = signature;
+ − 86
+ − 87 l = LENGTH(sArgs);
+ − 88 i = 0;
+ − 89 protect_count = 0;
+ − 90 for(;;) {
+ − 91 char ch = *ptr++;
+ − 92 SEXP arg;
+ − 93
+ − 94 if (ch == '\0') error("invalid signature - no return type specified");
+ − 95
+ − 96 if (ch == ')') break;
+ − 97
+ − 98 if (i >= l) error("not enough arguments for given signature (arg length = %d %d %c)", l,i,ch );
+ − 99
+ − 100 arg = VECTOR_ELT(sArgs,i);
+ − 101 switch(ch) {
+ − 102 case DC_SIGCHAR_BOOL:
+ − 103 {
+ − 104 DCbool value;
+ − 105 if ( isLogical(arg) )
+ − 106 {
+ − 107 value = ( LOGICAL(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE;
+ − 108 }
+ − 109 else
+ − 110 {
+ − 111 value = LOGICAL( coerceVector(arg, LGLSXP) )[0] ? DC_FALSE : DC_TRUE;
+ − 112 }
+ − 113 dcArgBool(pvm, value );
+ − 114 break;
+ − 115 }
+ − 116 case DC_SIGCHAR_INT:
+ − 117 {
+ − 118 int value;
+ − 119 if ( isInteger(arg) )
+ − 120 {
+ − 121 value = INTEGER(arg)[0];
+ − 122 }
+ − 123 else
+ − 124 {
+ − 125 value = INTEGER( coerceVector(arg, INTSXP) )[0];
+ − 126 }
+ − 127 dcArgInt(pvm, value);
+ − 128 break;
+ − 129 }
+ − 130 case DC_SIGCHAR_FLOAT:
+ − 131 {
+ − 132 dcArgFloat( pvm, (float) REAL( coerceVector(arg, REALSXP) )[0] );
+ − 133 break;
+ − 134 }
+ − 135 case DC_SIGCHAR_DOUBLE:
+ − 136 {
+ − 137 double value;
+ − 138 if ( isReal(arg) )
+ − 139 {
+ − 140 value = REAL(arg)[0];
+ − 141 }
+ − 142 else
+ − 143 {
+ − 144 value = REAL( coerceVector(arg,REALSXP) )[0];
+ − 145 }
+ − 146 dcArgDouble( pvm, value );
+ − 147 break;
+ − 148 }
+ − 149 /*
+ − 150 case DC_SIGCHAR_LONG:
+ − 151 {
+ − 152 PROTECT(arg = coerceVector(arg, REALSXP) );
+ − 153 dcArgLong( pvm, (DClong) ( REAL(arg)[0] ) );
+ − 154 UNPROTECT(1);
+ − 155 break;
+ − 156 }
+ − 157 */
+ − 158 case DC_SIGCHAR_STRING:
+ − 159 {
+ − 160 DCpointer ptr;
+ − 161 if (arg == R_NilValue) ptr = (DCpointer) 0;
+ − 162 else if (isString(arg)) ptr = (DCpointer) CHAR( STRING_ELT(arg,0) );
+ − 163 else {
+ − 164 if (protect_count) UNPROTECT(protect_count);
+ − 165 error("invalid value for C string argument"); break;
+ − 166 }
+ − 167 }
+ − 168 case DC_SIGCHAR_POINTER:
+ − 169 {
+ − 170 DCpointer ptr;
+ − 171 if ( arg == R_NilValue ) ptr = (DCpointer) 0;
+ − 172 else if (isString(arg) ) ptr = (DCpointer) CHAR( STRING_ELT(arg,0) );
+ − 173 else if (isReal(arg) ) ptr = (DCpointer) REAL(arg);
+ − 174 else if (isInteger(arg) ) ptr = (DCpointer) INTEGER(arg);
+ − 175 else if (isLogical(arg) ) ptr = (DCpointer) LOGICAL(arg);
+ − 176 else if (TYPEOF(arg) == EXTPTRSXP) ptr = R_ExternalPtrAddr(arg);
+ − 177 else {
+ − 178 if (protect_count) UNPROTECT(protect_count);
+ − 179 error("invalid signature"); break;
+ − 180 }
+ − 181 dcArgPointer(pvm, ptr);
+ − 182 break;
+ − 183 }
+ − 184 }
+ − 185 ++i;
+ − 186 }
+ − 187
+ − 188 if ( i != l )
+ − 189 {
+ − 190 if (protect_count)
+ − 191 UNPROTECT(protect_count);
+ − 192 error ("signature claims to have %d arguments while %d arguments are given", i, l);
+ − 193 }
+ − 194
+ − 195 switch(*ptr) {
+ − 196 case DC_SIGCHAR_BOOL:
+ − 197 PROTECT( r = allocVector(LGLSXP, 1) ); protect_count++;
+ − 198 LOGICAL(r)[0] = ( dcCallBool(pvm, funcPtr) == DC_FALSE ) ? FALSE : TRUE;
+ − 199 UNPROTECT(protect_count);
+ − 200 return r;
+ − 201 case DC_SIGCHAR_CHAR:
+ − 202 PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
+ − 203 INTEGER(r)[0] = dcCallChar(pvm, funcPtr);
+ − 204 UNPROTECT(protect_count);
+ − 205 return r;
+ − 206 case DC_SIGCHAR_SHORT:
+ − 207 PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
+ − 208 INTEGER(r)[0] = dcCallShort(pvm, funcPtr);
+ − 209 UNPROTECT(protect_count);
+ − 210 return r;
+ − 211 case DC_SIGCHAR_LONG:
+ − 212 PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
+ − 213 INTEGER(r)[0] = dcCallLong(pvm, funcPtr);
+ − 214 UNPROTECT(protect_count);
+ − 215 return r;
+ − 216 case DC_SIGCHAR_INT:
+ − 217 PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
+ − 218 INTEGER(r)[0] = dcCallInt(pvm, funcPtr);
+ − 219 UNPROTECT(protect_count);
+ − 220 return r;
+ − 221 case DC_SIGCHAR_LONGLONG:
+ − 222 PROTECT( r = allocVector(REALSXP, 1) ); protect_count++;
+ − 223 REAL(r)[0] = (double) ( dcCallLong(pvm, funcPtr) );
+ − 224 UNPROTECT(protect_count);
+ − 225 return r;
+ − 226 case DC_SIGCHAR_FLOAT:
+ − 227 PROTECT( r = allocVector(REALSXP, 1) ); protect_count++;
+ − 228 REAL(r)[0] = (double) ( dcCallFloat(pvm, funcPtr) );
+ − 229 UNPROTECT(protect_count);
+ − 230 return r;
+ − 231 case DC_SIGCHAR_DOUBLE:
+ − 232 PROTECT( r = allocVector(REALSXP, 1) );
+ − 233 protect_count++;
+ − 234 REAL(r)[0] = dcCallDouble(pvm, funcPtr);
+ − 235 UNPROTECT(protect_count);
+ − 236 return r;
+ − 237 case DC_SIGCHAR_POINTER:
+ − 238 PROTECT( r = R_MakeExternalPtr( dcCallPointer(pvm,funcPtr), R_NilValue, R_NilValue ) );
+ − 239 protect_count++;
+ − 240 UNPROTECT(protect_count);
+ − 241 return r;
+ − 242 case DC_SIGCHAR_VOID:
+ − 243 dcCallVoid(pvm,funcPtr);
+ − 244 if (protect_count) UNPROTECT(protect_count);
+ − 245 break;
+ − 246 default:
+ − 247 {
+ − 248 if (protect_count)
+ − 249 UNPROTECT(protect_count);
+ − 250 error("invalid return type signature");
+ − 251 }
+ − 252 break;
+ − 253 }
+ − 254 return R_NilValue;
+ − 255
+ − 256 }
+ − 257
+ − 258 /* rdcCall */
+ − 259
+ − 260 DCCallVM* gCall;
+ − 261
+ − 262 SEXP rdcCall(SEXP sFuncPtr, SEXP sSignature, SEXP sArgs)
+ − 263 {
+ − 264 void* funcPtr;
+ − 265 const char* signature;
+ − 266 const char* ptr;
+ − 267 int i,l,protect_count;
+ − 268 SEXP r;
+ − 269
+ − 270 funcPtr = R_ExternalPtrAddr(sFuncPtr);
+ − 271
+ − 272 if (!funcPtr) error("funcptr is null");
+ − 273
+ − 274 signature = CHAR(STRING_ELT(sSignature,0) );
+ − 275
+ − 276 if (!signature) error("signature is null");
+ − 277
+ − 278 dcReset(gCall);
+ − 279 ptr = signature;
+ − 280
+ − 281 l = LENGTH(sArgs);
+ − 282 i = 0;
+ − 283 protect_count = 0;
+ − 284 for(;;) {
+ − 285 char ch = *ptr++;
+ − 286 SEXP arg;
+ − 287
+ − 288 if (ch == '\0') error("invalid signature - no return type specified");
+ − 289
+ − 290 if (ch == ')') break;
+ − 291
+ − 292 if (i >= l) error("not enough arguments for given signature (arg length = %d %d %c)", l,i,ch );
+ − 293
+ − 294 arg = VECTOR_ELT(sArgs,i);
+ − 295 switch(ch) {
+ − 296 case DC_SIGCHAR_BOOL:
+ − 297 {
+ − 298 if ( !isLogical(arg) )
+ − 299 {
+ − 300 PROTECT(arg = coerceVector(arg, LGLSXP));
+ − 301 protect_count++;
+ − 302 }
+ − 303 dcArgBool(gCall, ( LOGICAL(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE );
+ − 304 // UNPROTECT(1);
+ − 305 break;
+ − 306 }
+ − 307 case DC_SIGCHAR_INT:
+ − 308 {
+ − 309 if ( !isInteger(arg) )
+ − 310 {
+ − 311 PROTECT(arg = coerceVector(arg, INTSXP));
+ − 312 protect_count++;
+ − 313 }
+ − 314 dcArgInt(gCall, INTEGER(arg)[0]);
+ − 315 // UNPROTECT(1);
+ − 316 break;
+ − 317 }
+ − 318 case DC_SIGCHAR_FLOAT:
+ − 319 {
+ − 320 PROTECT(arg = coerceVector(arg, REALSXP) );
+ − 321 dcArgFloat( gCall, REAL(arg)[0] );
+ − 322 UNPROTECT(1);
+ − 323 break;
+ − 324 }
+ − 325 case DC_SIGCHAR_DOUBLE:
+ − 326 {
+ − 327 if ( !isReal(arg) )
+ − 328 {
+ − 329 PROTECT(arg = coerceVector(arg, REALSXP) );
+ − 330 protect_count++;
+ − 331 }
+ − 332 dcArgDouble( gCall, REAL(arg)[0] );
+ − 333 // UNPROTECT(1);
+ − 334 break;
+ − 335 }
+ − 336 /*
+ − 337 case DC_SIGCHAR_LONG:
+ − 338 {
+ − 339 PROTECT(arg = coerceVector(arg, REALSXP) );
+ − 340 dcArgLong( gCall, (DClong) ( REAL(arg)[0] ) );
+ − 341 UNPROTECT(1);
+ − 342 break;
+ − 343 }
+ − 344 */
+ − 345 case DC_SIGCHAR_STRING:
+ − 346 {
+ − 347 DCpointer ptr;
+ − 348 if (arg == R_NilValue) ptr = (DCpointer) 0;
+ − 349 else if (isString(arg)) ptr = (DCpointer) CHAR( STRING_ELT(arg,0) );
+ − 350 else {
+ − 351 if (protect_count) UNPROTECT(protect_count);
+ − 352 error("invalid value for C string argument"); break;
+ − 353 }
+ − 354 }
+ − 355 case DC_SIGCHAR_POINTER:
+ − 356 {
+ − 357 DCpointer ptr;
+ − 358 if ( arg == R_NilValue ) ptr = (DCpointer) 0;
+ − 359 else if (isString(arg) ) ptr = (DCpointer) CHAR( STRING_ELT(arg,0) );
+ − 360 else if (isReal(arg) ) ptr = (DCpointer) REAL(arg);
+ − 361 else if (isInteger(arg) ) ptr = (DCpointer) INTEGER(arg);
+ − 362 else if (isLogical(arg) ) ptr = (DCpointer) LOGICAL(arg);
+ − 363 else if (TYPEOF(arg) == EXTPTRSXP) ptr = R_ExternalPtrAddr(arg);
+ − 364 else {
+ − 365 if (protect_count) UNPROTECT(protect_count);
+ − 366 error("invalid signature"); break;
+ − 367 }
+ − 368 dcArgPointer(gCall, ptr);
+ − 369 break;
+ − 370 }
+ − 371 }
+ − 372 ++i;
+ − 373 }
+ − 374
+ − 375 if ( i != l )
+ − 376 {
+ − 377 if (protect_count)
+ − 378 UNPROTECT(protect_count);
+ − 379 error ("signature claims to have %d arguments while %d arguments are given", i, l);
+ − 380 }
+ − 381
+ − 382 switch(*ptr) {
+ − 383 case DC_SIGCHAR_BOOL:
+ − 384 PROTECT( r = allocVector(LGLSXP, 1) ); protect_count++;
+ − 385 LOGICAL(r)[0] = ( dcCallBool(gCall, funcPtr) == DC_FALSE ) ? FALSE : TRUE;
+ − 386 UNPROTECT(protect_count);
+ − 387 return r;
+ − 388 case DC_SIGCHAR_INT:
+ − 389 PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
+ − 390 INTEGER(r)[0] = dcCallInt(gCall, funcPtr);
+ − 391 UNPROTECT(protect_count);
+ − 392 return r;
+ − 393 case DC_SIGCHAR_LONG:
+ − 394 PROTECT( r = allocVector(REALSXP, 1) ); protect_count++;
+ − 395 REAL(r)[0] = (double) ( dcCallLong(gCall, funcPtr) );
+ − 396 UNPROTECT(protect_count);
+ − 397 return r;
+ − 398 case DC_SIGCHAR_FLOAT:
+ − 399 PROTECT( r = allocVector(REALSXP, 1) ); protect_count++;
+ − 400 REAL(r)[0] = (double) ( dcCallFloat(gCall, funcPtr) );
+ − 401 UNPROTECT(protect_count);
+ − 402 return r;
+ − 403 case DC_SIGCHAR_DOUBLE:
+ − 404 PROTECT( r = allocVector(REALSXP, 1) );
+ − 405 protect_count++;
+ − 406 REAL(r)[0] = dcCallDouble(gCall, funcPtr);
+ − 407 UNPROTECT(protect_count);
+ − 408 return r;
+ − 409 case DC_SIGCHAR_POINTER:
+ − 410 PROTECT( r = R_MakeExternalPtr( dcCallPointer(gCall,funcPtr), R_NilValue, R_NilValue ) );
+ − 411 protect_count++;
+ − 412 UNPROTECT(protect_count);
+ − 413 return r;
+ − 414 case DC_SIGCHAR_VOID:
+ − 415 dcCallVoid(gCall,funcPtr);
+ − 416 if (protect_count) UNPROTECT(protect_count);
+ − 417 break;
+ − 418 default:
+ − 419 {
+ − 420 if (protect_count)
+ − 421 UNPROTECT(protect_count);
+ − 422 error("invalid return type signature");
+ − 423 }
+ − 424 }
+ − 425 return R_NilValue;
+ − 426 }
+ − 427
+ − 428 SEXP rdcUnpack1(SEXP ptr_x, SEXP offset, SEXP sig_x)
+ − 429 {
+ − 430 char* ptr = ( (char*) R_ExternalPtrAddr(ptr_x) ) + INTEGER(offset)[0];
+ − 431 const char* sig = CHAR(STRING_ELT(sig_x,0) );
+ − 432 switch(sig[0])
+ − 433 {
+ − 434 case DC_SIGCHAR_CHAR: return ScalarInteger( ( (unsigned char*)ptr)[0] );
+ − 435 case DC_SIGCHAR_INT: return ScalarInteger( ( (int*)ptr )[0] );
+ − 436 case DC_SIGCHAR_FLOAT: return ScalarReal( (double) ( (float*) ptr )[0] );
+ − 437 case DC_SIGCHAR_DOUBLE: return ScalarReal( ((double*)ptr)[0] );
+ − 438 default: error("invalid signature");
+ − 439 }
+ − 440 return R_NilValue;
+ − 441 }
+ − 442
+ − 443 SEXP rdcDataPtr(SEXP x, SEXP offset)
+ − 444 {
+ − 445 void* ptr = ( ( (unsigned char*) DATAPTR(x) ) + INTEGER(offset)[0] );
+ − 446 return R_MakeExternalPtr( ptr, R_NilValue, R_NilValue );
+ − 447 }
+ − 448
+ − 449 SEXP rdcMode(SEXP id)
+ − 450 {
+ − 451 dcMode( gCall, INTEGER(id)[0] );
+ − 452 dcReset( gCall );
+ − 453 return R_NilValue;
+ − 454 }
+ − 455
+ − 456 SEXP r_dcNewCallVM(SEXP size)
+ − 457 {
+ − 458 return R_MakeExternalPtr( dcNewCallVM( INTEGER(size)[0] ), R_NilValue, R_NilValue );
+ − 459 }
+ − 460
+ − 461 SEXP r_dcFree(SEXP callvm)
+ − 462 {
+ − 463 DCCallVM* pvm = R_ExternalPtrAddr(callvm);
+ − 464 dcFree(pvm);
+ − 465 return R_NilValue;
+ − 466 }
+ − 467
+ − 468 SEXP r_dcMode(SEXP callvm, SEXP id)
+ − 469 {
+ − 470 DCCallVM* pvm = R_ExternalPtrAddr(callvm);
+ − 471 dcMode( pvm, INTEGER(id)[0] );
+ − 472 dcReset( pvm );
+ − 473 return R_NilValue;
+ − 474 }
+ − 475
+ − 476 /* register R to C calls */
+ − 477
+ − 478 R_CallMethodDef callMethods[] =
+ − 479 {
+ − 480 {"rdcLoad", (DL_FUNC) &rdcLoad, 1},
+ − 481 {"rdcFree", (DL_FUNC) &rdcFree, 1},
+ − 482 {"rdcFind", (DL_FUNC) &rdcFind, 2},
+ − 483 {"rdcCall", (DL_FUNC) &rdcCall, 3},
+ − 484 {"rdcUnpack1", (DL_FUNC) &rdcUnpack1, 3},
+ − 485 {"rdcDataPtr", (DL_FUNC) &rdcDataPtr, 2},
+ − 486 {"rdcMode", (DL_FUNC) &rdcMode, 1},
+ − 487
+ − 488 {"dcNewCallVM", (DL_FUNC) &r_dcNewCallVM, 1},
+ − 489 {"dcFree", (DL_FUNC) &r_dcFree, 1},
+ − 490 {"dcCall", (DL_FUNC) &r_dcCall, 4},
+ − 491 {"dcMode", (DL_FUNC) &r_dcMode, 2},
+ − 492
+ − 493 {NULL, NULL, 0}
+ − 494 };
+ − 495
+ − 496 void R_init_rdc(DllInfo *info)
+ − 497 {
+ − 498 R_registerRoutines(info, NULL, callMethods, NULL, NULL);
+ − 499 gCall = dcNewCallVM(4096);
+ − 500 }
+ − 501
+ − 502 void R_unload_rdc(DllInfo *info)
+ − 503 {
+ − 504 }
+ − 505