The R Project SVN R

/*

/*

 *  R : A Computer Language for Statistical Data Analysis

 *  R : A Computer Language for Statistical Data Analysis

 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka

 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka

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

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

 *  Copyright (C) 2003	      The R Foundation

 *  Copyright (C) 2003	      The R Foundation

 *

 *

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

 *  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

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

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

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

 *  (at your option) any later version.

 *  (at your option) any later version.

 *

 *

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

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

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

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

 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 *  GNU General Public License for more details.

 *  GNU General Public License for more details.

 *

 *

 *  A copy of the GNU General Public License is available via WWW at

 *  A copy of the GNU General Public License is available via WWW at

 *  http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by

 *  http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by

 *  writing to the Free Software Foundation, Inc., 51 Franklin Street

 *  writing to the Free Software Foundation, Inc., 51 Franklin Street

 *  Fifth Floor, Boston, MA 02110-1301  USA.

 *  Fifth Floor, Boston, MA 02110-1301  USA.

 */

 */

/* <UTF8-FIXME>

/* <UTF8-FIXME>

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

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

   Check other uses.

   Check other uses.

 */

 */

#ifdef HAVE_CONFIG_H

#ifdef HAVE_CONFIG_H

# include <config.h>

# include <config.h>

#endif

#endif

#include <Defn.h>

#include <Defn.h>

#include <string.h>

#include <string.h>

#include <stdlib.h>

#include <stdlib.h>

#include <Rmath.h>

#include <Rmath.h>

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

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

#include <R_ext/RConverters.h>

#include <R_ext/RConverters.h>

#ifdef HAVE_ICONV

#ifdef HAVE_ICONV

#include <R_ext/Riconv.h>

#include <R_ext/Riconv.h>

#endif

#endif

#ifndef max

#ifndef max

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

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

#endif

#endif

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

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

static SEXP NaokSymbol = NULL;

static SEXP NaokSymbol = NULL;

static SEXP DupSymbol = NULL;

static SEXP DupSymbol = NULL;

static SEXP PkgSymbol = NULL;

static SEXP PkgSymbol = NULL;

static SEXP EncSymbol = NULL;

static SEXP EncSymbol = NULL;

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

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

   a much more straightforward manner. */

   a much more straightforward manner. */

#include <Rdynpriv.h>

#include <Rdynpriv.h>

enum {FILENAME, DLL_HANDLE, R_OBJECT, NOT_DEFINED};

enum {FILENAME, DLL_HANDLE, R_OBJECT, NOT_DEFINED};

typedef struct {

typedef struct {

    char DLLname[PATH_MAX];

    char DLLname[PATH_MAX];

    HINSTANCE dll;

    HINSTANCE dll;

    SEXP  obj;

    SEXP  obj;

    int type;

    int type;

} DllReference;

} DllReference;

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

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

#define MaxSymbolBytes 1024

#define MaxSymbolBytes 1024

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

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

#define MAX_ARGS 65

#define MAX_ARGS 65

static DL_FUNC

static DL_FUNC

R_FindNativeSymbolFromDLL(char *name, DllReference *dll,

R_FindNativeSymbolFromDLL(char *name, DllReference *dll,

			  R_RegisteredNativeSymbol *symbol);

			  R_RegisteredNativeSymbol *symbol);

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

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

		     DllReference *dll);

		     DllReference *dll);

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

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

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

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

/*

/*

  Checks whether the specified object correctly identifies a native routine.

  Checks whether the specified object correctly identifies a native routine.

  This can be

  This can be

   a) a string,

   a) a string,

   b) an external pointer giving the address of the routine

   b) an external pointer giving the address of the routine

      (e.g. getNativeSymbolInfo("foo")$address)

      (e.g. getNativeSymbolInfo("foo")$address)

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

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

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

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

 */

 */

static void

static void

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

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

		   R_RegisteredNativeSymbol *symbol, char *buf)

		   R_RegisteredNativeSymbol *symbol, char *buf)

{

{

    if (isValidString(op)) return;

    if (isValidString(op)) return;

    *fun = NULL;

    *fun = NULL;

    if(TYPEOF(op) == EXTPTRSXP) {

    if(TYPEOF(op) == EXTPTRSXP) {

	char *p = NULL;

	char *p = NULL;

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

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

   	   *fun = (DL_FUNC) R_ExternalPtrAddr(op);

   	   *fun = (DL_FUNC) R_ExternalPtrAddr(op);

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

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

   	   R_RegisteredNativeSymbol *tmp;

   	   R_RegisteredNativeSymbol *tmp;

	   tmp = (R_RegisteredNativeSymbol *) R_ExternalPtrAddr(op);

	   tmp = (R_RegisteredNativeSymbol *) R_ExternalPtrAddr(op);

	   if(tmp) {

	   if(tmp) {

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

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

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

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

   	        /* Check the type of the symbol. */

   	        /* Check the type of the symbol. */

   	      switch(symbol->type) {

   	      switch(symbol->type) {

	      case R_C_SYM:

	      case R_C_SYM:

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

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

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

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

		  break;

		  break;

	      case R_CALL_SYM:

	      case R_CALL_SYM:

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

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

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

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

		  break;

		  break;

	      case R_FORTRAN_SYM:

	      case R_FORTRAN_SYM:

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

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

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

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

		  break;

		  break;

	      case R_EXTERNAL_SYM:

	      case R_EXTERNAL_SYM:

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

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

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

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

		  break;

		  break;

	      default:

	      default:

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

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

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

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

			    symbol->type);

			    symbol->type);

  	          break;

  	          break;

	      }

	      }

	      *symbol = *tmp;

	      *symbol = *tmp;

	   }

	   }

	}

	}

	/* This is illegal C */

	/* This is illegal C */

	if(*fun == NULL)

	if(*fun == NULL)

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

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

        /* copy the symbol name. */

        /* copy the symbol name. */

	if (p) {

	if (p) {

	    if (strlen(p) >= MaxSymbolBytes)

	    if (strlen(p) >= MaxSymbolBytes)

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

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

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

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

	    /* Ouch, no length check

	    /* Ouch, no length check

	    q = buf;

	    q = buf;

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

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

	        p++;

	        p++;

	        q++;

	        q++;

	    } */

	    } */

	}

	}

	return;

	return;

    } 

    } 

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

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

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

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

	return;

	return;

    }

    }

    errorcall(call,

    errorcall(call,

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

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

    return; /* not reached */

    return; /* not reached */

}

}

/*

/*

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

  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

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

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

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

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

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

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

  address directly, and if the DLL is specified. 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.

  and look there.

*/

*/

static SEXP

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

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

{

{

    SEXP op;

    SEXP op;

    const char *p; char *q;

    const char *p; char *q;

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

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

    op = CAR(args);

    op = CAR(args);

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

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

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

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

    /* The following code modifies the argument list */

    /* The following code modifies the argument list */

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

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

    /* with its arguments evaluated. */

    /* with its arguments evaluated. */

    strcpy(dll.DLLname, "");

    strcpy(dll.DLLname, "");

    if(symbol->type == R_C_SYM || symbol->type == R_FORTRAN_SYM) {

    if(symbol->type == R_C_SYM || symbol->type == R_FORTRAN_SYM) {

	args = naokfind(CDR(args), nargs, naok, dup, &dll);

	args = naokfind(CDR(args), nargs, naok, dup, &dll);

	if(*naok == NA_LOGICAL)

	if(*naok == NA_LOGICAL)

	    errorcall(call, _("invalid '%s' value"), "naok");

	    errorcall(call, _("invalid '%s' value"), "naok");

	if(*nargs > MAX_ARGS)

	if(*nargs > MAX_ARGS)

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

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

    } else {

    } else {

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

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

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

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

	   argument if found */

	   argument if found */

	args = pkgtrim(args, &dll);

	args = pkgtrim(args, &dll);

    }

    }

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

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

    if(TYPEOF(op) == STRSXP) {

    if(TYPEOF(op) == STRSXP) {

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

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

	if(strlen(p) >= MaxSymbolBytes)

	if(strlen(p) >= MaxSymbolBytes)

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

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

	q = buf;

	q = buf;

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

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

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

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

	    p++;

	    p++;

	    q++;

	    q++;

	}

	}

    }

    }

    if(!*fun) {

    if(!*fun) {

	if(dll.type != FILENAME) {

	if(dll.type != FILENAME) {

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

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

	       from the namespace defining the function */

	       from the namespace defining the function */

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

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

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

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

	       namespace search failed

	       namespace search failed

	       if(!fun)

	       if(!fun)

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

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

	    */

	    */

	}

	}

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

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

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

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

	   and may append one or more underscores.

	   and may append one or more underscores.

	*/

	*/

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

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

	    if(strlen(dll.DLLname))

	    if(strlen(dll.DLLname))

		errorcall(call,

		errorcall(call,

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

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

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

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

			  dll.DLLname);

			  dll.DLLname);

	    else

	    else

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

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

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

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

	}

	}

    }

    }

    return(args);

    return(args);

}

}

/* Convert an R object to a non-moveable C/Fortran 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 Rboolean

static Rboolean

checkNativeType(int targetType, int actualType)

checkNativeType(int targetType, int actualType)

{

{

    if(targetType > 0) {

    if(targetType > 0) {

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

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

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

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

	}

	}

	return(targetType == actualType);

	return(targetType == actualType);

    }

    }

    return(TRUE);

    return(TRUE);

}

}

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,

			const char *name, R_toCConverter **converter,

			int targetType, char* encname)

			int targetType, char* encname)

{

{

    Rbyte *rawptr;

    Rbyte *rawptr;

    int *iptr;

    int *iptr;

    float *sptr;

    float *sptr;

    double *rptr;

    double *rptr;

    char **cptr, *fptr;

    char **cptr, *fptr;

    Rcomplex *zptr;

    Rcomplex *zptr;

    SEXP *lptr, CSingSymbol=install("Csingle");

    SEXP *lptr, CSingSymbol=install("Csingle");

    int i, l, n;

    int i, l, n;

    if(converter)

    if(converter)

	*converter = NULL;

	*converter = NULL;

    if(length(getAttrib(s, R_ClassSymbol))) {

    if(length(getAttrib(s, R_ClassSymbol))) {

	R_CConvertInfo info;

	R_CConvertInfo info;

	int success;

	int success;

        void *ans;

        void *ans;

	info.naok = naok;

	info.naok = naok;

	info.dup = dup;

	info.dup = dup;

	info.narg = narg;

	info.narg = narg;

	info.Fort = Fort;

	info.Fort = Fort;

        info.name = name;

        info.name = name;

	ans = Rf_convertToC(s, &info, &success, converter);

	ans = Rf_convertToC(s, &info, &success, converter);

	if(success)

	if(success)

	    return(ans);

	    return(ans);

    }

    }

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

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

	if(!dup) {

	if(!dup) {

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

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

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

	}

	}

	if(targetType != SINGLESXP)

	if(targetType != SINGLESXP)

	    s = coerceVector(s, targetType);

	    s = coerceVector(s, targetType);

    }

    }

    switch(TYPEOF(s)) {

    switch(TYPEOF(s)) {

    case RAWSXP:

    case RAWSXP:

    n = LENGTH(s);

    n = LENGTH(s);

    rawptr = RAW(s);

    rawptr = RAW(s);

    if (dup) {

    if (dup) {

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

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

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

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

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

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

    }

    }

    return (void *) rawptr;

    return (void *) rawptr;

    break;

    break;

    case LGLSXP:

    case LGLSXP:

    case INTSXP:

    case INTSXP:

	n = LENGTH(s);

	n = LENGTH(s);

	iptr = INTEGER(s);

	iptr = INTEGER(s);

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

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

	    if(!naok && iptr[i] == NA_INTEGER)

	    if(!naok && iptr[i] == NA_INTEGER)

		error(_("NAs in foreign function call (arg %d)"), narg);

		error(_("NAs in foreign function call (arg %d)"), narg);

	}

	}

	if (dup) {

	if (dup) {

	    iptr = (int*)R_alloc(n, sizeof(int));

	    iptr = (int*)R_alloc(n, sizeof(int));

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

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

		iptr[i] = INTEGER(s)[i];

		iptr[i] = INTEGER(s)[i];

	}

	}

	return (void*)iptr;

	return (void*)iptr;

	break;

	break;

    case REALSXP:

    case REALSXP:

	n = LENGTH(s);

	n = LENGTH(s);

	rptr = REAL(s);

	rptr = REAL(s);

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

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

	    if(!naok && !R_FINITE(rptr[i]))

	    if(!naok && !R_FINITE(rptr[i]))

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

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

	}

	}

	if (dup) {

	if (dup) {

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

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

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

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

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

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

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

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

		return (void*)sptr;

		return (void*)sptr;

	    } else {

	    } else {

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

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

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

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

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

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

		return (void*)rptr;

		return (void*)rptr;

	    }

	    }

	} else

	} else

	    return (void*)rptr;

	    return (void*)rptr;

	break;

	break;

    case CPLXSXP:

    case CPLXSXP:

	n = LENGTH(s);

	n = LENGTH(s);

	zptr = COMPLEX(s);

	zptr = COMPLEX(s);

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

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

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

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

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

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

		      narg);

		      narg);

	}

	}

	if (dup) {

	if (dup) {

	    zptr = (Rcomplex*)R_alloc(n, sizeof(Rcomplex));

	    zptr = (Rcomplex*)R_alloc(n, sizeof(Rcomplex));

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

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

		zptr[i] = COMPLEX(s)[i];

		zptr[i] = COMPLEX(s)[i];

	}

	}

	return (void*)zptr;

	return (void*)zptr;

	break;

	break;

    case STRSXP:

    case STRSXP:

	if(!dup)

	if(!dup)

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

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

	n = LENGTH(s);

	n = LENGTH(s);

	if(Fort) {

	if(Fort) {

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

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

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

	    l = strlen(ss);

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

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

	    strcpy(fptr, ss);

	    strcpy(fptr, ss);

	    return (void*)fptr;

	    return (void*)fptr;

	} else {

	} else {

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

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

	    if(strlen(encname)) {

	    if(strlen(encname)) {

#ifdef HAVE_ICONV

#ifdef HAVE_ICONV

		char *outbuf;

		char *outbuf;

                const char *inbuf;

                const char *inbuf;

		size_t inb, outb, outb0, res;

		size_t inb, outb, outb0, res;

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

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

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

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

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

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

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

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

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

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

		    inb = strlen(inbuf);

		    inb = strlen(inbuf);

		    outb0 = 3*inb;

		    outb0 = 3*inb;

		restart_in:

		restart_in:

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

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

		    outb = 3*inb;

		    outb = 3*inb;

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

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

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

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

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

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

			outb0 *= 3;

			outb0 *= 3;

			goto restart_in;

			goto restart_in;

		    }

		    }

		    if(res == -1) 

		    if(res == -1) 

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

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

			      encname);

			      encname);

		    *outbuf = '\0';

		    *outbuf = '\0';

		}

		}

		Riconv_close(obj);

		Riconv_close(obj);

	    } else 

	    } else 

#else

#else

		warning(_("re-encoding is not supported on this system"));

		warning(_("re-encoding is not supported on this system"));

	    }

	    }

#endif

#endif

	    {

	    {

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

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

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

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

		    l = strlen(ss);

		    l = strlen(ss);

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

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

		    strcpy(cptr[i], ss);

		    strcpy(cptr[i], ss);

		}

		}

	    }

	    }

	    return (void*)cptr;

	    return (void*)cptr;

	}

	}

	break;

	break;

    case VECSXP:

    case VECSXP:

	if(!dup)

	if(!dup)

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

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

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

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

  	n = length(s);

  	n = length(s);

	lptr = (SEXP*)R_alloc(n, sizeof(SEXP));

	lptr = (SEXP*)R_alloc(n, sizeof(SEXP));

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

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

	    lptr[i] = VECTOR_ELT(s, i);

	    lptr[i] = VECTOR_ELT(s, i);

	}

	}

 	return (void*)lptr;

 	return (void*)lptr;

	break;

	break;

    case LISTSXP:

    case LISTSXP:

	if(Fort) error(_("invalid mode to pass to Fortran (arg %d)"), narg);

	if(Fort) error(_("invalid mode to pass to Fortran (arg %d)"), narg);

	/* Warning : The following looks like it could bite ... */

	/* Warning : The following looks like it could bite ... */

	if(!dup) return (void*)s;

	if(!dup) return (void*)s;

	n = length(s);

	n = length(s);

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

	    cptr[i] = (char*)s;

	    cptr[i] = (char*)s;

	    s = CDR(s);

	    s = CDR(s);

	}

	}

	return (void*)cptr;

	return (void*)cptr;

	break;

	break;

    default:

    default:

	if(Fort) error(_("invalid mode to pass to Fortran (arg %d)"), narg);

	if(Fort) error(_("invalid mode to pass to Fortran (arg %d)"), narg);

	return (void*)s;

	return (void*)s;

    }

    }

}

}

static SEXP CPtrToRObj(void *p, SEXP arg, int Fort,

static SEXP CPtrToRObj(void *p, SEXP arg, int Fort,

		       R_NativePrimitiveArgType type, char *encname)

		       R_NativePrimitiveArgType type, char *encname)

{

{

    Rbyte *rawptr;

    Rbyte *rawptr;

    int *iptr, n=length(arg);

    int *iptr, n=length(arg);

    float *sptr;

    float *sptr;

    double *rptr;

    double *rptr;

    char **cptr, buf[256];

    char **cptr, buf[256];

    Rcomplex *zptr;

    Rcomplex *zptr;

    SEXP *lptr, CSingSymbol = install("Csingle");

    SEXP *lptr, CSingSymbol = install("Csingle");

    int i;

    int i;

    SEXP s, t;

    SEXP s, t;

    switch(type) {

    switch(type) {

    case RAWSXP:

    case RAWSXP:

    s = allocVector(type, n);

    s = allocVector(type, n);

    rawptr = (Rbyte *)p;

    rawptr = (Rbyte *)p;

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

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

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

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

    break;

    break;

    case LGLSXP:

    case LGLSXP:

    case INTSXP:

    case INTSXP:

	s = allocVector(type, n);

	s = allocVector(type, n);

	iptr = (int*)p;

	iptr = (int*)p;

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

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

            INTEGER(s)[i] = iptr[i];

            INTEGER(s)[i] = iptr[i];

	break;

	break;

    case REALSXP:

    case REALSXP:

    case SINGLESXP:

    case SINGLESXP:

	s = allocVector(REALSXP, n);

	s = allocVector(REALSXP, n);

	if(type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {

	if(type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {

	    sptr = (float*) p;

	    sptr = (float*) p;

	    for(i=0 ; i<n ; i++) REAL(s)[i] = (double) sptr[i];

	    for(i=0 ; i<n ; i++) REAL(s)[i] = (double) sptr[i];

	} else {

	} else {

	    rptr = (double*) p;

	    rptr = (double*) p;

	    for(i=0 ; i<n ; i++) REAL(s)[i] = rptr[i];

	    for(i=0 ; i<n ; i++) REAL(s)[i] = rptr[i];

	}

	}

	break;

	break;

    case CPLXSXP:

    case CPLXSXP:

	s = allocVector(type, n);

	s = allocVector(type, n);

	zptr = (Rcomplex*)p;

	zptr = (Rcomplex*)p;

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

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

	    COMPLEX(s)[i] = zptr[i];

	    COMPLEX(s)[i] = zptr[i];

	}

	}

	break;

	break;

    case STRSXP:

    case STRSXP:

	if(Fort) {

	if(Fort) {

	    /* only return one string: warned on the R -> Fortran step */

	    /* only return one string: warned on the R -> Fortran step */

	    strncpy(buf, (char*)p, 255);

	    strncpy(buf, (char*)p, 255);

	    buf[255] = '\0';

	    buf[255] = '\0';

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

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

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

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

	    UNPROTECT(1);

	    UNPROTECT(1);

	} else {

	} else {

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

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

	    cptr = (char**)p;

	    cptr = (char**)p;

	    if(strlen(encname)) {

	    if(strlen(encname)) {

#ifdef HAVE_ICONV

#ifdef HAVE_ICONV

                const char *inbuf;

                const char *inbuf;

		char *outbuf, *p;

		char *outbuf, *p;

		size_t inb, outb, outb0, res;

		size_t inb, outb, outb0, res;

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

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

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

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

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

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

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

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

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

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

		    outb0 = 3*inb;

		    outb0 = 3*inb;

		restart_out:

		restart_out:

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

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

		    outb = outb0;

		    outb = outb0;

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

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

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

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

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

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

			outb0 *= 3;

			outb0 *= 3;

			goto restart_out;

			goto restart_out;

		    }

		    }

		    if(res == -1) 

		    if(res == -1) 

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

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

			      encname);

			      encname);

		    *outbuf = '\0';

		    *outbuf = '\0';

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

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

		}

		}

		Riconv_close(obj);

		Riconv_close(obj);

	    } else 

	    } else 

#else

#else

		warning(_("re-encoding is not supported on this system"));

		warning(_("re-encoding is not supported on this system"));

	    }

	    }

#endif

#endif

	    {

	    {

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

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

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

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

	    }

	    }

	    UNPROTECT(1);

	    UNPROTECT(1);

	}

	}

	break;

	break;

    case VECSXP:

    case VECSXP:

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

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

	lptr = (SEXP*)p;

	lptr = (SEXP*)p;

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

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

	    SET_VECTOR_ELT(s, i, lptr[i]);

	    SET_VECTOR_ELT(s, i, lptr[i]);

	}

	}

	UNPROTECT(1);

	UNPROTECT(1);

	break;

	break;

    case LISTSXP:

    case LISTSXP:

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

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

	lptr = (SEXP*)p;

	lptr = (SEXP*)p;

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

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

	    SETCAR(t, lptr[i]);

	    SETCAR(t, lptr[i]);

	    t = CDR(t);

	    t = CDR(t);

	}

	}

	UNPROTECT(1);

	UNPROTECT(1);

    default:

    default:

	s = (SEXP)p;

	s = (SEXP)p;

    }

    }

    return s;

    return s;

}

}

#define THROW_REGISTRATION_TYPE_ERROR

#define THROW_REGISTRATION_TYPE_ERROR

#ifdef THROW_REGISTRATION_TYPE_ERROR

#ifdef THROW_REGISTRATION_TYPE_ERROR

static Rboolean

static Rboolean

comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)

comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)

{

{

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

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

      return(TRUE);

      return(TRUE);

   if(dup && type == SINGLESXP)

   if(dup && type == SINGLESXP)

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

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

   return(FALSE);

   return(FALSE);

}

}

#endif /* end of THROW_REGISTRATION_TYPE_ERROR */

#endif /* end of THROW_REGISTRATION_TYPE_ERROR */

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

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

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

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

/* NB: this leaves NAOK and DUP arguments on the list */

/* NB: this leaves NAOK and DUP arguments on the list */

/* find NAOK and DUP, find and remove PACKAGE */

/* find NAOK and DUP, find and remove PACKAGE */

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

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

		     DllReference *dll)

		     DllReference *dll)

{

{

    SEXP s, prev;

    SEXP s, prev;

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

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

    const char *p;

    const char *p;

    *naok = 0;

    *naok = 0;

    *dup = 1;

    *dup = 1;

    *len = 0;

    *len = 0;

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

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

	if(TAG(s) == NaokSymbol) {

	if(TAG(s) == NaokSymbol) {

	    *naok = asLogical(CAR(s));

	    *naok = asLogical(CAR(s));

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

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

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

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

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

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

	    *dup = asLogical(CAR(s));

	    *dup = asLogical(CAR(s));

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

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

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

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

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

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

	    dll->obj = CAR(s);

	    dll->obj = CAR(s);

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

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

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

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

		if(strlen(p) > PATH_MAX - 1)

		if(strlen(p) > PATH_MAX - 1)

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

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

		dll->type = FILENAME;

		dll->type = FILENAME;

		strcpy(dll->DLLname, p);

		strcpy(dll->DLLname, p);

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

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

		/* More generally, this should allow us to process

		/* More generally, this should allow us to process

		   any additional arguments and not insist that PACKAGE

		   any additional arguments and not insist that PACKAGE

		   be the last argument.

		   be the last argument.

		*/

		*/

	    } else {

	    } else {

		    /* Have a DLL object*/

		    /* Have a DLL object*/

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

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

		    dll->dll = (HINSTANCE) R_ExternalPtrAddr(CAR(s));

		    dll->dll = (HINSTANCE) R_ExternalPtrAddr(CAR(s));

		    dll->type = DLL_HANDLE;

		    dll->type = DLL_HANDLE;

		} else if(TYPEOF(CAR(s)) == VECSXP) {

		} else if(TYPEOF(CAR(s)) == VECSXP) {

		    dll->type = R_OBJECT;

		    dll->type = R_OBJECT;

		    dll->obj = s;

		    dll->obj = s;

		    strcpy(dll->DLLname,

		    strcpy(dll->DLLname,

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

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

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

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

		}

		}

	    }

	    }

	} else {

	} else {

	    nargs++;

	    nargs++;

	    prev = s;

	    prev = s;

	    s = CDR(s);

	    s = CDR(s);

	    continue;

	    continue;

	}

	}

	if(s == args)

	if(s == args)

	    args = s = CDR(s);

	    args = s = CDR(s);

	else

	else

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

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

    }

    }

    *len = nargs;

    *len = nargs;

    return args;

    return args;

}

}

static void setDLLname(SEXP s, char *DLLname)

static void setDLLname(SEXP s, char *DLLname)

{

{

    SEXP ss = CAR(s);

    SEXP ss = CAR(s);

    const char *name;

    const char *name;

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

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

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

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

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

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

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

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

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

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

	name += 8;

	name += 8;

    if(strlen(name) > PATH_MAX - 1)

    if(strlen(name) > PATH_MAX - 1)

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

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

    strcpy(DLLname, name);

    strcpy(DLLname, name);

}

}

static SEXP pkgtrim(SEXP args, DllReference *dll)

static SEXP pkgtrim(SEXP args, DllReference *dll)

{

{

    SEXP s, ss;

    SEXP s, ss;

    int pkgused=0;

    int pkgused=0;

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

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

	ss = CDR(s);

	ss = CDR(s);

	/* Look for PACKAGE=. We look at the next arg, unless

	/* Look for PACKAGE=. We look at the next arg, unless

	   this is the last one (which will only happen for one arg),

	   this is the last one (which will only happen for one arg),

	   and remove it */

	   and remove it */

	if(ss == R_NilValue && TAG(s) == PkgSymbol) {

	if(ss == R_NilValue && TAG(s) == PkgSymbol) {

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

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

	    setDLLname(s, dll->DLLname);

	    setDLLname(s, dll->DLLname);

	    dll->type = FILENAME;

	    dll->type = FILENAME;

	    return R_NilValue;

	    return R_NilValue;

	}

	}

	if(TAG(ss) == PkgSymbol) {

	if(TAG(ss) == PkgSymbol) {

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

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

	    setDLLname(ss, dll->DLLname);

	    setDLLname(ss, dll->DLLname);

	    dll->type = FILENAME;

	    dll->type = FILENAME;

	    SETCDR(s, CDR(ss));

	    SETCDR(s, CDR(ss));

	}

	}

	s = CDR(s);

	s = CDR(s);

    }

    }

    return args;

    return args;

}

}

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

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

{

{

    SEXP s, ss, sx;

    SEXP s, ss, sx;

    int pkgused=0;

    int pkgused=0;

    strcpy(name, "");

    strcpy(name, "");

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

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

	ss = CDR(s);

	ss = CDR(s);

	/* Look for ENCODING=. We look at the next arg, unless

	/* Look for ENCODING=. We look at the next arg, unless

	   this is the last one (which will only happen for one arg),

	   this is the last one (which will only happen for one arg),

	   and remove it */

	   and remove it */

	if(ss == R_NilValue && TAG(s) == EncSymbol) {

	if(ss == R_NilValue && TAG(s) == EncSymbol) {

	    sx = CAR(s);

	    sx = CAR(s);

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

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

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

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

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

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

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

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

	    return R_NilValue;

	    return R_NilValue;

	}

	}

	if(TAG(ss) == EncSymbol) {

	if(TAG(ss) == EncSymbol) {

	    sx = CAR(ss);

	    sx = CAR(ss);

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

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

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

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

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

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

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

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

	    SETCDR(s, CDR(ss));

	    SETCDR(s, CDR(ss));

	}

	}

	s = CDR(s);

	s = CDR(s);

    }

    }

    return args;

    return args;

}

}

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

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

{

{

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

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

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

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

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

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

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

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

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

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

    if(!isValidString(CAR(args)))

    if(!isValidString(CAR(args)))

	error(R_MSG_IA);

	error(R_MSG_IA);

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

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

    if(nargs >= 2) {

    if(nargs >= 2) {

	if(!isValidString(CADR(args)))

	if(!isValidString(CADR(args)))

	    error(R_MSG_IA);

	    error(R_MSG_IA);

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

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

    }

    }

    if(nargs >= 3) {

    if(nargs >= 3) {

	if(!isValidString(CADDR(args)))

	if(!isValidString(CADDR(args)))

	    error(R_MSG_IA);

	    error(R_MSG_IA);

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

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

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

	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, "Fortran") == 0) symbol.type = R_FORTRAN_SYM;

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

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

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

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

    }

    }

    if(strlen(type)) {

    if(strlen(type)) {

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

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

    } else {

    } else {

	if (!(R_FindSymbol(sym, pkg, NULL)) && 

	if (!(R_FindSymbol(sym, pkg, NULL)) && 

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

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

    }

    }

    return ScalarLogical(val);

    return ScalarLogical(val);

}

}

/*   Call dynamically loaded "internal" functions */

/*   Call dynamically loaded "internal" functions */

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

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

typedef SEXP (*R_ExternalRoutine)(SEXP);

typedef SEXP (*R_ExternalRoutine)(SEXP);

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

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

{

{

    DL_FUNC ofun = NULL;

    DL_FUNC ofun = NULL;

    R_ExternalRoutine fun = NULL;

    R_ExternalRoutine fun = NULL;

    SEXP retval;

    SEXP retval;

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

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

    void *vmax = vmaxget();

    void *vmax = vmaxget();

    char buf[MaxSymbolBytes];

    char buf[MaxSymbolBytes];

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

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

				NULL, call);

				NULL, call);

    fun = (R_ExternalRoutine) ofun;

    fun = (R_ExternalRoutine) ofun;

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

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

       expected number of arguments.  We may want a warning

       expected number of arguments.  We may want a warning

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

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

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

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

       we should just kill this check.

       we should just kill this check.

    */

    */

#ifdef CHECK_EXTERNAL_ARG_COUNT         /* Off by default. */

#ifdef CHECK_EXTERNAL_ARG_COUNT         /* Off by default. */

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

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

	if(symbol.symbol.external->numArgs != length(args))

	if(symbol.symbol.external->numArgs != length(args))

	    errorcall(call,

	    errorcall(call,

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

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

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

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

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

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

    }

    }

#endif

#endif

    retval = (SEXP)fun(args);

    retval = (SEXP)fun(args);

    vmaxset(vmax);

    vmaxset(vmax);

    return retval;

    return retval;

}

}

#ifdef __cplusplus

#ifdef __cplusplus

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

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

#else

#else

typedef DL_FUNC VarFun;

typedef DL_FUNC VarFun;

#endif

#endif

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

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

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

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

{

{

    DL_FUNC ofun = NULL;

    DL_FUNC ofun = NULL;

    VarFun fun = NULL;

    VarFun fun = NULL;

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

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

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

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

    int nargs;

    int nargs;

    void *vmax = vmaxget();

    void *vmax = vmaxget();

    char buf[MaxSymbolBytes];

    char buf[MaxSymbolBytes];

    nm = CAR(args);

    nm = CAR(args);

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

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

				NULL, call);

				NULL, call);

    args = CDR(args);

    args = CDR(args);

    fun = (VarFun) ofun;

    fun = (VarFun) ofun;

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

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

        if (nargs == MAX_ARGS)

        if (nargs == MAX_ARGS)

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

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

	cargs[nargs] = CAR(pargs);

	cargs[nargs] = CAR(pargs);

	nargs++;

	nargs++;

    }

    }

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

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

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

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

	    errorcall(call,

	    errorcall(call,

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

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

		      nargs, symbol.symbol.call->numArgs,

		      nargs, symbol.symbol.call->numArgs,

		      translateChar(STRING_ELT(nm, 0)));

		      translateChar(STRING_ELT(nm, 0)));

    }

    }

    retval = R_NilValue;	/* -Wall */

    retval = R_NilValue;	/* -Wall */

    fun = (VarFun) ofun;

    fun = (VarFun) ofun;

    switch (nargs) {

    switch (nargs) {

    case 0:

    case 0:

	retval = (SEXP)ofun();

	retval = (SEXP)ofun();

	break;

	break;

    case 1:

    case 1:

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

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

	break;

	break;

    case 2:

    case 2:

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

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

	break;

	break;

    case 3:

    case 3:

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

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

	break;

	break;

    case 4:

    case 4:

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

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

	break;

	break;

    case 5:

    case 5:

	retval = (SEXP)fun(

	retval = (SEXP)fun(

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

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

	break;

	break;

    case 6:

    case 6:

	retval = (SEXP)fun(

	retval = (SEXP)fun(