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



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997--2002  The R Development Core Team
 *  Copyright (C) 2003	      The R Foundation
 *
 *  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
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.

 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  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
 *  writing to the Free Software Foundation, Inc., 59 Temple Place,
 *  Suite 330, Boston, MA  02111-1307  USA.
 */
 
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

	    return(ans);
    }
 
    if(checkNativeType(targetType, TYPEOF(s)) == FALSE) {
     if(!dup) {
       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));
     }
 
     if(targetType != SINGLESXP)
        s = coerceVector(s, targetType);
    }
 
    switch(TYPEOF(s)) {
    case LGLSXP:

    switch(type) {
    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);

	s = (SEXP)p;
    }
    return s;
}
 
#define THROW_REGISTRATION_TYPE_ERROR
 
#ifdef THROW_REGISTRATION_TYPE_ERROR
static Rboolean
comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)
{
   if(type == ANYSXP || TYPEOF(s) == type)

static SEXP naokfind(SEXP args, int * len, int *naok, int *dup)
{
    SEXP s, prev;
    int nargs=0, naokused=0, dupused=0, pkgused=0;
    char *p;
 
    *naok = 0;
    *dup = 1;
    *len = 0;
    for(s = args, prev=args; s != R_NilValue;) {
	if(TAG(s) == NaokSymbol) {

	    nargs++;
	    prev = s;
	    s = CDR(s);
	    continue;
	}
	if(s == args)
	    args = s = CDR(s);
	else
	    SETCDR(prev, s = CDR(s));
    }
    *len = nargs;
    return args;
}
 
static void setDLLname(SEXP s, char *DLLName)
{
    SEXP ss = CAR(s); char *name;
    if(TYPEOF(ss) != STRSXP || length(ss) != 1)
	error("PACKAGE argument must be a single character string");
    name = CHAR(STRING_ELT(ss, 0));

    if (!(fun=R_FindSymbol(CHAR(STRING_ELT(op, 0)), DLLname, NULL)))
	errorcall(call, "C function name not in load table");
 
    if(symbol.symbol.external && symbol.symbol.external->numArgs > -1) {
	if(symbol.symbol.external->numArgs != length(args))
	    error("Incorrect number of arguments (%d), expecting %d for %s",
		  length(args), symbol.symbol.external->numArgs, CHAR(STRING_ELT(op, 0)));
    }
    retval = (SEXP)fun(args);
    vmaxset(vmax);
    return retval;

	cargs[nargs] = CAR(pargs);
	nargs++;
    }
    if(symbol.symbol.call && symbol.symbol.call->numArgs > -1) {
	if(symbol.symbol.call->numArgs != nargs)
	    error("Incorrect number of arguments (%d), expecting %d for %s",
		  nargs, symbol.symbol.call->numArgs, CHAR(STRING_ELT(op, 0)));
    }
 
    retval = R_NilValue;	/* -Wall */
    switch (nargs) {

    if (!(fun = R_FindSymbol(buf, DLLname, &symbol)))
	errorcall(call, "C/Fortran function name not in load table");
 
    if(symbol.symbol.c && symbol.symbol.c->numArgs > -1) {
	if(symbol.symbol.c->numArgs != nargs)
	    error("Incorrect number of arguments (%d), expecting %d for %s",
		  nargs, symbol.symbol.c->numArgs, buf);
 
        checkTypes = symbol.symbol.c->types;
        argStyles = symbol.symbol.c->styles;
    }
 
    /* Convert the arguments for use in foreign */

        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. */
  	   error("Wrong type for argument %d in call to %s", nargs+1, buf);
	}
#endif
	cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,
				  which, buf, argConverters + nargs,
				  checkTypes ? checkTypes[nargs] : 0);
	nargs++;
    }
 
 

	    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
		    s = R_NilValue;
		PROTECT(s);
	    } else {
		PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which,
				       checkTypes ? checkTypes[nargs] : TYPEOF(CAR(pargs))));
		SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));
		SET_OBJECT(s, OBJECT(CAR(pargs)));
	    }
	    if (TAG(pargs) != R_NilValue)

Rev 26418	Rev 26763
Line 1...	Line 1...
1	`/*`	1	`/*`
2	`* R : A Computer Langage 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--2002 The R Development Core Team`
-		5	`* Copyright (C) 2003 The R Foundation`
5	`*`	6	`*`
6	`* 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`
7	`* 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`
8	`* the Free Software Foundation; either version 2 of the License, or`	9	`* the Free Software Foundation; either version 2 of the License, or`
9	`* (at your option) any later version.`	10	`* (at your option) any later version.`
Line 11...	Line 12...
11	`* This program is distributed in the hope that it will be useful,`	12	`* This program is distributed in the hope that it will be useful,`
12	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`	13	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`
13	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`	14	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
14	`* GNU General Public License for more details.`	15	`* GNU General Public License for more details.`
15	`*`	16	`*`
16	`* You should have received a copy of the GNU General Public License`	17	`* A copy of the GNU General Public License is available via WWW at`
-		18	`* http://www.gnu.org/copyleft/gpl.html. You can also obtain it by`
17	`* along with this program; if not, write to the Free Software`	19	`* writing to the Free Software Foundation, Inc., 59 Temple Place,`
18	`* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA`	20	`* Suite 330, Boston, MA 02111-1307 USA.`
19	`*/`	21	`*/`
20		22
21	`#ifdef HAVE_CONFIG_H`	23	`#ifdef HAVE_CONFIG_H`
22	`#include <config.h>`	24	`#include <config.h>`
23	`#endif`	25	`#endif`
Line 97...	Line 99...
97	`return(ans);`	99	`return(ans);`
98	`}`	100	`}`
99		101
100	`if(checkNativeType(targetType, TYPEOF(s)) == FALSE) {`	102	`if(checkNativeType(targetType, TYPEOF(s)) == FALSE) {`
101	`if(!dup) {`	103	`if(!dup) {`
102	`error("explicit request not to duplicate arguments in call to %s, but argument %d is of the wrong type (%d != %d)",`	104	`error("explicit request not to duplicate arguments in call to %s, but argument %d is of the wrong type (%d != %d)",`
103	`name, narg + 1, targetType, TYPEOF(s));`	105	`name, narg + 1, targetType, TYPEOF(s));`
104	`}`	106	`}`
105		107
106	`if(targetType != SINGLESXP)`	108	`if(targetType != SINGLESXP)`
107	`s = coerceVector(s, targetType);`	109	`s = coerceVector(s, targetType);`
108	`}`	110	`}`
109		111
110	`switch(TYPEOF(s)) {`	112	`switch(TYPEOF(s)) {`
111	`case LGLSXP:`	113	`case LGLSXP:`
Line 221...	Line 223...
221	`switch(type) {`	223	`switch(type) {`
222	`case LGLSXP:`	224	`case LGLSXP:`
223	`case INTSXP:`	225	`case INTSXP:`
224	`s = allocVector(type, n);`	226	`s = allocVector(type, n);`
225	`iptr = (int*)p;`	227	`iptr = (int*)p;`
226	`for(i=0 ; i<n ; i++)`	228	`for(i=0 ; i<n ; i++)`
227	`INTEGER(s)[i] = iptr[i];`	229	`INTEGER(s)[i] = iptr[i];`
228	`break;`	230	`break;`
229	`case REALSXP:`	231	`case REALSXP:`
230	`case SINGLESXP:`	232	`case SINGLESXP:`
231	`s = allocVector(REALSXP, n);`	233	`s = allocVector(REALSXP, n);`
Line 281...	Line 283...
281	`s = (SEXP)p;`	283	`s = (SEXP)p;`
282	`}`	284	`}`
283	`return s;`	285	`return s;`
284	`}`	286	`}`
285		287
-		288	`#define THROW_REGISTRATION_TYPE_ERROR`
-		289
286	`#ifdef THROW_REGISTRATION_TYPE_ERROR`	290	`#ifdef THROW_REGISTRATION_TYPE_ERROR`
287	`static Rboolean`	291	`static Rboolean`
288	`comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)`	292	`comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)`
289	`{`	293	`{`
290	`if(type == ANYSXP \|\| TYPEOF(s) == type)`	294	`if(type == ANYSXP \|\| TYPEOF(s) == type)`
Line 307...	Line 311...
307	`static SEXP naokfind(SEXP args, int * len, int naok, int dup)`	311	`static SEXP naokfind(SEXP args, int * len, int naok, int dup)`
308	`{`	312	`{`
309	`SEXP s, prev;`	313	`SEXP s, prev;`
310	`int nargs=0, naokused=0, dupused=0, pkgused=0;`	314	`int nargs=0, naokused=0, dupused=0, pkgused=0;`
311	`char *p;`	315	`char *p;`
312		316
313	`*naok = 0;`	317	`*naok = 0;`
314	`*dup = 1;`	318	`*dup = 1;`
315	`*len = 0;`	319	`*len = 0;`
316	`for(s = args, prev=args; s != R_NilValue;) {`	320	`for(s = args, prev=args; s != R_NilValue;) {`
317	`if(TAG(s) == NaokSymbol) {`	321	`if(TAG(s) == NaokSymbol) {`
Line 336...	Line 340...
336	`nargs++;`	340	`nargs++;`
337	`prev = s;`	341	`prev = s;`
338	`s = CDR(s);`	342	`s = CDR(s);`
339	`continue;`	343	`continue;`
340	`}`	344	`}`
341	`if(s == args)`	345	`if(s == args)`
342	`args = s = CDR(s);`	346	`args = s = CDR(s);`
343	`else`	347	`else`
344	`SETCDR(prev, s = CDR(s));`	348	`SETCDR(prev, s = CDR(s));`
345	`}`	349	`}`
346	`*len = nargs;`	350	`*len = nargs;`
347	`return args;`	351	`return args;`
348	`}`	352	`}`
349		353
350	`static void setDLLname(SEXP s, char *DLLName)`	354	`static void setDLLname(SEXP s, char *DLLName)`
351	`{`	355	`{`
352	`SEXP ss = CAR(s); char *name;`	356	`SEXP ss = CAR(s); char *name;`
353	`if(TYPEOF(ss) != STRSXP \|\| length(ss) != 1)`	357	`if(TYPEOF(ss) != STRSXP \|\| length(ss) != 1)`
354	`error("PACKAGE argument must be a single character string");`	358	`error("PACKAGE argument must be a single character string");`
355	`name = CHAR(STRING_ELT(ss, 0));`	359	`name = CHAR(STRING_ELT(ss, 0));`
Line 454...	Line 458...
454	`if (!(fun=R_FindSymbol(CHAR(STRING_ELT(op, 0)), DLLname, NULL)))`	458	`if (!(fun=R_FindSymbol(CHAR(STRING_ELT(op, 0)), DLLname, NULL)))`
455	`errorcall(call, "C function name not in load table");`	459	`errorcall(call, "C function name not in load table");`
456		460
457	`if(symbol.symbol.external && symbol.symbol.external->numArgs > -1) {`	461	`if(symbol.symbol.external && symbol.symbol.external->numArgs > -1) {`
458	`if(symbol.symbol.external->numArgs != length(args))`	462	`if(symbol.symbol.external->numArgs != length(args))`
459	`error("Incorrect number of arguments (%d), expecting %d for %s",`	463	`error("Incorrect number of arguments (%d), expecting %d for %s",`
460	`length(args), symbol.symbol.external->numArgs, CHAR(STRING_ELT(op, 0)));`	464	`length(args), symbol.symbol.external->numArgs, CHAR(STRING_ELT(op, 0)));`
461	`}`	465	`}`
462	`retval = (SEXP)fun(args);`	466	`retval = (SEXP)fun(args);`
463	`vmaxset(vmax);`	467	`vmaxset(vmax);`
464	`return retval;`	468	`return retval;`
Line 491...	Line 495...
491	`cargs[nargs] = CAR(pargs);`	495	`cargs[nargs] = CAR(pargs);`
492	`nargs++;`	496	`nargs++;`
493	`}`	497	`}`
494	`if(symbol.symbol.call && symbol.symbol.call->numArgs > -1) {`	498	`if(symbol.symbol.call && symbol.symbol.call->numArgs > -1) {`
495	`if(symbol.symbol.call->numArgs != nargs)`	499	`if(symbol.symbol.call->numArgs != nargs)`
496	`error("Incorrect number of arguments (%d), expecting %d for %s",`	500	`error("Incorrect number of arguments (%d), expecting %d for %s",`
497	`nargs, symbol.symbol.call->numArgs, CHAR(STRING_ELT(op, 0)));`	501	`nargs, symbol.symbol.call->numArgs, CHAR(STRING_ELT(op, 0)));`
498	`}`	502	`}`
499		503
500	`retval = R_NilValue; /* -Wall */`	504	`retval = R_NilValue; /* -Wall */`
501	`switch (nargs) {`	505	`switch (nargs) {`
Line 1230...	Line 1234...
1230	`if (!(fun = R_FindSymbol(buf, DLLname, &symbol)))`	1234	`if (!(fun = R_FindSymbol(buf, DLLname, &symbol)))`
1231	`errorcall(call, "C/Fortran function name not in load table");`	1235	`errorcall(call, "C/Fortran function name not in load table");`
1232		1236
1233	`if(symbol.symbol.c && symbol.symbol.c->numArgs > -1) {`	1237	`if(symbol.symbol.c && symbol.symbol.c->numArgs > -1) {`
1234	`if(symbol.symbol.c->numArgs != nargs)`	1238	`if(symbol.symbol.c->numArgs != nargs)`
1235	`error("Incorrect number of arguments (%d), expecting %d for %s",`	1239	`error("Incorrect number of arguments (%d), expecting %d for %s",`
1236	`nargs, symbol.symbol.c->numArgs, buf);`	1240	`nargs, symbol.symbol.c->numArgs, buf);`
1237		1241
1238	`checkTypes = symbol.symbol.c->types;`	1242	`checkTypes = symbol.symbol.c->types;`
1239	`argStyles = symbol.symbol.c->styles;`	1243	`argStyles = symbol.symbol.c->styles;`
1240	`}`	1244	`}`
1241		1245
1242	`/* Convert the arguments for use in foreign */`	1246	`/* Convert the arguments for use in foreign */`
Line 1250...	Line 1254...
1250	`if(checkTypes && !comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {`	1254	`if(checkTypes && !comparePrimitiveTypes(checkTypes[nargs], CAR(pargs), dup)) {`
1251	`/* We can loop over all the arguments and report all the erroneous ones,`	1255	`/* We can loop over all the arguments and report all the erroneous ones,`
1252	`but then we would also want to avoid the conversions.`	1256	`but then we would also want to avoid the conversions.`
1253	`Also, in the future, we may just attempt to coerce the value`	1257	`Also, in the future, we may just attempt to coerce the value`
1254	`to the appropriate type. This is why we pass the checkTypes[nargs]`	1258	`to the appropriate type. This is why we pass the checkTypes[nargs]`
1255	`value to RObjToCPtr(). We just have to sort out the ability to`	1259	`value to RObjToCPtr(). We just have to sort out the ability to`
1256	`return the correct value which is complicated by dup, etc. */`	1260	`return the correct value which is complicated by dup, etc. */`
1257	`error("Wrong type for argument %d in call to %s", nargs+1, buf);`	1261	`error("Wrong type for argument %d in call to %s", nargs+1, buf);`
1258	`}`	1262	`}`
1259	`#endif`	1263	`#endif`
1260	`cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,`	1264	`cargs[nargs] = RObjToCPtr(CAR(pargs), naok, dup, nargs + 1,`
1261	`which, buf, argConverters + nargs,`	1265	`which, buf, argConverters + nargs,`
1262	`checkTypes ? checkTypes[nargs] : 0);`	1266	`checkTypes ? checkTypes[nargs] : 0);`
1263	`nargs++;`	1267	`nargs++;`
1264	`}`	1268	`}`
1265		1269
1266		1270
Line 1871...	Line 1875...
1871	`if(argStyles && argStyles[nargs] == R_ARG_IN) {`	1875	`if(argStyles && argStyles[nargs] == R_ARG_IN) {`
1872	`PROTECT(s = R_NilValue);`	1876	`PROTECT(s = R_NilValue);`
1873	`} else if(argConverters[nargs]) {`	1877	`} else if(argConverters[nargs]) {`
1874	`if(argConverters[nargs]->reverse) {`	1878	`if(argConverters[nargs]->reverse) {`
1875	`info.argIndex = nargs;`	1879	`info.argIndex = nargs;`
1876	`s = argConverters[nargs]->reverse(cargs[nargs], CAR(pargs),`	1880	`s = argConverters[nargs]->reverse(cargs[nargs], CAR(pargs),`
1877	`&info, argConverters[nargs]);`	1881	`&info, argConverters[nargs]);`
1878	`} else`	1882	`} else`
1879	`s = R_NilValue;`	1883	`s = R_NilValue;`
1880	`PROTECT(s);`	1884	`PROTECT(s);`
1881	`} else {`	1885	`} else {`
1882	`PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which,`	1886	`PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which,`
1883	`checkTypes ? checkTypes[nargs] : TYPEOF(CAR(pargs))));`	1887	`checkTypes ? checkTypes[nargs] : TYPEOF(CAR(pargs))));`
1884	`SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));`	1888	`SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));`
1885	`SET_OBJECT(s, OBJECT(CAR(pargs)));`	1889	`SET_OBJECT(s, OBJECT(CAR(pargs)));`
1886	`}`	1890	`}`
1887	`if (TAG(pargs) != R_NilValue)`	1891	`if (TAG(pargs) != R_NilValue)`

The R Project SVN R

(root)/branches/R-gcontext/src/main/dotcode.c @ 28362 – Rev 26418 → 26763