Mercurial > pub > dyncall > bindings
diff R/rdyncall/src/rdyncall.c @ 0:0cfcc391201f
initial from svn dyncall-1745
author | Daniel Adler |
---|---|
date | Thu, 19 Mar 2015 22:26:28 +0100 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/R/rdyncall/src/rdyncall.c Thu Mar 19 22:26:28 2015 +0100 @@ -0,0 +1,601 @@ +/** =========================================================================== + ** R-Package: rdyncall + ** File: src/rdyncall.c + ** Description: R bindings to dyncall + **/ + +#include <Rinternals.h> +#include "dyncall.h" +#include "rdyncall_signature.h" +#include <string.h> +#include <ctype.h> + +/** --------------------------------------------------------------------------- + ** C-Function: new_callvm + ** R-Interface: .Call + **/ + +SEXP r_new_callvm(SEXP mode_x, SEXP size_x) +{ + /* default call mode is "cdecl" */ + int size_i = INTEGER(size_x)[0]; + + const char* mode_S = CHAR( STRING_ELT( mode_x, 0 ) ); + + int mode_i = DC_CALL_C_DEFAULT; + if (strcmp(mode_S,"default") == 0 || strcmp(mode_S,"cdecl") == 0) mode_i = DC_CALL_C_DEFAULT; +#if WIN32 + else if (strcmp(mode_S,"stdcall") == 0) mode_i = DC_CALL_C_X86_WIN32_STD; + else if (strcmp(mode_S,"thiscall") == 0) mode_i = DC_CALL_C_X86_WIN32_THIS_GNU; + else if (strcmp(mode_S,"thiscall.gcc") == 0) mode_i = DC_CALL_C_X86_WIN32_THIS_GNU; + else if (strcmp(mode_S,"thiscall.msvc") == 0) mode_i = DC_CALL_C_X86_WIN32_THIS_MS; + else if (strcmp(mode_S,"fastcall") == 0) mode_i = DC_CALL_C_X86_WIN32_FAST_GNU; + else if (strcmp(mode_S,"fastcall.msvc") == 0) mode_i = DC_CALL_C_X86_WIN32_FAST_MS; + else if (strcmp(mode_S,"fastcall.gcc") == 0) mode_i = DC_CALL_C_X86_WIN32_FAST_GNU; +#endif +/* + else { error("invalid 'callmode'"); return R_NilValue; } +*/ + + DCCallVM* pvm = dcNewCallVM(size_i); + dcMode( pvm, mode_i ); + return R_MakeExternalPtr( pvm, R_NilValue, R_NilValue ); +} + +/** --------------------------------------------------------------------------- + ** C-Function: free_callvm + ** R-Interface: .Call + **/ + +SEXP r_free_callvm(SEXP callvm_x) +{ + DCCallVM* callvm_p = (DCCallVM*) R_ExternalPtrAddr( callvm_x ); + dcFree( callvm_p ); + return R_NilValue; +} + +/** --------------------------------------------------------------------------- + ** C-Function: r_dyncall + ** R-Interface: .External + **/ + +SEXP r_dyncall(SEXP args) /* callvm, address, signature, args ... */ +{ + DCCallVM* pvm; + void* addr; + const char* signature; + const char* sig; + SEXP arg; + int ptrcnt; + int argpos; + + args = CDR(args); + + /* extract CallVM reference, address and signature */ + + pvm = (DCCallVM*) R_ExternalPtrAddr( CAR(args) ); args = CDR(args); + + switch(TYPEOF(CAR(args))) { + case EXTPTRSXP: + addr = R_ExternalPtrAddr( CAR(args) ); args = CDR(args); + if (!addr) { + error("Target address is null-pointer."); + return R_NilValue; /* dummy */ + } + break; + default: + error("Target address must be external pointer."); + return R_NilValue; /* dummy */ + } + signature = CHAR( STRING_ELT( CAR(args), 0 ) ); args = CDR(args); + sig = signature; + + if (!pvm) { + error("Argument 'callvm' is null"); + /* dummy */ return R_NilValue; + } + if (!addr) { + error("Argument 'addr' is null"); + /* dummy */ return R_NilValue; + } + /* reset CallVM to initial state */ + + dcReset(pvm); + ptrcnt = 0; + argpos = 0; + + /* function calling convention prefix '_' */ + if (*sig == DC_SIGCHAR_CC_PREFIX) { + /* specify calling convention by signature prefix hint */ + ++sig; + char ch = *sig++; + int mode = DC_CALL_C_DEFAULT; + switch(ch) + { + case DC_SIGCHAR_CC_STDCALL: + mode = DC_CALL_C_X86_WIN32_STD; break; + case DC_SIGCHAR_CC_FASTCALL_GNU: + mode = DC_CALL_C_X86_WIN32_FAST_GNU; break; + case DC_SIGCHAR_CC_FASTCALL_MS: + mode = DC_CALL_C_X86_WIN32_FAST_MS; break; + default: + error("Unknown calling convention prefix hint signature character '%c'", ch ); + /* dummy */ return R_NilValue; + } + dcMode(pvm, mode); + } + + /* load arguments */ + for(;;) { + + char ch = *sig++; + + if (ch == '\0') { + error("Function-call signature '%s' is invalid - missing argument terminator character ')' and return type signature.", signature); + /* dummy */ return R_NilValue; + } + /* argument terminator */ + if (ch == ')') break; + + /* end of arguments? */ + if (args == R_NilValue) { + error("Not enough arguments for function-call signature '%s'.", signature); + /* dummy */ return R_NilValue; + } + /* pointer counter */ + else if (ch == '*') { ptrcnt++; continue; } + + /* unpack next argument */ + arg = CAR(args); args = CDR(args); + argpos++; + + int type_id = TYPEOF(arg); + + if (ptrcnt == 0) { /* base types */ + + /* 'x' signature for passing language objects 'as-is' */ + if (ch == DC_SIGCHAR_SEXP) { + dcArgPointer(pvm, (void*)arg); + continue; + } + + if ( type_id != NILSXP && type_id != EXTPTRSXP && LENGTH(arg) == 0 ) { + error("Argument type mismatch at position %d: expected length greater zero.", argpos); + /* dummy */ return R_NilValue; + } + switch(ch) { + case DC_SIGCHAR_BOOL: + { + DCbool boolValue; + switch(type_id) + { + case LGLSXP: boolValue = ( LOGICAL(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE; break; + case INTSXP: boolValue = ( INTEGER(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE; break; + case REALSXP: boolValue = ( REAL(arg)[0] == 0.0 ) ? DC_FALSE : DC_TRUE; break; + case RAWSXP: boolValue = ( RAW(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE; break; + default: error("Argument type mismatch at position %d: expected C bool convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgBool(pvm, boolValue ); + } + break; + case DC_SIGCHAR_CHAR: + { + char charValue; + switch(type_id) + { + case LGLSXP: charValue = (char) LOGICAL(arg)[0]; break; + case INTSXP: charValue = (char) INTEGER(arg)[0]; break; + case REALSXP: charValue = (char) REAL(arg)[0]; break; + case RAWSXP: charValue = (char) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C char convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgChar(pvm, charValue); + } + break; + case DC_SIGCHAR_UCHAR: + { + unsigned char charValue; + switch(type_id) + { + case LGLSXP: charValue = (unsigned char) LOGICAL(arg)[0]; break; + case INTSXP: charValue = (unsigned char) INTEGER(arg)[0]; break; + case REALSXP: charValue = (unsigned char) REAL(arg)[0]; break; + case RAWSXP: charValue = (unsigned char) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C unsigned char convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgChar(pvm, *( (char*) &charValue )); + } + break; + case DC_SIGCHAR_SHORT: + { + short shortValue; + switch(type_id) + { + case LGLSXP: shortValue = (short) LOGICAL(arg)[0]; break; + case INTSXP: shortValue = (short) INTEGER(arg)[0]; break; + case REALSXP: shortValue = (short) REAL(arg)[0]; break; + case RAWSXP: shortValue = (short) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C short convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgShort(pvm, shortValue); + } + break; + case DC_SIGCHAR_USHORT: + { + unsigned short shortValue; + switch(type_id) + { + case LGLSXP: shortValue = (unsigned short) LOGICAL(arg)[0]; break; + case INTSXP: shortValue = (unsigned short) INTEGER(arg)[0]; break; + case REALSXP: shortValue = (unsigned short) REAL(arg)[0]; break; + case RAWSXP: shortValue = (unsigned short) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C unsigned short convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgShort(pvm, *( (short*) &shortValue ) ); + } + break; + case DC_SIGCHAR_LONG: + { + long longValue; + switch(type_id) + { + case LGLSXP: longValue = (long) LOGICAL(arg)[0]; break; + case INTSXP: longValue = (long) INTEGER(arg)[0]; break; + case REALSXP: longValue = (long) REAL(arg)[0]; break; + case RAWSXP: longValue = (long) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C long convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgLong(pvm, longValue); + } + break; + case DC_SIGCHAR_ULONG: + { + unsigned long ulongValue; + switch(type_id) + { + case LGLSXP: ulongValue = (unsigned long) LOGICAL(arg)[0]; break; + case INTSXP: ulongValue = (unsigned long) INTEGER(arg)[0]; break; + case REALSXP: ulongValue = (unsigned long) REAL(arg)[0]; break; + case RAWSXP: ulongValue = (unsigned long) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C unsigned long convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgLong(pvm, (unsigned long) ulongValue); + } + break; + case DC_SIGCHAR_INT: + { + int intValue; + switch(type_id) + { + case LGLSXP: intValue = (int) LOGICAL(arg)[0]; break; + case INTSXP: intValue = INTEGER(arg)[0]; break; + case REALSXP: intValue = (int) REAL(arg)[0]; break; + case RAWSXP: intValue = (int) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C int convertable value", argpos); /*dummy*/ return R_NilValue; + } + dcArgInt(pvm, intValue); + } + break; + case DC_SIGCHAR_UINT: + { + unsigned int intValue; + switch(type_id) + { + case LGLSXP: intValue = (unsigned int) LOGICAL(arg)[0]; break; + case INTSXP: intValue = (unsigned int) INTEGER(arg)[0]; break; + case REALSXP: intValue = (unsigned int) REAL(arg)[0]; break; + case RAWSXP: intValue = (unsigned int) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C unsigned int convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgInt(pvm, * (int*) &intValue); + } + break; + case DC_SIGCHAR_FLOAT: + { + float floatValue; + switch(type_id) + { + case LGLSXP: floatValue = (float) LOGICAL(arg)[0]; break; + case INTSXP: floatValue = (float) INTEGER(arg)[0]; break; + case REALSXP: floatValue = (float) REAL(arg)[0]; break; + case RAWSXP: floatValue = (float) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C float convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgFloat( pvm, floatValue ); + } + break; + case DC_SIGCHAR_DOUBLE: + { + DCdouble doubleValue; + switch(type_id) + { + case LGLSXP: doubleValue = (double) LOGICAL(arg)[0]; break; + case INTSXP: doubleValue = (double) INTEGER(arg)[0]; break; + case REALSXP: doubleValue = REAL(arg)[0]; break; + case RAWSXP: doubleValue = (double) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C double convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgDouble( pvm, doubleValue ); + } + break; + case DC_SIGCHAR_LONGLONG: + { + DClonglong longlongValue; + switch(type_id) + { + case LGLSXP: longlongValue = (DClonglong) LOGICAL(arg)[0]; break; + case INTSXP: longlongValue = (DClonglong) INTEGER(arg)[0]; break; + case REALSXP: longlongValue = (DClonglong) REAL(arg)[0]; break; + case RAWSXP: longlongValue = (DClonglong) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C long long (int64_t) convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgLongLong( pvm, longlongValue ); + } + break; + case DC_SIGCHAR_ULONGLONG: + { + DCulonglong ulonglongValue; + switch(type_id) + { + case LGLSXP: ulonglongValue = (DCulonglong) LOGICAL(arg)[0]; break; + case INTSXP: ulonglongValue = (DCulonglong) INTEGER(arg)[0]; break; + case REALSXP: ulonglongValue = (DCulonglong) REAL(arg)[0]; break; + case RAWSXP: ulonglongValue = (DCulonglong) RAW(arg)[0]; break; + default: error("Argument type mismatch at position %d: expected C unsigned long long (uint64_t) convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgLongLong( pvm, *( (DClonglong*)&ulonglongValue ) ); + } + break; + case DC_SIGCHAR_POINTER: + { + DCpointer ptrValue; + switch(type_id) + { + case NILSXP: ptrValue = (DCpointer) 0; break; + case CHARSXP: ptrValue = (DCpointer) CHAR(arg); break; + case SYMSXP: ptrValue = (DCpointer) PRINTNAME(arg); break; + case STRSXP: ptrValue = (DCpointer) CHAR(STRING_ELT(arg,0)); break; + case LGLSXP: ptrValue = (DCpointer) LOGICAL(arg); break; + case INTSXP: ptrValue = (DCpointer) INTEGER(arg); break; + case REALSXP: ptrValue = (DCpointer) REAL(arg); break; + case CPLXSXP: ptrValue = (DCpointer) COMPLEX(arg); break; + case RAWSXP: ptrValue = (DCpointer) RAW(arg); break; + case EXTPTRSXP: ptrValue = R_ExternalPtrAddr(arg); break; + // case ENVSXP: ptrValue = (DCpointer) arg; break; + default: error("Argument type mismatch at position %d: expected C pointer convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgPointer(pvm, ptrValue); + } + break; + case DC_SIGCHAR_STRING: + { + DCpointer cstringValue; + switch(type_id) + { + case NILSXP: cstringValue = (DCpointer) 0; break; + case CHARSXP: cstringValue = (DCpointer) CHAR(arg); break; + case SYMSXP: cstringValue = (DCpointer) PRINTNAME(arg); break; + case STRSXP: cstringValue = (DCpointer) CHAR( STRING_ELT(arg,0) ); break; + case EXTPTRSXP: cstringValue = R_ExternalPtrAddr(arg); break; + default: error("Argument type mismatch at position %d: expected C string pointer convertable value", argpos); /* dummy */ return R_NilValue; + } + dcArgPointer(pvm, cstringValue); + } + break; + default: error("Signature type mismatch at position %d: Unknown token '%c' at argument %d.", ch, argpos); /* dummy */ return R_NilValue; + } + } else { /* ptrcnt > 0 */ + DCpointer ptrValue; + if (ch == '<') { /* typed high-level struct/union pointer */ + char const * e; + char const * b; + char const * n; + int l; + b = sig; + while( isalnum(*sig) || *sig == '_' ) sig++; + if (*sig != '>') { + error("Invalid signature '%s' - missing '>' marker for structure at argument %d.", signature, argpos); + return R_NilValue; /* Dummy */ + } + sig++; + /* check pointer type */ + if (type_id != NILSXP) { + SEXP structName = getAttrib(arg, install("struct")); + if (structName == R_NilValue) { + error("typed pointer needed here"); + return R_NilValue; /* Dummy */ + } + e = sig-1; + l = e - b; + n = CHAR(STRING_ELT(structName,0)); + if ( (strlen(n) != l) || (strncmp(b,n,l) != 0) ) { + error("incompatible pointer types"); + return R_NilValue; /* Dummy */ + } + } + switch(type_id) { + case NILSXP: ptrValue = (DCpointer) 0; break; + case EXTPTRSXP: ptrValue = R_ExternalPtrAddr(arg); break; + case RAWSXP: ptrValue = (DCpointer) RAW(arg); break; + default: error("internal error: typed-pointer can be external pointers or raw only."); + return R_NilValue; /* Dummy */ + } + dcArgPointer(pvm, ptrValue); + ptrcnt = 0; + } else { /* typed low-level pointers */ + switch(ch) { + case DC_SIGCHAR_VOID: + switch(type_id) + { + case NILSXP: ptrValue = (DCpointer) 0; break; + case STRSXP: ptrValue = (DCpointer) CHAR(STRING_ELT(arg,0)); break; + case LGLSXP: ptrValue = (DCpointer) LOGICAL(arg); break; + case INTSXP: ptrValue = (DCpointer) INTEGER(arg); break; + case REALSXP: ptrValue = (DCpointer) REAL(arg); break; + case CPLXSXP: ptrValue = (DCpointer) COMPLEX(arg); break; + case RAWSXP: ptrValue = (DCpointer) RAW(arg); break; + case EXTPTRSXP: ptrValue = R_ExternalPtrAddr(arg); break; + default: error("Argument type mismatch at position %d: expected pointer convertable value", argpos); + return R_NilValue; /* dummy */ + } + break; + case DC_SIGCHAR_CHAR: + case DC_SIGCHAR_UCHAR: + switch(type_id) + { + case NILSXP: ptrValue = (DCpointer) 0; break; + case STRSXP: + if (ptrcnt == 1) { + ptrValue = (DCpointer) CHAR( STRING_ELT(arg,0) ); + } else { + error("Argument type mismatch at position %d: expected 'C string' convertable value", argpos); + return R_NilValue; /* dummy */ + } + break; + case RAWSXP: + if (ptrcnt == 1) { + ptrValue = RAW(arg); + } else { + error("Argument type mismatch at position %d: expected 'C string' convertable value", argpos); + return R_NilValue; /* dummy */ + } + break; + case EXTPTRSXP: ptrValue = R_ExternalPtrAddr(arg); break; + default: + error("Argument type mismatch at position %d: expected 'C string' convertable value", argpos); + return R_NilValue; /* dummy */ + } + break; + case DC_SIGCHAR_USHORT: + case DC_SIGCHAR_SHORT: + error("Signature '*[sS]' not implemented"); + return R_NilValue; /* dummy */ + case DC_SIGCHAR_UINT: + case DC_SIGCHAR_INT: + switch(type_id) + { + case NILSXP: ptrValue = (DCpointer) 0; break; + case INTSXP: ptrValue = (DCpointer) INTEGER(arg); break; + default: error("Argument type mismatch at position %d: expected 'pointer to C integer' convertable value", argpos); + return R_NilValue; /* dummy */ + } + break; + case DC_SIGCHAR_ULONG: + case DC_SIGCHAR_LONG: + error("Signature '*[jJ]' not implemented"); + return R_NilValue; /* dummy */ + case DC_SIGCHAR_ULONGLONG: + case DC_SIGCHAR_LONGLONG: + error("Signature '*[lJ]' not implemented"); + return R_NilValue; /* dummy */ + case DC_SIGCHAR_FLOAT: + switch(type_id) + { + case NILSXP: ptrValue = (DCpointer) 0; break; + case RAWSXP: + if ( strcmp( CHAR(STRING_ELT(getAttrib(arg, install("class")),0)),"floatraw") == 0 ) { + ptrValue = (DCpointer) RAW(arg); + } else { + error("Argument type mismatch at position %d: expected 'pointer to C double' convertable value", argpos); + return R_NilValue; /* dummy */ + } + break; + default: error("Argument type mismatch at position %d: expected 'pointer to C double' convertable value", argpos); + return R_NilValue; /* dummy */ + } + break; + case DC_SIGCHAR_DOUBLE: + switch(type_id) + { + case NILSXP: ptrValue = (DCpointer) 0; break; + case REALSXP: ptrValue = (DCpointer) REAL(arg); break; + default: error("Argument type mismatch at position %d: expected 'pointer to C double' convertable value", argpos); + return R_NilValue; /* dummy */ + } + break; + case DC_SIGCHAR_POINTER: + case DC_SIGCHAR_STRING: + switch(type_id) + { + case EXTPTRSXP: + ptrValue = R_ExternalPtrAddr( arg ); break; + default: error("low-level typed pointer on pointer not implemented"); + return R_NilValue; /* dummy */ + } + break; + default: + error("low-level typed pointer on C char pointer not implemented"); + return R_NilValue; /* dummy */ + } + dcArgPointer(pvm, ptrValue); + ptrcnt = 0; + } + } + } + + + if (args != R_NilValue) { + error ("Too many arguments for signature '%s'.", signature); + return R_NilValue; /* dummy */ + } + /* process return type, invoke call and return R value */ + + switch(*sig++) { + case DC_SIGCHAR_BOOL: return ScalarLogical( ( dcCallBool(pvm, addr) == DC_FALSE ) ? FALSE : TRUE ); + + case DC_SIGCHAR_CHAR: return ScalarInteger( (int) dcCallChar(pvm, addr) ); + case DC_SIGCHAR_UCHAR: return ScalarInteger( (int) ( (unsigned char) dcCallChar(pvm, addr ) ) ); + + case DC_SIGCHAR_SHORT: return ScalarInteger( (int) dcCallShort(pvm,addr) ); + case DC_SIGCHAR_USHORT: return ScalarInteger( (int) ( (unsigned short) dcCallShort(pvm,addr) ) ); + + case DC_SIGCHAR_INT: return ScalarInteger( dcCallInt(pvm,addr) ); + case DC_SIGCHAR_UINT: return ScalarReal( (double) (unsigned int) dcCallInt(pvm, addr) ); + + case DC_SIGCHAR_LONG: return ScalarReal( (double) dcCallLong(pvm, addr) ); + case DC_SIGCHAR_ULONG: return ScalarReal( (double) ( (unsigned long) dcCallLong(pvm, addr) ) ); + + case DC_SIGCHAR_LONGLONG: return ScalarReal( (double) dcCallLongLong(pvm, addr) ); + case DC_SIGCHAR_ULONGLONG: return ScalarReal( (double) dcCallLongLong(pvm, addr) ); + + case DC_SIGCHAR_FLOAT: return ScalarReal( (double) dcCallFloat(pvm,addr) ); + case DC_SIGCHAR_DOUBLE: return ScalarReal( dcCallDouble(pvm,addr) ); + case DC_SIGCHAR_POINTER: return R_MakeExternalPtr( dcCallPointer(pvm,addr), R_NilValue, R_NilValue ); + case DC_SIGCHAR_STRING: return mkString( dcCallPointer(pvm, addr) ); + case DC_SIGCHAR_VOID: dcCallVoid(pvm,addr); /* TODO: return invisible */ return R_NilValue; + case '*': + { + SEXP ans; + ptrcnt = 1; + while (*sig == '*') { ptrcnt++; sig++; } + switch(*sig) { + case '<': { + /* struct/union pointers */ + PROTECT(ans = R_MakeExternalPtr( dcCallPointer(pvm, addr), R_NilValue, R_NilValue ) ); + char buf[128]; + const char* begin = ++sig; + const char* end = strchr(sig, '>'); + size_t n = end - begin; + strncpy(buf, begin, n); + buf[n] = '\0'; + setAttrib(ans, install("struct"), mkString(buf) ); + setAttrib(ans, install("class"), mkString("struct") ); + } break; + case 'C': + case 'c': { + PROTECT(ans = mkString( dcCallPointer(pvm, addr) ) ); + } break; + case 'v': { + PROTECT(ans = R_MakeExternalPtr( dcCallPointer(pvm, addr), R_NilValue, R_NilValue ) ); + } break; + default: error("Unsupported return type signature"); return R_NilValue; + } + UNPROTECT(1); + return(ans); + } + default: error("Unknown return type specification for signature '%s'.", signature); + return R_NilValue; /* dummy */ + } + +} +