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

 /* These are set during each call to do_dotCode() below. */
 static SEXP NaokSymbol = NULL;
 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. */
-DL_FUNC R_FindSymbol(char *);
+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)
+{
     int *iptr;
     double *rptr;
     char **cptr, *fptr;
     complex *zptr;
     SEXP *lptr, CSingSymbol=install("Csingle");
     int i, l, n;
     switch(TYPEOF(s)) {
     case LGLSXP:
     case INTSXP:
 	n = LENGTH(s);
 	iptr = INTEGER(s);
     complex *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;
 /* 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 */
+#ifdef OLD
 static SEXP naoktrim(SEXP s, int * len, int *naok, int *dup)
+{
     SEXP value;
     if(s == R_NilValue) {
 	value = R_NilValue;
 	*len = 0;
+    }
     else if(TAG(s) == NaokSymbol) {
 	value = naoktrim(CDR(s), len, naok, dup);
 	*naok = asLogical(CAR(s));
+	(*len)++;
+    }
     else if(TAG(s) == DupSymbol) {
 	value = naoktrim(CDR(s), len, naok, dup);
 	*dup = asLogical(CAR(s));
+	(*len)++;
+    }
+    else if(TAG(s) == PkgSymbol) {
+	value = naoktrim(CDR(s), len, naok, dup);
+	strcpy(DLLname, CHAR(STRING(CAR(s))[0]));
+	return value;
+    }
     else {
 	CDR(s) = naoktrim(CDR(s), len, naok, dup);
-	*len = *len + 1;
+	(*len)++;
+    }
     return s;
+}
+#endif
+/* find NAOK and DUP, find and remove PACKAGE */
+static SEXP naokfind(SEXP args, int * len, int *naok, int *dup)
+{
+    SEXP s, ss;
+    int nargs=0, naokused=0, dupused=0, pkgused=0;
+    *naok = 0;
+    *dup = 1;
+    *len = 0;
+    for(s = args; s != R_NilValue; ) {
+	if(TAG(s) == NaokSymbol) {
+	    *naok = asLogical(CAR(s));
+	    if(naokused++ == 1) warning("NAOK used more than once");
+	} else if(TAG(s) == DupSymbol) {
+	    *dup = asLogical(CAR(s));
+	    if(dupused++ == 1) warning("DUP used more than once");
+	}
+	/* Now 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 */
+	ss = CDR(s);
+	if(ss == R_NilValue && TAG(s) == PkgSymbol) {
+	    if(pkgused++ == 1) warning("PACKAGE used more than once");
+	    strcpy(DLLname, CHAR(STRING(CAR(s))[0]));
+	    return R_NilValue;
+	}
+	if(TAG(ss) == PkgSymbol) {
+	    if(pkgused++ == 1) warning("PACKAGE used more than once");
+	    strcpy(DLLname, CHAR(STRING(CAR(ss))[0]));
+	    CDR(s) = CDR(ss); /* delete this arg, which is the next one */
+	}
+	nargs++;
+	s = CDR(s);
+    }
+    *len = nargs;
+    return args;
+}
+static SEXP pkgtrim(SEXP args)
+{
+    SEXP s, ss;
+    int pkgused=0;
+    for(s = args ; s != R_NilValue;) {
+	ss = CDR(s);
+	/* 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");
+	    strcpy(DLLname, CHAR(STRING(CAR(s))[0]));
+	    return R_NilValue;
+	}
+	if(TAG(ss) == PkgSymbol) {
+	    if(pkgused++ == 1) warning("PACKAGE used more than once");
+	    strcpy(DLLname, CHAR(STRING(CAR(ss))[0]));
+	    CDR(s) = CDR(ss);
+	}
+	s = CDR(s);
+    }
+    return args;
+}
 #define MAX_ARGS 65
 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)
+    if(!isValidString(CAR(args)))
 	errorcall(call, "invalid argument");
     p = CHAR(STRING(CAR(args))[0]);
     q = buf;
     while ((*q = *p) != '\0') {
 	p++;
     SEXP ans;
     DL_FUNC fun;
     char *sym;
     int val;
     checkArity(op, args);
-    if(!isString(CAR(args)) || length(CAR(args)) < 1)
+    if(!isValidString(CAR(args)))
 	errorcall(call, "invalid argument");
     sym = CHAR(STRING(CAR(args))[0]);
     val = 1;
-    if (!(fun = R_FindSymbol(sym)))
+    if (!(fun = R_FindSymbol(sym, "")))
 	val = 0;
     ans = allocVector(LGLSXP, 1);
     LOGICAL(ans)[0] = val;
     return ans;
+}
 /*   Call dynamically loaded "internal" functions */
 /*   code by Jean Meloche <jean@stat.ubc.ca> */
 SEXP do_External(SEXP call, SEXP op, SEXP args, SEXP env)
+{
-      DL_FUNC fun;
+    DL_FUNC fun;
-      SEXP retval;
+    SEXP retval;
-      /* I don't like this messing with vmax <TSL> */
+    /* I don't like this messing with vmax <TSL> */
-      /* But it is needed for clearing R_alloc and to be like .Call <BDR>*/
+    /* But it is needed for clearing R_alloc and to be like .Call <BDR>*/
-      char *vmax = vmaxget();
+    char *vmax = vmaxget();
-      op = CAR(args);
+    op = CAR(args);
-      if (!isString(op))
+    if (!isValidString(op))
-	  errorcall(call,"function name must be a string");
+	errorcall(call, "function name must be a string (of length 1)\n");
+    if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");
+    strcpy(DLLname, "");
+    args = pkgtrim(args);
-      if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]))))
+    if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]), DLLname)))
-	  errorcall(call, "C-R function not in load table");
+	errorcall(call, "C function name not in load table\n");
-      retval = (SEXP)fun(args);
+    retval = (SEXP)fun(args);
-      vmaxset(vmax);
+    vmaxset(vmax);
-      return retval;
+    return retval;
+}
+/* .Call(name, <args>) */
 SEXP do_dotcall(SEXP call, SEXP op, SEXP args, SEXP env)
+{
     DL_FUNC fun;
     SEXP retval, cargs[MAX_ARGS], pargs;
     int nargs;
     char *vmax = vmaxget();
     op = CAR(args);
-    if (!isString(op))
+    if (!isValidString(op))
-        errorcall(call,"function name must be a string");
+	errorcall(call, "function name must be a string (of length 1)\n");
+    if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");
+    strcpy(DLLname, "");
+    args = pkgtrim(args);
-    if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]))))
+    if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]), DLLname)))
-        errorcall(call, "C-R function not in load table");
+        errorcall(call, "C function name not in load table\n");
     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");
+    }
     vmaxset(vmax);
     return retval;
+}
+/* .C() {op=0}  or  .Fortran() {op=1} */
 SEXP do_dotCode(SEXP call, SEXP op, SEXP args, SEXP env)
+{
     void **cargs;
     int dup, havenames, naok, nargs, which;
     DL_FUNC fun;
     SEXP ans, pargs, s;
     char buf[128], *p, *q, *vmax;
-    if (NaokSymbol == NULL || DupSymbol == NULL) {
+    if (NaokSymbol == NULL || DupSymbol == NULL || PkgSymbol == NULL) {
 	NaokSymbol = install("NAOK");
 	DupSymbol = install("DUP");
+	PkgSymbol = install("PACKAGE");
+    }
     vmax = vmaxget();
     which = PRIMVAL(op);
     op = CAR(args);
-    if (!isString(op))
+    if (!isValidString(op))
-	errorcall(call, "function name must be a string");
+	errorcall(call, "function name must be a string (of length 1)");
     /* The following code modifies the argument list */
     /* We know this is ok because do_dotCode is entered */
     /* with its arguments evaluated. */
+    strcpy(DLLname, "");
-    args = naoktrim(CDR(args), &nargs, &naok, &dup);
+    args = naokfind(CDR(args), &nargs, &naok, &dup);
     if(naok == NA_LOGICAL)
 	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*));
 #ifdef HAVE_F77_UNDERSCORE
     if (which)
 	*q++ = '_';
     *q = '\0';
 #endif
-    if (!(fun = R_FindSymbol(buf)))
+    if (!(fun = R_FindSymbol(buf, DLLname)))
-	errorcall(call, "C/Fortran function not in load table");
+	errorcall(call, "C/Fortran function name not in load table");
     switch (nargs) {
     case 0:
 	/* Silicon graphics C chokes here */
 	/* if there is no argument to fun. */

The R Project SVN R

(root)/branches/R-exp-API/src/main/dotcode.c @ 63243 – Rev 5769 → 6098