Commit 232cdd5d authored by Radford Neal's avatar Radford Neal

more use of TYPE_ETC and other eval improvements

parent f6dd867b
......@@ -235,9 +235,8 @@ struct sxpinfo_struct {
unsigned int debug : 1; /* Function/Environment: is being debugged */
unsigned int rstep_pname : 1; /* Function: is to be debugged just once */
/* CHARSXP: is used as a symbol's printname */
unsigned int trace_base : 1; /* Function: is being traced,
Symbol: has base binding in global cache,
Environment: R_BaseEnv or R_BaseNamespace*/
unsigned int base_sym_env : 1; /* Symbol: has base binding in global cache,
Envir: R_BaseEnv or R_BaseNamespace*/
unsigned int nmcnt : 3; /* Count of "names" referring to object */
......@@ -819,7 +818,8 @@ extern void helpers_wait_until_not_in_use(SEXP);
#define UNSET_VEC_DOTS_TR_BIT(x) (UPTR_FROM_SEXP(x)->sxpinfo.type_et_cetera \
&= ~TYPE_ET_CETERA_VEC_DOTS_TR)
#define OBJECT(x) NOT_LVALUE(UPTR_FROM_SEXP(x)->sxpinfo.obj)
#define RTRACE(x) NOT_LVALUE(UPTR_FROM_SEXP(x)->sxpinfo.trace_base)
#define RTRACE(x) NOT_LVALUE(UPTR_FROM_SEXP(x)->sxpinfo.type_et_cetera \
& TYPE_ET_CETERA_VEC_DOTS_TR)
#define LEVELS(x) NOT_LVALUE(UPTR_FROM_SEXP(x)->sxpinfo.gp)
/* For SET_OBJECT and SET_TYPEOF, don't set if new value is the current value,
to avoid crashing on an innocuous write to a constant that may be stored
......@@ -837,7 +837,9 @@ extern void helpers_wait_until_not_in_use(SEXP);
#define SET_TYPEOF0(x,v) /* don't check if same as previous; expr not stmt */ \
(UPTR_FROM_SEXP(x)->sxpinfo.type_et_cetera = \
(UPTR_FROM_SEXP(x)->sxpinfo.type_et_cetera & ~TYPE_ET_CETERA_TYPE) | v)
#define SET_RTRACE(x,v) (UPTR_FROM_SEXP(x)->sxpinfo.trace_base=(v))
#define SET_RTRACE(x,v) ((v) ? \
(UPTR_FROM_SEXP(x)->sxpinfo.type_et_cetera |= TYPE_ET_CETERA_VEC_DOTS_TR) \
: (UPTR_FROM_SEXP(x)->sxpinfo.type_et_cetera &= ~TYPE_ET_CETERA_VEC_DOTS_TR))
#define SETLEVELS(x,v) (UPTR_FROM_SEXP(x)->sxpinfo.gp=(v))
/* The TRUELENGTH is seldom used, and usually has no connection with length. */
......@@ -905,9 +907,9 @@ static inline void UNSET_S4_OBJECT_inline (SEXP x) {
#define SET_DDVAL_BIT(x) ((UPTR_FROM_SEXP(x)->sxpinfo.gp) |= DDVAL_MASK)
#define UNSET_DDVAL_BIT(x) ((UPTR_FROM_SEXP(x)->sxpinfo.gp) &= ~DDVAL_MASK)
#define SET_DDVAL(x,v) ((v) ? SET_DDVAL_BIT(x) : UNSET_DDVAL_BIT(x)) /* for ..1, ..2 etc */
#define BASE_CACHE(x) NOT_LVALUE(UPTR_FROM_SEXP(x)->sxpinfo.trace_base) /* 1 = base binding
#define BASE_CACHE(x) NOT_LVALUE(UPTR_FROM_SEXP(x)->sxpinfo.base_sym_env) /* 1 = base binding
in global cache*/
#define SET_BASE_CACHE(x,v) (UPTR_FROM_SEXP(x)->sxpinfo.trace_base = (v))
#define SET_BASE_CACHE(x,v) (UPTR_FROM_SEXP(x)->sxpinfo.base_sym_env = (v))
/* Environment Access Macros */
#define FRAME(x) NOT_LVALUE(((ENVSEXP)UPTR_FROM_SEXP(x))->frame)
......@@ -917,7 +919,7 @@ static inline void UNSET_S4_OBJECT_inline (SEXP x) {
#define SET_ENVFLAGS(x,v) ((UPTR_FROM_SEXP(x)->sxpinfo.gp)=(v))
#define ENVSYMBITS(x) NOT_LVALUE(((ENVSEXP)UPTR_FROM_SEXP(x))->envsymbits)
#define SET_ENVSYMBITS(x,v) (((ENVSEXP)UPTR_FROM_SEXP(x))->envsymbits=(v))
#define IS_BASE(x) NOT_LVALUE(UPTR_FROM_SEXP(x)->sxpinfo.trace_base)
#define IS_BASE(x) NOT_LVALUE(UPTR_FROM_SEXP(x)->sxpinfo.base_sym_env)
/* 1 = R_BaseEnv or R_BaseNamespace */
#define IS_USER_DATABASE(rho) \
( OBJECT((rho)) && inherits((rho), "UserDefinedDatabase") )
......
......@@ -660,7 +660,7 @@ static SEXP R_BaseNamespaceName;
void attribute_hidden InitBaseEnv()
{
R_BaseEnv = NewEnvironment(R_NilValue, R_NilValue, R_EmptyEnv);
UPTR_FROM_SEXP(R_BaseEnv)->sxpinfo.trace_base = 1;
UPTR_FROM_SEXP(R_BaseEnv)->sxpinfo.base_sym_env = 1;
}
void attribute_hidden InitGlobalEnv()
......@@ -670,7 +670,7 @@ void attribute_hidden InitGlobalEnv()
MARK_AS_GLOBAL_FRAME(R_GlobalEnv);
R_BaseNamespace = NewEnvironment(R_NilValue, R_NilValue, R_GlobalEnv);
UPTR_FROM_SEXP(R_BaseNamespace)->sxpinfo.trace_base = 1;
UPTR_FROM_SEXP(R_BaseNamespace)->sxpinfo.base_sym_env = 1;
R_PreserveObject(R_BaseNamespace);
SET_SYMVALUE(install(".BaseNamespaceEnv"), R_BaseNamespace);
R_BaseNamespaceName = ScalarString(mkChar("base"));
......
......@@ -404,8 +404,9 @@ static SEXP evalv_other (SEXP, SEXP, int);
SELF_EVAL(TYPEOF(e)) ? \
(UPTR_FROM_SEXP(e)->sxpinfo.nmcnt == MAX_NAMEDCNT ? e \
: (UPTR_FROM_SEXP(e)->sxpinfo.nmcnt = MAX_NAMEDCNT, e)) \
: SYM_NO_DOTS(e) ? Rf_evalv_sym (e, rho, variant) \
: Rf_evalv_other (e, rho, variant) \
: TYPE_ETC(e) == SYMSXP /* not ..., ..1, etc */ ? \
Rf_evalv_sym (e, rho, variant) \
: Rf_evalv_other (e, rho, variant) \
)
......@@ -426,6 +427,7 @@ SEXP eval (SEXP e, SEXP rho)
SEXP evalv (SEXP e, SEXP rho, int variant)
{
R_variant_result = 0;
R_Visible = TRUE;
/* Handle check for user interrupt. */
......@@ -435,6 +437,19 @@ SEXP evalv (SEXP e, SEXP rho, int variant)
evalcount = 1000;
}
/* Quick return for self-evaluating constants. */
if (SELF_EVAL(TYPEOF(e))) {
SET_NAMEDCNT_MAX(e);
return e;
}
/* Handle symbol lookup without stack overflow or expression depth check */
if (TYPE_ETC(e) == SYMSXP /* symbol, but not ..., ..1, etc */) {
return Rf_evalv_sym (e, rho, variant);
}
/* Check for stack overflow. */
R_CHECKSTACK();
......@@ -449,9 +464,9 @@ SEXP evalv (SEXP e, SEXP rho, int variant)
_("evaluation nested too deeply: infinite recursion / options(expressions=)?"));
}
/* Do evaluation as for fast eval macro. */
/* Handle other evaluations, typically of LANGSXP. */
SEXP res = EVALV (e, rho, variant);
SEXP res = Rf_evalv_other (e, rho, variant);
R_EvalDepth -= 1;
......@@ -559,9 +574,10 @@ SEXP attribute_hidden Rf_evalv_other (SEXP e, SEXP rho, int variant)
else
op = eval(fn,rho);
if (RTRACE(op)) R_trace_call(e,op);
int type_tr = TYPE_ETC(op) & ~TYPE_ET_CETERA_HAS_ATTR;
if (TYPEOF(op) == CLOSXP) {
redo:
if (type_tr == CLOSXP) {
PROTECT(op);
res = applyClosure_v (e, op, promiseArgs(args,rho), rho,
NULL, variant);
......@@ -573,11 +589,18 @@ SEXP attribute_hidden Rf_evalv_other (SEXP e, SEXP rho, int variant)
R_Visible = TRUE;
if (TYPEOF(op) == SPECIALSXP)
if (type_tr == SPECIALSXP) {
res = CALL_PRIMFUN (e, op, args, rho, variant);
else if (TYPEOF(op) == BUILTINSXP)
}
else if (type_tr == BUILTINSXP) {
res = R_Profiling ? Rf_builtin_op(op, e, rho, variant)
: Rf_builtin_op_no_cntxt(op, e, rho, variant);
}
else if (type_tr & TYPE_ET_CETERA_VEC_DOTS_TR) {
R_trace_call(e,op);
type_tr &= ~TYPE_ET_CETERA_VEC_DOTS_TR;
goto redo;
}
else
apply_non_function_error();
......
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