The R Project SVN R

Rev

Rev 31591 | Rev 31601 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 31591 Rev 31593
Line 1... Line 1...
1 
/*
 1 
/*
2 
 *  R : A Computer Language for Statistical Data Analysis
 2 
 *  R : A Computer Language for Statistical Data Analysis
3 
 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka
 3 
 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka
4 
 *  Copyright (C) 1997--2002  The R Development Core Team
 4 
 *  Copyright (C) 1997--2004  The R Development Core Team
5 
 *  Copyright (C) 2003	      The R Foundation
 5 
 *  Copyright (C) 2003	      The R Foundation
6 
 *
 6 
 *
7 
 *  This program is free software; you can redistribute it and/or modify
 7 
 *  This program is free software; you can redistribute it and/or modify
8 
 *  it under the terms of the GNU General Public License as published by
 8 
 *  it under the terms of the GNU General Public License as published by
9 
 *  the Free Software Foundation; either version 2 of the License, or
 9 
 *  the Free Software Foundation; either version 2 of the License, or
Line 19... Line 19...
19 
 *  writing to the Free Software Foundation, Inc., 59 Temple Place,
 19 
 *  writing to the Free Software Foundation, Inc., 59 Temple Place,
20 
 *  Suite 330, Boston, MA  02111-1307  USA.
 20 
 *  Suite 330, Boston, MA  02111-1307  USA.
21 
 */
 21 
 */
22 
 
 22 
 
23 
#ifdef HAVE_CONFIG_H
 23 
#ifdef HAVE_CONFIG_H
24 
#include <config.h>
 24 
# include <config.h>
25 
#endif
 25 
#endif
26 
 
 26 
 
27 
#include <string.h>
 27 
#include <string.h>
28 
#include <stdlib.h>
 28 
#include <stdlib.h>
29 
 
 29 
 
Line 43... Line 43...
43 
 
 43 
 
44 
static SEXP NaokSymbol = NULL;
 44 
static SEXP NaokSymbol = NULL;
45 
static SEXP DupSymbol = NULL;
 45 
static SEXP DupSymbol = NULL;
46 
static SEXP PkgSymbol = NULL;
 46 
static SEXP PkgSymbol = NULL;
47 
 
 47 
 
48 
/* Global variable that should go. Should actually be doing this in a much more straightforward manner. */
 48 
/* Global variable that should go. Should actually be doing this in
- 
 
 49 
   a much more straightforward manner. */
49 
#include <Rdynpriv.h>
 50 
#include <Rdynpriv.h>
50 
enum {FILENAME, DLL_HANDLE, R_OBJECT, NOT_DEFINED};
 51 
enum {FILENAME, DLL_HANDLE, R_OBJECT, NOT_DEFINED};
51 
typedef struct {
 52 
typedef struct {
52 
    char DLLname[PATH_MAX];
 53 
    char DLLname[PATH_MAX];
53 
    HINSTANCE dll;
 54 
    HINSTANCE dll;
Line 55... Line 56...
55 
    int type;
 56 
    int type;
56 
} DllReference;
 57 
} DllReference;
57 
 
 58 
 
58 
 
 59 
 
59 
/* This looks up entry points in DLLs in a platform specific way. */
 60 
/* This looks up entry points in DLLs in a platform specific way. */
60 
#include <Rdynpriv.h>
 - 
 
61 
 
 - 
 
62 
#define MAX_ARGS 65
 61 
#define MAX_ARGS 65
63 
 
 62 
 
64 
static DL_FUNC
 63 
static DL_FUNC
65 
R_FindNativeSymbolFromDLL(char *name, DllReference *dll,
 64 
R_FindNativeSymbolFromDLL(char *name, DllReference *dll,
66 
			  R_RegisteredNativeSymbol *symbol);
 65 
			  R_RegisteredNativeSymbol *symbol);
Line 81... Line 80...
81 
checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun)
 80 
checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun)
82 
{
 81 
{
83 
    if (isValidString(op))
 82 
    if (isValidString(op))
84 
	return(0);
 83 
	return(0);
85 
 
 84 
 
- 
 
 85 
    else if((TYPEOF(op) == EXTPTRSXP &&
86 
    else if((TYPEOF(op) == EXTPTRSXP && R_ExternalPtrTag(op) == Rf_install("native symbol"))) {
 86 
	     R_ExternalPtrTag(op) == Rf_install("native symbol"))) {
87 
 
 - 
 
88 
	if((*fun = R_ExternalPtrAddr(op)) == NULL)
 87 
	if((*fun = R_ExternalPtrAddr(op)) == NULL)
89 
	    errorcall(call, "NULL value passed as symbol address.");
 88 
	    errorcall(call, "NULL value passed as symbol address.");
90 
	return(0);
 89 
	return(0);
91 
 
 - 
 
92 
    } else if(inherits(op, "NativeSymbolInfo")) {
 90 
    } else if(inherits(op, "NativeSymbolInfo"))
93 
 
 - 
 
94 
	return(checkValidSymbolId(VECTOR_ELT(op, 1), call, fun));
 91 
	return(checkValidSymbolId(VECTOR_ELT(op, 1), call, fun));
95 
 
 - 
 
96 
    }
 92 
    errorcall(call,
97 
 
 - 
 
98 
    errorcall(call, "function name must be a string (of length 1) or native symbol reference.");
 93 
	      "function name must be a string (of length 1) or native symbol reference.");
99 
    return(0);
 94 
    return(0);
100 
}
 95 
}
101 
 
 96 
 
102 
 
 97 
 
103 
/*
 98 
/*
Line 179... Line 174...
179 
*/
 174 
*/
180 
 
 175 
 
181 
static Rboolean
 176 
static Rboolean
182 
checkNativeType(int targetType, int actualType)
 177 
checkNativeType(int targetType, int actualType)
183 
{
 178 
{
184 
   if(targetType > 0) {
 179 
    if(targetType > 0) {
185 
      if(targetType == INTSXP || targetType == LGLSXP) {
 180 
	if(targetType == INTSXP || targetType == LGLSXP) {
186 
	  return(actualType == INTSXP || actualType == LGLSXP);
 181 
	    return(actualType == INTSXP || actualType == LGLSXP);
187 
      }
 182 
	}
188 
      return(targetType == actualType);
 183 
	return(targetType == actualType);
189 
   }
 184 
    }
190 
 
 185 
 
191 
  return(TRUE);
 186 
    return(TRUE);
192 
}
 187 
}
193 
 
 188 
 
194 
 
 189 
 
195 
 
 190 
 
196 
static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort,
 191 
static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort,
Line 223... Line 218...
223 
	if(success)
 218 
	if(success)
224 
	    return(ans);
 219 
	    return(ans);
225 
    }
 220 
    }
226 
 
 221 
 
227 
    if(checkNativeType(targetType, TYPEOF(s)) == FALSE) {
 222 
    if(checkNativeType(targetType, TYPEOF(s)) == FALSE) {
228 
     if(!dup) {
 223 
	if(!dup) {
229 
       error("explicit request not to duplicate arguments in call to %s, but argument %d is of the wrong type (%d != %d)",
 224 
	    error("explicit request not to duplicate arguments in call to %s, but argument %d is of the wrong type (%d != %d)",
230 
	     name, narg + 1, targetType, TYPEOF(s));
 225 
		  name, narg + 1, targetType, TYPEOF(s));
231 
     }
 226 
	}
232 
 
 227 
 
233 
     if(targetType != SINGLESXP)
 228 
	if(targetType != SINGLESXP)
234 
        s = coerceVector(s, targetType);
 229 
	    s = coerceVector(s, targetType);
235 
    }
 230 
    }
236 
 
 231 
 
237 
    switch(TYPEOF(s)) {
 232 
    switch(TYPEOF(s)) {
238 
    case LGLSXP:
 233 
    case LGLSXP:
239 
    case INTSXP:
 234 
    case INTSXP:
Line 431... Line 426...
431 
 
 426 
 
432 
 
 427 
 
433 
/* Foreign Function Interface.  This code allows a user to call C */
 428 
/* Foreign Function Interface.  This code allows a user to call C */
434 
/* or Fortran code which is either statically or dynamically linked. */
 429 
/* or Fortran code which is either statically or dynamically linked. */
435 
 
 430 
 
436 
/* NB: despite its name, this leaves NAOK and DUP arguments on the list */
 431 
/* NB: this leaves NAOK and DUP arguments on the list */
437 
 
 432 
 
438 
/* find NAOK and DUP, find and remove PACKAGE */
 433 
/* find NAOK and DUP, find and remove PACKAGE */
439 
static SEXP naokfind(SEXP args, int * len, int *naok, int *dup,
 434 
static SEXP naokfind(SEXP args, int * len, int *naok, int *dup,
440 
		     DllReference *dll)
 435 
		     DllReference *dll)
441 
{
 436 
{
Line 1372... Line 1367...
1372 
    }
 1367 
    }
1373 
 
 1368 
 
1374 
    if(inherits(dll->obj, "DLLInfo")) {
 1369 
    if(inherits(dll->obj, "DLLInfo")) {
1375 
	SEXP tmp;
 1370 
	SEXP tmp;
1376 
/*XXX*/
 1371 
/*XXX*/
1377 
DL_FUNC R_dlsym(DllInfo *info, char const *name,
 1372 
	DL_FUNC R_dlsym(DllInfo *info, char const *name,
1378 
		R_RegisteredNativeSymbol *symbol);
 1373 
			R_RegisteredNativeSymbol *symbol);
1379 
	tmp = VECTOR_ELT(dll->obj, 4);
 1374 
	tmp = VECTOR_ELT(dll->obj, 4);
1380 
	info = (DllInfo *) R_ExternalPtrAddr(tmp);
 1375 
	info = (DllInfo *) R_ExternalPtrAddr(tmp);
1381 
	if(!info)
 1376 
	if(!info)
1382 
	    error("NULL value for DLLInfoReference when looking for DLL");
 1377 
	    error("NULL value for DLLInfoReference when looking for DLL");
1383 
	fun = R_dlsym(info, name, symbol);
 1378 
	fun = R_dlsym(info, name, symbol);