Mercurial > pub > dyncall > bindings

comparison R/rdc/src/api.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 #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