The R Project SVN – R – Diff – /branches/R-gcontext/src/main/dotcode.c

 /* Convert an R object to a non-moveable C/Fortran object and return
    a pointer to it.  This leaves pointers for anything other
    than vectors and lists unaltered.
 */
-static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort, const char *name, R_toCConverter **converter)
+static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort, const char *name, R_toCConverter **converter,
+                          int targetType)
+{
     int *iptr;
     float *sptr;
     double *rptr;
     char **cptr, *fptr;
 	ans = Rf_convertToC(s, &info, &success, converter);
 	if(success)
 	    return(ans);
+    }
+    if(targetType > 0 && targetType != TYPEOF(s)) {
+     if(!dup) {
+       error("expliciti request not to duplicate arguments in call to %s, but argument %d is of the wrong type",
+	     name, narg + 1);
+     }
+     if(targetType != SINGLESXP)
+        s = coerceVector(s, targetType);
+    }
     switch(TYPEOF(s)) {
     case LGLSXP:
     case INTSXP:
 	n = LENGTH(s);
 	iptr = INTEGER(s);
 	return (void*)s;
+    }
+}
-static SEXP CPtrToRObj(void *p, SEXP arg, int Fort)
+static SEXP CPtrToRObj(void *p, SEXP arg, int Fort, R_NativePrimitiveArgType type)
+{
     int *iptr, n=length(arg);
     float *sptr;
     double *rptr;
     char **cptr, buf[256];
     Rcomplex *zptr;
     SEXP *lptr, CSingSymbol = install("Csingle");
     int i;
     SEXP s, t;
-    SEXPTYPE type =TYPEOF(arg);
     switch(type) {
     case LGLSXP:
     case INTSXP:
 	s = allocVector(type, n);
 	iptr = (int*)p;
-	for(i=0 ; i<n ; i++) {
+	for(i=0 ; i<n ; i++)
-	    INTEGER(s)[i] = iptr[i];
+            INTEGER(s)[i] = iptr[i];
-	}
 	break;
     case REALSXP:
+    case SINGLESXP:
-	s = allocVector(type, n);
+	s = allocVector(REALSXP, n);
-	if(asLogical(getAttrib(arg, CSingSymbol)) == 1) {
+	if(type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
 	    sptr = (float*) p;
 	    for(i=0 ; i<n ; i++) REAL(s)[i] = (double) sptr[i];
 	} else {
 	    rptr = (double*) p;
 	    for(i=0 ; i<n ; i++) REAL(s)[i] = rptr[i];
 	s = (SEXP)p;
+    }
     return s;
+}
+#ifdef THROW_REGISTRATION_TYPE_ERROR
+static Rboolean
+comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)
+{
+   if(TYPEOF(s) == type)
+      return(TRUE);
+   if(dup && type == SINGLESXP)
+      return(asLogical(getAttrib(s, install("Csingle"))) == TRUE);
+   return(FALSE);
+}
+#endif /* end of THROW_REGISTRATION_TYPE_ERROR */
 /* Foreign Function Interface.  This code allows a user to call C */
 /* or Fortran code which is either statically or dynamically linked. */
 /* NB: despite its name, this leaves NAOK and DUP arguments on the list */
+{
     void **cargs;
     int dup, havenames, naok, nargs, which;
     DL_FUNC fun;
     SEXP ans, pargs, s;
-    R_toCConverter  *argConverters[65];
+    R_toCConverter  *argConverters[65]; /* the post-call converters back to R objects. */
     R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};
+    R_NativePrimitiveArgType *checkTypes = NULL;
+    R_NativeArgStyle *argStyles = NULL;
     char buf[128], *p, *q, *vmax;
     if (NaokSymbol == NULL || DupSymbol == NULL || PkgSymbol == NULL) {
 	NaokSymbol = install("NAOK");
 	DupSymbol = install("DUP");
     if(symbol.symbol.c && symbol.symbol.c->numArgs > -1) {
 	if(symbol.symbol.c->numArgs != nargs)
 	    error("Incorrect number of arguments (%d), expecting %d for %s",
 		  nargs, symbol.symbol.c->numArgs, buf);
+        checkTypes = symbol.symbol.c->types;
+        argStyles = symbol.symbol.c->styles;
+    }
     /* Convert the arguments for use in foreign */
     /* function calls.  Note that we copy twice */
     /* once here, on the way into the call, and */
     /* once below on the way out. */
     cargs = (void**)R_alloc(nargs, sizeof(void*));
     nargs = 0;
     for(pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
+#ifdef THROW_REGISTRATION_TYPE_ERROR
+        if(checkTypes && !comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {
+            /* We can loop over all the arguments and report all the erroneous ones,
+               but then we would also want to avoid the conversions.
+               Also, in the future, we may just attempt to coerce the value
+               to the appropriate type. This is why we pass the checkTypes[nargs]
+               value to RObjToCPtr(). We just have to sort out the ability to
+               return the correct value which is complicated by dup, etc. */
+  	   error("Wrong type for argument %d in call to %s", nargs+1, buf);
+	}
+#endif
 	cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,
-				  which, buf, argConverters + nargs);
+				  which, buf, argConverters + nargs,
+				  checkTypes ? checkTypes[nargs] : 0);
 	nargs++;
+    }
     switch (nargs) {
 	info.allArgs = args;
 	info.nargs = nargs;
 	info.functionName = buf;
 	nargs = 0;
 	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
+	    if(argStyles && argStyles[nargs] == R_ARG_IN) {
+	        PROTECT(s = R_NilValue);
-            if(argConverters[nargs]) {
+	    } else if(argConverters[nargs]) {
                 if(argConverters[nargs]->reverse) {
 		    info.argIndex = nargs;
 		    s = argConverters[nargs]->reverse(cargs[nargs], CAR(pargs),
                                                        &info, argConverters[nargs]);
 		} else
 		    s = R_NilValue;
 		PROTECT(s);
 	    } else {
-		PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which));
+		PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which,
+				       checkTypes ? checkTypes[nargs] : TYPEOF(CAR(pargs))));
 		SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));
 		SET_OBJECT(s, OBJECT(CAR(pargs)));
+	    }
 	    if (TAG(pargs) != R_NilValue)
 		havenames = 1;
     case INTSXP:
     case REALSXP:
     case CPLXSXP:
     case STRSXP:
 	if(nres > 0)
-	    results[0] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL);
+	    results[0] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL, 0);
 	break;
     case VECSXP:
 	n = length(s);
 	if (nres < n) n = nres;
 	for (i = 0 ; i < n ; i++) {
-	    results[i] = RObjToCPtr(VECTOR_ELT(s, i), 1, 1, 0, 0, (const char *)NULL, NULL);
+	    results[i] = RObjToCPtr(VECTOR_ELT(s, i), 1, 1, 0, 0, (const char *)NULL, NULL, 0);
+	}
 	break;
     case LISTSXP:
 	n = length(s);
 	if(nres < n) n = nres;
 	for(i=0 ; i<n ; i++) {
-	    results[i] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL);
+	    results[i] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL, 0);
 	    s = CDR(s);
+	}
 	break;
+    }
     UNPROTECT(2);

The R Project SVN R

(root)/branches/R-gcontext/src/main/dotcode.c @ 28362 – Rev 19912 → 20110