annotate R/rdyncall/src/rcallback.c @ 3:f5d4d5c2f750

- gemspec fix
author cslag
date Thu, 31 Dec 2015 20:24:53 +0100
parents 0cfcc391201f
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
1 /** ===========================================================================
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
2 ** R-Package: rdyncall
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
3 ** File: src/rcallback.c
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
4 ** Description: dyncall callback R backend
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
5 **/
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
6
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
7 #include "Rinternals.h"
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
8 #include "Rdefines.h"
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
9 #include "dyncall_callback.h"
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
10
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
11 typedef struct
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
12 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
13 int disabled;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
14 SEXP fun;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
15 SEXP rho;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
16 int nargs;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
17 const char* signature; /* argument signature without call mode prefix */
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
18 } R_Callback;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
19
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
20 char dcCallbackHandler_R( DCCallback* pcb, DCArgs* args, DCValue* result, void* userdata )
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
21 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
22 R_Callback* rdata;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
23 const char* ptr;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
24 int i,n;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
25 SEXP s, x, ans, item;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
26 char ch;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
27
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
28 rdata = (R_Callback*) userdata;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
29
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
30 if (rdata->disabled) return DC_SIGCHAR_VOID;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
31
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
32 ptr = rdata->signature;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
33
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
34 // allocate an nargs + 1 'call' language object
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
35 // first argument is function
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
36 // rest is arguments from callback
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
37 n = 1 + rdata->nargs;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
38
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
39 PROTECT( s = allocList(n) );
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
40 SET_TYPEOF(s, LANGSXP);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
41 SETCAR( s, rdata->fun ); x = CDR(s);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
42
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
43 // fill up call object
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
44
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
45 i = 1;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
46 for( ;; ++i) {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
47 ch = *ptr++;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
48 if (ch == ')') break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
49 if (i >= n) {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
50 warning("invalid signature.");
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
51 rdata->disabled = 1;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
52 UNPROTECT(1);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
53 return DC_SIGCHAR_VOID;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
54 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
55 switch(ch) {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
56 case DC_SIGCHAR_BOOL: item = ScalarLogical( ( dcbArgBool(args) == DC_FALSE ) ? FALSE : TRUE ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
57 case DC_SIGCHAR_CHAR: item = ScalarInteger( (int) dcbArgChar(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
58 case DC_SIGCHAR_UCHAR: item = ScalarInteger( (int) dcbArgUChar(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
59 case DC_SIGCHAR_SHORT: item = ScalarInteger( (int) dcbArgShort(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
60 case DC_SIGCHAR_USHORT: item = ScalarInteger( (int) dcbArgUShort(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
61 case DC_SIGCHAR_INT: item = ScalarInteger( (int) dcbArgInt(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
62 case DC_SIGCHAR_UINT: item = ScalarReal( (double) dcbArgUInt(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
63 case DC_SIGCHAR_LONG: item = ScalarReal( (double) dcbArgLong(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
64 case DC_SIGCHAR_ULONG: item = ScalarReal( (double) dcbArgULong(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
65 case DC_SIGCHAR_LONGLONG: item = ScalarReal( (double) dcbArgLongLong(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
66 case DC_SIGCHAR_ULONGLONG: item = ScalarReal( (double) dcbArgULongLong(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
67 case DC_SIGCHAR_FLOAT: item = ScalarReal( (double) dcbArgFloat(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
68 case DC_SIGCHAR_DOUBLE: item = ScalarReal( dcbArgDouble(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
69 case DC_SIGCHAR_POINTER: item = R_MakeExternalPtr( dcbArgPointer(args), R_NilValue, R_NilValue ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
70 case DC_SIGCHAR_STRING: item = mkString( dcbArgPointer(args) ); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
71 default:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
72 case '\0':
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
73 warning("invalid signature");
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
74 rdata->disabled = 1;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
75 UNPROTECT(1);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
76 return DC_SIGCHAR_VOID;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
77 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
78 SETCAR( x, item);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
79 x = CDR(x);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
80 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
81
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
82 /* evaluate expression */
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
83
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
84 int error = 0;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
85
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
86 PROTECT( ans = R_tryEval( s, rdata->rho, &error ) );
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
87
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
88 if (error)
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
89 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
90 warning("an error occurred during callback invocation in R. Callback disabled.");
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
91 rdata->disabled = 1;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
92 UNPROTECT(2);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
93 return DC_SIGCHAR_VOID;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
94 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
95
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
96 /* propagate return value */
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
97
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
98 ch = *ptr; /* scan return value type character */
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
99
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
100 /* handle NULL and len(x) == 0 expressions special */
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
101 if ( (ans == R_NilValue) || (LENGTH(ans) == 0) )
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
102 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
103 /* handle NULL */
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
104 result->L = 0;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
105 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
106 else
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
107 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
108 switch(ch)
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
109 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
110 case DC_SIGCHAR_VOID:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
111 break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
112 case DC_SIGCHAR_BOOL:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
113 switch( TYPEOF(ans) )
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
114 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
115 case INTSXP: result->B = (INTEGER(ans)[0] == 0 ) ? DC_FALSE : DC_TRUE; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
116 case LGLSXP: result->B = (LOGICAL(ans)[0] == FALSE ) ? DC_FALSE : DC_TRUE; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
117 default: result->B = DC_FALSE; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
118 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
119 break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
120 case DC_SIGCHAR_CHAR:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
121 case DC_SIGCHAR_UCHAR:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
122 case DC_SIGCHAR_SHORT:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
123 case DC_SIGCHAR_USHORT:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
124 case DC_SIGCHAR_INT:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
125 case DC_SIGCHAR_UINT:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
126 case DC_SIGCHAR_LONG:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
127 case DC_SIGCHAR_ULONG:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
128 switch( TYPEOF(ans) )
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
129 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
130 case INTSXP: result->i = INTEGER(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
131 case REALSXP: result->i = (int) REAL(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
132 default: result->i = 0; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
133 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
134 break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
135 case DC_SIGCHAR_ULONGLONG:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
136 case DC_SIGCHAR_LONGLONG:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
137 switch( TYPEOF(ans) )
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
138 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
139 case INTSXP: result->L = (long long) INTEGER(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
140 case REALSXP: result->L = (long long) REAL(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
141 default: result->L = 0; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
142 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
143 break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
144 case DC_SIGCHAR_FLOAT:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
145 switch( TYPEOF(ans) )
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
146 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
147 case INTSXP: result->f = (float) INTEGER(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
148 case REALSXP: result->f = (float) REAL(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
149 default: result->f = 0.0f; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
150 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
151 break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
152 case DC_SIGCHAR_DOUBLE:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
153 switch( TYPEOF(ans) )
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
154 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
155 case INTSXP: result->d = (double) INTEGER(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
156 case REALSXP: result->d = REAL(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
157 default: result->d = 0.0; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
158 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
159 break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
160 case DC_SIGCHAR_POINTER:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
161 switch( TYPEOF(ans) )
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
162 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
163 case EXTPTRSXP: result->p = R_ExternalPtrAddr(ans); break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
164 case INTSXP : result->p = (DCpointer) (ptrdiff_t) (unsigned long long int) INTEGER(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
165 case REALSXP : result->p = (DCpointer) (ptrdiff_t) (unsigned long long int) REAL(ans)[0]; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
166 default: result->p = NULL; break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
167 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
168 break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
169 case DC_SIGCHAR_STRING:
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
170 warning("not implemented");
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
171 rdata->disabled = 1;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
172 break;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
173 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
174 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
175 UNPROTECT(2);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
176 return ch;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
177 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
178
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
179 void R_callback_finalizer(SEXP x);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
180
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
181 SEXP r_new_callback(SEXP sig_x, SEXP fun_x, SEXP rho_x)
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
182 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
183 const char* signature;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
184 R_Callback* rdata;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
185 const char* ptr;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
186 char ch;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
187 signature = CHAR( STRING_ELT( sig_x, 0 ) );
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
188 rdata = Calloc(1, R_Callback);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
189 rdata->disabled = 0;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
190 rdata->fun = fun_x;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
191 rdata->rho = rho_x;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
192 R_PreserveObject(rdata->fun);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
193 R_PreserveObject(rdata->rho);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
194 ptr = signature;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
195 // skip call mode signature
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
196 if ( (ch=*ptr) == '_') {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
197 ptr += 2;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
198 ch=*ptr;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
199 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
200 rdata->signature = ptr++;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
201 int nargs = 0;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
202 while( ch != ')') {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
203 nargs ++;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
204 ch = *ptr++;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
205 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
206 rdata->nargs = nargs;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
207 DCCallback* cb = dcbNewCallback( signature, dcCallbackHandler_R, rdata);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
208 SEXP ans = R_MakeExternalPtr( cb, R_NilValue, R_NilValue );
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
209 R_RegisterCFinalizerEx(ans, R_callback_finalizer, TRUE);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
210 return ans;
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
211 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
212
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
213 void R_callback_finalizer(SEXP x)
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
214 {
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
215 DCCallback* cb = R_ExternalPtrAddr(x);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
216 R_Callback* rdata = dcbGetUserData(cb);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
217 R_ReleaseObject(rdata->fun);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
218 R_ReleaseObject(rdata->rho);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
219 Free(rdata);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
220 dcbFreeCallback(cb);
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
221 }
0cfcc391201f initial from svn dyncall-1745
Daniel Adler
parents:
diff changeset
222