The R Project SVN – R – Diff – /branches/R-classInheritance/src/main/dotcode.c



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

    if (isValidString(op)) return;
 
    *fun = NULL;
    if(TYPEOF(op) == EXTPTRSXP) {
	char *p = NULL;
	if(R_ExternalPtrTag(op) == Rf_install("native symbol"))
	   *fun = R_ExternalPtrAddrFn(op);
	else if(R_ExternalPtrTag(op) == Rf_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 */
}
 

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

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

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

    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:

	} else {
	    cptr = (char**)R_alloc(n, sizeof(char*));
	    if(strlen(encname)) {
#ifdef HAVE_ICONV
		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++) {

		    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
#else
		warning(_("re-encoding is not supported on this system"));
	    }
#endif
	    {

	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;

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

	} else {
	    PROTECT(s = allocVector(type, n));
	    cptr = (char**)p;
	    if(strlen(encname)) {
#ifdef HAVE_ICONV
		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);

		    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
#else
		warning(_("re-encoding is not supported on this system"));
	    }
#endif
	    {

		   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;

				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)

    Rboolean record = dd->recordGraphics;
    dd->recordGraphics = FALSE;
    PROTECT(retval = do_External(call, op, args, env));
    /*
     * If there is an error or user-interrupt in the above
     * evaluation, dd->recordGraphics is set to TRUE
     * on all graphics devices (see GEonExit(); called in errors.c)
     */
    dd->recordGraphics = record;
    if (GErecording(call, dd)) {
	if (!GEcheckState(dd))

    Rboolean record = dd->recordGraphics;
    dd->recordGraphics = FALSE;
    PROTECT(retval = do_dotcall(call, op, args, env));
    /*
     * If there is an error or user-interrupt in the above
     * evaluation, dd->recordGraphics is set to TRUE
     * on all graphics devices (see GEonExit(); called in errors.c)
     */
    dd->recordGraphics = record;
    if (GErecording(call, dd)) {
	if (!GEcheckState(dd))

    /* once below on the way out. */
    cargs = (void**)R_alloc(nargs, sizeof(void*));
    nargs = 0;
    for(pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
#ifdef THROW_REGISTRATION_TYPE_ERROR
	if(checkTypes &&
	   !comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {
	    /* We can loop over all the arguments and report all the
	       erroneous ones, but then we would also want to avoid
	       the conversions.  Also, in the future, we may just
	       attempt to coerce the value to the appropriate
	       type. This is why we pass the checkTypes[nargs] value
	       to RObjToCPtr(). We just have to sort out the ability
	       to return the correct value which is complicated by
	       dup, etc. */
	    errorcall(call, _("Wrong type for argument %d in call to %s"),
		      nargs+1, symName);
	}
#endif
	cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,

	info.nargs = nargs;
	info.functionName = symName;
	nargs = 0;
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
	    if(argStyles && argStyles[nargs] == R_ARG_IN) {
		PROTECT(s = R_NilValue);
	    } else if(argConverters[nargs]) {
		if(argConverters[nargs]->reverse) {
		    info.argIndex = nargs;
		    s = argConverters[nargs]->reverse(cargs[nargs], CAR(pargs),
						      &info,
						      argConverters[nargs]);
		} else

#if R_MEMORY_PROFILING
		if (TRACE(CAR(pargs)) && dup){
			memtrace_report(cargs[nargs], s);
			SET_TRACE(s, 1);
		}
#endif
		DUPLICATE_ATTRIB(s, CAR(pargs));
	    }
	    if (TAG(pargs) != R_NilValue)
		havenames = 1;
	    SET_VECTOR_ELT(ans, nargs, s);

	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
	    if (TAG(pargs) == R_NilValue)
		SET_STRING_ELT(names, nargs++, R_BlankString);
	    else
		SET_STRING_ELT(names, nargs++, PRINTNAME(TAG(pargs)));
	}
	setAttrib(ans, R_NamesSymbol, names);
	UNPROTECT(1);
    }
    UNPROTECT(1);
    vmaxset(vmax);

	    n = lengths[i];
	    SETCAR(pcall, allocVector(STRSXP, n));
	    for (j = 0 ; j < n ; j++) {
		char *str = (char*)(arguments[i]);
		SET_STRING_ELT(CAR(pcall), i, mkChar(str));
	    }
	    break;
	    /* FIXME : This copy is unnecessary! */
	    /* FIXME : This is obviously incorrect so disable
	case VECSXP:
	    n = lengths[i];

Rev 45209	Rev 45446
Line 52...	Line 52...
52	`static SEXP NaokSymbol = NULL;`	52	`static SEXP NaokSymbol = NULL;`
53	`static SEXP DupSymbol = NULL;`	53	`static SEXP DupSymbol = NULL;`
54	`static SEXP PkgSymbol = NULL;`	54	`static SEXP PkgSymbol = NULL;`
55	`static SEXP EncSymbol = NULL;`	55	`static SEXP EncSymbol = NULL;`
56		56
57	`/* Global variable that should go. Should actually be doing this in`	57	`/* Global variable that should go. Should actually be doing this in`
58	`a much more straightforward manner. */`	58	`a much more straightforward manner. */`
59	`#include <Rdynpriv.h>`	59	`#include <Rdynpriv.h>`
60	`enum {FILENAME, DLL_HANDLE, R_OBJECT, NOT_DEFINED};`	60	`enum {FILENAME, DLL_HANDLE, R_OBJECT, NOT_DEFINED};`
61	`typedef struct {`	61	`typedef struct {`
62	`char DLLname[PATH_MAX];`	62	`char DLLname[PATH_MAX];`
Line 97...	Line 97...
97	`if (isValidString(op)) return;`	97	`if (isValidString(op)) return;`
98		98
99	`*fun = NULL;`	99	`*fun = NULL;`
100	`if(TYPEOF(op) == EXTPTRSXP) {`	100	`if(TYPEOF(op) == EXTPTRSXP) {`
101	`char *p = NULL;`	101	`char *p = NULL;`
102	`if(R_ExternalPtrTag(op) == Rf_install("native symbol"))`	102	`if(R_ExternalPtrTag(op) == Rf_install("native symbol"))`
103	`*fun = R_ExternalPtrAddrFn(op);`	103	`*fun = R_ExternalPtrAddrFn(op);`
104	`else if(R_ExternalPtrTag(op) == Rf_install("registered native symbol")) {`	104	`else if(R_ExternalPtrTag(op) == Rf_install("registered native symbol")) {`
105	`R_RegisteredNativeSymbol *tmp;`	105	`R_RegisteredNativeSymbol *tmp;`
106	`tmp = (R_RegisteredNativeSymbol *) R_ExternalPtrAddr(op);`	106	`tmp = (R_RegisteredNativeSymbol *) R_ExternalPtrAddr(op);`
107	`if(tmp) {`	107	`if(tmp) {`
108	`if(symbol->type != R_ANY_SYM && symbol->type != tmp->type)`	108	`if(symbol->type != R_ANY_SYM && symbol->type != tmp->type)`
109	`errorcall(call, _("NULL value passed as symbol address"));`	109	`errorcall(call, _("NULL value passed as symbol address"));`
110	`/* Check the type of the symbol. */`	110	`/* Check the type of the symbol. */`
111	`switch(symbol->type) {`	111	`switch(symbol->type) {`
112	`case R_C_SYM:`	112	`case R_C_SYM:`
113	`*fun = tmp->symbol.c->fun;`	113	`*fun = tmp->symbol.c->fun;`
114	`p = tmp->symbol.c->name;`	114	`p = tmp->symbol.c->name;`
115	`break;`	115	`break;`
116	`case R_CALL_SYM:`	116	`case R_CALL_SYM:`
117	`*fun = tmp->symbol.call->fun;`	117	`*fun = tmp->symbol.call->fun;`
118	`p = tmp->symbol.call->name;`	118	`p = tmp->symbol.call->name;`
119	`break;`	119	`break;`
120	`case R_FORTRAN_SYM:`	120	`case R_FORTRAN_SYM:`
121	`*fun = tmp->symbol.fortran->fun;`	121	`*fun = tmp->symbol.fortran->fun;`
122	`p = tmp->symbol.fortran->name;`	122	`p = tmp->symbol.fortran->name;`
123	`break;`	123	`break;`
124	`case R_EXTERNAL_SYM:`	124	`case R_EXTERNAL_SYM:`
125	`*fun = tmp->symbol.external->fun;`	125	`*fun = tmp->symbol.external->fun;`
126	`p = tmp->symbol.external->name;`	126	`p = tmp->symbol.external->name;`
127	`break;`	127	`break;`
128	`default:`	128	`default:`
129	`/* Something unintended has happened if we get here. */`	129	`/* Something unintended has happened if we get here. */`
130	`errorcall(call, _("Unimplemented type %d in createRSymbolObject"),`	130	`errorcall(call, _("Unimplemented type %d in createRSymbolObject"),`
131	`symbol->type);`	131	`symbol->type);`
132	`break;`	132	`break;`
133	`}`	133	`}`
134	`symbol = tmp;`	134	`symbol = tmp;`
135	`}`	135	`}`
136	`}`	136	`}`
137	`/* This is illegal C */`	137	`/* This is illegal C */`
138	`if(*fun == NULL)`	138	`if(*fun == NULL)`
139	`errorcall(call, _("NULL value passed as symbol address"));`	139	`errorcall(call, _("NULL value passed as symbol address"));`
140		140
141	`/* copy the symbol name. */`	141	`/* copy the symbol name. */`
142	`if (p) {`	142	`if (p) {`
143	`if (strlen(p) >= MaxSymbolBytes)`	143	`if (strlen(p) >= MaxSymbolBytes)`
144	`error(_("symbol '%s' is too long"), p);`	144	`error(_("symbol '%s' is too long"), p);`
145	`memcpy(buf, p, strlen(p)+1);`	145	`memcpy(buf, p, strlen(p)+1);`
146	`/* Ouch, no length check`	146	`/* Ouch, no length check`
147	`q = buf;`	147	`q = buf;`
148	`while ((q = p) != '\0') {`	148	`while ((q = p) != '\0') {`
149	`p++;`	149	`p++;`
150	`q++;`	150	`q++;`
151	`} */`	151	`} */`
152	`}`	152	`}`
153		153
154	`return;`	154	`return;`
155	`}`	155	`}`
156	`else if(inherits(op, "NativeSymbolInfo")) {`	156	`else if(inherits(op, "NativeSymbolInfo")) {`
157	`checkValidSymbolId(VECTOR_ELT(op, 1), call, fun, symbol, buf);`	157	`checkValidSymbolId(VECTOR_ELT(op, 1), call, fun, symbol, buf);`
158	`return;`	158	`return;`
159	`}`	159	`}`
160		160
161	`errorcall(call,`	161	`errorcall(call,`
162	`_("'name' must be a string (of length 1) or native symbol reference"));`	162	`_("'name' must be a string (of length 1) or native symbol reference"));`
163	`return; /* not reached */`	163	`return; /* not reached */`
164	`}`	164	`}`
165		165
Line 183...	Line 183...
183	`const char p; char q;`	183	`const char p; char q;`
184	`DllReference dll = {"", NULL, NULL, NOT_DEFINED};`	184	`DllReference dll = {"", NULL, NULL, NOT_DEFINED};`
185		185
186	`op = CAR(args);`	186	`op = CAR(args);`
187	`/* NB, this sets fun, symbol and buf and is not just a check! */`	187	`/* NB, this sets fun, symbol and buf and is not just a check! */`
188	`checkValidSymbolId(op, call, fun, symbol, buf);`	188	`checkValidSymbolId(op, call, fun, symbol, buf);`
189		189
190	`/* The following code modifies the argument list */`	190	`/* The following code modifies the argument list */`
191	`/* We know this is ok because do_dotCode is entered */`	191	`/* We know this is ok because do_dotCode is entered */`
192	`/* with its arguments evaluated. */`	192	`/* with its arguments evaluated. */`
193		193
Line 217...	Line 217...
217	`if(symbol->type == R_FORTRAN_SYM) q = tolower(q);`	217	`if(symbol->type == R_FORTRAN_SYM) q = tolower(q);`
218	`p++;`	218	`p++;`
219	`q++;`	219	`q++;`
220	`}`	220	`}`
221	`}`	221	`}`
222		222
223	`if(!*fun) {`	223	`if(!*fun) {`
224	`if(dll.type != FILENAME) {`	224	`if(dll.type != FILENAME) {`
225	`/* no PACKAGE= arg, so see if we can identify a DLL`	225	`/* no PACKAGE= arg, so see if we can identify a DLL`
226	`from the namespace defining the function */`	226	`from the namespace defining the function */`
227	`*fun = R_FindNativeSymbolFromDLL(buf, &dll, symbol);`	227	`*fun = R_FindNativeSymbolFromDLL(buf, &dll, symbol);`
228	`/* need to continue if there is no PACKAGE arg or if the`	228	`/* need to continue if there is no PACKAGE arg or if the`
229	`namespace search failed`	229	`namespace search failed`
230	`if(!fun)`	230	`if(!fun)`
231	`errorcall(call, _("cannot resolve native routine"));`	231	`errorcall(call, _("cannot resolve native routine"));`
232	`*/`	232	`*/`
233	`}`	233	`}`
234		234
235	`/* NB: the actual conversion to the symbol is done in`	235	`/* NB: the actual conversion to the symbol is done in`
236	`R_dlsym in Rdynload.c. That prepends an underscore (usually),`	236	`R_dlsym in Rdynload.c. That prepends an underscore (usually),`
Line 289...	Line 289...
289	`*converter = NULL;`	289	`*converter = NULL;`
290		290
291	`if(length(getAttrib(s, R_ClassSymbol))) {`	291	`if(length(getAttrib(s, R_ClassSymbol))) {`
292	`R_CConvertInfo info;`	292	`R_CConvertInfo info;`
293	`int success;`	293	`int success;`
294	`void *ans;`	294	`void *ans;`
295		295
296	`info.naok = naok;`	296	`info.naok = naok;`
297	`info.dup = dup;`	297	`info.dup = dup;`
298	`info.narg = narg;`	298	`info.narg = narg;`
299	`info.Fort = Fort;`	299	`info.Fort = Fort;`
300	`info.name = name;`	300	`info.name = name;`
301		301
302	`ans = Rf_convertToC(s, &info, &success, converter);`	302	`ans = Rf_convertToC(s, &info, &success, converter);`
303	`if(success)`	303	`if(success)`
304	`return(ans);`	304	`return(ans);`
305	`}`	305	`}`
Line 317...	Line 317...
317	`switch(TYPEOF(s)) {`	317	`switch(TYPEOF(s)) {`
318	`case RAWSXP:`	318	`case RAWSXP:`
319	`n = LENGTH(s);`	319	`n = LENGTH(s);`
320	`rawptr = RAW(s);`	320	`rawptr = RAW(s);`
321	`if (dup) {`	321	`if (dup) {`
322	`rawptr = (Rbyte *) R_alloc(n, sizeof(Rbyte));`	322	`rawptr = (Rbyte *) R_alloc(n, sizeof(Rbyte));`
323	`for (i = 0; i < n; i++)`	323	`for (i = 0; i < n; i++)`
324	`rawptr[i] = RAW(s)[i];`	324	`rawptr[i] = RAW(s)[i];`
325	`}`	325	`}`
326	`return (void *) rawptr;`	326	`return (void *) rawptr;`
327	`break;`	327	`break;`
328	`case LGLSXP:`	328	`case LGLSXP:`
329	`case INTSXP:`	329	`case INTSXP:`
Line 392...	Line 392...
392	`} else {`	392	`} else {`
393	`cptr = (char*)R_alloc(n, sizeof(char));`	393	`cptr = (char*)R_alloc(n, sizeof(char));`
394	`if(strlen(encname)) {`	394	`if(strlen(encname)) {`
395	`#ifdef HAVE_ICONV`	395	`#ifdef HAVE_ICONV`
396	`char *outbuf;`	396	`char *outbuf;`
397	`const char *inbuf;`	397	`const char *inbuf;`
398	`size_t inb, outb, outb0, res;`	398	`size_t inb, outb, outb0, res;`
399	`void obj = Riconv_open("", encname); / (to, from) */`	399	`void obj = Riconv_open("", encname); / (to, from) */`
400	`if(obj == (void *)-1)`	400	`if(obj == (void *)-1)`
401	`error(_("unsupported encoding '%s'"), encname);`	401	`error(_("unsupported encoding '%s'"), encname);`
402	`for (i = 0 ; i < n ; i++) {`	402	`for (i = 0 ; i < n ; i++) {`
Line 410...	Line 410...
410	`res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);`	410	`res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);`
411	`if(res == -1 && errno == E2BIG) {`	411	`if(res == -1 && errno == E2BIG) {`
412	`outb0 *= 3;`	412	`outb0 *= 3;`
413	`goto restart_in;`	413	`goto restart_in;`
414	`}`	414	`}`
415	`if(res == -1)`	415	`if(res == -1)`
416	`error(_("conversion problem in re-encoding to '%s'"),`	416	`error(_("conversion problem in re-encoding to '%s'"),`
417	`encname);`	417	`encname);`
418	`*outbuf = '\0';`	418	`*outbuf = '\0';`
419	`}`	419	`}`
420	`Riconv_close(obj);`	420	`Riconv_close(obj);`
421	`} else`	421	`} else`
422	`#else`	422	`#else`
423	`warning(_("re-encoding is not supported on this system"));`	423	`warning(_("re-encoding is not supported on this system"));`
424	`}`	424	`}`
425	`#endif`	425	`#endif`
426	`{`	426	`{`
Line 436...	Line 436...
436	`break;`	436	`break;`
437	`case VECSXP:`	437	`case VECSXP:`
438	`if(!dup)`	438	`if(!dup)`
439	`error(_("lists must be duplicated in .C"));`	439	`error(_("lists must be duplicated in .C"));`
440	`/* if (!dup) return (void)VECTOR_PTR(s); **** Dangerous to GC!!! */`	440	`/* if (!dup) return (void)VECTOR_PTR(s); **** Dangerous to GC!!! */`
441	`n = length(s);`	441	`n = length(s);`
442	`lptr = (SEXP*)R_alloc(n, sizeof(SEXP));`	442	`lptr = (SEXP*)R_alloc(n, sizeof(SEXP));`
443	`for (i = 0 ; i < n ; i++) {`	443	`for (i = 0 ; i < n ; i++) {`
444	`lptr[i] = VECTOR_ELT(s, i);`	444	`lptr[i] = VECTOR_ELT(s, i);`
445	`}`	445	`}`
446	`return (void*)lptr;`	446	`return (void*)lptr;`
447	`break;`	447	`break;`
448	`case LISTSXP:`	448	`case LISTSXP:`
449	`if(Fort) error(_("invalid mode to pass to Fortran (arg %d)"), narg);`	449	`if(Fort) error(_("invalid mode to pass to Fortran (arg %d)"), narg);`
450	`/* Warning : The following looks like it could bite ... */`	450	`/* Warning : The following looks like it could bite ... */`
451	`if(!dup) return (void*)s;`	451	`if(!dup) return (void*)s;`
Line 480...	Line 480...
480	`switch(type) {`	480	`switch(type) {`
481	`case RAWSXP:`	481	`case RAWSXP:`
482	`s = allocVector(type, n);`	482	`s = allocVector(type, n);`
483	`rawptr = (Rbyte *)p;`	483	`rawptr = (Rbyte *)p;`
484	`for (i = 0; i < n; i++)`	484	`for (i = 0; i < n; i++)`
485	`RAW(s)[i] = rawptr[i];`	485	`RAW(s)[i] = rawptr[i];`
486	`break;`	486	`break;`
487	`case LGLSXP:`	487	`case LGLSXP:`
488	`case INTSXP:`	488	`case INTSXP:`
489	`s = allocVector(type, n);`	489	`s = allocVector(type, n);`
490	`iptr = (int*)p;`	490	`iptr = (int*)p;`
491	`for(i=0 ; i<n ; i++)`	491	`for(i=0 ; i<n ; i++)`
492	`INTEGER(s)[i] = iptr[i];`	492	`INTEGER(s)[i] = iptr[i];`
493	`break;`	493	`break;`
494	`case REALSXP:`	494	`case REALSXP:`
495	`case SINGLESXP:`	495	`case SINGLESXP:`
496	`s = allocVector(REALSXP, n);`	496	`s = allocVector(REALSXP, n);`
497	`if(type == SINGLESXP \|\| asLogical(getAttrib(arg, CSingSymbol)) == 1) {`	497	`if(type == SINGLESXP \|\| asLogical(getAttrib(arg, CSingSymbol)) == 1) {`
Line 520...	Line 520...
520	`} else {`	520	`} else {`
521	`PROTECT(s = allocVector(type, n));`	521	`PROTECT(s = allocVector(type, n));`
522	`cptr = (char**)p;`	522	`cptr = (char**)p;`
523	`if(strlen(encname)) {`	523	`if(strlen(encname)) {`
524	`#ifdef HAVE_ICONV`	524	`#ifdef HAVE_ICONV`
525	`const char *inbuf;`	525	`const char *inbuf;`
526	`char outbuf, p;`	526	`char outbuf, p;`
527	`size_t inb, outb, outb0, res;`	527	`size_t inb, outb, outb0, res;`
528	`void obj = Riconv_open(encname, ""); / (to, from) */`	528	`void obj = Riconv_open(encname, ""); / (to, from) */`
529	`if(obj == (void *)(-1))`	529	`if(obj == (void *)(-1))`
530	`error(_("unsupported encoding '%s'"), encname);`	530	`error(_("unsupported encoding '%s'"), encname);`
Line 538...	Line 538...
538	`res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);`	538	`res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);`
539	`if(res == -1 && errno == E2BIG) {`	539	`if(res == -1 && errno == E2BIG) {`
540	`outb0 *= 3;`	540	`outb0 *= 3;`
541	`goto restart_out;`	541	`goto restart_out;`
542	`}`	542	`}`
543	`if(res == -1)`	543	`if(res == -1)`
544	`error(_("conversion problem in re-encoding from '%s'"),`	544	`error(_("conversion problem in re-encoding from '%s'"),`
545	`encname);`	545	`encname);`
546	`*outbuf = '\0';`	546	`*outbuf = '\0';`
547	`SET_STRING_ELT(s, i, mkChar(p));`	547	`SET_STRING_ELT(s, i, mkChar(p));`
548	`}`	548	`}`
549	`Riconv_close(obj);`	549	`Riconv_close(obj);`
550	`} else`	550	`} else`
551	`#else`	551	`#else`
552	`warning(_("re-encoding is not supported on this system"));`	552	`warning(_("re-encoding is not supported on this system"));`
553	`}`	553	`}`
554	`#endif`	554	`#endif`
555	`{`	555	`{`
Line 636...	Line 636...
636	`any additional arguments and not insist that PACKAGE`	636	`any additional arguments and not insist that PACKAGE`
637	`be the last argument.`	637	`be the last argument.`
638	`*/`	638	`*/`
639	`} else {`	639	`} else {`
640	`/* Have a DLL object*/`	640	`/* Have a DLL object*/`
641	`if(TYPEOF(CAR(s)) == EXTPTRSXP) {`	641	`if(TYPEOF(CAR(s)) == EXTPTRSXP) {`
642	`dll->dll = (HINSTANCE) R_ExternalPtrAddr(CAR(s));`	642	`dll->dll = (HINSTANCE) R_ExternalPtrAddr(CAR(s));`
643	`dll->type = DLL_HANDLE;`	643	`dll->type = DLL_HANDLE;`
644	`} else if(TYPEOF(CAR(s)) == VECSXP) {`	644	`} else if(TYPEOF(CAR(s)) == VECSXP) {`
645	`dll->type = R_OBJECT;`	645	`dll->type = R_OBJECT;`
646	`dll->obj = s;`	646	`dll->obj = s;`
Line 832...	Line 832...
832	`NULL, call);`	832	`NULL, call);`
833	`args = CDR(args);`	833	`args = CDR(args);`
834	`fun = (VarFun) ofun;`	834	`fun = (VarFun) ofun;`
835		835
836	`for(nargs = 0, pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {`	836	`for(nargs = 0, pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {`
837	`if (nargs == MAX_ARGS)`	837	`if (nargs == MAX_ARGS)`
838	`errorcall(call, _("too many arguments in foreign function call"));`	838	`errorcall(call, _("too many arguments in foreign function call"));`
839	`cargs[nargs] = CAR(pargs);`	839	`cargs[nargs] = CAR(pargs);`
840	`nargs++;`	840	`nargs++;`
841	`}`	841	`}`
842	`if(symbol.symbol.call && symbol.symbol.call->numArgs > -1) {`	842	`if(symbol.symbol.call && symbol.symbol.call->numArgs > -1) {`
843	`if(symbol.symbol.call->numArgs != nargs)`	843	`if(symbol.symbol.call->numArgs != nargs)`
Line 1517...	Line 1517...
1517	`Rboolean record = dd->recordGraphics;`	1517	`Rboolean record = dd->recordGraphics;`
1518	`dd->recordGraphics = FALSE;`	1518	`dd->recordGraphics = FALSE;`
1519	`PROTECT(retval = do_External(call, op, args, env));`	1519	`PROTECT(retval = do_External(call, op, args, env));`
1520	`/*`	1520	`/*`
1521	`* If there is an error or user-interrupt in the above`	1521	`* If there is an error or user-interrupt in the above`
1522	`* evaluation, dd->recordGraphics is set to TRUE`	1522	`* evaluation, dd->recordGraphics is set to TRUE`
1523	`* on all graphics devices (see GEonExit(); called in errors.c)`	1523	`* on all graphics devices (see GEonExit(); called in errors.c)`
1524	`*/`	1524	`*/`
1525	`dd->recordGraphics = record;`	1525	`dd->recordGraphics = record;`
1526	`if (GErecording(call, dd)) {`	1526	`if (GErecording(call, dd)) {`
1527	`if (!GEcheckState(dd))`	1527	`if (!GEcheckState(dd))`
Line 1539...	Line 1539...
1539	`Rboolean record = dd->recordGraphics;`	1539	`Rboolean record = dd->recordGraphics;`
1540	`dd->recordGraphics = FALSE;`	1540	`dd->recordGraphics = FALSE;`
1541	`PROTECT(retval = do_dotcall(call, op, args, env));`	1541	`PROTECT(retval = do_dotcall(call, op, args, env));`
1542	`/*`	1542	`/*`
1543	`* If there is an error or user-interrupt in the above`	1543	`* If there is an error or user-interrupt in the above`
1544	`* evaluation, dd->recordGraphics is set to TRUE`	1544	`* evaluation, dd->recordGraphics is set to TRUE`
1545	`* on all graphics devices (see GEonExit(); called in errors.c)`	1545	`* on all graphics devices (see GEonExit(); called in errors.c)`
1546	`*/`	1546	`*/`
1547	`dd->recordGraphics = record;`	1547	`dd->recordGraphics = record;`
1548	`if (GErecording(call, dd)) {`	1548	`if (GErecording(call, dd)) {`
1549	`if (!GEcheckState(dd))`	1549	`if (!GEcheckState(dd))`
Line 1681...	Line 1681...
1681	`/* once below on the way out. */`	1681	`/* once below on the way out. */`
1682	`cargs = (void*)R_alloc(nargs, sizeof(void));`	1682	`cargs = (void*)R_alloc(nargs, sizeof(void));`
1683	`nargs = 0;`	1683	`nargs = 0;`
1684	`for(pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {`	1684	`for(pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {`
1685	`#ifdef THROW_REGISTRATION_TYPE_ERROR`	1685	`#ifdef THROW_REGISTRATION_TYPE_ERROR`
1686	`if(checkTypes &&`	1686	`if(checkTypes &&`
1687	`!comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {`	1687	`!comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {`
1688	`/* We can loop over all the arguments and report all the`	1688	`/* We can loop over all the arguments and report all the`
1689	`erroneous ones, but then we would also want to avoid`	1689	`erroneous ones, but then we would also want to avoid`
1690	`the conversions. Also, in the future, we may just`	1690	`the conversions. Also, in the future, we may just`
1691	`attempt to coerce the value to the appropriate`	1691	`attempt to coerce the value to the appropriate`
1692	`type. This is why we pass the checkTypes[nargs] value`	1692	`type. This is why we pass the checkTypes[nargs] value`
1693	`to RObjToCPtr(). We just have to sort out the ability`	1693	`to RObjToCPtr(). We just have to sort out the ability`
1694	`to return the correct value which is complicated by`	1694	`to return the correct value which is complicated by`
1695	`dup, etc. */`	1695	`dup, etc. */`
1696	`errorcall(call, _("Wrong type for argument %d in call to %s"),`	1696	`errorcall(call, _("Wrong type for argument %d in call to %s"),`
1697	`nargs+1, symName);`	1697	`nargs+1, symName);`
1698	`}`	1698	`}`
1699	`#endif`	1699	`#endif`
1700	`cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,`	1700	`cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,`
Line 2312...	Line 2312...
2312	`info.nargs = nargs;`	2312	`info.nargs = nargs;`
2313	`info.functionName = symName;`	2313	`info.functionName = symName;`
2314	`nargs = 0;`	2314	`nargs = 0;`
2315	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`	2315	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`
2316	`if(argStyles && argStyles[nargs] == R_ARG_IN) {`	2316	`if(argStyles && argStyles[nargs] == R_ARG_IN) {`
2317	`PROTECT(s = R_NilValue);`	2317	`PROTECT(s = R_NilValue);`
2318	`} else if(argConverters[nargs]) {`	2318	`} else if(argConverters[nargs]) {`
2319	`if(argConverters[nargs]->reverse) {`	2319	`if(argConverters[nargs]->reverse) {`
2320	`info.argIndex = nargs;`	2320	`info.argIndex = nargs;`
2321	`s = argConverters[nargs]->reverse(cargs[nargs], CAR(pargs),`	2321	`s = argConverters[nargs]->reverse(cargs[nargs], CAR(pargs),`
2322	`&info,`	2322	`&info,`
2323	`argConverters[nargs]);`	2323	`argConverters[nargs]);`
2324	`} else`	2324	`} else`
Line 2331...	Line 2331...
2331	`#if R_MEMORY_PROFILING`	2331	`#if R_MEMORY_PROFILING`
2332	`if (TRACE(CAR(pargs)) && dup){`	2332	`if (TRACE(CAR(pargs)) && dup){`
2333	`memtrace_report(cargs[nargs], s);`	2333	`memtrace_report(cargs[nargs], s);`
2334	`SET_TRACE(s, 1);`	2334	`SET_TRACE(s, 1);`
2335	`}`	2335	`}`
2336	`#endif`	2336	`#endif`
2337	`DUPLICATE_ATTRIB(s, CAR(pargs));`	2337	`DUPLICATE_ATTRIB(s, CAR(pargs));`
2338	`}`	2338	`}`
2339	`if (TAG(pargs) != R_NilValue)`	2339	`if (TAG(pargs) != R_NilValue)`
2340	`havenames = 1;`	2340	`havenames = 1;`
2341	`SET_VECTOR_ELT(ans, nargs, s);`	2341	`SET_VECTOR_ELT(ans, nargs, s);`
Line 2359...	Line 2359...
2359	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`	2359	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`
2360	`if (TAG(pargs) == R_NilValue)`	2360	`if (TAG(pargs) == R_NilValue)`
2361	`SET_STRING_ELT(names, nargs++, R_BlankString);`	2361	`SET_STRING_ELT(names, nargs++, R_BlankString);`
2362	`else`	2362	`else`
2363	`SET_STRING_ELT(names, nargs++, PRINTNAME(TAG(pargs)));`	2363	`SET_STRING_ELT(names, nargs++, PRINTNAME(TAG(pargs)));`
2364	`}`	2364	`}`
2365	`setAttrib(ans, R_NamesSymbol, names);`	2365	`setAttrib(ans, R_NamesSymbol, names);`
2366	`UNPROTECT(1);`	2366	`UNPROTECT(1);`
2367	`}`	2367	`}`
2368	`UNPROTECT(1);`	2368	`UNPROTECT(1);`
2369	`vmaxset(vmax);`	2369	`vmaxset(vmax);`
Line 2440...	Line 2440...
2440	`n = lengths[i];`	2440	`n = lengths[i];`
2441	`SETCAR(pcall, allocVector(STRSXP, n));`	2441	`SETCAR(pcall, allocVector(STRSXP, n));`
2442	`for (j = 0 ; j < n ; j++) {`	2442	`for (j = 0 ; j < n ; j++) {`
2443	`char str = (char)(arguments[i]);`	2443	`char str = (char)(arguments[i]);`
2444	`SET_STRING_ELT(CAR(pcall), i, mkChar(str));`	2444	`SET_STRING_ELT(CAR(pcall), i, mkChar(str));`
2445	`}`	2445	`}`
2446	`break;`	2446	`break;`
2447	`/* FIXME : This copy is unnecessary! */`	2447	`/* FIXME : This copy is unnecessary! */`
2448	`/* FIXME : This is obviously incorrect so disable`	2448	`/* FIXME : This is obviously incorrect so disable`
2449	`case VECSXP:`	2449	`case VECSXP:`
2450	`n = lengths[i];`	2450	`n = lengths[i];`

The R Project SVN R

(root)/branches/R-classInheritance/src/main/dotcode.c @ 63243 – Rev 45209 → 45446