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

 #include <stdlib.h>
 #include "Defn.h"
 #include "Mathlib.h"
+#ifndef max
+#define max(a, b) ((a > b)?(a):(b))
+#endif
 typedef int (*DL_FUNC)();
 /* These are set during each call to do_dotCode() below. */
 static SEXP NaokSymbol = NULL;
 /* entry points in DLLs in a platform specific way. */
 DL_FUNC R_FindSymbol(char *);
-/* Convert an R object to a non-moveable C object and return */
+/* Convert an R object to a non-moveable C/Fortran object and return
-/* a pointer to it.  This leaves pointers for anything other */
+   a pointer to it.  This leaves pointers for anything other
-/* than vectors and lists unaltered. */
+   than vectors and lists unaltered.
+*/
-static void *RObjToCPtr(SEXP s, int naok, int dup, int narg)
+static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort)
+{
     int *iptr;
     double *rptr;
-    char **cptr;
+    char **cptr, *fptr;
     complex *zptr;
     SEXP *lptr;
     int i, l, n;
     switch(TYPEOF(s)) {
     case LGLSXP:
     case INTSXP:
 	n = LENGTH(s);
 	iptr = INTEGER(s);
 	for (i = 0 ; i < n ; i++) {
 	    if(!naok && iptr[i] == NA_INTEGER)
-		error("NAs in foreign function call (arg %d)\n", narg);
+		error("NAs in foreign function call (arg %d)", narg);
+	}
 	if (dup) {
 	    iptr = (int*)R_alloc(n, sizeof(int));
 	    for (i = 0 ; i < n ; i++)
 		iptr[i] = INTEGER(s)[i];
     case REALSXP:
 	n = LENGTH(s);
 	rptr = REAL(s);
 	for (i = 0 ; i < n ; i++) {
 	    if(!naok && !R_FINITE(rptr[i]))
-		error("NA/NaN/Inf in foreign function call (arg %d)\n", narg);
+		error("NA/NaN/Inf in foreign function call (arg %d)", narg);
+	}
 	if (dup) {
 	    rptr = (double*)R_alloc(n, sizeof(double));
 	    for (i = 0 ; i < n ; i++)
 		rptr[i] = REAL(s)[i];
     case CPLXSXP:
 	n = LENGTH(s);
 	zptr = COMPLEX(s);
 	for (i = 0 ; i < n ; i++) {
 	    if(!naok && (!R_FINITE(zptr[i].r) || !R_FINITE(zptr[i].i)))
-		error("Complex NA/NaN/Inf in foreign function call (arg %d)\n", narg);
+		error("Complex NA/NaN/Inf in foreign function call (arg %d)", narg);
+	}
 	if (dup) {
 	    zptr = (complex*)R_alloc(n, sizeof(complex));
 	    for (i = 0 ; i < n ; i++)
 		zptr[i] = COMPLEX(s)[i];
+	}
 	return (void*)zptr;
 	break;
     case STRSXP:
 	if(!dup)
-	    error("character variables must be duplicated in .C/.Fortran\n");
+	    error("character variables must be duplicated in .C/.Fortran");
 	n = LENGTH(s);
+	if(Fort) {
+	    if(n > 1) warning("only first string in char vector used in .Fortran");
+	    l = strlen(CHAR(STRING(s)[0]));
+	    fptr = (char*)R_alloc(max(255, l) + 1, sizeof(char));
+	    strcpy(fptr, CHAR(STRING(s)[0]));
+	    return (void*)fptr;
+	} else {
-	cptr = (char**)R_alloc(n, sizeof(char*));
+	    cptr = (char**)R_alloc(n, sizeof(char*));
-	for (i = 0 ; i < n ; i++) {
+	    for (i = 0 ; i < n ; i++) {
-	    l = strlen(CHAR(STRING(s)[i]));
+		l = strlen(CHAR(STRING(s)[i]));
-	    cptr[i] = (char*)R_alloc(l + 1, sizeof(char));
+		cptr[i] = (char*)R_alloc(l + 1, sizeof(char));
-	    strcpy(cptr[i], CHAR(STRING(s)[i]));
+		strcpy(cptr[i], CHAR(STRING(s)[i]));
+	    }
+	    return (void*)cptr;
+	}
-	return (void*)cptr;
 	break;
     case VECSXP:
 	if (!dup) return (void*)VECTOR(s);
 	n = length(s);
 	lptr = (SEXP*)R_alloc(n, sizeof(SEXP));
 	    lptr[i] = VECTOR(s)[i];
+	}
 	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;
 	n = length(s);
 	cptr = (char**)R_alloc(n, sizeof(char*));
 	for(i=0 ; i<n ; i++) {
 	    s = CDR(s);
+	}
 	return (void*)cptr;
 	break;
     default:
+	if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);
 	return (void*)s;
+    }
+}
-static SEXP CPtrToRObj(void *p, int n, SEXPTYPE type)
+static SEXP CPtrToRObj(void *p, int n, SEXPTYPE type, int Fort)
+{
     int *iptr;
     double *rptr;
-    char **cptr;
+    char **cptr, buf[256];
     complex *zptr;
     SEXP *lptr;
     int i;
     SEXP s, t;
     switch(type) {
 	for(i=0 ; i<n ; i++) {
 	    COMPLEX(s)[i] = zptr[i];
+	}
 	break;
     case STRSXP:
+	if(Fort) {
+	    /* only return one string: warned on the R -> Fortran step */
+	    strncpy(buf, (char*)p, 255);
+	    buf[256] = '\0';
+	    PROTECT(s = allocVector(type, 1));
+	    STRING(s)[0] = mkChar(buf);
+	    UNPROTECT(1);
+	} else {
-	PROTECT(s = allocVector(type, n));
+	    PROTECT(s = allocVector(type, n));
-	cptr = (char**)p;
+	    cptr = (char**)p;
-	for(i=0 ; i<n ; i++) {
+	    for(i = 0 ; i < n ; i++) {
-	    STRING(s)[i] = mkChar(cptr[i]);
+		STRING(s)[i] = mkChar(cptr[i]);
+	    }
+	    UNPROTECT(1);
+	}
-	UNPROTECT(1);
 	break;
     case VECSXP:
 	PROTECT(s = allocVector(VECSXP, n));
 	lptr = (SEXP*)p;
 	for (i = 0 ; i < n ; i++) {
 SEXP do_symbol(SEXP call, SEXP op, SEXP args, SEXP env)
+{
     char buf[128], *p, *q;
     checkArity(op, args);
     if(!isString(CAR(args)) || length(CAR(args)) < 1)
-	errorcall(call, "invalid argument\n");
+	errorcall(call, "invalid argument");
     p = CHAR(STRING(CAR(args))[0]);
     q = buf;
     while ((*q = *p) != '\0') {
 	p++;
 	q++;
     DL_FUNC fun;
     char *sym;
     int val;
     checkArity(op, args);
     if(!isString(CAR(args)) || length(CAR(args)) < 1)
-	errorcall(call, "invalid argument\n");
+	errorcall(call, "invalid argument");
     sym = CHAR(STRING(CAR(args))[0]);
     val = 1;
     if (!(fun = R_FindSymbol(sym)))
 	val = 0;
     ans = allocVector(LGLSXP, 1);
       /* I don't like this messing with vmax <TSL> */
       /* vmax = vmaxget(); */
       op = CAR(args);
       if (!isString(op))
-	  errorcall(call,"function name must be a string\n");
+	  errorcall(call,"function name must be a string");
       /* make up load symbol & look it up */
       /*      p = CHAR(STRING(op)[0]);
       q = buf; while ((*q = *p) != '\0') { p++; q++; }
       if (!(fun=R_FindSymbol(buf))) */
       if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]))))
-	  errorcall(call, "C-R function not in load table\n");
+	  errorcall(call, "C-R function not in load table");
       retval = (SEXP)fun(args);
       /* vmaxset(vmax); */
       return retval;
     SEXP retval, cargs[MAX_ARGS], pargs;
     int nargs;
     char *vmax = vmaxget();
     op = CAR(args);
     if (!isString(op))
-        errorcall(call,"function name must be a string\n");
+        errorcall(call,"function name must be a string");
     if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]))))
-        errorcall(call, "C-R function not in load table\n");
+        errorcall(call, "C-R function not in load table");
     args = CDR(args);
     for(nargs = 0, pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
         if (nargs == MAX_ARGS)
-            errorcall(call, "too many arguments in foreign function call\n");
+            errorcall(call, "too many arguments in foreign function call");
 	cargs[nargs] = CAR(pargs);
 	nargs++;
+    }
     retval = R_NilValue;	/* -Wall */
 	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
 	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
 	    cargs[60], cargs[61], cargs[62], cargs[63], cargs[64]);
 	break;
     default:
-	errorcall(call, "too many arguments, sorry\n");
+	errorcall(call, "too many arguments, sorry");
+    }
     vmaxset(vmax);
     return retval;
+}
+    }
     vmax = vmaxget();
     which = PRIMVAL(op);
     op = CAR(args);
     if (!isString(op))
-	errorcall(call, "function name must be a string\n");
+	errorcall(call, "function name must be a string");
     /* The following code modifies the argument list */
     /* We know this is ok because do_dotcode is entered */
     /* with its arguments evaluated. */
     args = naoktrim(CDR(args), &nargs, &naok, &dup);
     if(naok == NA_LOGICAL)
-	errorcall(call, "invalid naok value\n");
+	errorcall(call, "invalid naok value");
     if(nargs > MAX_ARGS)
-	errorcall(call, "too many arguments in foreign function call\n");
+	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);
+	cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1, which);
 	nargs++;
+    }
     /* Make up the load symbol and look it up. */
     if (which)
 	*q++ = '_';
     *q = '\0';
 #endif
     if (!(fun = R_FindSymbol(buf)))
-	errorcall(call, "C/Fortran function not in load table\n");
+	errorcall(call, "C/Fortran function not in load table");
     switch (nargs) {
     case 0:
 	/* Silicon graphics C chokes here */
 	/* if there is no argument to fun. */
 	    cargs[50], cargs[51], cargs[52], cargs[53], cargs[54],
 	    cargs[55], cargs[56], cargs[57], cargs[58], cargs[59],
 	    cargs[60], cargs[61], cargs[62], cargs[63], cargs[64]);
 	break;
     default:
-	errorcall(call, "too many arguments, sorry\n");
+	errorcall(call, "too many arguments, sorry");
+    }
     PROTECT(ans = allocVector(VECSXP, nargs));
     havenames = 0;
     if (dup) {
 	nargs = 0;
 	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
 	    PROTECT(s = CPtrToRObj(cargs[nargs], LENGTH(CAR(pargs)),
-				   TYPEOF(CAR(pargs))));
+				   TYPEOF(CAR(pargs)), which));
 	    ATTRIB(s) = duplicate(ATTRIB(CAR(pargs)));
 	    if (TAG(pargs) != R_NilValue)
 		havenames = 1;
 	    VECTOR(ans)[nargs] = s;
 	    nargs++;
     for (i = 0 ; typeinfo[i].name ; i++) {
 	if(!strcmp(typeinfo[i].name, s)) {
 	    return typeinfo[i].type;
+	}
+    }
-    error("type \"%s\" not supported in interlanguage calls\n", s);
+    error("type \"%s\" not supported in interlanguage calls", s);
     return 1; /* for -Wall */
+}
 void call_R(char *func, long nargs, void **arguments, char **modes,
 	    long *lengths, char **names, long nres, char **results)
+{
     SEXP call, pcall, s;
     SEXPTYPE type;
     int i, j, n;
     if (!isFunction((SEXP)func))
-	error("invalid function in call_R\n");
+	error("invalid function in call_R");
     if (nargs < 0)
-	error("invalid argument count in call_R\n");
+	error("invalid argument count in call_R");
     if (nres < 0)
-	error("invalid return value count in call_R\n");
+	error("invalid return value count in call_R");
     PROTECT(pcall = call = allocList(nargs + 1));
     TYPEOF(call) = LANGSXP;
     CAR(pcall) = (SEXP)func;
     s = R_NilValue;		/* -Wall */
     for (i = 0 ; i < nargs ; i++) {
     case INTSXP:
     case REALSXP:
     case CPLXSXP:
     case STRSXP:
 	if(nres > 0)
-	    results[0] = RObjToCPtr(s, 1, 1, 0);
+	    results[0] = RObjToCPtr(s, 1, 1, 0, 0);
 	break;
     case VECSXP:
 	n = length(s);
 	if (nres < n) n = nres;
 	for (i = 0 ; i < n ; i++) {
-	    results[i] = RObjToCPtr(VECTOR(s)[i], 1, 1, 0);
+	    results[i] = RObjToCPtr(VECTOR(s)[i], 1, 1, 0, 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);
+	    results[i] = RObjToCPtr(s, 1, 1, 0, 0);
 	    s = CDR(s);
+	}
 	break;
+    }
     UNPROTECT(2);

The R Project SVN R

(root)/branches/R-exp-API/src/main/dotcode.c @ 28362 – Rev 5458 → 5730