The R Project SVN R

Rev

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

Rev 41894 Rev 41901
Line 64... Line 64...
64 
    HINSTANCE dll;
 64 
    HINSTANCE dll;
65 
    SEXP  obj;
 65 
    SEXP  obj;
66 
    int type;
 66 
    int type;
67 
} DllReference;
 67 
} DllReference;
68 
 
 68 
 
- 
 
 69 
/* Maximum length of entry-point name, including nul terminator */
- 
 
 70 
#define MaxSymbolBytes 128
- 
 
 71 
 
69 
/* This looks up entry points in DLLs in a platform specific way. */
 72 
/* This looks up entry points in DLLs in a platform specific way. */
70 
#define MAX_ARGS 65
 73 
#define MAX_ARGS 65
71 
 
 74 
 
72 
static DL_FUNC
 75 
static DL_FUNC
73 
R_FindNativeSymbolFromDLL(char *name, DllReference *dll,
 76 
R_FindNativeSymbolFromDLL(char *name, DllReference *dll,
Line 87... Line 90...
87 
   c) or a NativeSymbolInfo itself  (e.g. getNativeSymbolInfo("foo"))
 90 
   c) or a NativeSymbolInfo itself  (e.g. getNativeSymbolInfo("foo"))
88 
 
 91 
 
89 
   NB: in the last two cases it sets fun as well!
 92 
   NB: in the last two cases it sets fun as well!
90 
 */
 93 
 */
91 
static void
 94 
static void
92 
checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun, R_RegisteredNativeSymbol *symbol, char *buf)
 95 
checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun,
- 
 
 96 
		   R_RegisteredNativeSymbol *symbol, char *buf)
93 
{
 97 
{
94 
    if (isValidString(op)) return;
 98 
    if (isValidString(op)) return;
95 
 
 99 
 
96 
    *fun = NULL;
 100 
    *fun = NULL;
97 
    if(TYPEOF(op) == EXTPTRSXP) {
 101 
    if(TYPEOF(op) == EXTPTRSXP) {
98 
	char *q, *p = NULL;
 102 
	char *p = NULL;
99 
	if(R_ExternalPtrTag(op) == Rf_install("native symbol"))
103 
	if(R_ExternalPtrTag(op) == Rf_install("native symbol"))
100 
   	   *fun = (DL_FUNC) R_ExternalPtrAddr(op);
 104 
   	   *fun = (DL_FUNC) R_ExternalPtrAddr(op);
101 
	else if(R_ExternalPtrTag(op) == Rf_install("registered native symbol")) {
 105 
	else if(R_ExternalPtrTag(op) == Rf_install("registered native symbol")) {
102 
   	   R_RegisteredNativeSymbol *tmp;
 106 
   	   R_RegisteredNativeSymbol *tmp;
103 
	   tmp = (R_RegisteredNativeSymbol *) R_ExternalPtrAddr(op);
 107 
	   tmp = (R_RegisteredNativeSymbol *) R_ExternalPtrAddr(op);
Line 135... Line 139...
135 
	if(*fun == NULL)
 139 
	if(*fun == NULL)
136 
	    errorcall(call, _("NULL value passed as symbol address"));
 140 
	    errorcall(call, _("NULL value passed as symbol address"));
137 
 
 141 
 
138 
        /* copy the symbol name. */
 142 
        /* copy the symbol name. */
139 
	if (p) {
 143 
	if (p) {
- 
 
 144 
	    if (strlen(p) >= MaxSymbolBytes)
- 
 
 145 
		error(_("symbol '%s' is too long"), p);
- 
 
 146 
	    memcpy(buf, p, strlen(p)+1);
- 
 
 147 
	    /* Ouch, no length check
140 
	    q = buf;
 148 
	    q = buf;
141 
	    while ((*q = *p) != '\0') {
 149 
	    while ((*q = *p) != '\0') {
142 
	        p++;
 150 
	        p++;
143 
	        q++;
 151 
	        q++;
144 
	    }
 152 
	    } */
145 
	}
 153 
	}
146 
 
 154 
 
147 
	return;
 155 
	return;
148 
    }
156 
    }
149 
    else if(inherits(op, "NativeSymbolInfo")) {
 157 
    else if(inherits(op, "NativeSymbolInfo")) {
Line 164... Line 172...
164 
  of the cases where we are given a NativeSymbolInfo object, an
 172 
  of the cases where we are given a NativeSymbolInfo object, an
165 
  address directly, and if the DLL is specified. If no PACKAGE is
 173 
  address directly, and if the DLL is specified. If no PACKAGE is
166 
  provided, we check whether the calling function is in a namespace
 174 
  provided, we check whether the calling function is in a namespace
167 
  and look there.
 175 
  and look there.
168 
*/
 176 
*/
- 
 
 177 
 
169 
static SEXP
 178 
static SEXP
170 
resolveNativeRoutine(SEXP args, DL_FUNC *fun,
 179 
resolveNativeRoutine(SEXP args, DL_FUNC *fun,
171 
		     R_RegisteredNativeSymbol *symbol, char *buf,
 180 
		     R_RegisteredNativeSymbol *symbol, char *buf,
172 
		     int *nargs, int *naok, int *dup, SEXP call)
 181 
		     int *nargs, int *naok, int *dup, SEXP call)
173 
{
 182 
{
Line 200... Line 209...
200 
 
 209 
 
201 
    /* Make up the load symbol and look it up. */
 210 
    /* Make up the load symbol and look it up. */
202 
 
 211 
 
203 
    if(TYPEOF(op) == STRSXP) {
 212 
    if(TYPEOF(op) == STRSXP) {
204 
	p = translateChar(STRING_ELT(op, 0));
 213 
	p = translateChar(STRING_ELT(op, 0));
- 
 
 214 
	if(strlen(p) >= MaxSymbolBytes)
- 
 
 215 
	    error(_("symbol '%s' is too long"), p);
205 
	q = buf;
 216 
	q = buf;
206 
	while ((*q = *p) != '\0') {
 217 
	while ((*q = *p) != '\0') {
207 
	    if(symbol->type == R_FORTRAN_SYM) *q = tolower(*q);
 218 
	    if(symbol->type == R_FORTRAN_SYM) *q = tolower(*q);
208 
	    p++;
 219 
	    p++;
209 
	    q++;
 220 
	    q++;
Line 775... Line 786...
775 
{
 786 
{
776 
    DL_FUNC ofun = NULL;
 787 
    DL_FUNC ofun = NULL;
777 
    R_ExternalRoutine fun = NULL;
 788 
    R_ExternalRoutine fun = NULL;
778 
    SEXP retval;
 789 
    SEXP retval;
779 
    R_RegisteredNativeSymbol symbol = {R_EXTERNAL_SYM, {NULL}, NULL};
 790 
    R_RegisteredNativeSymbol symbol = {R_EXTERNAL_SYM, {NULL}, NULL};
780 
    /* I don't like this messing with vmax <TSL> */
 791 
    void *vmax = vmaxget();
781 
    /* But it is needed for clearing R_alloc and to be like .Call <BDR>*/
 - 
 
782 
    char *vmax = vmaxget(), buf[128];
 792 
    char buf[MaxSymbolBytes];
783 
 
 793 
 
784 
    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,
 794 
    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,
785 
				NULL, call);
 795 
				NULL, call);
786 
    fun = (R_ExternalRoutine) ofun;
 796 
    fun = (R_ExternalRoutine) ofun;
787 
 
 797 
 
Line 818... Line 828...
818 
    DL_FUNC ofun = NULL;
 828 
    DL_FUNC ofun = NULL;
819 
    VarFun fun = NULL;
 829 
    VarFun fun = NULL;
820 
    SEXP retval, nm, cargs[MAX_ARGS], pargs;
 830 
    SEXP retval, nm, cargs[MAX_ARGS], pargs;
821 
    R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};
 831 
    R_RegisteredNativeSymbol symbol = {R_CALL_SYM, {NULL}, NULL};
822 
    int nargs;
 832 
    int nargs;
823 
    char *vmax = vmaxget();
 833 
    void *vmax = vmaxget();
824 
    char buf[128];
 834 
    char buf[MaxSymbolBytes];
825 
 
 835 
 
826 
    nm = CAR(args);
 836 
    nm = CAR(args);
827 
    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,
 837 
    args = resolveNativeRoutine(args, &ofun, &symbol, buf, NULL, NULL,
828 
				NULL, call);
 838 
				NULL, call);
829 
    args = CDR(args);
 839 
    args = CDR(args);
Line 1638... Line 1648...
1638 
    /* the post-call converters back to R objects. */
 1648 
    /* the post-call converters back to R objects. */
1639 
    R_toCConverter  *argConverters[65];
 1649 
    R_toCConverter  *argConverters[65];
1640 
    R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};
 1650 
    R_RegisteredNativeSymbol symbol = {R_C_SYM, {NULL}, NULL};
1641 
    R_NativePrimitiveArgType *checkTypes = NULL;
 1651 
    R_NativePrimitiveArgType *checkTypes = NULL;
1642 
    R_NativeArgStyle *argStyles = NULL;
 1652 
    R_NativeArgStyle *argStyles = NULL;
- 
 
 1653 
    void *vmax;
1643 
    char *vmax, symName[128], encname[101];
 1654 
    char symName[MaxSymbolBytes], encname[101];
1644 
 
 - 
 
1645 
 
 - 
 
1646 
 
 1655 
 
1647 
    if (NaokSymbol == NULL || DupSymbol == NULL || PkgSymbol == NULL) {
 1656 
    if (NaokSymbol == NULL || DupSymbol == NULL || PkgSymbol == NULL) {
1648 
	NaokSymbol = install("NAOK");
 1657 
	NaokSymbol = install("NAOK");
1649 
	DupSymbol = install("DUP");
 1658 
	DupSymbol = install("DUP");
1650 
	PkgSymbol = install("PACKAGE");
 1659 
	PkgSymbol = install("PACKAGE");