The R Project SVN – R – Diff – /trunk/src/main/dotcode.c

 /* This looks up entry points in DLLs in a platform specific way. */
 #include <Rdynpriv.h>
 #define MAX_ARGS 65
+static DL_FUNC
-static DL_FUNC R_FindNativeSymbolFromDLL(char *name, DllReference *dll, R_RegisteredNativeSymbol *symbol);
+R_FindNativeSymbolFromDLL(char *name, DllReference *dll,
+			  R_RegisteredNativeSymbol *symbol);
-static SEXP naokfind(SEXP args, int * len, int *naok, int *dup, DllReference *dll);
+static SEXP naokfind(SEXP args, int * len, int *naok, int *dup,
+		     DllReference *dll);
 static SEXP pkgtrim(SEXP args, DllReference *dll);
 /*
   Checks whether the specified object correctly identifies a native routine.
   This can be
    a) a string,
-   b) an external pointer giving the address of the routine (e.g. getNativeSymbolInfo("foo")$address)
+   b) an external pointer giving the address of the routine
+      (e.g. getNativeSymbolInfo("foo")$address)
    c) or a NativeSymbolInfo itself  (e.g. getNativeSymbolInfo("foo"))
  */
 static int
 checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun)
+{
     if (isValidString(op))
 	return(0);
     else if((TYPEOF(op) == EXTPTRSXP && R_ExternalPtrTag(op) == Rf_install("native symbol"))) {
 	if((*fun = R_ExternalPtrAddr(op)) == NULL)
 	    errorcall(call, "NULL value passed as symbol address.");
 	return(0);
     } else if(inherits(op, "NativeSymbolInfo")) {
     return(0);
+}
 /*
-  This is the routine that is called by do_dotCode, do_dotcall and do_External
+  This is the routine that is called by do_dotCode, do_dotcall and
-  to find the DL_FUNC to invoke. It handles processing the arguments for the
+  do_External to find the DL_FUNC to invoke. It handles processing the
-  PACKAGE argument, if present, and also takes care of the cases where we are given
+  arguments for the PACKAGE argument, if present, and also takes care
+  of the cases where we are given a NativeSymbolInfo object, an
-  a NativeSymbolInfo object, an address directly, and if the DLL is specified.
+  address directly, and if the DLL is specified. If no PACKAGE is
-  If no PACKAGE is provided, we check whether the calling function is in a namespace
+  provided, we check whether the calling function is in a namespace
   and look there.
 */
 SEXP
+resolveNativeRoutine(SEXP args, DL_FUNC *fun,
-resolveNativeRoutine(SEXP args, DL_FUNC *fun, R_RegisteredNativeSymbol *symbol, char *buf,
+		     R_RegisteredNativeSymbol *symbol, char *buf,
 		     int *nargs, int *naok, int *dup, SEXP call)
+{
     SEXP op;
     char *p, *q;
     DllReference dll = {"", NULL, NULL, NOT_DEFINED};
     op = CAR(args);
     checkValidSymbolId(op, call, fun);
     /* The following code modifies the argument list */
     /* with its arguments evaluated. */
     strcpy(dll.DLLname, "");
     if(symbol->type == R_C_SYM || symbol->type == R_FORTRAN_SYM) {
 	args = naokfind(CDR(args), nargs, naok, dup, &dll);
 	if(*naok == NA_LOGICAL)
 	    errorcall(call, "invalid naok value");
 	if(*nargs > MAX_ARGS)
 	    errorcall(call, "too many arguments in foreign function call");
     } else {
 	q = buf;
 	while ((*q = *p) != '\0') {
 	    p++;
 	    q++;
+	}
     }
     if(!*fun) {
 	if(dll.type != FILENAME) {
 	    *fun = R_FindNativeSymbolFromDLL(buf, &dll, symbol);
 	    if(!fun) {
 		errorcall(call, "cannot resolve native routine");
+	    }
 	}
 	if (!*fun && !(*fun = R_FindSymbol(buf, dll.DLLname, symbol))) {
 	    if(strlen(dll.DLLname))
 		errorcall(call, "%s function name not in DLL for package %s",
 			   symbol->type == R_FORTRAN_SYM ? "Fortran" : "C",
 			   dll.DLLname);
 	    else
 		errorcall(call, "%s function name not in load table",
 			  symbol->type == R_FORTRAN_SYM ? "Fortran" : "C");
+	}
+    }
     return(args);
+}
   return(TRUE);
+}
-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 targetType)
+{
     int *iptr;
     float *sptr;
     double *rptr;
     char **cptr, *fptr;
     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)", narg);
+		error("Complex NA/NaN/Inf in foreign function call (arg %d)",
+		      narg);
+	}
 	if (dup) {
 	    zptr = (Rcomplex*)R_alloc(n, sizeof(Rcomplex));
 	    for (i = 0 ; i < n ; i++)
 		zptr[i] = COMPLEX(s)[i];
     case STRSXP:
 	if(!dup)
 	    error("character variables must be duplicated in .C/.Fortran");
 	n = LENGTH(s);
 	if(Fort) {
+	    if(n > 1)
-	    if(n > 1) warning("only first string in char vector used in .Fortran");
+		warning("only first string in char vector used in .Fortran");
 	    l = strlen(CHAR(STRING_ELT(s, 0)));
 	    fptr = (char*)R_alloc(max(255, l) + 1, sizeof(char));
 	    strcpy(fptr, CHAR(STRING_ELT(s, 0)));
 	    return (void*)fptr;
 	} else {
 	return (void*)s;
+    }
+}
-static SEXP CPtrToRObj(void *p, SEXP arg, int Fort, R_NativePrimitiveArgType type)
+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];
 /* or Fortran code which is either statically or dynamically linked. */
 /* NB: despite its name, this leaves NAOK and DUP arguments on the list */
 /* find NAOK and DUP, find and remove PACKAGE */
-static SEXP naokfind(SEXP args, int * len, int *naok, int *dup, DllReference *dll)
+static SEXP naokfind(SEXP args, int * len, int *naok, int *dup,
+		     DllReference *dll)
+{
     SEXP s, prev;
     int nargs=0, naokused=0, dupused=0, pkgused=0;
     char *p;
 		    dll->dll = (HINSTANCE) R_ExternalPtrAddr(CAR(s));
 		    dll->type = DLL_HANDLE;
 		} else if(TYPEOF(CAR(s)) == VECSXP) {
 		    dll->type = R_OBJECT;
 		    dll->obj = s;
+		    strcpy(dll->DLLname,
-		    strcpy(dll->DLLname, CHAR(STRING_ELT(VECTOR_ELT(CAR(s), 1), 0)));
+			   CHAR(STRING_ELT(VECTOR_ELT(CAR(s), 1), 0)));
 		    dll->dll = (HINSTANCE) R_ExternalPtrAddr(VECTOR_ELT(s, 4));
+		}
+	    }
 	} else {
 	    nargs++;
     R_RegisteredNativeSymbol symbol = {R_EXTERNAL_SYM, {NULL}, NULL};
     /* I don't like this messing with vmax <TSL> */
     /* But it is needed for clearing R_alloc and to be like .Call <BDR>*/
     char *vmax = vmaxget(), buf[128];
-    args = resolveNativeRoutine(args, &fun, &symbol, buf, NULL, NULL, NULL, call);
+    args = resolveNativeRoutine(args, &fun, &symbol, buf, NULL, NULL,
+				NULL, call);
-    /* Some external symbols that are registered may have 0 as the expected number of arguments.
+    /* Some external symbols that are registered may have 0 as the
+       expected number of arguments.  We may want a warning
-       We may want a warning here. However, the number of values may vary across calls
+       here. However, the number of values may vary across calls and
-       and that is why people use the .External() mechanism.  So perhaps we should just kill this
+       that is why people use the .External() mechanism.  So perhaps
+       we should just kill this check.
-       check. */
+    */
 #ifdef CHECK_EXTERNAL_ARG_COUNT         /* Off by default. */
     if(symbol.symbol.external && symbol.symbol.external->numArgs > -1) {
 	if(symbol.symbol.external->numArgs != length(args))
 	    error("Incorrect number of arguments (%d), expecting %d for %s",
-		  length(args), symbol.symbol.external->numArgs, CHAR(STRING_ELT(op, 0)));
+		  length(args), symbol.symbol.external->numArgs,
+		  CHAR(STRING_ELT(CAR(args), 0)));
+    }
 #endif
     retval = (SEXP)fun(args);
     vmaxset(vmax);
     R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};
     int nargs;
     char *vmax = vmaxget();
     char buf[128];
-    op = CAR(args);
-    args = resolveNativeRoutine(args, &fun, &symbol, buf, NULL, NULL, NULL, call);
+    args = resolveNativeRoutine(args, &fun, &symbol, buf, NULL, NULL,
+				NULL, call);
     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");
 	nargs++;
+    }
     if(symbol.symbol.call && symbol.symbol.call->numArgs > -1) {
 	if(symbol.symbol.call->numArgs != nargs)
 	    error("Incorrect number of arguments (%d), expecting %d for %s",
-		  nargs, symbol.symbol.call->numArgs, CHAR(STRING_ELT(op, 0)));
+		  nargs, symbol.symbol.call->numArgs,
+		  CHAR(STRING_ELT(CAR(args), 0)));
+    }
     retval = R_NilValue;	/* -Wall */
     switch (nargs) {
     case 0:
 /*
   We are given the PACKAGE argument in dll.obj
   and we can try to figure out how to resolve this.
 ) dll.obj is NULL.  Then find the environment of the
    calling function and if it is a namespace, get the
 ) dll.obj is a DLLInfo object
 */
 static DL_FUNC
-R_FindNativeSymbolFromDLL(char *name, DllReference *dll, R_RegisteredNativeSymbol *symbol)
+R_FindNativeSymbolFromDLL(char *name, DllReference *dll,
+			  R_RegisteredNativeSymbol *symbol)
+{
     int numProtects = 0;
     DllInfo *info;
     DL_FUNC fun = NULL;
+    }
     if(inherits(dll->obj, "DLLInfo")) {
 	SEXP tmp;
 /*XXX*/
-DL_FUNC R_dlsym(DllInfo *info, char const *name, R_RegisteredNativeSymbol *symbol);
+DL_FUNC R_dlsym(DllInfo *info, char const *name,
+		R_RegisteredNativeSymbol *symbol);
 	tmp = VECTOR_ELT(dll->obj, 4);
 	info = (DllInfo *) R_ExternalPtrAddr(tmp);
 	if(!info)
 	    error("NULL value for DLLInfoReference when looking for DLL");
 	fun = R_dlsym(info, name, symbol);
+    }
     if(numProtects)
+{
     void **cargs;
     int dup, havenames, naok, nargs, which;
     DL_FUNC fun = NULL;
     SEXP ans, pargs, s;
-    R_toCConverter  *argConverters[65]; /* the post-call converters back to R objects. */
+    /* the post-call converters back to R objects. */
+    R_toCConverter  *argConverters[65];
     R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};
     R_NativePrimitiveArgType *checkTypes = NULL;
     R_NativeArgStyle *argStyles = NULL;
     char *vmax, symName[128];
     vmax = vmaxget();
     which = PRIMVAL(op);
     if(which)
 	symbol.type = R_FORTRAN_SYM;
-    args = resolveNativeRoutine(args, &fun, &symbol, symName, &nargs, &naok, &dup, call);
+    args = resolveNativeRoutine(args, &fun, &symbol, symName, &nargs,
+				&naok, &dup, call);
     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, symName);
     /* 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 &&
-        if(checkTypes && !comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {
+	   !comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {
-            /* We can loop over all the arguments and report all the erroneous ones,
+            /* We can loop over all the arguments and report all the
-               but then we would also want to avoid the conversions.
+               erroneous ones, but then we would also want to avoid
+               the conversions.  Also, in the future, we may just
-               Also, in the future, we may just attempt to coerce the value
+               attempt to coerce the value to the appropriate
-               to the appropriate type. This is why we pass the checkTypes[nargs]
+               type. This is why we pass the checkTypes[nargs] value
-               value to RObjToCPtr(). We just have to sort out the ability to
+               to RObjToCPtr(). We just have to sort out the ability
-               return the correct value which is complicated by dup, etc. */
+               to return the correct value which is complicated by
+               dup, etc. */
-	    error("Wrong type for argument %d in call to %s", nargs+1, symName);
+	    error("Wrong type for argument %d in call to %s",
+		  nargs+1, symName);
+	}
 #endif
 	cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,
 				  which, symName, argConverters + nargs,
 				  checkTypes ? checkTypes[nargs] : 0);
 	        PROTECT(s = R_NilValue);
 	    } else if(argConverters[nargs]) {
                 if(argConverters[nargs]->reverse) {
 		    info.argIndex = nargs;
 		    s = argConverters[nargs]->reverse(cargs[nargs], CAR(pargs),
+						      &info,
-                                                       &info, argConverters[nargs]);
+						      argConverters[nargs]);
 		} else
 		    s = R_NilValue;
 		PROTECT(s);
 	    } else {
 		PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which,
     case INTSXP:
     case REALSXP:
     case CPLXSXP:
     case STRSXP:
 	if(nres > 0)
-	    results[0] = RObjToCPtr(s, 1, 1, 0, 0, (const char *)NULL, NULL, 0);
+	    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, 0);
+	    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, 0);
+	    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)/trunk/src/main/dotcode.c @ 28362 – Rev 31319 → 31591