--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/R/rdyncall/src/rcallback.c	Thu Mar 19 22:26:28 2015 +0100
@@ -0,0 +1,222 @@
+/** ===========================================================================
+ ** R-Package: rdyncall
+ ** File: src/rcallback.c
+ ** Description: dyncall callback R backend
+ **/
+
+#include "Rinternals.h"
+#include "Rdefines.h"
+#include "dyncall_callback.h"
+
+typedef struct
+{
+  int         disabled;
+  SEXP        fun;
+  SEXP        rho;
+  int         nargs;
+  const char* signature; /* argument signature without call mode prefix */
+} R_Callback;
+
+char dcCallbackHandler_R( DCCallback* pcb, DCArgs* args, DCValue* result, void* userdata )
+{
+	R_Callback* rdata;
+	const char* ptr;
+	int i,n;
+	SEXP s, x, ans, item;
+	char ch;
+
+	rdata = (R_Callback*) userdata;
+
+	if (rdata->disabled) return DC_SIGCHAR_VOID;
+
+	ptr = rdata->signature;
+
+	// allocate an nargs + 1 'call' language object
+	//   first argument is function
+	//   rest is arguments from callback
+	n = 1 + rdata->nargs;
+
+	PROTECT( s = allocList(n) );
+	SET_TYPEOF(s, LANGSXP);
+	SETCAR( s, rdata->fun ); x = CDR(s);
+
+	// fill up call object
+
+	i = 1;
+	for( ;; ++i) {
+		ch = *ptr++;
+		if (ch == ')') break;
+		if (i >= n) {
+			warning("invalid signature.");
+			rdata->disabled = 1;
+			UNPROTECT(1);
+			return DC_SIGCHAR_VOID;
+		}
+		switch(ch) {
+		case DC_SIGCHAR_BOOL:      item = ScalarLogical( ( dcbArgBool(args) == DC_FALSE ) ? FALSE : TRUE ); break;
+		case DC_SIGCHAR_CHAR:      item = ScalarInteger( (int) dcbArgChar(args) ); break;
+		case DC_SIGCHAR_UCHAR:     item = ScalarInteger( (int) dcbArgUChar(args) ); break;
+		case DC_SIGCHAR_SHORT:     item = ScalarInteger( (int) dcbArgShort(args) ); break;
+		case DC_SIGCHAR_USHORT:    item = ScalarInteger( (int) dcbArgUShort(args) ); break;
+		case DC_SIGCHAR_INT:       item = ScalarInteger( (int) dcbArgInt(args) ); break;
+		case DC_SIGCHAR_UINT:      item = ScalarReal( (double) dcbArgUInt(args) ); break;
+		case DC_SIGCHAR_LONG:      item = ScalarReal( (double) dcbArgLong(args) ); break;
+		case DC_SIGCHAR_ULONG:     item = ScalarReal( (double) dcbArgULong(args) ); break;
+		case DC_SIGCHAR_LONGLONG:  item = ScalarReal( (double) dcbArgLongLong(args) ); break;
+		case DC_SIGCHAR_ULONGLONG: item = ScalarReal( (double) dcbArgULongLong(args) ); break;
+		case DC_SIGCHAR_FLOAT:     item = ScalarReal( (double) dcbArgFloat(args) ); break;
+		case DC_SIGCHAR_DOUBLE:    item = ScalarReal( dcbArgDouble(args) ); break;
+		case DC_SIGCHAR_POINTER:   item = R_MakeExternalPtr( dcbArgPointer(args), R_NilValue, R_NilValue ); break;
+		case DC_SIGCHAR_STRING:    item = mkString( dcbArgPointer(args) ); break;
+		default:
+		case '\0':
+			warning("invalid signature");
+			rdata->disabled = 1;
+			UNPROTECT(1);
+			return DC_SIGCHAR_VOID;
+		}
+		SETCAR( x, item);
+		x = CDR(x);
+	}
+
+	/* evaluate expression */
+
+	int error = 0;
+
+	PROTECT( ans = R_tryEval( s, rdata->rho, &error ) );
+
+	if (error)
+	{
+		warning("an error occurred during callback invocation in R. Callback disabled.");
+		rdata->disabled = 1;
+		UNPROTECT(2);
+		return DC_SIGCHAR_VOID;
+	}
+
+	/* propagate return value */
+
+	ch = *ptr;	/* scan return value type character */
+
+	/* handle NULL and len(x) == 0 expressions special */
+	if ( (ans == R_NilValue) || (LENGTH(ans) == 0) )
+	{
+		/* handle NULL */
+		result->L = 0;
+	}
+	else
+	{
+		switch(ch)
+		{
+		case DC_SIGCHAR_VOID:
+			break;
+		case DC_SIGCHAR_BOOL:
+			switch( TYPEOF(ans) )
+			{
+			case INTSXP: result->B = (INTEGER(ans)[0] == 0 ) ? DC_FALSE : DC_TRUE; break;
+			case LGLSXP: result->B = (LOGICAL(ans)[0] == FALSE ) ? DC_FALSE : DC_TRUE; break;
+			default:     result->B = DC_FALSE; break;
+			}
+			break;
+		case DC_SIGCHAR_CHAR:
+		case DC_SIGCHAR_UCHAR:
+		case DC_SIGCHAR_SHORT:
+		case DC_SIGCHAR_USHORT:
+		case DC_SIGCHAR_INT:
+		case DC_SIGCHAR_UINT:
+		case DC_SIGCHAR_LONG:
+		case DC_SIGCHAR_ULONG:
+			switch( TYPEOF(ans) )
+			{
+			case INTSXP:  result->i = INTEGER(ans)[0]; break;
+			case REALSXP: result->i = (int) REAL(ans)[0]; break;
+			default:      result->i = 0; break;
+			}
+			break;
+		case DC_SIGCHAR_ULONGLONG:
+		case DC_SIGCHAR_LONGLONG:
+			switch( TYPEOF(ans) )
+			{
+			case INTSXP:  result->L = (long long) INTEGER(ans)[0]; break;
+			case REALSXP: result->L = (long long) REAL(ans)[0]; break;
+			default:      result->L = 0; break;
+			}
+			break;
+		case DC_SIGCHAR_FLOAT:
+			switch( TYPEOF(ans) )
+			{
+			case INTSXP:  result->f = (float) INTEGER(ans)[0]; break;
+			case REALSXP: result->f = (float) REAL(ans)[0]; break;
+			default:      result->f = 0.0f; break;
+			}
+			break;
+		case DC_SIGCHAR_DOUBLE:
+			switch( TYPEOF(ans) )
+			{
+			case INTSXP:  result->d = (double) INTEGER(ans)[0]; break;
+			case REALSXP: result->d = REAL(ans)[0]; break;
+			default:      result->d = 0.0; break;
+			}
+			break;
+		case DC_SIGCHAR_POINTER:
+			switch( TYPEOF(ans) )
+			{
+			case EXTPTRSXP: result->p = R_ExternalPtrAddr(ans); break;
+			case INTSXP   : result->p = (DCpointer) (ptrdiff_t) (unsigned long long int) INTEGER(ans)[0]; break;
+			case REALSXP  : result->p = (DCpointer) (ptrdiff_t) (unsigned long long int) REAL(ans)[0]; break;
+			default:        result->p = NULL; break;
+			}
+			break;
+		case DC_SIGCHAR_STRING:
+			warning("not implemented");
+			rdata->disabled = 1;
+			break;
+		}
+	}
+	UNPROTECT(2);
+	return ch;
+}
+
+void R_callback_finalizer(SEXP x);
+
+SEXP r_new_callback(SEXP sig_x, SEXP fun_x, SEXP rho_x)
+{
+  const char* signature;
+  R_Callback* rdata;
+  const char* ptr;
+  char ch;
+  signature  = CHAR( STRING_ELT( sig_x, 0 ) );
+  rdata = Calloc(1, R_Callback);
+  rdata->disabled = 0;
+  rdata->fun = fun_x;
+  rdata->rho = rho_x;
+  R_PreserveObject(rdata->fun);
+  R_PreserveObject(rdata->rho);
+  ptr = signature;
+  // skip call mode signature
+  if ( (ch=*ptr) == '_') {
+    ptr += 2;
+    ch=*ptr;
+  }
+  rdata->signature = ptr++;
+  int nargs = 0;
+  while( ch != ')') {
+    nargs ++;
+    ch = *ptr++;
+  }
+  rdata->nargs = nargs;
+  DCCallback* cb = dcbNewCallback( signature, dcCallbackHandler_R, rdata);
+  SEXP ans = R_MakeExternalPtr( cb, R_NilValue, R_NilValue );
+  R_RegisterCFinalizerEx(ans, R_callback_finalizer, TRUE);
+  return ans;
+}
+
+void R_callback_finalizer(SEXP x)
+{
+  DCCallback* cb = R_ExternalPtrAddr(x);
+  R_Callback* rdata = dcbGetUserData(cb);
+  R_ReleaseObject(rdata->fun);
+  R_ReleaseObject(rdata->rho);
+  Free(rdata);
+  dcbFreeCallback(cb);
+}
+