Commit 578447ae authored by Radford Neal's avatar Radford Neal

First version released on github

parent 9ea54f65
......@@ -143,7 +143,33 @@ users, such as cleanups of source code.
17)
18)
o The matchArgs function, used in the interpreter to match
formal and actual arguments when calling functions has been
sped up, and given a new interface.
One interface change allows the formal arguments to either be
given as a list SEXP (as before), or as an array of C strings,
along with a count of how many strings are in the array. (If
formals are given by C strings, the SEXP for the formals list
parameter should be NULL, whereas if the formals are given by a
list, the pointer for the C strings should be NULL and their
count should be 0.)
Numerous calls of matchArgs are changed to use the interface with
an array of C strings (for example, in the code implementing rep
and seq.int). These calls were previously preceded by creation
of a list with calls to "install" for all the formal argument
names. Using the new interface is cleaner and considerably
faster.
A second interface change is that if the formals are given by a
list SEXP, tags for the arguments are attached to the actuals
list by matchArgs. Places where matchArgs is called are changed
to no longer do this themselves. (Doing this in matchArgs is
both cleaner and faster.)
The new code is also faster in ways unrelated to these interface
changes.
19)
......@@ -170,7 +196,8 @@ users, such as cleanups of source code.
29)
30)
30) The 38 calls of check1arg(args,call,"x") were replaced with calls
of a new macro check1arg_x(args,call) that should be faster.
31)
......
The matchArgs function, used in the interpreter to match formal and
actual arguments when calling functions has been sped up, and given a
new interface.
One interface change allows the formal arguments to either be given as
a list SEXP (as before), or as an array of C strings, along with a
count of how many strings are in the array. (If formals are given by
C strings, the SEXP for the formals list parameter should be NULL,
whereas if the formals are given by a list, the pointer for the C
strings should be NULL and their count should be 0.)
Numerous calls of matchArgs are changed to use the interface with an
array of C strings (for example, in the code implementing rep and
seq.int). These calls were previously preceded by creation of a list
with calls to "install" for all the formal argument names. Using the
new interface is cleaner and considerably faster.
A second interface change is that if the formals are given by a list
SEXP, tags for the arguments are attached to the actuals list by
matchArgs. Places where matchArgs is called are changed to no longer
do this themselves. (Doing this in matchArgs is both cleaner and
faster.)
The new code is also faster in ways unrelated to these interface
changes.
Finally, 38 calls of check1arg(args,call,"x") were replaced with calls
of a new macro check1arg_x(args,call) that should be faster.
......@@ -479,6 +479,12 @@ typedef struct {
#define LOCK_BINDING(b) ((b)->sxpinfo.gp |= BINDING_LOCK_MASK)
#define UNLOCK_BINDING(b) ((b)->sxpinfo.gp &= (~BINDING_LOCK_MASK))
#define check1arg_x(args,call) \
do { \
if (TAG(args) != R_NilValue && TAG(args) != R_xSymbol) \
check1arg_error (args, call, "x"); \
} while (0)
#else /* USE_RINTERNALS */
typedef struct VECREC *VECP;
......@@ -815,6 +821,7 @@ extern0 Rboolean known_to_be_utf8 INI_as(FALSE);
# define begincontext Rf_begincontext
# define check_stack_balance Rf_check_stack_balance
# define check1arg Rf_check1arg
# define check1arg_error Rf_check1arg_error
# define CheckFormals Rf_CheckFormals
# define CleanEd Rf_CleanEd
# define CoercionWarning Rf_CoercionWarning
......@@ -1013,6 +1020,7 @@ SEXP Rf_EnsureString(SEXP);
SEXP Rf_allocCharsxp(R_len_t);
SEXP Rf_append(SEXP, SEXP); /* apparently unused now */
void check1arg(SEXP, SEXP, const char *);
void check1arg_error(SEXP, SEXP, const char *);
void Rf_checkArityCall(SEXP, SEXP, SEXP);
void CheckFormals(SEXP);
void R_check_locale(void);
......@@ -1075,7 +1083,7 @@ SEXP markKnown(const char *, SEXP);
SEXP mat2indsub(SEXP, SEXP, SEXP);
SEXP matchArg(SEXP, SEXP*);
SEXP matchArgExact(SEXP, SEXP*);
SEXP matchArgs(SEXP, SEXP, SEXP);
SEXP matchArgs(SEXP, char **, int, SEXP, SEXP);
SEXP matchPar(const char *, SEXP*);
void memtrace_report(void *, void *);
SEXP mkCLOSXP(SEXP, SEXP, SEXP);
......
......@@ -558,6 +558,7 @@ LibExtern SEXP R_ModeSymbol; /* "mode" */
LibExtern SEXP R_NameSymbol; /* "name" */
LibExtern SEXP R_NamesSymbol; /* "names" */
LibExtern SEXP R_NaRmSymbol; /* "na.rm" */
LibExtern SEXP R_xSymbol; /* "x" */
LibExtern SEXP R_PackageSymbol; /* "package" */
LibExtern SEXP R_QuoteSymbol; /* "quote" */
LibExtern SEXP R_RowNamesSymbol; /* "row.names" */
......
......@@ -1078,7 +1078,7 @@ SEXP attribute_hidden do_math1(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP s;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchGroup("Math", call, op, args, env, &s))
return s;
......@@ -1136,7 +1136,7 @@ SEXP attribute_hidden do_trunc(SEXP call, SEXP op, SEXP args, SEXP env)
if (DispatchGroup("Math", call, op, args, env, &s))
return s;
checkArity(op, args); /* but is -1 in names.c */
check1arg(args, call, "x");
check1arg_x (args, call);
if (isComplex(CAR(args)))
errorcall(call, _("unimplemented complex function"));
return math1(CAR(args), trunc, call);
......@@ -1152,7 +1152,7 @@ SEXP attribute_hidden do_abs(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP x, s = R_NilValue /* -Wall */;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
x = CAR(args);
if (DispatchGroup("Math", call, op, args, env, &s))
......@@ -1465,7 +1465,7 @@ SEXP attribute_hidden do_math2(SEXP call, SEXP op, SEXP args, SEXP env)
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_Math2(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP res, ap, call2;
SEXP res, call2;
int n, nprotect = 2;
if (length(args) >= 2 &&
......@@ -1497,11 +1497,9 @@ SEXP attribute_hidden do_Math2(SEXP call, SEXP op, SEXP args, SEXP env)
} else {
/* If named, do argument matching by name */
if (TAG(args) != R_NilValue || TAG(CDR(args)) != R_NilValue) {
PROTECT(ap = CONS(R_NilValue, list1(R_NilValue)));
SET_TAG(ap, install("x"));
SET_TAG(CDR(ap), install("digits"));
PROTECT(args = matchArgs(ap, args, call));
nprotect +=2;
static char *ap[2] = { "x", "digits" };
PROTECT(args = matchArgs(R_NilValue, ap, 2, args, call));
nprotect += 1;
}
if (length(CADR(args)) == 0)
errorcall(call, _("invalid second argument of length 0"));
......@@ -1518,7 +1516,7 @@ SEXP attribute_hidden do_log1arg(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP res, call2, args2, tmp = R_NilValue /* -Wall */;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchGroup("Math", call, op, args, env, &res)) return res;
......@@ -1541,7 +1539,7 @@ SEXP attribute_hidden do_log1arg(SEXP call, SEXP op, SEXP args, SEXP env)
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_log(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP res, ap = args, call2;
SEXP res, call2;
int n = length(args), nprotect = 2;
if (n >= 2 && isSymbol(CADR(args)) && R_isMissing(CADR(args), env)) {
......@@ -1568,11 +1566,9 @@ SEXP attribute_hidden do_log(SEXP call, SEXP op, SEXP args, SEXP env)
case 2:
{
/* match argument names if supplied */
PROTECT(ap = list2(R_NilValue, R_NilValue));
SET_TAG(ap, install("x"));
SET_TAG(CDR(ap), install("base"));
PROTECT(args = matchArgs(ap, args, call));
nprotect += 2;
static char *ap[2] = { "x", "base" };
PROTECT(args = matchArgs(R_NilValue, ap, 2, args, call));
nprotect += 1;
if (length(CADR(args)) == 0)
errorcall(call, _("invalid argument 'base' of length 0"));
if (isComplex(CAR(args)) || isComplex(CADR(args)))
......
......@@ -363,7 +363,7 @@ SEXP attribute_hidden do_length(SEXP call, SEXP op, SEXP args, SEXP rho)
R_len_t len;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if(isObject(CAR(args)) && DispatchOrEval(call, op, "length", args,
rho, &ans, 0, 1))
......
......@@ -523,7 +523,7 @@ SEXP classgets(SEXP vec, SEXP klass)
SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
......@@ -537,7 +537,7 @@ SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP attribute_hidden do_class(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
SEXP x = CAR(args), s3class;
if(IS_S4_OBJECT(x)) {
if((s3class = S3Class(x)) != R_NilValue) {
......@@ -744,7 +744,7 @@ SEXP attribute_hidden R_do_data_class(SEXP call, SEXP op, SEXP args, SEXP env)
class = translateChar(STRING_ELT(klass, 0));
return cache_class(class, CADR(args));
}
check1arg(args, call, "x");
check1arg_x (args, call);
return R_data_class(CAR(args), FALSE);
}
......@@ -753,7 +753,7 @@ SEXP attribute_hidden do_namesgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "names<-", args, env, &ans, 0, 1))
return(ans);
......@@ -868,7 +868,7 @@ SEXP attribute_hidden do_names(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "names", args, env, &ans, 0, 1))
return(ans);
PROTECT(args = ans);
......@@ -886,7 +886,7 @@ SEXP attribute_hidden do_dimnamesgets(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP ans;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "dimnames<-", args, env, &ans, 0, 1))
return(ans);
......@@ -988,7 +988,7 @@ SEXP attribute_hidden do_dimnames(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "dimnames", args, env, &ans, 0, 1))
return(ans);
PROTECT(args = ans);
......@@ -1001,7 +1001,7 @@ SEXP attribute_hidden do_dim(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "dim", args, env, &ans, 0, 1))
return(ans);
PROTECT(args = ans);
......@@ -1073,7 +1073,7 @@ SEXP attribute_hidden do_attributes(SEXP call, SEXP op, SEXP args, SEXP env)
int nvalues;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
namesattr = R_NilValue;
attrs = ATTRIB(CAR(args));
nvalues = length(attrs);
......@@ -1120,7 +1120,7 @@ SEXP attribute_hidden do_levelsgets(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP ans;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "levels<-", args, env, &ans, 0, 1))
/* calls, e.g., levels<-.factor() */
......@@ -1149,7 +1149,7 @@ SEXP attribute_hidden do_attributesgets(SEXP call, SEXP op, SEXP args, SEXP env)
/* Extract the arguments from the argument list */
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
object = CAR(args);
attrs = CADR(args);
......@@ -1245,22 +1245,19 @@ fairly minor. LT */
SEXP attribute_hidden do_attr(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ap, argList, s, t, tag = R_NilValue, alist, ans;
SEXP argList, s, t, tag = R_NilValue, alist, ans;
const char *str;
size_t n;
int nargs = length(args), exact = 0;
enum { NONE, PARTIAL, PARTIAL2, FULL } match = NONE;
static char *ap[3] = { "x", "which", "exact" };
if (nargs < 2 || nargs > 3)
errorcall(call, "either 2 or 3 arguments are required");
/* argument matching */
PROTECT(ap = list3(R_NilValue, R_NilValue, R_NilValue));
SET_TAG(ap, install("x"));
SET_TAG(CDR(ap), install("which"));
SET_TAG(CDDR(ap), install("exact"));
argList = matchArgs(ap, args, call);
UNPROTECT(1); /* ap */
argList = matchArgs(R_NilValue, ap, 3, args, call);
PROTECT(argList);
s = CAR(argList);
t = CADR(argList);
......@@ -1359,7 +1356,8 @@ SEXP attribute_hidden do_attr(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP attribute_hidden do_attrgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
/* attr(x, which = "<name>") <- value */
SEXP obj, name, ap, argList;
SEXP obj, name, argList;
static char *ap[3] = { "x", "which", "value" };
checkArity(op, args);
......@@ -1370,12 +1368,8 @@ SEXP attribute_hidden do_attrgets(SEXP call, SEXP op, SEXP args, SEXP env)
PROTECT(obj);
/* argument matching */
PROTECT(ap = list3(R_NilValue, R_NilValue, R_NilValue));
SET_TAG(ap, install("x"));
SET_TAG(CDR(ap), install("which"));
SET_TAG(CDDR(ap), install("value"));
argList = matchArgs(ap, args, call);
UNPROTECT(1); /* ap */
argList = matchArgs(R_NilValue, ap, 3, args, call);
PROTECT(argList);
name = CADR(argList);
......
......@@ -125,13 +125,11 @@ SEXP attribute_hidden do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *ctxt;
SEXP code, oldcode, tmp, ap, argList;
SEXP code, oldcode, tmp, argList;
static char *ap[2] = { "expr", "add" };
int addit = 0;
PROTECT(ap = list2(R_NilValue, R_NilValue));
SET_TAG(ap, install("expr"));
SET_TAG(CDR(ap), install("add"));
PROTECT(argList = matchArgs(ap, args, call));
PROTECT(argList = matchArgs(R_NilValue, ap, 2, args, call));
if (CAR(argList) == R_MissingArg) code = R_NilValue;
else code = CAR(argList);
if (CADR(argList) != R_MissingArg) {
......@@ -172,7 +170,7 @@ SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
else
ctxt->conexit = code;
}
UNPROTECT(2);
UNPROTECT(1);
return R_NilValue;
}
......@@ -274,7 +272,7 @@ SEXP attribute_hidden do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP env, s = CAR(args);
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
env = CADR(args);
......@@ -864,7 +862,7 @@ SEXP attribute_hidden do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP x, ans;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
x = CAR(args);
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
......
......@@ -103,7 +103,7 @@ SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
int i, len;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nzchar()");
......
......@@ -1318,7 +1318,7 @@ SEXP attribute_hidden do_ascharacter(SEXP call, SEXP op, SEXP args, SEXP rho)
int type = STRSXP, op0 = PRIMVAL(op);
char *name = NULL /* -Wall */;
check1arg(args, call, "x");
check1arg_x (args, call);
switch(op0) {
case 0:
name = "as.character"; break;
......@@ -1494,7 +1494,7 @@ SEXP attribute_hidden do_ascall(SEXP call, SEXP op, SEXP args, SEXP rho)
int i, n;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
args = CAR(args);
switch (TYPEOF(args)) {
......@@ -1680,7 +1680,7 @@ SEXP attribute_hidden do_is(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
/* These are all builtins, so we do not need to worry about
evaluating arguments in DispatchOrEval */
......@@ -1889,7 +1889,7 @@ SEXP attribute_hidden do_isna(SEXP call, SEXP op, SEXP args, SEXP rho)
int i, n;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "is.na", args, rho, &ans, 1, 1))
return(ans);
......@@ -2002,7 +2002,7 @@ SEXP attribute_hidden do_isnan(SEXP call, SEXP op, SEXP args, SEXP rho)
int i, n;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "is.nan", args, rho, &ans, 1, 1))
return(ans);
......@@ -2065,7 +2065,7 @@ SEXP attribute_hidden do_isfinite(SEXP call, SEXP op, SEXP args, SEXP rho)
int i, n;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "is.finite", args, rho, &ans, 0, 1))
return(ans);
......@@ -2125,7 +2125,7 @@ SEXP attribute_hidden do_isinfinite(SEXP call, SEXP op, SEXP args, SEXP rho)
int i, n;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
if (DispatchOrEval(call, op, "is.infinite", args, rho, &ans, 0, 1))
return(ans);
......@@ -2361,13 +2361,11 @@ SEXP attribute_hidden substituteList(SEXP el, SEXP rho)
/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_substitute(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ap, argList, env, s, t;
SEXP argList, env, s, t;
static char *ap[2] = { "expr", "env" };
/* argument matching */
PROTECT(ap = list2(R_NilValue, R_NilValue));
SET_TAG(ap, install("expr"));
SET_TAG(CDR(ap), install("env"));
PROTECT(argList = matchArgs(ap, args, call));
PROTECT(argList = matchArgs(R_NilValue, ap, 2, args, call));
/* set up the environment for substitution */
if (CADR(argList) == R_MissingArg)
......@@ -2386,7 +2384,7 @@ SEXP attribute_hidden do_substitute(SEXP call, SEXP op, SEXP args, SEXP rho)
PROTECT(env);
PROTECT(t = CONS(duplicate(CAR(argList)), R_NilValue));
s = substituteList(t, env);
UNPROTECT(4);
UNPROTECT(3);
return CAR(s);
}
......@@ -2546,7 +2544,7 @@ static SEXP R_set_class(SEXP obj, SEXP value, SEXP call)
SEXP attribute_hidden R_do_set_class(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
return R_set_class(CAR(args), CADR(args), call);
}
......@@ -2559,7 +2557,7 @@ SEXP attribute_hidden do_storage_mode(SEXP call, SEXP op, SEXP args, SEXP env)
SEXPTYPE type;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
obj = CAR(args);
......
......@@ -71,7 +71,7 @@ SEXP attribute_hidden do_debug(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP attribute_hidden do_trace(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
find_char_fun
......@@ -125,7 +125,7 @@ SEXP attribute_hidden do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
char buffer[20];
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
object = CAR(args);
if (TYPEOF(object) == CLOSXP ||
......@@ -159,7 +159,7 @@ SEXP attribute_hidden do_untracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP object;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
object=CAR(args);
if (TYPEOF(object) == CLOSXP ||
......@@ -209,13 +209,11 @@ void attribute_hidden memtrace_report(void * old, void * _new)
SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
SEXP object, previous, ans, ap, argList;
SEXP object, previous, ans, argList;
char buffer[20];
static char *ap[2] = { "x", "previous" };
PROTECT(ap = list2(R_NilValue, R_NilValue));
SET_TAG(ap, install("x"));
SET_TAG(CDR(ap), install("previous"));
PROTECT(argList = matchArgs(ap, args, call));
PROTECT(argList = matchArgs(R_NilValue, ap, 2, args, call));
if(CAR(argList) == R_MissingArg) SETCAR(argList, R_NilValue);
if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue);
......@@ -247,7 +245,7 @@ SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
memtrace_stack_dump();
}
}
UNPROTECT(2);
UNPROTECT(1);
return ans;
#else
return R_NilValue;
......
......@@ -2003,7 +2003,7 @@ SEXP attribute_hidden do_missing(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP rval, t, sym, s;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
s = sym = CAR(args);
if( isString(sym) && length(sym)==1 )
s = sym = install(translateChar(STRING_ELT(CAR(args), 0)));
......@@ -2737,7 +2737,7 @@ SEXP attribute_hidden do_pos2env(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP env, pos;
int i, npos;
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);
PROTECT(pos = coerceVector(CAR(args), INTSXP));
npos = length(pos);
......
......@@ -743,8 +743,9 @@ static SEXP applyClosure_v (SEXP call, SEXP op, SEXP arglist, SEXP rho,
contains the matched pairs. Ideally this environment sould be
hashed. */
PROTECT(actuals = matchArgs(formals, arglist, call));
PROTECT(newrho = NewEnvironment(formals, actuals, savedrho));
PROTECT(actuals = matchArgs(formals, NULL, 0, arglist, call));
PROTECT(newrho = NewEnvironment(R_NilValue, actuals, savedrho));
/* no longer passes formals, since matchArg now puts tags in actuals */
/* Use the default code for unbound formals. FIXME: It looks like
this code should preceed the building of the environment so that
......
......@@ -1068,16 +1068,11 @@ SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho)
RCNTXT *saveGlobalContext;
RCNTXT thiscontext, returncontext, *cptr;
int savestack, browselevel, tmp;
SEXP ap, topExp, argList;
SEXP topExp, argList;
static char *ap[4] = { "text", "condition", "expr", "skipCalls" };
/* argument matching */
PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
SET_TAG(ap, install("text"));
SET_TAG(CDR(ap), install("condition"));
SET_TAG(CDDR(ap), install("expr"));
SET_TAG(CDR(CDDR(ap)), install("skipCalls"));
argList = matchArgs(ap, args, call);
UNPROTECT(1);
argList = matchArgs(R_NilValue, ap, 4, args, call);
PROTECT(argList);
/* substitute defaults */
if(CAR(argList) == R_MissingArg)
......
This diff is collapsed.
......@@ -2144,7 +2144,10 @@ SEXP cons_with_tag(SEXP car, SEXP cdr, SEXP tag)
Create an environment by extending "rho" with a frame obtained by
pairing the variable names given by the tags on "namelist" with
the values given by the elements of "valuelist".
the values given by the elements of "valuelist". Note that "namelist"
can be shorter than "valuelist" if the rest of "valuelist" already
has tags. (In particular, "namelist" can be R_NilValue if all of
"valuelist" already has tags.)
NewEnvironment is defined directly to avoid the need to protect its
arguments unless a GC will actually occur. This definition allows
......@@ -3404,7 +3407,7 @@ SEXP attribute_hidden do_pnamedcnt(SEXP call, SEXP op, SEXP args, SEXP rho)
if (args == R_NilValue)
error(_("too few arguments"));
check1arg(args, call, "x");
check1arg_x (args, call);
for (a = CDR(args); a != R_NilValue; a = CDR(a))
if (!isString(CAR(a)))
......
......@@ -1109,6 +1109,7 @@ static void SymbolShortcuts(void)
R_NameSymbol = install("name");
R_NamesSymbol = install("names");
R_NaRmSymbol = install("na.rm");
R_xSymbol = install("x");
R_PackageSymbol = install("package");
R_QuoteSymbol = install("quote");
R_RowNamesSymbol = install("row.names");
......
......@@ -386,13 +386,11 @@ SEXP attribute_hidden do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, generic = R_NilValue /* -Wall */, obj, val;
SEXP callenv, defenv;
SEXP ap, argList;
SEXP argList;
RCNTXT *cptr;
static char *ap[2] = { "generic", "object" };
PROTECT(ap = list2(R_NilValue, R_NilValue));
SET_TAG(ap, install("generic"));
SET_TAG(CDR(ap), install("object"));
PROTECT(argList = matchArgs(ap, args, call));
PROTECT(argList = matchArgs(R_NilValue, ap, 2, args, call));
if (CAR(argList) == R_MissingArg)
errorcall(call, _("there must be a 'generic' argument"));
else
......@@ -446,7 +444,7 @@ SEXP attribute_hidden do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
if (usemethod(translateChar(STRING_ELT(generic, 0)), obj, call, CDR(args),
env, callenv, defenv, &ans) == 1) {
UNPROTECT(3); /* obj, ap, argList */
UNPROTECT(2); /* obj, argList */
PROTECT(ans);
findcontext(CTXT_RETURN, env, ans); /* does not return */
}
......@@ -564,26 +562,30 @@ SEXP attribute_hidden do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)
_("'function' is not a function, but of type %d"),
TYPEOF(s));
}
/* get formals and actuals; attach the names of the formals to
the actuals, expanding any ... that occurs */
/* Get formals and actuals; matchArgs attaches the names of the formals to
the actuals. Then expand any ... that occurs. */
formals = FORMALS(s);
PROTECT(actuals = matchArgs(formals, cptr->promargs, call));
PROTECT(actuals = matchArgs(formals, NULL, 0, cptr->promargs, call));
i = 0;
for(s = formals, t = actuals; s != R_NilValue; s = CDR(s), t = CDR(t)) {
SET_TAG(t, TAG(s));
if(TAG(t) == R_DotsSymbol) i = length(CAR(t));
for(t = actuals; t != R_NilValue; t = CDR(t)) {
if(TAG(t) == R_DotsSymbol) {
i = length(CAR(t));
break;
}
}
if(i) { /* we need to expand out the dots */
PROTECT(t = allocList(i+length(actuals)-1));
for(s = actuals, m = t; s != R_NilValue; s = CDR(s)) {
if(TYPEOF(CAR(s)) == DOTSXP) {
if(TYPEOF(CAR(s)) == DOTSXP && i!=0) {
for(i = 1, a = CAR(s); a != R_NilValue;
a = CDR(a), i++, m = CDR(m)) {
sprintf(tbuf, "..%d", i);
SET_TAG(m, mkSYMSXP(mkChar(tbuf), R_UnboundValue));
SETCAR(m, CAR(a));
}
i = 0; /* precaution just in case there are multiple ... args */
} else {
SET_TAG(m, TAG(s));
SETCAR(m, CAR(s));
......@@ -817,7 +819,7 @@ SEXP attribute_hidden do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP attribute_hidden do_unclass(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
check1arg_x (args, call);