The R Project SVN R

Rev

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

Rev 36820 Rev 36902
Line 87... Line 87...
87 
   c) or a NativeSymbolInfo itself  (e.g. getNativeSymbolInfo("foo"))
 87 
   c) or a NativeSymbolInfo itself  (e.g. getNativeSymbolInfo("foo"))
88 
 
 88 
 
89 
   NB: in the last two cases it sets fun as well!
 89 
   NB: in the last two cases it sets fun as well!
90 
 */
 90 
 */
91 
static void
 91 
static void
92 
checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun)
 92 
checkValidSymbolId(SEXP op, SEXP call, DL_FUNC *fun, R_RegisteredNativeSymbol *symbol, char *buf)
93 
{
 93 
{
94 
    if (isValidString(op)) return;
 94 
    if (isValidString(op)) return;
95 
 
 95 
 
- 
 
 96 
    *fun = NULL;
96 
    else if((TYPEOF(op) == EXTPTRSXP &&
97 
    if(TYPEOF(op) == EXTPTRSXP) {
- 
 
 98 
	char *q, *p = NULL;
97 
	     R_ExternalPtrTag(op) == Rf_install("native symbol"))) {
 99 
	if(R_ExternalPtrTag(op) == Rf_install("native symbol"))
- 
 
 100 
   	   *fun = (DL_FUNC) R_ExternalPtrAddr(op);
- 
 
 101 
	else if(R_ExternalPtrTag(op) == Rf_install("registered native symbol")) {
- 
 
 102 
   	   R_RegisteredNativeSymbol *tmp;
- 
 
 103 
	   tmp = (R_RegisteredNativeSymbol *) R_ExternalPtrAddr(op);
- 
 
 104 
	   if(tmp) {
- 
 
 105 
  	      if(symbol->type != R_ANY_SYM && symbol->type != tmp->type)
- 
 
 106 
 	         errorcall(call, _("NULL value passed as symbol address"));
- 
 
 107 
   	        /* Check the type of the symbol. */
- 
 
 108 
   	      switch(symbol->type) {
- 
 
 109 
	      case R_C_SYM:
- 
 
 110 
  	          *fun = tmp->symbol.c->fun;
- 
 
 111 
  	          p = tmp->symbol.c->name;
- 
 
 112 
		  break;
- 
 
 113 
	      case R_CALL_SYM:
- 
 
 114 
  	          *fun = tmp->symbol.call->fun;
- 
 
 115 
  	          p = tmp->symbol.call->name;
- 
 
 116 
		  break;
- 
 
 117 
	      case R_FORTRAN_SYM:
- 
 
 118 
  	          *fun = tmp->symbol.fortran->fun;
- 
 
 119 
  	          p = tmp->symbol.fortran->name;
- 
 
 120 
		  break;
- 
 
 121 
	      case R_EXTERNAL_SYM:
- 
 
 122 
  	          *fun = tmp->symbol.external->fun;
- 
 
 123 
  	          p = tmp->symbol.external->name;
- 
 
 124 
		  break;
- 
 
 125 
	      default:
- 
 
 126 
  	         /* Something unintended has happened if we get here. */
- 
 
 127 
	          error(_("Unimplemented type %d in createRSymbolObject"),
- 
 
 128 
		         symbol->type);
- 
 
 129 
  	          break;
- 
 
 130 
	      }
- 
 
 131 
	      *symbol = *tmp;
- 
 
 132 
	   }
- 
 
 133 
	}
98 
	/* This is illegal C */
 134 
	/* This is illegal C */
99 
	if((*fun = R_ExternalPtrAddr(op)) == NULL)
 135 
	if(*fun == NULL)
100 
	    errorcall(call, _("NULL value passed as symbol address"));
 136 
	    errorcall(call, _("NULL value passed as symbol address"));
- 
 
 137 
 
- 
 
 138 
        /* copy the symbol name. */
- 
 
 139 
	if (p) {
- 
 
 140 
	    q = buf;
- 
 
 141 
	    while ((*q = *p) != '\0') {
- 
 
 142 
	        p++;
- 
 
 143 
	        q++;
- 
 
 144 
	    }
- 
 
 145 
	}
- 
 
 146 
 
101 
	return;
 147 
	return;
102 
    }
148 
    }
103 
    else if(inherits(op, "NativeSymbolInfo")) {
 149 
    else if(inherits(op, "NativeSymbolInfo")) {
104 
	checkValidSymbolId(VECTOR_ELT(op, 1), call, fun);
 150 
	checkValidSymbolId(VECTOR_ELT(op, 1), call, fun, symbol, buf);
105 
	return;
 151 
	return;
106 
    }
 152 
    }
107
153
108 
    errorcall(call,
 154 
    errorcall(call,
109 
      _("'name' must be a string (of length 1) or native symbol reference"));
 155 
      _("'name' must be a string (of length 1) or native symbol reference"));
Line 128... Line 174...
128 
    SEXP op;
 174 
    SEXP op;
129 
    char *p, *q;
 175 
    char *p, *q;
130 
    DllReference dll = {"", NULL, NULL, NOT_DEFINED};
 176 
    DllReference dll = {"", NULL, NULL, NOT_DEFINED};
131 
 
 177 
 
132 
    op = CAR(args);
 178 
    op = CAR(args);
- 
 
 179 
    /* NB, this sets fun, symbol and buf and is not just a check! */
133 
    checkValidSymbolId(op, call, fun); /* NB, might set fun,
180 
    checkValidSymbolId(op, call, fun, symbol, buf);
134 
					  not just a check! */
 - 
 
135 
 
 181 
 
136 
    /* The following code modifies the argument list */
 182 
    /* The following code modifies the argument list */
137 
    /* We know this is ok because do_dotCode is entered */
 183 
    /* We know this is ok because do_dotCode is entered */
138 
    /* with its arguments evaluated. */
 184 
    /* with its arguments evaluated. */
139 
 
 185 
 
Line 1618... Line 1664...
1618 
 
 1664 
 
1619 
    args = enctrim(args, encname, 100);
 1665 
    args = enctrim(args, encname, 100);
1620 
    args = resolveNativeRoutine(args, &fun, &symbol, symName, &nargs,
 1666 
    args = resolveNativeRoutine(args, &fun, &symbol, symName, &nargs,
1621 
				&naok, &dup, call);
 1667 
				&naok, &dup, call);
1622 
 
 1668 
 
- 
 
 1669 
 
1623 
    if(symbol.symbol.c && symbol.symbol.c->numArgs > -1) {
 1670 
    if(symbol.symbol.c && symbol.symbol.c->numArgs > -1) {
1624 
	if(symbol.symbol.c->numArgs != nargs)
 1671 
	if(symbol.symbol.c->numArgs != nargs)
1625 
	    error(_("Incorrect number of arguments (%d), expecting %d for %s"),
 1672 
	    error(_("Incorrect number of arguments (%d), expecting %d for %s"),
1626 
		  nargs, symbol.symbol.c->numArgs, symName);
 1673 
		  nargs, symbol.symbol.c->numArgs, symName);
1627 
 
 1674