[Rcpp-commits] r1042 - in pkg/Rcpp: R src

[noreply at r-forge.r-project.org]

Author: romain
Date: 2010-04-15 10:10:34 +0200 (Thu, 15 Apr 2010)
New Revision: 1042

Modified:
   pkg/Rcpp/R/dot_cpp.R
   pkg/Rcpp/src/do_dot_cpp.cpp
Log:
taking the registration info into account

Modified: pkg/Rcpp/R/dot_cpp.R
===================================================================
--- pkg/Rcpp/R/dot_cpp.R	2010-04-14 12:41:13 UTC (rev 1041)
+++ pkg/Rcpp/R/dot_cpp.R	2010-04-15 08:10:34 UTC (rev 1042)
@@ -15,11 +15,28 @@
 # You should have received a copy of the GNU General Public License
 # along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
 
+
+is.valid.for.dot.call <- function( symbol ){
+	cl <- oldClass( symbol )
+	identical( cl, "NativeSymbolInfo" ) || identical( cl, c("CallRoutine", "NativeSymbolInfo") )
+}
+
 .Cpp <- function(name, ..., PACKAGE){
-	symbol <- if( missing(PACKAGE) ){
-		getNativeSymbolInfo( name )
+	symbol <- if( inherits( name , "NativeSymbolInfo" ) ){
+		name
 	} else{
-		getNativeSymbolInfo( name, PACKAGE )
+		if( missing(PACKAGE) ){
+			getNativeSymbolInfo( name )
+		} else{
+			getNativeSymbolInfo( name, PACKAGE )
+		}
 	}
-	.External( "do_dot_cpp", symbol$address, ..., PACKAGE = "Rcpp" )
+	if( ! is.valid.for.dot.call(symbol ) ){
+		stop( ".Cpp only supports .Call compatible routines" )
+	}
+	.External( "do_dot_cpp", 
+		symbol$address,         # external pointer tp the C routine
+		symbol$numParameters,   # number of parameters it expects (or NULL)
+		...,                    # actual parameters 
+		PACKAGE = "Rcpp" )
 }

Modified: pkg/Rcpp/src/do_dot_cpp.cpp
===================================================================
--- pkg/Rcpp/src/do_dot_cpp.cpp	2010-04-14 12:41:13 UTC (rev 1041)
+++ pkg/Rcpp/src/do_dot_cpp.cpp	2010-04-15 08:10:34 UTC (rev 1042)
@@ -22,18 +22,15 @@
 #include <Rcpp.h>
 #include <R_ext/Rdynload.h>
 
+/* borrowed from R */
+
 /* because here we know we are using c++ */
 typedef SEXP (*VarFun)(...);
-
-/* This looks up entry points in DLLs in a platform specific way. */
 #define MAX_ARGS 65
-
-/* Maximum length of entry-point name, including nul terminator */
 #define MaxSymbolBytes 1024
-
-/* Work around casting issues: works where it is needed */
 typedef union {void *p; DL_FUNC fn;} fn_ptr;
 
+/* retrieves a function pointer from an external pointer */
 static DL_FUNC get_fun_symbol(SEXP s){
     fn_ptr tmp;
     tmp.p =  EXTPTR_PTR(s);
@@ -55,14 +52,18 @@
 	
     /* grab the external pointer to the native routine */
     SEXP xp = CADR( args ) ;
+    SEXP np = CADDR( args ) ;
     DL_FUNC ofun = get_fun_symbol(xp) ;
     
     SEXP res = R_NilValue ;
     /* 
     	- the first argument is "do_dot_cpp" 
     	- the second argument is the external pointer to the function */
-    SEXP p = CDDR(args) ;
-    if( p == R_NilValue ){	
+    SEXP p = CDR(CDDR(args)) ;
+    if( p == R_NilValue ){
+    	if( ::Rf_isNull( np ) || INTEGER(np)[0] != 0 ){
+    		::Rf_error( "incorrect number of arguments" ) ;
+    	}
     	/* no arguments, simple case */
     	try{                               
 			res = (SEXP) ofun() ;               
@@ -79,8 +80,11 @@
     		p = CDR(p) ;
     	}
     	if( p != R_NilValue ){
-    		Rf_error( "too many arguments in foreign function call" );
+    		::Rf_error( "too many arguments in foreign function call" );
     	}
+    	if( ! ::Rf_isNull(np) && INTEGER(np)[0] != nargs ){
+    		::Rf_error( "incorrect number of arguments in foreign function call, expecting %d arguments, got %d", INTEGER(np)[0], nargs );
+    	}
     	/* we know there is at least one argument otherwise we would not 
     	   be in this branch */
     	VarFun fun = reinterpret_cast<VarFun>( ofun ) ;