The R Project SVN R

/*

 *  R : A Computer Language for Statistical Data Analysis

 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka

 *  Copyright (C) 1997--2010  The R Development Core Team

 *  Copyright (C) 2003	      The R Foundation

 *

 *  This program is free software; you can redistribute it and/or modify

 *  it under the terms of the GNU General Public License as published by

 *  the Free Software Foundation; either version 2 of the License, or

 *  (at your option) any later version.

 *

 *  This program is distributed in the hope that it will be useful,

 *  but WITHOUT ANY WARRANTY; without even the implied warranty of

 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 *  GNU General Public License for more details.

 *

 *  You should have received a copy of the GNU General Public License

 *  along with this program; if not, a copy is available at

 *  http://www.r-project.org/Licenses/

 */

/* <UTF8-FIXME>

   Need to convert character strings to and from 8-bit.

   Check other uses.

 */

#ifdef HAVE_CONFIG_H

# include <config.h>

#endif

#include <Defn.h>

#include <ctype.h> /* for tolower */

#include <string.h>

#include <errno.h>

#include <Rmath.h>

#include <R_ext/GraphicsEngine.h> /* needed for GEDevDesc in do_Externalgr */

#include <R_ext/RConverters.h>

#include <R_ext/Riconv.h>

#ifndef max

#define max(a, b) ((a > b)?(a):(b))

#endif

/* These are set during each call to do_dotCode() below. */

static SEXP NaokSymbol = NULL;

static SEXP DupSymbol = NULL;

static SEXP PkgSymbol = NULL;

static SEXP EncSymbol = NULL;

/* Global variable that should go. Should actually be doing this in

   a much more straightforward manner. */

#include <Rdynpriv.h>

enum {FILENAME, DLL_HANDLE, R_OBJECT, NOT_DEFINED};

typedef struct {

    char DLLname[PATH_MAX];

    HINSTANCE dll;

    SEXP  obj;

    int type;

} DllReference;

/* Maximum length of entry-point name, including nul terminator */

#define MaxSymbolBytes 1024

/* This looks up entry points in DLLs in a platform specific way. */

#define MAX_ARGS 65

static DL_FUNC

R_FindNativeSymbolFromDLL(char *name, DllReference *dll,

			  R_RegisteredNativeSymbol *symbol);

static SEXP naokfind(SEXP args, int * len, int *naok, int *dup,

		     DllReference *dll);

static SEXP pkgtrim(SEXP args, DllReference *dll);

static SEXP enctrim(SEXP args, char *name, int len);

/*

  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)

   c) or a NativeSymbolInfo itself  (e.g. getNativeSymbolInfo("foo"))

   NB: in the last two cases it sets fun as well!

 */

static void

checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun,

		   R_RegisteredNativeSymbol *symbol, char *buf)

{

    if (isValidString(op)) return;

    *fun = NULL;

    if(TYPEOF(op) == EXTPTRSXP) {

	char *p = NULL;

	if(R_ExternalPtrTag(op) == install("native symbol"))

	   *fun = R_ExternalPtrAddrFn(op);

	else if(R_ExternalPtrTag(op) == install("registered native symbol")) {

	   R_RegisteredNativeSymbol *tmp;

	   tmp = (R_RegisteredNativeSymbol *) R_ExternalPtrAddr(op);

	   if(tmp) {

	      if(symbol->type != R_ANY_SYM && symbol->type != tmp->type)

		 errorcall(call, _("NULL value passed as symbol address"));

		/* Check the type of the symbol. */

	      switch(symbol->type) {

	      case R_C_SYM:

		  *fun = tmp->symbol.c->fun;

		  p = tmp->symbol.c->name;

		  break;

	      case R_CALL_SYM:

		  *fun = tmp->symbol.call->fun;

		  p = tmp->symbol.call->name;

		  break;

	      case R_FORTRAN_SYM:

		  *fun = tmp->symbol.fortran->fun;

		  p = tmp->symbol.fortran->name;

		  break;

	      case R_EXTERNAL_SYM:

		  *fun = tmp->symbol.external->fun;

		  p = tmp->symbol.external->name;

		  break;

	      default:

		 /* Something unintended has happened if we get here. */

		  errorcall(call, _("Unimplemented type %d in createRSymbolObject"),

			    symbol->type);

		  break;

	      }

	      *symbol = *tmp;

	   }

	}

	/* This is illegal C */

	if(*fun == NULL)

	    errorcall(call, _("NULL value passed as symbol address"));

	/* copy the symbol name. */

	if (p) {

	    if (strlen(p) >= MaxSymbolBytes)

		error(_("symbol '%s' is too long"), p);

	    memcpy(buf, p, strlen(p)+1);

	    /* Ouch, no length check

	    q = buf;

	    while ((*q = *p) != '\0') {

		p++;

		q++;

	    } */

	}

	return;

    }

    else if(inherits(op, "NativeSymbolInfo")) {

	checkValidSymbolId(VECTOR_ELT(op, 1), call, fun, symbol, buf);

	return;

    }

    errorcall(call,

      _("'name' must be a string (of length 1) or native symbol reference"));

    return; /* not reached */

}

/*

  This is the routine that is called by do_dotCode, do_dotcall and

  do_External to find the DL_FUNC to invoke. It handles processing the

  arguments for the PACKAGE argument, if present, and also takes care

  of the cases where we are given a NativeSymbolInfo object, an

  address directly, and if the DLL is specified. If no PACKAGE is

  provided, we check whether the calling function is in a namespace

  and look there.

*/

static SEXP

resolveNativeRoutine(SEXP args, DL_FUNC *fun,

		     R_RegisteredNativeSymbol *symbol, char *buf,

		     int *nargs, int *naok, int *dup, SEXP call)

{

    SEXP op;

    const char *p; char *q;

    DllReference dll = {"", NULL, NULL, NOT_DEFINED};

    op = CAR(args);

    /* NB, this sets fun, symbol and buf and is not just a check! */

    checkValidSymbolId(op, call, fun, symbol, buf);

    /* The following code modifies the argument list */

    /* We know this is ok because do_dotCode is entered */

    /* 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 '%s' value"), "naok");

	if(*nargs > MAX_ARGS)

	    errorcall(call, _("too many arguments in foreign function call"));

    } else {

	if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");

	/* This has the side effect of setting dll.type if a PACKAGE=

	   argument if found */

	args = pkgtrim(args, &dll);

    }

    /* Make up the load symbol and look it up. */

    if(TYPEOF(op) == STRSXP) {

	p = translateChar(STRING_ELT(op, 0));

	if(strlen(p) >= MaxSymbolBytes)

	    error(_("symbol '%s' is too long"), p);

	q = buf;

	while ((*q = *p) != '\0') {

	    if(symbol->type == R_FORTRAN_SYM) *q = tolower(*q);

	    p++;

	    q++;

	}

    }

    if(!*fun) {

	if(dll.type != FILENAME) {

	    /* no PACKAGE= arg, so see if we can identify a DLL

	       from the namespace defining the function */

	    *fun = R_FindNativeSymbolFromDLL(buf, &dll, symbol);

	    /* need to continue if there is no PACKAGE arg or if the

	       namespace search failed

	       if(!fun)

		   errorcall(call, _("cannot resolve native routine"));

	    */

	}

	/* NB: the actual conversion to the symbol is done in

	   R_dlsym in Rdynload.c.  That prepends an underscore (usually),

	   and may append one or more underscores.

	*/

	if (!*fun && !(*fun = R_FindSymbol(buf, dll.DLLname, symbol))) {

	    if(strlen(dll.DLLname))

		errorcall(call,

			  _("%s symbol name \"%s\" not in DLL for package \"%s\""),

			  symbol->type == R_FORTRAN_SYM ? "Fortran" : "C", buf,

			  dll.DLLname);

	    else

		errorcall(call, _("%s symbol name \"%s\" not in load table"),

			  symbol->type == R_FORTRAN_SYM ? "Fortran" : "C", buf);

	}

    }

    return(args);

}

/* 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 Rboolean

checkNativeType(int targetType, int actualType)

{

    if(targetType > 0) {

	if(targetType == INTSXP || targetType == LGLSXP) {

	    return(actualType == INTSXP || actualType == LGLSXP);

	}

	return(targetType == actualType);

    }

    return(TRUE);

}

static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort,

			const char *name, R_toCConverter **converter,

			int targetType, char* encname)

{

    Rbyte *rawptr;

    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);

    }

    if(checkNativeType(targetType, TYPEOF(s)) == FALSE) {

	if(!dup) {

	    error(_("explicit request not to duplicate arguments in call to '%s', but argument %d is of the wrong type (%d != %d)"),

		  name, narg + 1, targetType, TYPEOF(s));

	}

	if(targetType != SINGLESXP)

	    s = coerceVector(s, targetType);

    }

    switch(TYPEOF(s)) {

    case RAWSXP:

    n = LENGTH(s);

    rawptr = RAW(s);

    if (dup) {

	rawptr = (Rbyte *) R_alloc(n, sizeof(Rbyte));

	for (i = 0; i < n; i++)

	    rawptr[i] = RAW(s)[i];

    }

    return (void *) rawptr;

    break;

    case LGLSXP:

    case INTSXP:

	n = LENGTH(s);

	iptr = INTEGER(s);

	if(!naok)

	    for (i = 0 ; i < n ; i++)

		if(iptr[i] == NA_INTEGER)

		    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];

	}

	return (void*)iptr;

	break;

    case REALSXP:

	n = LENGTH(s);

	rptr = REAL(s);

	if(!naok)

	    for (i = 0 ; i < n ; i++)

		if(!R_FINITE(rptr[i]))

		    error(_("NA/NaN/Inf in foreign function call (arg %d)"), narg);

	if (dup) {

	    if(asLogical(getAttrib(s, CSingSymbol)) == 1) {

		sptr = (float*)R_alloc(n, sizeof(float));

		for (i = 0 ; i < n ; i++)

		    sptr[i] = (float) REAL(s)[i];

		return (void*)sptr;

	    } else {

		rptr = (double*)R_alloc(n, sizeof(double));

		for (i = 0 ; i < n ; i++)

		    rptr[i] = REAL(s)[i];

		return (void*)rptr;

	    }

	} else

	    return (void*)rptr;

	break;

    case CPLXSXP:

	n = LENGTH(s);

	zptr = COMPLEX(s);

	if(!naok)

	    for (i = 0 ; i < n ; i++)

		if(!R_FINITE(zptr[i].r) || !R_FINITE(zptr[i].i))

		    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];

	}

	return (void*)zptr;

	break;

    case STRSXP:

	if(!dup)

	    error(_("character variables must be duplicated in .C/.Fortran"));

	n = LENGTH(s);

	if(Fort) {

	    const char *ss = translateChar(STRING_ELT(s, 0));

	    if(n > 1)

		warning(_("only first string in char vector used in .Fortran"));

	    l = strlen(ss);

	    fptr = (char*)R_alloc(max(255, l) + 1, sizeof(char));

	    strcpy(fptr, ss);

	    return (void*)fptr;

	} else {

	    cptr = (char**)R_alloc(n, sizeof(char*));

	    if(strlen(encname)) {

		char *outbuf;

		const char *inbuf;

		size_t inb, outb, outb0, res;

		void *obj = Riconv_open("", encname); /* (to, from) */

		if(obj == (void *)-1)

		    error(_("unsupported encoding '%s'"), encname);

		for (i = 0 ; i < n ; i++) {

		    inbuf = CHAR(STRING_ELT(s, i));

		    inb = strlen(inbuf);

		    outb0 = 3*inb;

		restart_in:

		    cptr[i] = outbuf = (char*)R_alloc(outb0 + 1, sizeof(char));

		    outb = 3*inb;

		    Riconv(obj, NULL, NULL, &outbuf, &outb);

		    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);

		    if(res == -1 && errno == E2BIG) {

			outb0 *= 3;

			goto restart_in;

		    }

		    if(res == -1)

			error(_("conversion problem in re-encoding to '%s'"),

			      encname);

		    *outbuf = '\0';

		}

		Riconv_close(obj);

	    } else {

		for (i = 0 ; i < n ; i++) {

		    const char *ss = translateChar(STRING_ELT(s, i));

		    l = strlen(ss);

		    cptr[i] = (char*)R_alloc(l + 1, sizeof(char));

		    strcpy(cptr[i], ss);

		}

	    }

	    return (void*)cptr;

	}

	break;

    case VECSXP:

	if(!dup)

	    error(_("lists must be duplicated in .C"));

	/* if (!dup) return (void*)VECTOR_PTR(s); ***** Dangerous to GC!!! */

	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;

	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++) {

	    cptr[i] = (char*)s;

	    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, SEXP arg, int Fort,

		       R_NativePrimitiveArgType type, char *encname)

{

    Rbyte *rawptr;

    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;

    switch(type) {

    case RAWSXP:

    s = allocVector(type, n);

    rawptr = (Rbyte *)p;

    for (i = 0; i < n; i++) RAW(s)[i] = rawptr[i];

    break;

    case LGLSXP:

	s = allocVector(type, n);

	iptr = (int*)p;

	for(i = 0 ; i < n ; i++) {

	    int tmp =  iptr[i];

	    LOGICAL(s)[i] = (tmp == NA_INTEGER || tmp == 0) ? tmp : 1;

	}

	break;

    case INTSXP:

	s = allocVector(type, n);

	iptr = (int*)p;

	for(i = 0 ; i < n ; i++) INTEGER(s)[i] = iptr[i];

	break;

    case REALSXP:

    case SINGLESXP:

	s = allocVector(REALSXP, n);

	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];

	}

	break;

    case CPLXSXP:

	s = allocVector(type, n);

	zptr = (Rcomplex*)p;

	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[255] = '\0';

	    PROTECT(s = allocVector(type, 1));

	    SET_STRING_ELT(s, 0, mkChar(buf));

	    UNPROTECT(1);

	} else {

	    PROTECT(s = allocVector(type, n));

	    cptr = (char**)p;

	    if(strlen(encname)) {

		const char *inbuf;

		char *outbuf, *p;

		size_t inb, outb, outb0, res;

		void *obj = Riconv_open(encname, ""); /* (to, from) */

		if(obj == (void *)(-1))

		    error(_("unsupported encoding '%s'"), encname);

		for (i = 0 ; i < n ; i++) {

		    inbuf = cptr[i]; inb = strlen(inbuf);

		    outb0 = 3*inb;

		restart_out:

		    p = outbuf = (char*)R_alloc(outb0 + 1, sizeof(char));

		    outb = outb0;

		    Riconv(obj, NULL, NULL, &outbuf, &outb);

		    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);

		    if(res == -1 && errno == E2BIG) {

			outb0 *= 3;

			goto restart_out;

		    }

		    if(res == -1)

			error(_("conversion problem in re-encoding from '%s'"),

			      encname);

		    *outbuf = '\0';

		    SET_STRING_ELT(s, i, mkChar(p));

		}

		Riconv_close(obj);

	    } else {

		for(i = 0 ; i < n ; i++)

		    SET_STRING_ELT(s, i, mkChar(cptr[i]));

	    }

	    UNPROTECT(1);

	}

	break;

    case VECSXP:

	PROTECT(s = allocVector(VECSXP, n));

	lptr = (SEXP*)p;

	for (i = 0 ; i < n ; i++) SET_VECTOR_ELT(s, i, lptr[i]);

	UNPROTECT(1);

	break;

    case LISTSXP:

	PROTECT(t = s = allocList(n));

	lptr = (SEXP*)p;

	for(i = 0 ; i < n ; i++) {

	    SETCAR(t, lptr[i]);

	    t = CDR(t);

	}

	UNPROTECT(1);

    default:

	s = (SEXP)p;

    }

    return s;

}

static Rboolean

comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)

{

   if(type == ANYSXP || TYPEOF(s) == type)

      return(TRUE);

   if(dup && type == SINGLESXP)

      return(asLogical(getAttrib(s, install("Csingle"))) == TRUE);

   return(FALSE);

}

/* Foreign Function Interface.  This code allows a user to call C */

/* or Fortran code which is either statically or dynamically linked. */

/* NB: 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)

{

    SEXP s, prev;

    int nargs=0, naokused=0, dupused=0, pkgused=0;

    const char *p;

    *naok = 0;

    *dup = 1;

    *len = 0;

    for(s = args, prev=args; s != R_NilValue;) {

	if(TAG(s) == NaokSymbol) {

	    *naok = asLogical(CAR(s));

	    /* SETCDR(prev, s = CDR(s)); */

	    if(naokused++ == 1) warning(_("NAOK used more than once"));

	} else if(TAG(s) == DupSymbol) {

	    *dup = asLogical(CAR(s));

	    /* SETCDR(prev, s = CDR(s)); */

	    if(dupused++ == 1) warning(_("DUP used more than once"));

	} else if(TAG(s) == PkgSymbol) {

	    dll->obj = CAR(s);

	    if(TYPEOF(CAR(s)) == STRSXP) {

		p = translateChar(STRING_ELT(CAR(s), 0));

		if(strlen(p) > PATH_MAX - 1)

		    error(_("DLL name is too long"));

		dll->type = FILENAME;

		strcpy(dll->DLLname, p);

		if(pkgused++ > 1) warning(_("PACKAGE used more than once"));

		/* More generally, this should allow us to process

		   any additional arguments and not insist that PACKAGE

		   be the last argument.

		*/

	    } else {

		    /* Have a DLL object*/

		if(TYPEOF(CAR(s)) == EXTPTRSXP) {

		    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,

			   translateChar(STRING_ELT(VECTOR_ELT(CAR(s), 1), 0)));

		    dll->dll = (HINSTANCE) R_ExternalPtrAddr(VECTOR_ELT(s, 4));

		}

	    }

	} else {

	    nargs++;

	    prev = s;

	    s = CDR(s);

	    continue;

	}

	if(s == args)

	    args = s = CDR(s);

	else

	    SETCDR(prev, s = CDR(s));

    }

    *len = nargs;

    return args;

}

static void setDLLname(SEXP s, char *DLLname)

{

    SEXP ss = CAR(s);

    const char *name;

    if(TYPEOF(ss) != STRSXP || length(ss) != 1)

	error(_("PACKAGE argument must be a single character string"));

    name = translateChar(STRING_ELT(ss, 0));

    /* allow the package: form of the name, as returned by find */

    if(strncmp(name, "package:", 8) == 0)

	name += 8;

    if(strlen(name) > PATH_MAX - 1)

	error(_("PACKAGE argument is too long"));

    strcpy(DLLname, name);

}

static SEXP pkgtrim(SEXP args, DllReference *dll)

{

    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"));

	    setDLLname(s, dll->DLLname);

	    dll->type = FILENAME;

	    return R_NilValue;

	}

	if(TAG(ss) == PkgSymbol) {

	    if(pkgused++ == 1) warning(_("PACKAGE used more than once"));

	    setDLLname(ss, dll->DLLname);

	    dll->type = FILENAME;

	    SETCDR(s, CDR(ss));

	}

	s = CDR(s);

    }

    return args;

}

static SEXP enctrim(SEXP args, char *name, int len)

{

    SEXP s, ss, sx;

    int pkgused=0;

    strcpy(name, "");

    for(s = args ; s != R_NilValue;) {

	ss = CDR(s);

	/* Look for ENCODING=. 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) == EncSymbol) {

	    sx = CAR(s);

	    if(pkgused++ == 1) warning(_("ENCODING used more than once"));

	    if(TYPEOF(sx) != STRSXP || length(sx) != 1)

		error(_("ENCODING argument must be a single character string"));

	    strncpy(name, translateChar(STRING_ELT(sx, 0)), len);

	    return R_NilValue;

	}

	if(TAG(ss) == EncSymbol) {

	    sx = CAR(ss);

	    if(pkgused++ == 1) warning(_("ENCODING used more than once"));

	    if(TYPEOF(sx) != STRSXP || length(sx) != 1)

		error(_("ENCODING argument must be a single character string"));

	    strncpy(name, translateChar(STRING_ELT(sx, 0)), len);

	    SETCDR(s, CDR(ss));

	}

	s = CDR(s);

    }

    return args;

}

SEXP attribute_hidden do_isloaded(SEXP call, SEXP op, SEXP args, SEXP env)

{

    const char *sym, *type="", *pkg = "";

    int val = 1, nargs = length(args);

    R_RegisteredNativeSymbol symbol = {R_ANY_SYM, {NULL}, NULL};

    if (nargs < 1) error(_("no arguments supplied"));

    if (nargs > 3) error(_("too many arguments"));

    if(!isValidString(CAR(args)))

	error(_("invalid '%s' argument"), "symbol");

    sym = translateChar(STRING_ELT(CAR(args), 0));

    if(nargs >= 2) {

	if(!isValidString(CADR(args)))

	    error(_("invalid '%s' argument"), "PACKAGE");

	pkg = translateChar(STRING_ELT(CADR(args), 0));

    }

    if(nargs >= 3) {

	if(!isValidString(CADDR(args)))

	    error(_("invalid '%s' argument"), "type");

	type = CHAR(STRING_ELT(CADDR(args), 0)); /* ASCII */

	if(strcmp(type, "C") == 0) symbol.type = R_C_SYM;

	else if(strcmp(type, "Fortran") == 0) symbol.type = R_FORTRAN_SYM;

	else if(strcmp(type, "Call") == 0) symbol.type = R_CALL_SYM;

	else if(strcmp(type, "External") == 0) symbol.type = R_EXTERNAL_SYM;

    }

    if(!(R_FindSymbol(sym, pkg, &symbol))) val = 0;

    return ScalarLogical(val);

}

/*   Call dynamically loaded "internal" functions */

/*   code by Jean Meloche <jean@stat.ubc.ca> */

typedef SEXP (*R_ExternalRoutine)(SEXP);

SEXP attribute_hidden do_External(SEXP call, SEXP op, SEXP args, SEXP env)

{

    DL_FUNC ofun = NULL;

    R_ExternalRoutine fun = NULL;

    SEXP retval;

    R_RegisteredNativeSymbol symbol = {R_EXTERNAL_SYM, {NULL}, NULL};

    const void *vmax = vmaxget();

    char buf[MaxSymbolBytes];

    if (length(args) < 1) errorcall(call, _("'name' is missing"));

    check1arg(args, call, "name");

    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,

				NULL, call);

    fun = (R_ExternalRoutine) ofun;

    /* Some external symbols that are registered may have 0 as the

       expected number of arguments.  We may want a warning

       here. However, the number of values may vary across calls and

       that is why people use the .External() mechanism.  So perhaps

       we should just kill this 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))

	    errorcall(call,

		      _("Incorrect number of arguments (%d), expecting %d for %s"),

		      length(args), symbol.symbol.external->numArgs, buf);

    }

#endif

    retval = (SEXP)fun(args);

    vmaxset(vmax);

    return retval;

}

#ifdef __cplusplus

typedef SEXP (*VarFun)(...);

#else

typedef DL_FUNC VarFun;

#endif

/* .Call(name, <args>) */

SEXP attribute_hidden do_dotcall(SEXP call, SEXP op, SEXP args, SEXP env)

{

    DL_FUNC ofun = NULL;

    VarFun fun = NULL;

    SEXP retval, nm, cargs[MAX_ARGS], pargs;

    R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};

    int nargs;

    const void *vmax = vmaxget();

    char buf[MaxSymbolBytes];

    if (length(args) < 1) errorcall(call, _("'name' is missing"));

    check1arg(args, call, "name");

    nm = CAR(args);

    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,

				NULL, call);

    args = CDR(args);

    fun = (VarFun) ofun;

    for(nargs = 0, pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {

	if (nargs == MAX_ARGS)

	    errorcall(call, _("too many arguments in foreign function call"));

	cargs[nargs] = CAR(pargs);

	nargs++;

    }

    if(symbol.symbol.call && symbol.symbol.call->numArgs > -1) {

	if(symbol.symbol.call->numArgs != nargs)

	    errorcall(call,

		      _("Incorrect number of arguments (%d), expecting %d for %s"),

		      nargs, symbol.symbol.call->numArgs, buf);

    }

    retval = R_NilValue;	/* -Wall */

    fun = (VarFun) ofun;

    switch (nargs) {

    case 0:

	retval = (SEXP)ofun();

	break;

    case 1:

	retval = (SEXP)fun(cargs[0]);

	break;

    case 2:

	retval = (SEXP)fun(cargs[0], cargs[1]);

	break;

    case 3:

	retval = (SEXP)fun(cargs[0], cargs[1], cargs[2]);

	break;

    case 4:

	retval = (SEXP)fun(cargs[0], cargs[1], cargs[2], cargs[3]);

	break;

    case 5:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4]);

	break;

    case 6:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5]);

	break;

    case 7:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6]);

	break;

    case 8:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7]);

	break;

    case 9:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8]);

	break;

    case 10:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9]);

	break;

    case 11:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10]);

	break;

    case 12:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11]);

	break;

    case 13:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11], cargs[12]);

	break;

    case 14:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11], cargs[12], cargs[13]);

	break;

    case 15:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14]);

	break;

    case 16:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],

	    cargs[15]);

	break;

    case 17:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],

	    cargs[15], cargs[16]);

	break;

    case 18:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],

	    cargs[15], cargs[16], cargs[17]);

	break;

    case 19:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],

	    cargs[15], cargs[16], cargs[17], cargs[18]);

	break;

    case 20:

	retval = (SEXP)fun(

	    cargs[0],  cargs[1],  cargs[2],  cargs[3],  cargs[4],

	    cargs[5],  cargs[6],  cargs[7],  cargs[8],  cargs[9],

	    cargs[10], cargs[11], cargs[12], cargs[13], cargs[14],