in source/src/main/eval.c [5171:6148]
static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
{
SEXP value = R_NilValue, constants;
BCODE *pc, *codebase;
R_bcstack_t *oldntop = R_BCNodeStackTop;
static int evalcount = 0;
#ifdef BC_INT_STACK
IStackval *olditop = R_BCIntStackTop;
#endif
#ifdef BC_PROFILING
int old_current_opcode = current_opcode;
#endif
#ifdef THREADED_CODE
int which = 0;
#endif
BC_CHECK_SIGINT();
INITIALIZE_MACHINE();
codebase = pc = BCCODE(body);
constants = BCCONSTS(body);
/* allow bytecode to be disabled for testing */
if (R_disable_bytecode)
return eval(bytecodeExpr(body), rho);
/* check version */
{
int version = GETOP();
if (version < R_bcMinVersion || version > R_bcVersion) {
if (version >= 2) {
static Rboolean warned = FALSE;
if (! warned) {
warned = TRUE;
warning(_("bytecode version mismatch; using eval"));
}
return eval(bytecodeExpr(body), rho);
}
else if (version < R_bcMinVersion)
error(_("bytecode version is too old"));
else error(_("bytecode version is too new"));
}
}
R_binding_cache_t vcache = NULL;
Rboolean smallcache = TRUE;
#ifdef USE_BINDING_CACHE
if (useCache) {
R_len_t n = LENGTH(constants);
# ifdef CACHE_MAX
if (n > CACHE_MAX) {
n = CACHE_MAX;
smallcache = FALSE;
}
# endif
# ifdef CACHE_ON_STACK
/* initialize binding cache on the stack */
vcache = R_BCNodeStackTop;
if (R_BCNodeStackTop + n > R_BCNodeStackEnd)
nodeStackOverflow();
while (n > 0) {
SETSTACK(0, R_NilValue);
R_BCNodeStackTop++;
n--;
}
# else
/* allocate binding cache and protect on stack */
vcache = allocVector(VECSXP, n);
BCNPUSH(vcache);
# endif
}
#endif
BEGIN_MACHINE {
OP(BCMISMATCH, 0): error(_("byte code version mismatch"));
OP(RETURN, 0): value = GETSTACK(-1); goto done;
OP(GOTO, 1):
{
int label = GETOP();
BC_CHECK_SIGINT();
pc = codebase + label;
NEXT();
}
OP(BRIFNOT, 2):
{
int callidx = GETOP();
int label = GETOP();
Rboolean cond = GETSTACK_LOGICAL_NO_NA_PTR(R_BCNodeStackTop - 1,
callidx, constants);
BCNPOP_IGNORE_VALUE();
if (! cond) {
BC_CHECK_SIGINT(); /**** only on back branch?*/
pc = codebase + label;
}
NEXT();
}
OP(POP, 0): BCNPOP_IGNORE_VALUE(); NEXT();
OP(DUP, 0): BCNDUP(); NEXT();
OP(PRINTVALUE, 0): PrintValue(BCNPOP()); NEXT();
OP(STARTLOOPCNTXT, 1):
{
SEXP code = VECTOR_ELT(constants, GETOP());
loopWithContext(code, rho);
NEXT();
}
OP(ENDLOOPCNTXT, 0): value = R_NilValue; goto done;
OP(DOLOOPNEXT, 0): findcontext(CTXT_NEXT, rho, R_NilValue);
OP(DOLOOPBREAK, 0): findcontext(CTXT_BREAK, rho, R_NilValue);
OP(STARTFOR, 3):
{
Rboolean iscompact = FALSE;
SEXP seq = getForLoopSeq(-1, &iscompact);
int callidx = GETOP();
SEXP symbol = VECTOR_ELT(constants, GETOP());
int label = GETOP();
/* if we are iterating over a factor, coerce to character first */
if (inherits(seq, "factor")) {
seq = asCharacterFactor(seq);
SETSTACK(-1, seq);
}
defineVar(symbol, R_NilValue, rho);
BCNPUSH(GET_BINDING_CELL(symbol, rho));
value = allocVector(INTSXP, 2);
INTEGER(value)[0] = -1;
#ifdef COMPACT_INTSEQ
if (iscompact) {
int n1 = INTEGER(seq)[0];
int n2 = INTEGER(seq)[1];
INTEGER(value)[1] = n1 <= n2 ? n2 - n1 + 1 : n1 - n2 + 1;
}
else
#endif
if (isVector(seq))
INTEGER(value)[1] = LENGTH(seq);
else if (isList(seq) || isNull(seq))
INTEGER(value)[1] = length(seq);
else errorcall(VECTOR_ELT(constants, callidx),
_("invalid for() loop sequence"));
BCNPUSH(value);
/* bump up NAMED count of seq to avoid modification by loop code */
INCREMENT_NAMED(seq);
INCREMENT_REFCNT(seq);
/* place initial loop variable value object on stack */
switch(TYPEOF(seq)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
value = allocVector(TYPEOF(seq), 1);
SET_NAMED(value, 1);
BCNPUSH(value);
break;
default: BCNPUSH(R_NilValue);
}
BC_CHECK_SIGINT();
pc = codebase + label;
NEXT();
}
OP(STEPFOR, 1):
{
int label = GETOP();
int *loopinfo = INTEGER(GETSTACK_SXPVAL(-2));
int i = ++loopinfo[0];
int n = loopinfo[1];
if (i < n) {
Rboolean iscompact = FALSE;
SEXP seq = getForLoopSeq(-4, &iscompact);
SEXP cell = GETSTACK(-3);
switch (TYPEOF(seq)) {
case LGLSXP:
GET_VEC_LOOP_VALUE(value, -1);
LOGICAL(value)[0] = LOGICAL(seq)[i];
break;
case INTSXP:
GET_VEC_LOOP_VALUE(value, -1);
#ifdef COMPACT_INTSEQ
if (iscompact) {
int *info = INTEGER(seq);
int n1 = info[0];
int n2 = info[1];
int val = n1 <= n2 ? n1 + i : n1 - i;
INTEGER(value)[0] = val;
}
else
#endif
INTEGER(value)[0] = INTEGER(seq)[i];
break;
case REALSXP:
GET_VEC_LOOP_VALUE(value, -1);
REAL(value)[0] = REAL(seq)[i];
break;
case CPLXSXP:
GET_VEC_LOOP_VALUE(value, -1);
COMPLEX(value)[0] = COMPLEX(seq)[i];
break;
case STRSXP:
GET_VEC_LOOP_VALUE(value, -1);
SET_STRING_ELT(value, 0, STRING_ELT(seq, i));
break;
case RAWSXP:
GET_VEC_LOOP_VALUE(value, -1);
RAW(value)[0] = RAW(seq)[i];
break;
case EXPRSXP:
case VECSXP:
value = VECTOR_ELT(seq, i);
SET_NAMED(value, 2);
break;
case LISTSXP:
value = CAR(seq);
SETSTACK(-4, CDR(seq));
SET_NAMED(value, 2);
break;
default:
error(_("invalid sequence argument in for loop"));
}
if (CAR(cell) == R_UnboundValue || ! SET_BINDING_VALUE(cell, value))
defineVar(BINDING_SYMBOL(cell), value, rho);
BC_CHECK_SIGINT();
pc = codebase + label;
}
NEXT();
}
OP(ENDFOR, 0):
{
#ifdef COMPUTE_REFCNT_VALUES
Rboolean iscompact = FALSE;
SEXP seq = getForLoopSeq(-4, &iscompact);
DECREMENT_REFCNT(seq);
#endif
R_BCNodeStackTop -= 3;
SETSTACK(-1, R_NilValue);
NEXT();
}
OP(SETLOOPVAL, 0):
BCNPOP_IGNORE_VALUE(); SETSTACK(-1, R_NilValue); NEXT();
OP(INVISIBLE,0): R_Visible = FALSE; NEXT();
OP(LDCONST, 1):
R_Visible = TRUE;
value = VECTOR_ELT(constants, GETOP());
MARK_NOT_MUTABLE(value);
BCNPUSH(value);
NEXT();
OP(LDNULL, 0): R_Visible = TRUE; BCNPUSH(R_NilValue); NEXT();
OP(LDTRUE, 0): R_Visible = TRUE; BCNPUSH(R_TrueValue); NEXT();
OP(LDFALSE, 0): R_Visible = TRUE; BCNPUSH(R_FalseValue); NEXT();
OP(GETVAR, 1): DO_GETVAR(FALSE, FALSE);
OP(DDVAL, 1): DO_GETVAR(TRUE, FALSE);
OP(SETVAR, 1):
{
int sidx = GETOP();
SEXP loc;
if (smallcache)
loc = GET_SMALLCACHE_BINDING_CELL(vcache, sidx);
else {
SEXP symbol = VECTOR_ELT(constants, sidx);
loc = GET_BINDING_CELL_CACHE(symbol, rho, vcache, sidx);
}
#ifdef TYPED_STACK
R_bcstack_t *s = R_BCNodeStackTop - 1;
/* reading the locked bit is OK even if cell is R_NilValue */
if (s->tag && ! BINDING_IS_LOCKED(loc)) {
/* if cell is R_NilValue or an active binding, or if the value
is R_UnboundValue, then TYPEOF(CAR(cell)) will not match the
immediate value tag. */
SEXP x = CAR(loc); /* fast, but assumes binding is a CONS */
if (NOT_SHARED(x) && IS_SIMPLE_SCALAR(x, s->tag)) {
/* if the binding value is not shared and is a simple
scaler of the same type as the immediate value,
then we can copy the stack value into the binding
value */
switch (s->tag) {
case REALSXP: REAL(x)[0] = s->u.dval; NEXT();
case INTSXP: INTEGER(x)[0] = s->u.ival; NEXT();
case LGLSXP: LOGICAL(x)[0] = s->u.ival; NEXT();
}
}
}
#endif
value = GETSTACK(-1);
INCREMENT_NAMED(value);
if (! SET_BINDING_VALUE(loc, value)) {
SEXP symbol = VECTOR_ELT(constants, sidx);
PROTECT(value);
defineVar(symbol, value, rho);
UNPROTECT(1);
}
NEXT();
}
OP(GETFUN, 1):
{
/* get the function */
SEXP symbol = VECTOR_ELT(constants, GETOP());
value = findFun(symbol, rho);
INIT_CALL_FRAME(value);
if(RTRACE(value)) {
Rprintf("trace: ");
PrintValue(symbol);
}
NEXT();
}
OP(GETGLOBFUN, 1):
{
/* get the function */
SEXP symbol = VECTOR_ELT(constants, GETOP());
value = findFun(symbol, R_GlobalEnv);
INIT_CALL_FRAME(value);
if(RTRACE(value)) {
Rprintf("trace: ");
PrintValue(symbol);
}
NEXT();
}
OP(GETSYMFUN, 1):
{
/* get the function */
SEXP symbol = VECTOR_ELT(constants, GETOP());
value = SYMVALUE(symbol);
if (TYPEOF(value) == PROMSXP) {
value = forcePromise(value);
SET_NAMED(value, 2);
}
if(RTRACE(value)) {
Rprintf("trace: ");
PrintValue(symbol);
}
INIT_CALL_FRAME(value);
NEXT();
}
OP(GETBUILTIN, 1):
{
/* get the function */
SEXP symbol = VECTOR_ELT(constants, GETOP());
value = getPrimitive(symbol, BUILTINSXP);
//#define REPORT_OVERRIDEN_BUILTINS
#ifdef REPORT_OVERRIDEN_BUILTINS
if (value != findFun(symbol, rho)) {
Rprintf("Possibly overriden builtin: %s\n", PRIMNAME(value));
}
#endif
if (RTRACE(value)) {
Rprintf("trace: ");
PrintValue(symbol);
}
INIT_CALL_FRAME(value);
NEXT();
}
OP(GETINTLBUILTIN, 1):
{
/* get the function */
SEXP symbol = VECTOR_ELT(constants, GETOP());
value = INTERNAL(symbol);
if (TYPEOF(value) != BUILTINSXP)
error(_("there is no .Internal function '%s'"),
CHAR(PRINTNAME(symbol)));
INIT_CALL_FRAME(value);
NEXT();
}
OP(CHECKFUN, 0):
{
/* check then the value on the stack is a function */
value = GETSTACK(-1);
if (TYPEOF(value) != CLOSXP && TYPEOF(value) != BUILTINSXP &&
TYPEOF(value) != SPECIALSXP)
error(_("attempt to apply non-function"));
INIT_CALL_FRAME_ARGS();
NEXT();
}
OP(MAKEPROM, 1):
{
SEXP code = VECTOR_ELT(constants, GETOP());
SEXPTYPE ftype = CALL_FRAME_FTYPE();
if (ftype != SPECIALSXP) {
if (ftype == BUILTINSXP)
value = bcEval(code, rho, TRUE);
else
value = mkPROMISE(code, rho);
PUSHCALLARG(value);
}
NEXT();
}
OP(DOMISSING, 0):
{
SEXPTYPE ftype = CALL_FRAME_FTYPE();
if (ftype != SPECIALSXP)
PUSHCALLARG(R_MissingArg);
NEXT();
}
OP(SETTAG, 1):
{
SEXPTYPE ftype = CALL_FRAME_FTYPE();
int tagidx = GETOP();
if (ftype != SPECIALSXP) {
SEXP tag = VECTOR_ELT(constants, tagidx);
SETCALLARG_TAG(tag);
}
NEXT();
}
OP(DODOTS, 0):
{
SEXPTYPE ftype = CALL_FRAME_FTYPE();
if (ftype != SPECIALSXP) {
SEXP h = findVar(R_DotsSymbol, rho);
if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
PROTECT(h);
for (; h != R_NilValue; h = CDR(h)) {
SEXP val;
if (ftype == BUILTINSXP) val = eval(CAR(h), rho);
else val = mkPROMISE(CAR(h), rho);
PUSHCALLARG(val);
SETCALLARG_TAG(TAG(h));
}
UNPROTECT(1); /* h */
}
else if (h != R_MissingArg)
error(_("'...' used in an incorrect context"));
}
NEXT();
}
OP(PUSHARG, 0): PUSHCALLARG(BCNPOP()); NEXT();
/**** for now PUSHCONST, PUSHTRUE, and PUSHFALSE duplicate/allocate to
be defensive against bad package C code */
OP(PUSHCONSTARG, 1):
value = VECTOR_ELT(constants, GETOP());
MARK_NOT_MUTABLE(value);
PUSHCALLARG(value);
NEXT();
OP(PUSHNULLARG, 0): PUSHCALLARG(R_NilValue); NEXT();
OP(PUSHTRUEARG, 0): PUSHCALLARG(R_TrueValue); NEXT();
OP(PUSHFALSEARG, 0): PUSHCALLARG(R_FalseValue); NEXT();
OP(CALL, 1):
{
SEXP fun = CALL_FRAME_FUN();
SEXP call = VECTOR_ELT(constants, GETOP());
SEXP args = CALL_FRAME_ARGS();
int flag;
switch (TYPEOF(fun)) {
case BUILTINSXP:
checkForMissings(args, call);
flag = PRIMPRINT(fun);
R_Visible = flag != 1;
value = PRIMFUN(fun) (call, fun, args, rho);
if (flag < 2) R_Visible = flag != 1;
break;
case SPECIALSXP:
flag = PRIMPRINT(fun);
R_Visible = flag != 1;
value = PRIMFUN(fun) (call, fun, markSpecialArgs(CDR(call)), rho);
if (flag < 2) R_Visible = flag != 1;
break;
case CLOSXP:
value = applyClosure(call, fun, args, rho, R_NilValue);
break;
default: error(_("bad function"));
}
POP_CALL_FRAME(value);
NEXT();
}
OP(CALLBUILTIN, 1):
{
SEXP fun = CALL_FRAME_FUN();
SEXP call = VECTOR_ELT(constants, GETOP());
SEXP args = CALL_FRAME_ARGS();
int flag;
const void *vmax = vmaxget();
if (TYPEOF(fun) != BUILTINSXP)
error(_("not a BUILTIN function"));
flag = PRIMPRINT(fun);
R_Visible = flag != 1;
if (R_Profiling && IS_TRUE_BUILTIN(fun)) {
RCNTXT cntxt;
SEXP oldref = R_Srcref;
begincontext(&cntxt, CTXT_BUILTIN, call,
R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue);
R_Srcref = NULL;
value = PRIMFUN(fun) (call, fun, args, rho);
R_Srcref = oldref;
endcontext(&cntxt);
} else {
value = PRIMFUN(fun) (call, fun, args, rho);
}
if (flag < 2) R_Visible = flag != 1;
vmaxset(vmax);
POP_CALL_FRAME(value);
NEXT();
}
OP(CALLSPECIAL, 1):
{
SEXP call = VECTOR_ELT(constants, GETOP());
SEXP symbol = CAR(call);
SEXP fun = getPrimitive(symbol, SPECIALSXP);
int flag;
const void *vmax = vmaxget();
if (RTRACE(fun)) {
Rprintf("trace: ");
PrintValue(symbol);
}
flag = PRIMPRINT(fun);
R_Visible = flag != 1;
value = PRIMFUN(fun) (call, fun, markSpecialArgs(CDR(call)), rho);
if (flag < 2) R_Visible = flag != 1;
vmaxset(vmax);
BCNPUSH(value);
NEXT();
}
OP(MAKECLOSURE, 1):
{
SEXP fb = VECTOR_ELT(constants, GETOP());
SEXP forms = VECTOR_ELT(fb, 0);
SEXP body = VECTOR_ELT(fb, 1);
value = mkCLOSXP(forms, body, rho);
BCNPUSH(value);
NEXT();
}
OP(UMINUS, 1): FastUnary(-, R_SubSym);
OP(UPLUS, 1): FastUnary(+, R_AddSym);
OP(ADD, 1): FastBinary(R_ADD, PLUSOP, R_AddSym);
OP(SUB, 1): FastBinary(R_SUB, MINUSOP, R_SubSym);
OP(MUL, 1): FastBinary(R_MUL, TIMESOP, R_MulSym);
OP(DIV, 1): FastBinary(R_DIV, DIVOP, R_DivSym);
OP(EXPT, 1): FastBinary(R_POW, POWOP, R_ExptSym);
OP(SQRT, 1): FastMath1(R_sqrt, R_SqrtSym);
OP(EXP, 1): FastMath1(exp, R_ExpSym);
OP(EQ, 1): FastRelop2(==, EQOP, R_EqSym);
OP(NE, 1): FastRelop2(!=, NEOP, R_NeSym);
OP(LT, 1): FastRelop2(<, LTOP, R_LtSym);
OP(LE, 1): FastRelop2(<=, LEOP, R_LeSym);
OP(GE, 1): FastRelop2(>=, GEOP, R_GeSym);
OP(GT, 1): FastRelop2(>, GTOP, R_GtSym);
OP(AND, 1): Builtin2(do_logic, R_AndSym, rho);
OP(OR, 1): Builtin2(do_logic, R_OrSym, rho);
OP(NOT, 1): Builtin1(do_logic, R_NotSym, rho);
OP(DOTSERR, 0): error(_("'...' used in an incorrect context"));
OP(STARTASSIGN, 1):
{
int sidx = GETOP();
SEXP symbol = VECTOR_ELT(constants, sidx);
SEXP cell = GET_BINDING_CELL_CACHE(symbol, rho, vcache, sidx);
value = BINDING_VALUE(cell);
if (value == R_UnboundValue ||
TYPEOF(value) == PROMSXP ||
#ifdef SWITCH_TO_REFCNT
REFCNT(value) != 1
#else
NAMED(value) != 1
#endif
)
value = EnsureLocal(symbol, rho);
BCNPUSH(value);
BCNDUP2ND();
/* top three stack entries are now RHS value, LHS value, RHS value */
if (IS_STACKVAL_BOXED(-1)) {
FIXUP_RHS_NAMED(GETSTACK(-1));
INCREMENT_REFCNT(GETSTACK(-1));
}
NEXT();
}
OP(ENDASSIGN, 1):
{
int sidx = GETOP();
SEXP symbol = VECTOR_ELT(constants, sidx);
SEXP cell = GET_BINDING_CELL_CACHE(symbol, rho, vcache, sidx);
value = GETSTACK(-1); /* leave on stack for GC protection */
INCREMENT_NAMED(value);
if (! SET_BINDING_VALUE(cell, value))
defineVar(symbol, value, rho);
R_BCNodeStackTop--; /* now pop LHS value off the stack */
/* original right-hand side value is now on top of stack again */
#ifdef OLD_RHS_NAMED
/* we do not duplicate the right-hand side value, so to be
conservative mark the value as NAMED = 2 */
SET_NAMED(GETSTACK(-1), 2);
#else
if (IS_STACKVAL_BOXED(-1)) {
INCREMENT_NAMED(GETSTACK(-1));
DECREMENT_REFCNT(GETSTACK(-1));
}
#endif
NEXT();
}
OP(STARTSUBSET, 2): DO_STARTDISPATCH("[");
OP(DFLTSUBSET, 0): DO_DFLTDISPATCH(do_subset_dflt, R_SubsetSym);
OP(STARTSUBASSIGN, 2): DO_START_ASSIGN_DISPATCH("[<-");
OP(DFLTSUBASSIGN, 0):
DO_DFLT_ASSIGN_DISPATCH(do_subassign_dflt, R_SubassignSym);
OP(STARTC, 2): DO_STARTDISPATCH("c");
OP(DFLTC, 0): DO_DFLTDISPATCH(do_c_dflt, R_CSym);
OP(STARTSUBSET2, 2): DO_STARTDISPATCH("[[");
OP(DFLTSUBSET2, 0): DO_DFLTDISPATCH(do_subset2_dflt, R_Subset2Sym);
OP(STARTSUBASSIGN2, 2): DO_START_ASSIGN_DISPATCH("[[<-");
OP(DFLTSUBASSIGN2, 0):
DO_DFLT_ASSIGN_DISPATCH(do_subassign2_dflt, R_Subassign2Sym);
OP(DOLLAR, 2):
{
int dispatched = FALSE;
SEXP call = VECTOR_ELT(constants, GETOP());
SEXP symbol = VECTOR_ELT(constants, GETOP());
SEXP x = GETSTACK(-1);
if (isObject(x)) {
SEXP ncall;
PROTECT(ncall = duplicate(call));
/**** hack to avoid evaluating the symbol */
SETCAR(CDDR(ncall), ScalarString(PRINTNAME(symbol)));
dispatched = tryDispatch("$", ncall, x, rho, &value);
UNPROTECT(1);
}
if (dispatched)
SETSTACK(-1, value);
else
SETSTACK(-1, R_subset3_dflt(x, PRINTNAME(symbol), R_NilValue));
NEXT();
}
OP(DOLLARGETS, 2):
{
int dispatched = FALSE;
SEXP call = VECTOR_ELT(constants, GETOP());
SEXP symbol = VECTOR_ELT(constants, GETOP());
SEXP x = GETSTACK(-2);
SEXP rhs = GETSTACK(-1);
if (MAYBE_SHARED(x)) {
x = shallow_duplicate(x);
SETSTACK(-2, x);
SET_NAMED(x, 1);
}
if (isObject(x)) {
SEXP ncall, prom;
PROTECT(ncall = duplicate(call));
/**** hack to avoid evaluating the symbol */
SETCAR(CDDR(ncall), ScalarString(PRINTNAME(symbol)));
prom = mkRHSPROMISE(CADDDR(ncall), rhs);
SETCAR(CDDDR(ncall), prom);
dispatched = tryDispatch("$<-", ncall, x, rho, &value);
UNPROTECT(1);
}
if (! dispatched)
value = R_subassign3_dflt(call, x, symbol, rhs);
R_BCNodeStackTop--;
SETSTACK(-1, value);
NEXT();
}
OP(ISNULL, 0): DO_ISTEST(isNull);
OP(ISLOGICAL, 0): DO_ISTYPE(LGLSXP);
OP(ISINTEGER, 0): {
SEXP arg = GETSTACK(-1);
Rboolean test = (TYPEOF(arg) == INTSXP) && ! inherits(arg, "factor");
SETSTACK(-1, test ? R_TrueValue : R_FalseValue);
NEXT();
}
OP(ISDOUBLE, 0): DO_ISTYPE(REALSXP);
OP(ISCOMPLEX, 0): DO_ISTYPE(CPLXSXP);
OP(ISCHARACTER, 0): DO_ISTYPE(STRSXP);
OP(ISSYMBOL, 0): DO_ISTYPE(SYMSXP); /**** S4 thingy allowed now???*/
OP(ISOBJECT, 0): DO_ISTEST(OBJECT);
OP(ISNUMERIC, 0): DO_ISTEST(isNumericOnly);
OP(VECSUBSET, 1): DO_VECSUBSET(rho, FALSE); NEXT();
OP(MATSUBSET, 1): DO_MATSUBSET(rho, FALSE); NEXT();
OP(VECSUBASSIGN, 1): DO_VECSUBASSIGN(rho, FALSE); NEXT();
OP(MATSUBASSIGN, 1): DO_MATSUBASSIGN(rho, FALSE); NEXT();
OP(AND1ST, 2): {
int callidx = GETOP();
int label = GETOP();
FIXUP_SCALAR_LOGICAL(callidx, "'x'", "&&");
value = GETSTACK(-1);
if (LOGICAL(value)[0] == FALSE)
pc = codebase + label;
NEXT();
}
OP(AND2ND, 1): {
int callidx = GETOP();
FIXUP_SCALAR_LOGICAL(callidx, "'y'", "&&");
value = GETSTACK(-1);
/* The first argument is TRUE or NA. If the second argument is
not TRUE then its value is the result. If the second
argument is TRUE, then the first argument's value is the
result. */
if (LOGICAL(value)[0] != TRUE)
SETSTACK(-2, value);
R_BCNodeStackTop -= 1;
NEXT();
}
OP(OR1ST, 2): {
int callidx = GETOP();
int label = GETOP();
FIXUP_SCALAR_LOGICAL(callidx, "'x'", "||");
value = GETSTACK(-1);
if (LOGICAL(value)[0] != NA_LOGICAL && LOGICAL(value)[0]) /* is true */
pc = codebase + label;
NEXT();
}
OP(OR2ND, 1): {
int callidx = GETOP();
FIXUP_SCALAR_LOGICAL(callidx, "'y'", "||");
value = GETSTACK(-1);
/* The first argument is FALSE or NA. If the second argument is
not FALSE then its value is the result. If the second
argument is FALSE, then the first argument's value is the
result. */
if (LOGICAL(value)[0] != FALSE)
SETSTACK(-2, value);
R_BCNodeStackTop -= 1;
NEXT();
}
OP(GETVAR_MISSOK, 1): DO_GETVAR(FALSE, TRUE);
OP(DDVAL_MISSOK, 1): DO_GETVAR(TRUE, TRUE);
OP(VISIBLE, 0): R_Visible = TRUE; NEXT();
OP(SETVAR2, 1):
{
SEXP symbol = VECTOR_ELT(constants, GETOP());
value = GETSTACK(-1);
if (MAYBE_REFERENCED(value)) {
value = duplicate(value);
SETSTACK(-1, value);
}
setVar(symbol, value, ENCLOS(rho));
NEXT();
}
OP(STARTASSIGN2, 1):
{
SEXP symbol = VECTOR_ELT(constants, GETOP());
value = GETSTACK(-1);
BCNPUSH(getvar(symbol, ENCLOS(rho), FALSE, FALSE, NULL, 0));
BCNPUSH(value);
/* top three stack entries are now RHS value, LHS value, RHS value */
FIXUP_RHS_NAMED(value);
INCREMENT_REFCNT(value);
NEXT();
}
OP(ENDASSIGN2, 1):
{
SEXP symbol = VECTOR_ELT(constants, GETOP());
value = BCNPOP();
INCREMENT_NAMED(value);
setVar(symbol, value, ENCLOS(rho));
/* original right-hand side value is now on top of stack again */
#ifdef OLD_RHS_NAMED
/* we do not duplicate the right-hand side value, so to be
conservative mark the value as NAMED = 2 */
SET_NAMED(GETSTACK(-1), 2);
#else
INCREMENT_NAMED(GETSTACK(-1));
#endif
DECREMENT_REFCNT(GETSTACK(-1));
NEXT();
}
OP(SETTER_CALL, 2):
{
SEXP lhs = GETSTACK_BELOW_CALL_FRAME(-2);
SEXP rhs = GETSTACK_BELOW_CALL_FRAME(-1);
SEXP fun = CALL_FRAME_FUN();
SEXP call = VECTOR_ELT(constants, GETOP());
SEXP vexpr = VECTOR_ELT(constants, GETOP());
SEXP args, prom, last;
if (MAYBE_SHARED(lhs)) {
lhs = shallow_duplicate(lhs);
SETSTACK_BELOW_CALL_FRAME(-2, lhs);
SET_NAMED(lhs, 1);
}
switch (TYPEOF(fun)) {
case BUILTINSXP:
/* push RHS value onto arguments with 'value' tag */
PUSHCALLARG(rhs);
SETCALLARG_TAG_SYMBOL(R_valueSym);
/* replace first argument with LHS value */
args = CALL_FRAME_ARGS();
SETCAR(args, lhs);
/* make the call */
checkForMissings(args, call);
value = PRIMFUN(fun) (call, fun, args, rho);
break;
case SPECIALSXP:
/* duplicate arguments and protect */
PROTECT(args = duplicate(CDR(call)));
/* insert evaluated promise for LHS as first argument */
/* promise won't be captured so don't track references */
prom = R_mkEVPROMISE_NR(R_TmpvalSymbol, lhs);
SETCAR(args, prom);
/* insert evaluated promise for RHS as last argument */
last = args;
while (CDR(last) != R_NilValue)
last = CDR(last);
prom = mkRHSPROMISE(vexpr, rhs);
SETCAR(last, prom);
/* make the call */
value = PRIMFUN(fun) (call, fun, args, rho);
UNPROTECT(1);
break;
case CLOSXP:
/* push evaluated promise for RHS onto arguments with 'value' tag */
prom = mkRHSPROMISE(vexpr, rhs);
PUSHCALLARG(prom);
SETCALLARG_TAG_SYMBOL(R_valueSym);
/* replace first argument with evaluated promise for LHS */
/* promise might be captured, so track references */
args = CALL_FRAME_ARGS();
prom = R_mkEVPROMISE(R_TmpvalSymbol, lhs);
SETCAR(args, prom);
/* make the call */
value = applyClosure(call, fun, args, rho, R_NilValue);
break;
default: error(_("bad function"));
}
POP_CALL_FRAME_PLUS(2, value);
NEXT();
}
OP(GETTER_CALL, 1):
{
SEXP lhs = GETSTACK_BELOW_CALL_FRAME(-2);
SEXP fun = CALL_FRAME_FUN();
SEXP call = VECTOR_ELT(constants, GETOP());
SEXP args, prom;
switch (TYPEOF(fun)) {
case BUILTINSXP:
/* replace first argument with LHS value */
args = CALL_FRAME_ARGS();
SETCAR(args, lhs);
/* make the call */
checkForMissings(args, call);
value = PRIMFUN(fun) (call, fun, args, rho);
break;
case SPECIALSXP:
/* duplicate arguments and put into stack for GC protection */
args = duplicate(CDR(call));
SETSTACK(-2, args);
/* insert evaluated promise for LHS as first argument */
/* promise won't be captured so don't track refrences */
prom = R_mkEVPROMISE_NR(R_TmpvalSymbol, lhs);
SETCAR(args, prom);
/* make the call */
value = PRIMFUN(fun) (call, fun, args, rho);
break;
case CLOSXP:
/* replace first argument with evaluated promise for LHS */
/* promise might be captured, so track references */
args = CALL_FRAME_ARGS();
prom = R_mkEVPROMISE(R_TmpvalSymbol, lhs);
SETCAR(args, prom);
/* make the call */
value = applyClosure(call, fun, args, rho, R_NilValue);
break;
default: error(_("bad function"));
}
POP_CALL_FRAME(value);
NEXT();
}
OP(SWAP, 0): {
R_bcstack_t tmp = R_BCNodeStackTop[-1];
/* This instruction only occurs between accessor calls in
complex assignments. [It should probably be renamed to
reflect this.] It needs to make sure intermediate LHS
values in complex assignments are not shared by duplicating
the extracted value in tmp when necessary. Duplicating is
necessary if the value might be shared _or_ if the
container, which is in R_BCNodeStackTop[-3], has become
possibly shared by going through a closure in the preceding
accessor call. This is taken to indicate that the
corresponding replacement function might be a closure and
will need to see an unmodified LHS value. This heuristic
fails if the accessor function called here is not a closure
but the replacement function is. */
/* For the typed stack it might be OK just to force boxing at
this point, but for now this code tries to avoid doing
that. The macros make the code a little more reabable. */
#define STACKVAL_MAYBE_REFERENCED(idx) \
(IS_STACKVAL_BOXED(idx) && \
MAYBE_REFERENCED(GETSTACK_SXPVAL_PTR(R_BCNodeStackTop + (idx))))
#define STACKVAL_MAYBE_SHARED(idx) \
(IS_STACKVAL_BOXED(idx) && \
MAYBE_SHARED(GETSTACK_SXPVAL_PTR(R_BCNodeStackTop + (idx))))
if (STACKVAL_MAYBE_REFERENCED(-1) &&
(STACKVAL_MAYBE_SHARED(-1) || STACKVAL_MAYBE_SHARED(-3)))
GETSTACK_SXPVAL_PTR(&tmp) =
shallow_duplicate(GETSTACK_SXPVAL_PTR(&tmp));
R_BCNodeStackTop[-1] = R_BCNodeStackTop[-2];
R_BCNodeStackTop[-2] = tmp;
NEXT();
}
OP(DUP2ND, 0): BCNDUP2ND(); NEXT();
OP(SWITCH, 4): {
SEXP call = VECTOR_ELT(constants, GETOP());
SEXP names = VECTOR_ELT(constants, GETOP());
SEXP coffsets = VECTOR_ELT(constants, GETOP());
SEXP ioffsets = VECTOR_ELT(constants, GETOP());
value = BCNPOP();
if (!isVector(value) || length(value) != 1)
errorcall(call, _("EXPR must be a length 1 vector"));
if (isFactor(value))
warningcall(call,
_("EXPR is a \"factor\", treated as integer.\n"
" Consider using '%s' instead."),
"switch(as.character( * ), ...)");
if (TYPEOF(value) == STRSXP) {
int i, n, which;
if (names == R_NilValue) {
if (TYPEOF(ioffsets) != INTSXP)
errorcall(call, _("bad numeric 'switch' offsets"));
if (LENGTH(ioffsets) == 1) {
pc = codebase + INTEGER(ioffsets)[0]; /* returns NULL */
warningcall(call, _("'switch' with no alternatives"));
}
else
errorcall(call, _("numeric EXPR required for 'switch' "
"without named alternatives"));
} else {
if (TYPEOF(coffsets) != INTSXP)
errorcall(call, _("bad character 'switch' offsets"));
if (TYPEOF(names) != STRSXP || LENGTH(names) != LENGTH(coffsets))
errorcall(call, "bad 'switch' names");
n = LENGTH(names);
which = n - 1;
for (i = 0; i < n - 1; i++)
if (pmatch(STRING_ELT(value, 0),
STRING_ELT(names, i), 1 /* exact */)) {
which = i;
break;
}
pc = codebase + INTEGER(coffsets)[which];
}
}
else {
if (TYPEOF(ioffsets) != INTSXP)
errorcall(call, "bad numeric 'switch' offsets");
int which = asInteger(value);
if (which != NA_INTEGER) which--;
if (which < 0 || which >= LENGTH(ioffsets))
which = LENGTH(ioffsets) - 1;
if (LENGTH(ioffsets) == 1)
warningcall(call, _("'switch' with no alternatives"));
pc = codebase + INTEGER(ioffsets)[which];
}
NEXT();
}
OP(RETURNJMP, 0): {
value = BCNPOP();
findcontext(CTXT_BROWSER | CTXT_FUNCTION, rho, value);
}
OP(STARTSUBSET_N, 2): DO_STARTDISPATCH_N("[");
OP(STARTSUBASSIGN_N, 2): DO_START_ASSIGN_DISPATCH_N("[<-");
OP(VECSUBSET2, 1): DO_VECSUBSET(rho, TRUE); NEXT();
OP(MATSUBSET2, 1): DO_MATSUBSET(rho, TRUE); NEXT();
OP(VECSUBASSIGN2, 1): DO_VECSUBASSIGN(rho, TRUE); NEXT();
OP(MATSUBASSIGN2, 1): DO_MATSUBASSIGN(rho, TRUE); NEXT();
OP(STARTSUBSET2_N, 2): DO_STARTDISPATCH_N("[[");
OP(STARTSUBASSIGN2_N, 2): DO_START_ASSIGN_DISPATCH_N("[[<-");
OP(SUBSET_N, 2): DO_SUBSET_N(rho, FALSE); NEXT();
OP(SUBSET2_N, 2): DO_SUBSET_N(rho, TRUE); NEXT();
OP(SUBASSIGN_N, 2): DO_SUBASSIGN_N(rho, FALSE); NEXT();
OP(SUBASSIGN2_N, 2): DO_SUBASSIGN_N(rho, TRUE); NEXT();
OP(LOG, 1): DO_LOG(); NEXT();
OP(LOGBASE, 1): DO_LOGBASE(); NEXT();
OP(MATH1, 2): DO_MATH1(); NEXT();
OP(DOTCALL, 2): DO_DOTCALL(); NEXT();
OP(COLON, 1): DO_COLON(); NEXT();
OP(SEQALONG, 1): DO_SEQ_ALONG(); NEXT();
OP(SEQLEN, 1): DO_SEQ_LEN(); NEXT();
LASTOP;
}
done:
R_BCNodeStackTop = oldntop;
#ifdef BC_INT_STACK
R_BCIntStackTop = olditop;
#endif
#ifdef BC_PROFILING
current_opcode = old_current_opcode;
#endif
return value;
}