Commit ca4257cc authored by Radford Neal's avatar Radford Neal

make all special primitives take variant arg

parent 2d718792
......@@ -1318,6 +1318,8 @@ copied to a single table for all such functions by initialization
code in @file{names.c}. This table also has other information, such
as whether the primitive is BUILTIN or SPECIAL, and whether the
variant argument of evalv is passed on to the @code{do_XXX} function.
(Currently, SPECIAL primitive functions must be called with a variant
argument, so that a check for this in time-critical code can be avoided.)
Arguments are passed to the @code{do_XXX} function as a pairlist.
This is inefficient, since it requires that a CONS cell be allocated
......
Make all SPECIAL primitives take a 'variant' argument, so that
this doesn't have to be checked for in evalv_other.
......@@ -594,7 +594,6 @@
do_dimgets
do_dllversion
do_edit
do_expression
do_flushconsole
do_getClipboardFormats
do_getGraphicsEvent
......
......@@ -101,7 +101,6 @@ SEXP do_dataframe(SEXP, SEXP, SEXP, SEXP);
SEXP do_dataviewer(SEXP, SEXP, SEXP, SEXP);
SEXP do_dumpb(SEXP, SEXP, SEXP, SEXP);
SEXP do_edit(SEXP, SEXP, SEXP, SEXP);
SEXP do_expression(SEXP, SEXP, SEXP, SEXP);
SEXP do_flatContour(SEXP, SEXP, SEXP, SEXP);
SEXP do_getGraphicsEvent(SEXP, SEXP, SEXP, SEXP);
SEXP do_getGraphicsEventEnv(SEXP, SEXP, SEXP, SEXP);
......
......@@ -2198,7 +2198,7 @@ SEXP do_math2(SEXP call, SEXP op, SEXP args, SEXP env)
/* The S4 Math2 group, round and signif */
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP do_Math2(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP do_Math2(SEXP call, SEXP op, SEXP args, SEXP env, int variant)
{
SEXP res, call2;
......@@ -2833,8 +2833,8 @@ attribute_hidden FUNTAB R_FunTab_arithmetic[] =
/* Mathematical Functions */
/* primitives: these are group generic and so need to eval args (possibly internally) */
{"round", do_Math2, 10001, 0, -1, {PP_FUNCALL, PREC_FN, 0}},
{"signif", do_Math2, 10004, 0, -1, {PP_FUNCALL, PREC_FN, 0}},
{"round", do_Math2, 10001, 1000, -1, {PP_FUNCALL, PREC_FN, 0}},
{"signif", do_Math2, 10004, 1000, -1, {PP_FUNCALL, PREC_FN, 0}},
{"log", do_log, 10003, 1000, -1, {PP_FUNCALL, PREC_FN, 0}},
{"log10", do_log1arg, 10, 1, 1, {PP_FUNCALL, PREC_FN, 0}},
{"log2", do_log1arg, 2, 1, 1, {PP_FUNCALL, PREC_FN, 0}},
......
......@@ -1641,109 +1641,107 @@ static void check_slot_assign(SEXP obj, SEXP input, SEXP value, SEXP env)
UNPROTECT(3);
}
/* Implements attr(obj, which = "<name>") <- value (op == 0, BUILTIN)
and obj @ <name> <- value (op == 1, SPECIAL)
and `@internal`(obj,name) <- value (op == 2, BUILTIN)
** for internal use only, no validity check **
*/
/* Implements attr(obj, which = "<name>") <- value */
static SEXP do_attrgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
if (PRIMVAL(op) == 1) { /* obj@name <- value, code adapted from R-3.0.0 */
SEXP obj, name, input, ans, value;
PROTECT(input = allocVector(STRSXP, 1));
name = CADR(args);
if (TYPEOF(name) == PROMSXP)
name = PRCODE(name);
if (isSymbol(name))
SET_STRING_ELT(input, 0, PRINTNAME(name));
else if(isString(name) )
SET_STRING_ELT(input, 0, STRING_ELT(name, 0));
else {
error(_("invalid type '%s' for slot name"),
type2char(TYPEOF(name)));
return R_NilValue; /*-Wall*/
}
SEXP obj, name, argList;
static const char * const ap[3] = { "x", "which", "value" };
/* replace the second argument with a string */
SETCADR(args, input);
UNPROTECT(1); /* 'input' is now protected */
checkArity(op, args);
if (DispatchOrEval(call, op, "@<-", args, env, &ans, 0, 0))
return(ans);
obj = CAR(args);
if (NAMEDCNT_GT_1(obj))
PROTECT(obj = dup_top_level(obj));
else
PROTECT(obj);
PROTECT(obj = CAR(ans));
PROTECT(value = CADDR(ans));
check_slot_assign(obj, input, value, env);
obj = R_do_slot_assign(obj, input, value);
/* argument matching */
argList = matchArgs_strings (ap, 3, args, call);
SET_NAMEDCNT_0(obj); /* The standard kludge for subassign primitives */
R_Visible = TRUE;
UNPROTECT(2);
return obj;
PROTECT(argList);
name = CADR(argList);
if (!isValidString(name) || STRING_ELT(name, 0) == NA_STRING)
errorcall(call,_("'name' must be non-null character string"));
/* TODO? if (isFactor(obj) && !strcmp(asChar(name), "levels"))
* --- if(any_duplicated(CADDR(args)))
* error(.....)
*/
setAttrib(obj, name, CADDR(args));
UNPROTECT(2);
return obj;
}
/* Implements obj @ <name> <- value (SPECIAL)
Code adapted from R-3.0.0 */
static SEXP do_ATgets(SEXP call, SEXP op, SEXP args, SEXP env, int variant)
{
SEXP obj, name, input, ans, value;
PROTECT(input = allocVector(STRSXP, 1));
name = CADR(args);
if (TYPEOF(name) == PROMSXP)
name = PRCODE(name);
if (isSymbol(name))
SET_STRING_ELT(input, 0, PRINTNAME(name));
else if(isString(name) )
SET_STRING_ELT(input, 0, STRING_ELT(name, 0));
else {
error(_("invalid type '%s' for slot name"), type2char(TYPEOF(name)));
return R_NilValue; /*-Wall*/
}
else if (PRIMVAL(op) == 2) { /* `@internal`(obj,name) <- value */
/* replace the second argument with a string */
SETCADR(args, input);
UNPROTECT(1); /* 'input' is now protected */
SEXP obj, name, input, value;
if (DispatchOrEval(call, op, "@<-", args, env, &ans, 0, 0))
return(ans);
PROTECT(obj = CAR(args));
PROTECT(value = CADDR(args));
PROTECT(input = allocVector(STRSXP, 1));
PROTECT(obj = CAR(ans));
PROTECT(value = CADDR(ans));
check_slot_assign(obj, input, value, env);
obj = R_do_slot_assign(obj, input, value);
name = CADR(args);
if (TYPEOF(name) == PROMSXP)
name = PRCODE(name);
if (isSymbol(name))
SET_STRING_ELT(input, 0, PRINTNAME(name));
else if(isString(name) )
SET_STRING_ELT(input, 0, STRING_ELT(name, 0));
else {
error(_("invalid type '%s' for slot name"),
type2char(TYPEOF(name)));
return R_NilValue; /*-Wall*/
}
SET_NAMEDCNT_0(obj); /* The standard kludge for subassign primitives */
R_Visible = TRUE;
UNPROTECT(2);
return obj;
}
obj = R_do_slot_assign(obj, input, value);
/* Implements `@internal`(obj,name) <- value
** for internal use only, no validity check **
*/
SET_NAMEDCNT_0(obj); /* The standard kludge for subassign primitives */
UNPROTECT(3);
return obj;
static SEXP do_ATinternalgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP obj, name, input, value;
PROTECT(obj = CAR(args));
PROTECT(value = CADDR(args));
PROTECT(input = allocVector(STRSXP, 1));
name = CADR(args);
if (TYPEOF(name) == PROMSXP)
name = PRCODE(name);
if (isSymbol(name))
SET_STRING_ELT(input, 0, PRINTNAME(name));
else if(isString(name) )
SET_STRING_ELT(input, 0, STRING_ELT(name, 0));
else {
error(_("invalid type '%s' for slot name"),
type2char(TYPEOF(name)));
return R_NilValue; /*-Wall*/
}
else { /* attr(x, which = "<name>") <- value */
obj = R_do_slot_assign(obj, input, value);
SEXP obj, name, argList;
static const char * const ap[3] = { "x", "which", "value" };
checkArity(op, args);
obj = CAR(args);
if (NAMEDCNT_GT_1(obj))
PROTECT(obj = dup_top_level(obj));
else
PROTECT(obj);
/* argument matching */
argList = matchArgs_strings (ap, 3, args, call);
PROTECT(argList);
name = CADR(argList);
if (!isValidString(name) || STRING_ELT(name, 0) == NA_STRING)
errorcall(call,_("'name' must be non-null character string"));
/* TODO? if (isFactor(obj) && !strcmp(asChar(name), "levels"))
* --- if(any_duplicated(CADDR(args)))
* error(.....)
*/
setAttrib(obj, name, CADDR(args));
UNPROTECT(2);
return obj;
}
SET_NAMEDCNT_0(obj); /* The standard kludge for subassign primitives */
UNPROTECT(3);
return obj;
}
......@@ -2006,7 +2004,7 @@ SEXP R_do_slot_assign(SEXP obj, SEXP name, SEXP value)
return obj;
}
static SEXP do_AT(SEXP call, SEXP op, SEXP args, SEXP env)
static SEXP do_AT(SEXP call, SEXP op, SEXP args, SEXP env, int variant)
{
SEXP nlist, object, ans, klass;
......@@ -2118,11 +2116,12 @@ attribute_hidden FUNTAB R_FunTab_attrib[] =
{"attributes<-",do_attributesgets,0, 1, 2, {PP_FUNCALL, PREC_LEFT, 1}},
{"attr", do_attr, 0, 1, -1, {PP_FUNCALL, PREC_FN, 0}},
{"attr<-", do_attrgets, 0, 1, 3, {PP_FUNCALL, PREC_LEFT, 1}},
{"@<-", do_attrgets, 1, 0, 3, {PP_SUBASS, PREC_LEFT, 1}},
{"@internal<-", do_attrgets, 2, 1, 3, {PP_SUBASS, PREC_LEFT, 1}},
{"levels<-", do_levelsgets, 0, 1, 2, {PP_FUNCALL, PREC_LEFT, 1}},
{"@", do_AT, 0, 0, 2, {PP_DOLLAR, PREC_DOLLAR, 0}},
{"@", do_AT, 0, 1000, 2, {PP_DOLLAR, PREC_DOLLAR, 0}},
{"@<-", do_ATgets, 0, 1000, 3, {PP_SUBASS, PREC_LEFT, 1}},
{"@internal<-", do_ATinternalgets, 0, 1, 3, {PP_SUBASS, PREC_LEFT, 1}},
{"set_slot.internal", do_set_slot, 0, 11, 3, {PP_FUNCALL, PREC_FN, }},
{"get_slot.internal", do_get_slot, 0, 11, 2, {PP_FUNCALL, PREC_FN, }},
......
......@@ -260,7 +260,7 @@ static SEXP do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho)
}
/* This is a primitive SPECIALSXP */
static SEXP do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
RCNTXT *ctxt;
SEXP code, oldcode, tmp, argList;
......@@ -817,7 +817,7 @@ static SEXP do_cat(SEXP call, SEXP op, SEXP args, SEXP rho)
return R_NilValue;
}
/* This is BUILTIN for "list" (op 0) and SPECIAL for "expression" (op 1). */
/* This is BUILTIN for "list". */
static SEXP do_makelist(SEXP call, SEXP op, SEXP args, SEXP rho)
{
......@@ -850,6 +850,13 @@ static SEXP do_makelist(SEXP call, SEXP op, SEXP args, SEXP rho)
return list;
}
/* This is SPECIAL for "expression". */
static SEXP do_expression(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
return do_makelist (call, op, args, rho);
}
/* vector(mode="logical", length=0) */
static SEXP do_makevector(SEXP call, SEXP op, SEXP args, SEXP rho)
{
......@@ -1096,7 +1103,7 @@ static SEXP setDflt(SEXP arg, SEXP dflt)
*/
static SEXP do_switch(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_switch(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
int argval, nargs = length(args);
SEXP x, y, z, w, ans, dflt = R_NoObject;
......@@ -1197,7 +1204,7 @@ attribute_hidden FUNTAB R_FunTab_builtin[] =
{"delayedAssign",do_delayed, 0, 111, 4, {PP_FUNCALL, PREC_FN, 0}},
{"makeLazy", do_makelazy, 0, 111, 5, {PP_FUNCALL, PREC_FN, 0}},
{"on.exit", do_onexit, 0, 100, 1, {PP_FUNCALL, PREC_FN, 0}},
{"on.exit", do_onexit, 0, 1100, 1, {PP_FUNCALL, PREC_FN, 0}},
{"args", do_args, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}},
{"formals", do_formals, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}},
{"body", do_body, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}},
......@@ -1209,11 +1216,11 @@ attribute_hidden FUNTAB R_FunTab_builtin[] =
{"parent.env<-",do_parentenvgets, 0, 11, 2, {PP_FUNCALL, PREC_LEFT, 1}},
{"environmentName",do_envirName,0, 11, 1, {PP_FUNCALL, PREC_FN, 0}},
{"cat", do_cat, 0, 111, 6, {PP_FUNCALL, PREC_FN, 0}},
{"expression", do_makelist, 1, 0, -1, {PP_FUNCALL, PREC_FN, 0}},
{"expression", do_expression, 0, 1000, -1, {PP_FUNCALL, PREC_FN, 0}},
{"list", do_makelist, 0, 1, -1, {PP_FUNCALL, PREC_FN, 0}},
{"vector", do_makevector, 0, 11, 2, {PP_FUNCALL, PREC_FN, 0}},
{"length<-", do_lengthgets, 0, 1, 2, {PP_FUNCALL, PREC_LEFT, 1}},
{"switch", do_switch, 0, 200, -1, {PP_FUNCALL, PREC_FN, 0}},
{"switch", do_switch, 0, 1200, -1, {PP_FUNCALL, PREC_FN, 0}},
{"setNumMathThreads", do_setnumthreads, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}},
{"setMaxNumMathThreads", do_setmaxnumthreads,0, 11, 1, {PP_FUNCALL, PREC_FN, 0}},
......
......@@ -2732,7 +2732,7 @@ static SEXP do_isinfinite (SEXP call, SEXP op, SEXP args, SEXP rho,
}
/* This is a primitive SPECIALSXP */
static SEXP do_call(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_call(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
SEXP rest, evargs, rfun;
......@@ -2903,7 +2903,7 @@ SEXP attribute_hidden substituteList(SEXP el, SEXP rho)
/* This is a primitive SPECIALSXP */
static SEXP do_substitute(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_substitute(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
SEXP argList, env, s, t;
static const char * const ap[2] = { "expr", "env" };
......@@ -2933,7 +2933,7 @@ static SEXP do_substitute(SEXP call, SEXP op, SEXP args, SEXP rho)
}
/* This is a primitive SPECIALSXP */
static SEXP do_quote(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_quote(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
checkArity(op, args);
check1arg(args, call, "expr");
......@@ -3188,10 +3188,10 @@ attribute_hidden FUNTAB R_FunTab_coerce[] =
{"is.finite", do_isfinite, 0, 1001, 1, {PP_FUNCALL, PREC_FN, 0}},
{"is.infinite", do_isinfinite, 0, 1001, 1, {PP_FUNCALL, PREC_FN, 0}},
{"call", do_call, 0, 0, -1, {PP_FUNCALL, PREC_FN, 0}},
{"call", do_call, 0, 1000, -1, {PP_FUNCALL, PREC_FN, 0}},
{"do.call", do_docall, 0, 211, 3, {PP_FUNCALL, PREC_FN, 0}},
{"substitute", do_substitute, 0, 0, -1, {PP_FUNCALL, PREC_FN, 0}},
{"quote", do_quote, 0, 0, 1, {PP_FUNCALL, PREC_FN, 0}},
{"substitute", do_substitute, 0, 1000, -1, {PP_FUNCALL, PREC_FN, 0}},
{"quote", do_quote, 0, 1000, 1, {PP_FUNCALL, PREC_FN, 0}},
{"storage.mode<-",do_storage_mode,0, 1, 2, {PP_FUNCALL, PREC_FN, 0}},
{"class<-", R_do_set_class, 0, 1, 2, {PP_FUNCALL, PREC_FN, 0}},
......
......@@ -434,7 +434,8 @@ typedef SEXP (*R_ExternalRoutine)(SEXP);
static SEXP do_External_e (SEXP call, SEXP op, SEXP args, SEXP env);
SEXP attribute_hidden do_External(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP attribute_hidden do_External(SEXP call, SEXP op, SEXP args, SEXP env,
int variant)
{
return do_External_e (call, op, evalListUnshared (args, env), env);
}
......@@ -479,7 +480,8 @@ typedef SEXP (*VarFun)();
static SEXP do_dotcall_e (SEXP call, SEXP op, SEXP args, SEXP env, int evald);
SEXP attribute_hidden do_dotcall (SEXP call, SEXP op, SEXP args, SEXP env)
SEXP attribute_hidden do_dotcall (SEXP call, SEXP op, SEXP args, SEXP env,
int variant)
{
return do_dotcall_e (call, op, args, env, 0);
}
......@@ -1237,7 +1239,8 @@ static SEXP do_dotcall_e (SEXP call, SEXP op, SEXP args, SEXP env, int evald)
to TRUE as per the comment above.
*/
SEXP attribute_hidden do_Externalgr(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP attribute_hidden do_Externalgr(SEXP call, SEXP op, SEXP args, SEXP env,
int variant)
{
SEXP retval;
pGEDevDesc dd = GEcurrentDevice();
......@@ -1258,7 +1261,8 @@ SEXP attribute_hidden do_Externalgr(SEXP call, SEXP op, SEXP args, SEXP env)
return retval;
}
SEXP attribute_hidden do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP attribute_hidden do_dotcallgr(SEXP call, SEXP op, SEXP args, SEXP env,
int variant)
{
SEXP retval;
pGEDevDesc dd = GEcurrentDevice();
......@@ -2729,10 +2733,10 @@ attribute_hidden FUNTAB R_FunTab_dotcode[] =
/* printname c-entry offset eval arity pp-kind precedence rightassoc */
{"is.loaded", do_isloaded, 0, 11, -1, {PP_FOREIGN, PREC_FN, 0}},
{".External", do_External, 0, 0, -1, {PP_FOREIGN, PREC_FN, 0}},
{".Call", do_dotcall, 0, 0, -1, {PP_FOREIGN, PREC_FN, 0}},
{".External.graphics", do_Externalgr, 0, 0, -1, {PP_FOREIGN, PREC_FN, 0}},
{".Call.graphics", do_dotcallgr, 0, 0, -1, {PP_FOREIGN, PREC_FN, 0}},
{".External", do_External, 0, 1000, -1, {PP_FOREIGN, PREC_FN, 0}},
{".Call", do_dotcall, 0, 1000, -1, {PP_FOREIGN, PREC_FN, 0}},
{".External.graphics", do_Externalgr, 0, 1000, -1, {PP_FOREIGN, PREC_FN, 0}},
{".Call.graphics", do_dotcallgr, 0, 1000, -1, {PP_FOREIGN, PREC_FN, 0}},
{".C", do_dotCode, 0, 1000, -1, {PP_FOREIGN, PREC_FN, 0}},
{".Fortran", do_dotCode, 1, 1000, -1, {PP_FOREIGN, PREC_FN, 0}},
......
......@@ -2264,7 +2264,7 @@ static int isMissing_recursive(SEXP symbol, SEXP rho, struct detectcycle *dc)
These are primitive and SPECIALSXP */
static SEXP do_missing(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_missing(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
SEXP t, sym, s;
int under = PRIMVAL(op);
......@@ -3617,8 +3617,8 @@ attribute_hidden FUNTAB R_FunTab_envir[] =
{"get", do_get, 1, 11, 4, {PP_FUNCALL, PREC_FN, 0}},
{"exists", do_get, 0, 11, 4, {PP_FUNCALL, PREC_FN, 0}},
{"mget", do_mget, 1, 11, 5, {PP_FUNCALL, PREC_FN, 0}},
{"missing", do_missing, 0, 0, 1, {PP_FUNCALL, PREC_FN, 0}},
{"missing_from_underline",do_missing,1, 0, 1, {PP_FUNCALL, PREC_FN, 0}},
{"missing", do_missing, 0, 1000, 1, {PP_FUNCALL, PREC_FN, 0}},
{"missing_from_underline",do_missing,1, 1000, 1, {PP_FUNCALL, PREC_FN, 0}},
{"globalenv", do_globalenv, 0, 1, 0, {PP_FUNCALL, PREC_FN, 0}},
{"baseenv", do_baseenv, 0, 1, 0, {PP_FUNCALL, PREC_FN, 0}},
{"emptyenv", do_emptyenv, 0, 1, 0, {PP_FUNCALL, PREC_FN, 0}},
......
......@@ -850,9 +850,10 @@ static SEXP attribute_noinline evalv_other (SEXP e, SEXP rho, int variant)
/* Note: If called from evalv, R_Visible will've been set to TRUE */
if (type_etc == SPECIALSXP) {
res = CALL_PRIMFUN (e, op, args, rho, variant);
/* Note: Special primitives are responsible for setting
R_Visible as desired themselves, with default of TRUE. */
res = PRIMFUNV(op) (e, op, args, rho, variant);
/* Note: Special primitives always take variant argument,
and are responsible for setting R_Visible as desired
themselves, with default of TRUE. */
}
else if (type_etc == BUILTINSXP) {
res = R_Profiling ? Rf_builtin_op(op, e, rho, variant)
......@@ -1503,7 +1504,7 @@ static SEXP do_if (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
if (!bgn && RDEBUG(rho)) start_browser (call, op, body, rho); \
} while (0)
static SEXP do_for (SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_for (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
/* Need to declare volatile variables whose values are relied on
after for_next or for_break longjmps and that might change between
......@@ -1796,7 +1797,7 @@ static SEXP do_for (SEXP call, SEXP op, SEXP args, SEXP rho)
/* While statement. Evaluates body with VARIANT_NULL | VARIANT_PENDING_OK. */
static SEXP do_while(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_while(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
/* Don't check arg count - missing are seen as R_NilValue, extra ignored. */
......@@ -1837,7 +1838,7 @@ static SEXP do_while(SEXP call, SEXP op, SEXP args, SEXP rho)
/* Repeat statement. Evaluates body with VARIANT_NULL | VARIANT_PENDING_OK. */
static SEXP do_repeat(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_repeat(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
/* Don't check arg count - missing are seen as R_NilValue, extra ignored. */
......@@ -1872,7 +1873,8 @@ static SEXP do_repeat(SEXP call, SEXP op, SEXP args, SEXP rho)
/* "break" */
static R_NORETURN SEXP do_break(SEXP call, SEXP op, SEXP args, SEXP rho)
static R_NORETURN SEXP do_break(SEXP call, SEXP op, SEXP args, SEXP rho,
int variant)
{
findcontext (CTXT_BREAK, rho, R_NilValue);
}
......@@ -1880,7 +1882,8 @@ static R_NORETURN SEXP do_break(SEXP call, SEXP op, SEXP args, SEXP rho)
/* "next" */
static R_NORETURN SEXP do_next(SEXP call, SEXP op, SEXP args, SEXP rho)
static R_NORETURN SEXP do_next(SEXP call, SEXP op, SEXP args, SEXP rho,
int variant)
{
findcontext (CTXT_NEXT, rho, R_NilValue);
}
......@@ -3468,7 +3471,7 @@ void attribute_hidden CheckFormals(SEXP ls)
}
/* Declared with a variable number of args in names.c */
static SEXP do_function(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_function(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
SEXP rval, srcref;
......@@ -3966,7 +3969,8 @@ SEXP attribute_hidden do_not(SEXP call, SEXP op, SEXP args, SEXP env,
/* Handles the && (op 1) and || (op 2) operators. */
SEXP attribute_hidden do_andor2(SEXP call, SEXP op, SEXP args, SEXP env)
SEXP attribute_hidden do_andor2(SEXP call, SEXP op, SEXP args, SEXP env,
int variant)
{
int ov = PRIMVAL(op);
......@@ -5178,15 +5182,15 @@ attribute_hidden FUNTAB R_FunTab_eval[] =
/* printname c-entry offset eval arity pp-kind precedence rightassoc */
{"if", do_if, 0, 1200, -1, {PP_IF, PREC_FN, 1}},
{"for", do_for, 0, 100, -1, {PP_FOR, PREC_FN, 0}},
{"while", do_while, 0, 100, -1, {PP_WHILE, PREC_FN, 0}},
{"repeat", do_repeat, 0, 100, -1, {PP_REPEAT, PREC_FN, 0}},
{"break", do_break, 0, 0, -1, {PP_BREAK, PREC_FN, 0}},
{"next", do_next, 0, 0, -1, {PP_NEXT, PREC_FN, 0}},
{"for", do_for, 0, 1100, -1, {PP_FOR, PREC_FN, 0}},
{"while", do_while, 0, 1100, -1, {PP_WHILE, PREC_FN, 0}},
{"repeat", do_repeat, 0, 1100, -1, {PP_REPEAT, PREC_FN, 0}},
{"break", do_break, 0, 1000, -1, {PP_BREAK, PREC_FN, 0}},
{"next", do_next, 0, 1000, -1, {PP_NEXT, PREC_FN, 0}},
{"(", do_paren, 0, 1000, 1, {PP_PAREN, PREC_FN, 0}},
{"{", do_begin, 0, 1200, -1, {PP_CURLY, PREC_FN, 0}},
{"return", do_return, 0, 1200, -1, {PP_RETURN, PREC_FN, 0}},
{"function", do_function, 0, 0, -1, {PP_FUNCTION,PREC_FN, 0}},
{"function", do_function, 0, 1000, -1, {PP_FUNCTION,PREC_FN, 0}},
{"<-", do_set, 1, 1100, 2, {PP_ASSIGN, PREC_LEFT, 1}},
{"=", do_set, 3, 1100, 2, {PP_ASSIGN, PREC_EQ, 1}},
{"<<-", do_set, 2, 1100, 2, {PP_ASSIGN2, PREC_LEFT, 1}},
......@@ -5206,8 +5210,8 @@ attribute_hidden FUNTAB R_FunTab_eval[] =
{"!", do_not, 1, 1001, 1, {PP_UNARY, PREC_NOT, 0}},
/* specials as conditionally evaluate second arg */
{"&&", do_andor2, 1, 0, 2, {PP_BINARY, PREC_AND, 0}},
{"||", do_andor2, 2, 0, 2, {PP_BINARY, PREC_OR, 0}},
{"&&", do_andor2, 1, 1000, 2, {PP_BINARY, PREC_AND, 0}},
{"||", do_andor2, 2, 1000, 2, {PP_BINARY, PREC_OR, 0}},
/* these are group generic and so need to eval args */
{"all", do_allany, 1, 1, -1, {PP_FUNCALL, PREC_FN, 0}},
......
......@@ -1478,7 +1478,7 @@ static SEXP do_modelframe(SEXP call, SEXP op, SEXP args, SEXP rho)
/* Just returns the unevaluated call */
/* No longer needed??? */
static SEXP do_tilde(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_tilde(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
if (isObject(call))
return duplicate(call);
......@@ -2010,7 +2010,7 @@ attribute_hidden FUNTAB R_FunTab_model[] =
{"terms.formula",do_termsform, 0, 11, 5, {PP_FUNCALL, PREC_FN, 0}},
{"update.formula",do_updateform,0, 11, 2, {PP_FUNCALL, PREC_FN, 0}},
{"model.frame", do_modelframe, 0, 11, 8, {PP_FUNCALL, PREC_FN, 0}},
{"~", do_tilde, 0, 0, 2, {PP_BINARY, PREC_TILDE, 0}},
{"~", do_tilde, 0, 1000, 2, {PP_BINARY, PREC_TILDE, 0}},
{"model.matrix",do_modelmatrix, 0, 11, 2, {PP_FUNCALL, PREC_FN, 0}},
{NULL, NULL, 0, 0, 0, {PP_INVALID, PREC_FN, 0}}
......
......@@ -587,6 +587,13 @@ static void SetupBuiltins(void)
PRIMINTERNAL(prim), PRIMPRINT(prim), PRIMPENDINGOK(prim));
}
if (TYPEOF(prim) == SPECIALSXP && !PRIMINTERNAL(prim)
&& !PRIMVARIANT(prim)) {
REprintf("SPECIAL primitive must take a 'variant' argument: %s\n",
PRIMNAME(prim));
/* abort(); */
}
SEXP sym = install(R_FunTab[i].name);
if ((R_FunTab[i].eval % 100) / 10) {
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment