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
|