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

 #include <Defn.h>
 #include <Rmath.h>
 #include <Rdevices.h>
+#include <R_ext/RConverters.h>
 #ifndef max
 #define max(a, b) ((a > b)?(a):(b))
 #endif
 static SEXP DupSymbol = NULL;
 static SEXP PkgSymbol = NULL;
 static char DLLname[PATH_MAX];
-/* This is a per-platform function which looks up */
-/* entry points in DLLs in a platform specific way. */
+/* This looks up entry points in DLLs in a platform specific way. */
 DL_FUNC R_FindSymbol(char const *, char const *);
 /* 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)
+static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort, const char *name, R_toCConverter **converter)
+{
     int *iptr;
     float *sptr;
     double *rptr;
     char **cptr, *fptr;
     Rcomplex *zptr;
     SEXP *lptr, CSingSymbol=install("Csingle");
     int i, l, n;
+    if(converter)
+	*converter = NULL;
+    if(length(getAttrib(s, R_ClassSymbol))) {
+	R_CConvertInfo info;
+	int success;
+        void *ans;
+	info.naok = naok;
+	info.dup = dup;
+	info.narg = narg;
+	info.Fort = Fort;
+        info.name = name;
+	ans = Rf_convertToC(s, &info, &success, converter);
+	if(success)
+	    return(ans);
+    }
     switch(TYPEOF(s)) {
     case LGLSXP:
     case INTSXP:
 	n = LENGTH(s);
 	iptr = INTEGER(s);
 	    return (void*)cptr;
+	}
 	break;
     case VECSXP:
 	if (!dup) return (void*)VECTOR_PTR(s); /***** Dangerous to GC!!! */
-	n = length(s);
+  	n = length(s);
 	lptr = (SEXP*)R_alloc(n, sizeof(SEXP));
 	for (i = 0 ; i < n ; i++) {
 	    lptr[i] = VECTOR_ELT(s, i);
+	}
-	return (void*)lptr;
+ 	return (void*)lptr;
 	break;
     case LISTSXP:
 	if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);
 	/* Warning : The following looks like it could bite ... */
 	if(!dup) return (void*)s;
 	if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);
 	return (void*)s;
+    }
+}
 static SEXP CPtrToRObj(void *p, SEXP arg, int Fort)
+{
     int *iptr, n=length(arg);
     float *sptr;
     double *rptr;
+    }
     *len = nargs;
     return args;
+}
-static void setDLLname(SEXP s) {
+static void setDLLname(SEXP s, char *DLLName) {
   SEXP ss = CAR(s); char *name;
   if(TYPEOF(ss) != STRSXP || length(ss) != 1)
     error("PACKAGE argument must be a single character string");
   name = CHAR(STRING_ELT(ss, 0));
   /* allow the package: form of the name, as returned by find */
 	/* Look for PACKAGE=. We look at the next arg, unless
 	   this is the last one (which will only happen for one arg),
 	   and remove it */
 	if(ss == R_NilValue && TAG(s) == PkgSymbol) {
 	    if(pkgused++ == 1) warning("PACKAGE used more than once");
-	    setDLLname(s);
+	    setDLLname(s, DLLname);
 	    return R_NilValue;
+	}
 	if(TAG(ss) == PkgSymbol) {
 	    if(pkgused++ == 1) warning("PACKAGE used more than once");
-	    setDLLname(ss);
+	    setDLLname(ss, DLLname);
 	    SETCDR(s, CDR(ss));
+	}
 	s = CDR(s);
+    }
     return args;
+{
     void **cargs;
     int dup, havenames, naok, nargs, which;
     DL_FUNC fun;
     SEXP ans, pargs, s;
+    R_toCConverter  *argConverters[65];
     char buf[128], *p, *q, *vmax;
     if (NaokSymbol == NULL || DupSymbol == NULL || PkgSymbol == NULL) {
 	NaokSymbol = install("NAOK");
 	DupSymbol = install("DUP");
 	PkgSymbol = install("PACKAGE");
 	errorcall(call, "invalid naok value");
     if(nargs > MAX_ARGS)
 	errorcall(call, "too many arguments in foreign function call");
     cargs = (void**)R_alloc(nargs, sizeof(void*));
-    /* 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. */
-    nargs = 0;
-    for(pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
-	cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1, which);
-	nargs++;
-    }
     /* Make up the load symbol and look it up. */
     p = CHAR(STRING_ELT(op, 0));
     q = buf;
 #else
     if (!(fun = R_FindSymbol(buf, DLLname)))
 #endif /* Macintosh */
 	errorcall(call, "C/Fortran function name not in load table");
+    /* 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. */
+    nargs = 0;
+    for(pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
+	cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1, which, buf, argConverters + nargs);
+	nargs++;
+    }
     switch (nargs) {
     case 0:
 	/* Silicon graphics C chokes here */
 	/* if there is no argument to fun. */
 	fun(0);
 	errorcall(call, "too many arguments, sorry");
+    }
     PROTECT(ans = allocVector(VECSXP, nargs));
     havenames = 0;
     if (dup) {
+	R_FromCConvertInfo info;
+	info.cargs = cargs;
+	info.allArgs = args;
+	info.nargs = nargs;
+	info.functionName = buf;
 	nargs = 0;
 	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
+            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));
-	    SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));
+		SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));
-	    SET_OBJECT(s, OBJECT(CAR(pargs)));
+		SET_OBJECT(s, OBJECT(CAR(pargs)));
+	    }
 	    if (TAG(pargs) != R_NilValue)
 		havenames = 1;
 	    SET_VECTOR_ELT(ans, nargs, s);
 	    nargs++;
 	    UNPROTECT(1);
     case INTSXP:
     case REALSXP:
     case CPLXSXP:
     case STRSXP:
 	if(nres > 0)
-	    results[0] = RObjToCPtr(s, 1, 1, 0, 0);
+	    results[0] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL);
 	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);
+	    results[i] = RObjToCPtr(VECTOR_ELT(s, i), 1, 1, 0, 0, (const char *)NULL, NULL);
+	}
 	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);
+	    results[i] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL);
 	    s = CDR(s);
+	}
 	break;
+    }
     UNPROTECT(2);

The R Project SVN R

(root)/branches/R-NaString/src/main/dotcode.c @ 77458 – Rev 14107 → 14156