Commit 5d4aadc0 authored by Radford Neal's avatar Radford Neal

First version released on github

parent 18a099b4
......@@ -38,9 +38,31 @@ users, such as cleanups of source code.
12)
13)
14)
13) A facility has been introduced for an expression to be evaluated
in a context in which a "variant result" is allowed - eg, if the
result will be ignored anyway (expression is evaluated only for
side effects), a null result might be allowed. This is done by
introducing an "evalv" function that is like "eval" but with an
extra parameter saying what variant results are permissible.
This facility is used for some modifications noted elsewhere.
14) Calling of primitive functions has been speeded up by copying
relevant information (eg, arity) from the table defining
primitives (in names.c) to fields in the SEXP for the primitive.
This saves table access computations and also division and
remainder operations to get at the information in the "eval"
field in names.c, which is encoded as decimal digits.
A procedure SET_PRIMFUN in memory.c was surreptitiously changing
the function pointer for a primitive via the function pointer
access macro, PRIMFUN. I have introduced a SET_PRIMFUN macro to
do this properly.
Code in saveload.c (for loading old workspaces?) creates a
primitive directly, bypassing the mkPRIMSXP procedure. This
seems unwise, since creation via mkPRIMSXP is apparently needed
to ensure protection of primitives. Whatever is going on there
should not be affected by this modification, however.
15)
......
......@@ -104,6 +104,7 @@ checked against the current version of the source code.
* Contexts::
* Argument evaluation::
* Autoprinting::
* The eval function::
* The write barrier::
* Serialization Formats::
* Encodings for CHARSXPs::
......@@ -382,6 +383,10 @@ that is @code{NA_STRING} or is in the @code{CHARSXP} cache (this is not
serialized). Only exceptionally is a @code{CHARSXP} not hashed, and
this should never happen in end-user code.
The whole gp field is used for the table offset in a @code{BUILTINSXP}
or @code{SPECIALSXP}. This offset is found again from the name when
restoring saved data.
@node The 'data', Allocation classes, Rest of header, SEXPs
@subsection The `data'
......@@ -401,8 +406,8 @@ union @{
@end example
@noindent
All of these alternatives apart from the first (an @code{int}) are three
pointers, so the union occupies three words.
All of these alternatives apart from the first are three pointers, and
the first should be no larger, so the union should occupy three words.
@cindex vector type
The vector types are @code{RAWSXP}, @code{CHARSXP}, @code{LGLSXP},
......@@ -464,8 +469,10 @@ expression vectors (@code{EXPRSXP}s).
@item SPECIALSXP
@itemx BUILTINSXP
An integer giving the offset into the table of
primitives/@code{.Internal}s.
An integer (in the gp field) giving the offset into the table of
primitives/@code{.Internal}s, plus various information copied from
that table for fast access. This extra information is set up when
the offset is set with @code{SET_PRIMOFFSET}.
@item CHARSXP
@code{length}, @code{truelength} followed by a block of bytes (allowing
......@@ -1027,7 +1034,7 @@ Special primitives may need to handle @code{...} arguments: see for
example the internal code of @code{switch} in file
@file{src/main/builtin.c}.
@node Autoprinting, The write barrier, Argument evaluation, R Internal Structures
@node Autoprinting, The eval function, Argument evaluation, R Internal Structures
@section Autoprinting
@cindex autoprinting
......@@ -1089,8 +1096,48 @@ Otherwise, if the object bit is set (so the object has a
for objects without a class the internal code of @code{print.default}
is called.
@node The write barrier, Serialization Formats, Autoprinting, R Internal Structures
@node The eval function, The write barrier, Autoprinting, R Internal Structures
@section The eval function
@findex eval
@findex evalv
The @code{eval} function is the central routine in the interpreter.
It takes as arguments an expression to evaluate and an environment
(both of which must be protected by the caller) and returns the
value that the expression evaluates to.
In pqR, @code{eval} calls @code{evalv} (or is a macro expanding to a
call of @code{evalv} internally), which takes one additional argument,
that may specify that a ``variant'' result is allowed. This argument
should be 0 if no variant is allowed, as for plain @code{eval}.
Symbols for other variants are defined in @file{Rinternals.h}.
For example, a caller of @code{evalv} might specify that the value
will not be used (evaluation being done only for side effects), and
may therefore be returned as @code{R_NilValue}, or that if the value
is a numeric vector, only the sum of vector elements is needed, so
that this sum may be returned rather than the vector (which will then
not need to have space allocated for it). However, the caller of
@code{evalv} must always be prepared to receive an ordinary value,
rather than the variant asked for.
For many variants, a value returned by @code{evalv} that is a variant
is identified by an attribute field of @code{R_VariantResult}, which
is a special object that should not be propagated to be visible from
user code.
The variant argument of @code{evalv} will be passed on to a function
implementing a primitive if the appropriate flag is set in the
primitive's specification in @file{names.c}. Variant arguments may be
passed onwards from the expression passed to @code{evalv} --- for
example, from an ``if'' statement to the evaluation of the chosen
branch, or from a function call to the evaluation of the body of the
function --- with any variant result propagated back.
@comment Just here to help with merging new section later...
@node The write barrier, Serialization Formats, The eval function, R Internal Structures
@section The write barrier and the garbage collector
@cindex write barrier
......
Two changes to how expressions are evaluated.
First, a facility has been introduced for an expression to be
evaluated in a context in which a "variant result" is allowed - eg, if
the result will be ignored anyway (expression is evaluated only for
side effects), a null result might be allowed. This is done by
introducing an "evalv" function that is like "eval" but with an extra
parameter saying what variant results are permissible. This facility
is used for later modifications, with some symbols defined here in
anticipation of these modifications.
Second, calling of primitive functions has been speeded up by copying
relevant information (eg, arity) from the table defining primitives
(in names.c) to fields in the SEXP for the primitive. This saves
table access computations and also division and remainder operations
to get at the information in the "eval" field in names.c, which is
encoded as decimal digits.
A procedure SET_PRIMFUN in memory.c was surreptitiously changing the
function pointer for a primitive via the function pointer access
macro, PRIMFUN. A SET_PRIMFUN macro now does this properly.
Code in saveload.c (for loading old workspaces?) creates a primitive
directly, bypassing the mkPRIMSXP procedure. This seems unwise, since
creation via mkPRIMSXP is apparently needed to ensure protection of
primitives. Whatever is going on there should not be affected by this
modification, however.
R-ints.texi has been updated to document evalv and variants.
......@@ -84,7 +84,10 @@ Rcomplex Rf_ComplexFromReal(double, int*);
#define CALLED_FROM_DEFN_H 1
#include <Rinternals.h> /*-> Arith.h, Boolean.h, Complex.h, Error.h,
Memory.h, PrtUtil.h, Utils.h */
#undef eval
#define eval(e,rho) evalv(e,rho,0) /* eval is a macro within interpreter */
#undef CALLED_FROM_DEFN_H
extern0 SEXP R_CommentSymbol; /* "comment" */
extern0 SEXP R_DotEnvSymbol; /* ".Environment" */
extern0 SEXP R_ExactSymbol; /* "exact" */
......@@ -305,9 +308,14 @@ extern int putenv(char *string);
Was 256 prior to 2.13.0, now just a sanity check.
*/
/* The type of the do_xxxx functions. */
/* These are the built-in R functions. */
/* Types for the do_xxxx functions for SPECIAL and BUILTIN operations. */
typedef SEXP (*CCODE)(SEXP, SEXP, SEXP, SEXP);
typedef SEXP (*CCODEV)(SEXP, SEXP, SEXP, SEXP, int); /* with variant info */
#define CALL_PRIMFUN(call,op,args,env,variant) \
(PRIMVARIANT(op) ? PRIMFUNV(op)(call,op,args,env,variant) \
: PRIMFUN(op)(call,op,args,env))
/* Information for Deparsing Expressions */
typedef enum {
......@@ -365,9 +373,9 @@ typedef struct {
/* This table can be found in ../main/names.c */
typedef struct {
char *name; /* print name */
CCODE cfun; /* c-code address */
void *cfun; /* c-code address */
int code; /* offset within c-code */
int eval; /* evaluate args? */
int eval; /* evaluate args? (and other info) */
int arity; /* function arity */
PPinfo gram; /* pretty-print info */
} FUNTAB;
......@@ -378,15 +386,57 @@ typedef struct {
*/
/* Primitive Access Macros */
#define PRIMOFFSET(x) ((x)->u.primsxp.offset)
#define SET_PRIMOFFSET(x,v) (((x)->u.primsxp.offset)=(v))
#define PRIMFUN(x) (R_FunTab[(x)->u.primsxp.offset].cfun)
#define PRIMNAME(x) (R_FunTab[(x)->u.primsxp.offset].name)
#define PRIMVAL(x) (R_FunTab[(x)->u.primsxp.offset].code)
#define PRIMARITY(x) (R_FunTab[(x)->u.primsxp.offset].arity)
#define PPINFO(x) (R_FunTab[(x)->u.primsxp.offset].gram)
#define PRIMPRINT(x) (((R_FunTab[(x)->u.primsxp.offset].eval)/100)%10)
#define PRIMINTERNAL(x) (((R_FunTab[(x)->u.primsxp.offset].eval)%100)/10)
/* Set offset of primitive in table, and copy some of the information from
the table into the primsxp structure for fast access. Note that
primsxp_fast_cfun will (possibly) be set by the slow function, not here. */
#define SET_PRIMOFFSET(x,v) do { \
SEXP setprim_ptr = (x); \
int setprim_value = (v); \
setprim_ptr->sxpinfo.gp = setprim_value; \
setprim_ptr->u.primsxp.primsxp_cfun = R_FunTab[setprim_value].cfun; \
setprim_ptr->u.primsxp.primsxp_fast_cfun = 0; \
setprim_ptr->u.primsxp.primsxp_code = R_FunTab[setprim_value].code; \
setprim_ptr->u.primsxp.primsxp_arity = R_FunTab[setprim_value].arity; \
setprim_ptr->u.primsxp.primsxp_foreign \
= R_FunTab[setprim_value].gram.kind==PP_FOREIGN; \
setprim_ptr->u.primsxp.primsxp_print \
= (R_FunTab[setprim_value].eval/100)%10; \
setprim_ptr->u.primsxp.primsxp_variant \
= (R_FunTab[setprim_value].eval/1000)&1; \
setprim_ptr->u.primsxp.primsxp_internal \
= (R_FunTab[setprim_value].eval/10)&1; \
} while (0)
#define PRIMOFFSET(x) ((x)->sxpinfo.gp)
#define PRIMFUN(x) ((CCODE)((x)->u.primsxp.primsxp_cfun))
#define PRIMFUNV(x) ((CCODEV)((x)->u.primsxp.primsxp_cfun))
#define SET_PRIMFUN(x,f) \
( (x)->u.primsxp.primsxp_cfun = R_FunTab[PRIMOFFSET(x)].cfun = (f), \
(x)->u.primsxp.primsxp_fast_cfun = 0 )
#define PRIMVAL(x) ((x)->u.primsxp.primsxp_code)
#define PRIMARITY(x) ((x)->u.primsxp.primsxp_arity)
#define PRIMPRINT(x) ((x)->u.primsxp.primsxp_print)
#define PRIMINTERNAL(x) ((x)->u.primsxp.primsxp_internal)
#define PRIMVARIANT(x) ((x)->u.primsxp.primsxp_variant)
#define PRIMFOREIGN(x) ((x)->u.primsxp.primsxp_foreign)
#define PRIMNAME(x) (R_FunTab[PRIMOFFSET(x)].name)
#define PPINFO(x) (R_FunTab[PRIMOFFSET(x)].gram)
#define PRIMFUN_FAST(x) ((x)->u.primsxp.primsxp_fast_cfun)
#define SET_PRIMFUN_FAST(x,f) \
((x)->u.primsxp.primsxp_fast_cfun = (f))
/* Symbols for eval variants. Return of a variant result is indicated by
the attribute field being R_VariantResult. */
#define VARIANT_NULL 1 /* May just return R_NilValue (but do side effects) */
#define VARIANT_SEQ 2 /* May return a sequence spec, rather than a vector */
#define VARIANT_AND 3 /* May return AND of a logical vec rather than vec */
#define VARIANT_OR 4 /* May return OR of a logical vec rather than vec */
#define VARIANT_SUM 5 /* May return sum of vec elements rather than vec */
/* Promise Access Macros */
#define PRCODE(x) ((x)->u.promsxp.expr)
......
......@@ -183,8 +183,15 @@ struct vecsxp_struct {
R_len_t truelength;
};
struct primsxp_struct {
int offset;
struct primsxp_struct { /* table offset of this and other info is in gp */
void *primsxp_cfun; /* c-code address, cast as func, from table */
void *primsxp_fast_cfun; /* c-code address for fast interface, or NULL*/
short primsxp_code; /* operation code, from table */
signed char primsxp_arity; /* function arity (-1 for any), from table */
unsigned int primsxp_print:2; /* print/invisible indicator, from table*/
unsigned int primsxp_variant:1; /* pass variant to cfun, from table */
unsigned int primsxp_internal:1;/* call with .Internal flag, from table */
unsigned int primsxp_foreign:1; /* primitive to call C/Fortran function */
};
struct symsxp_struct {
......@@ -522,6 +529,7 @@ LibExtern SEXP R_Srcref; /* Current srcref, for debuggers */
/* Special Values */
LibExtern SEXP R_NilValue; /* The nil object */
LibExtern SEXP R_VariantResult; /* Marker for variant result of op */
LibExtern SEXP R_UnboundValue; /* Unbound marker */
LibExtern SEXP R_MissingArg; /* Missing argument marker */
#ifdef __MAIN__
......@@ -609,6 +617,7 @@ SEXP Rf_DropDims(SEXP);
SEXP Rf_duplicate(SEXP);
SEXP Rf_duplicated(SEXP, Rboolean);
SEXP Rf_eval(SEXP, SEXP);
SEXP Rf_evalv(SEXP, SEXP, int);
SEXP Rf_findFun(SEXP, SEXP);
SEXP Rf_findVar(SEXP, SEXP);
SEXP Rf_findVarInFrame(SEXP, SEXP);
......@@ -903,6 +912,7 @@ Rboolean R_compute_identical(SEXP, SEXP, int);
#define elt Rf_elt
#define errorcall Rf_errorcall
#define eval Rf_eval
#define evalv Rf_evalv
#define findFun Rf_findFun
#define findVar Rf_findVar
#define findVarInFrame Rf_findVarInFrame
......
......@@ -2755,7 +2755,7 @@ void GEplayDisplayList(pGEDevDesc dd)
SEXP theOperation = CAR(theList);
SEXP op = CAR(theOperation);
SEXP args = CADR(theOperation);
PRIMFUN(op) (R_NilValue, op, args, R_NilValue);
CALL_PRIMFUN(R_NilValue, op, args, R_NilValue, 0);
/* Check with each graphics system that the plotting went ok
*/
if (!GEcheckState(dd)) {
......
......@@ -39,6 +39,7 @@
#define ARGUSED(x) LEVELS(x)
static SEXP applyClosure_v (SEXP, SEXP, SEXP, SEXP, SEXP, int);
static SEXP bcEval(SEXP, SEXP, Rboolean);
/*#define BC_PROFILING*/
......@@ -334,9 +335,18 @@ static SEXP forcePromise(SEXP e)
return PRVALUE(e);
}
/* Return value of "e" evaluated in "rho". */
/* Return value of "e" evaluated in "rho". This will be bypassed by
a macro definition for "eval" in the interpreter itself. */
SEXP eval(SEXP e, SEXP rho)
SEXP Rf_eval(SEXP e, SEXP rho)
{
evalv(e,rho,0);
}
/* Return value of "e" evalued in "rho", allowing the result to possibly
be a variant as described by "variant". */
SEXP evalv(SEXP e, SEXP rho, int variant)
{
SEXP op, tmp;
static int evalcount = 0;
......@@ -469,7 +479,7 @@ SEXP eval(SEXP e, SEXP rho)
const void *vmax = vmaxget();
PROTECT(CDR(e));
R_Visible = flag != 1;
tmp = PRIMFUN(op) (e, op, CDR(e), rho);
tmp = CALL_PRIMFUN(e, op, CDR(e), rho, variant);
#ifdef CHECK_VISIBILITY
if(flag < 2 && R_Visible == flag) {
char *nm = PRIMNAME(op);
......@@ -495,10 +505,10 @@ SEXP eval(SEXP e, SEXP rho)
if (R_Profiling || (PPINFO(op).kind == PP_FOREIGN)) {
begincontext(&cntxt, CTXT_BUILTIN, e,
R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue);
tmp = PRIMFUN(op) (e, op, tmp, rho);
tmp = CALL_PRIMFUN(e, op, tmp, rho, variant);
endcontext(&cntxt);
} else {
tmp = PRIMFUN(op) (e, op, tmp, rho);
tmp = CALL_PRIMFUN(e, op, tmp, rho, variant);
}
#ifdef CHECK_VISIBILITY
if(flag < 2 && R_Visible == flag) {
......@@ -513,7 +523,7 @@ SEXP eval(SEXP e, SEXP rho)
}
else if (TYPEOF(op) == CLOSXP) {
PROTECT(tmp = promiseArgs(CDR(e), rho));
tmp = applyClosure(e, op, tmp, rho, R_BaseEnv);
tmp = applyClosure_v (e, op, tmp, rho, R_BaseEnv, variant);
UNPROTECT(1);
}
else
......@@ -698,7 +708,8 @@ static R_INLINE SEXP getSrcref(SEXP srcrefs, int ind)
return R_NilValue;
}
SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedenv)
static SEXP applyClosure_v (SEXP call, SEXP op, SEXP arglist, SEXP rho,
SEXP suppliedenv, int variant)
{
SEXP formals, actuals, savedrho;
volatile SEXP body, newrho;
......@@ -852,13 +863,13 @@ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedenv)
if (R_ReturnedValue == R_RestartToken) {
cntxt.callflag = CTXT_RETURN; /* turn restart off */
R_ReturnedValue = R_NilValue; /* remove restart token */
PROTECT(tmp = eval(body, newrho));
PROTECT(tmp = evalv (body, newrho, variant));
}
else
PROTECT(tmp = R_ReturnedValue);
}
else {
PROTECT(tmp = eval(body, newrho));
PROTECT(tmp = evalv (body, newrho, variant));
}
endcontext(&cntxt);
......@@ -871,6 +882,12 @@ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedenv)
return (tmp);
}
SEXP applyClosure (SEXP call, SEXP op, SEXP arglist, SEXP rho,
SEXP suppliedenv)
{
return applyClosure_v (call, op, arglist, rho, suppliedenv, 0);
}
/* **** FIXME: This code is factored out of applyClosure. If we keep
**** it we should change applyClosure to run through this routine
**** to avoid code drift. */
......@@ -2178,7 +2195,7 @@ SEXP attribute_hidden do_recall(SEXP call, SEXP op, SEXP args, SEXP rho)
PROTECT(s = eval(CAR(cptr->call), cptr->sysparent));
if (TYPEOF(s) != CLOSXP)
error(_("'Recall' called from outside a closure"));
ans = applyClosure(cptr->call, s, args, cptr->sysparent, R_BaseEnv);
ans = applyClosure_v(cptr->call, s, args, cptr->sysparent, R_BaseEnv, 0);
UNPROTECT(1);
return ans;
}
......@@ -2614,7 +2631,7 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
if(isOps) SET_TAG(m, R_NilValue);
}
*ans = applyClosure(t, lsxp, s, rho, newrho);
*ans = applyClosure_v(t, lsxp, s, rho, newrho, 0);
UNPROTECT(5);
return 1;
}
......@@ -4400,17 +4417,17 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
checkForMissings(args, call);
flag = PRIMPRINT(fun);
R_Visible = flag != 1;
value = PRIMFUN(fun) (call, fun, args, rho);
value = CALL_PRIMFUN(call, fun, args, rho, 0);
if (flag < 2) R_Visible = flag != 1;
break;
case SPECIALSXP:
flag = PRIMPRINT(fun);
R_Visible = flag != 1;
value = PRIMFUN(fun) (call, fun, CDR(call), rho);
value = CALL_PRIMFUN(call, fun, CDR(call), rho, 0);
if (flag < 2) R_Visible = flag != 1;
break;
case CLOSXP:
value = applyClosure(call, fun, args, rho, R_BaseEnv);
value = applyClosure_v(call, fun, args, rho, R_BaseEnv, 0);
break;
default: error(_("bad function"));
}
......@@ -4430,7 +4447,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
error(_("not a BUILTIN function"));
flag = PRIMPRINT(fun);
R_Visible = flag != 1;
value = PRIMFUN(fun) (call, fun, args, rho);
value = CALL_PRIMFUN(call, fun, args, rho, 0);
if (flag < 2) R_Visible = flag != 1;
vmaxset(vmax);
R_BCNodeStackTop -= 2;
......@@ -4451,7 +4468,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
BCNPUSH(fun); /* for GC protection */
flag = PRIMPRINT(fun);
R_Visible = flag != 1;
value = PRIMFUN(fun) (call, fun, CDR(call), rho);
value = CALL_PRIMFUN(call, fun, CDR(call), rho, 0);
if (flag < 2) R_Visible = flag != 1;
vmaxset(vmax);
SETSTACK(-1, value); /* replaces fun on stack */
......@@ -4701,7 +4718,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
SETCAR(args, lhs);
/* make the call */
checkForMissings(args, call);
value = PRIMFUN(fun) (call, fun, args, rho);
value = CALL_PRIMFUN(call, fun, args, rho, 0);
break;
case SPECIALSXP:
/* duplicate arguments and put into stack for GC protection */
......@@ -4719,7 +4736,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
SET_PRVALUE(prom, rhs);
SETCAR(last, prom);
/* make the call */
value = PRIMFUN(fun) (call, fun, args, rho);
value = CALL_PRIMFUN(call, fun, args, rho, 0);
break;
case CLOSXP:
/* push evaluated promise for RHS onto arguments with 'value' tag */
......@@ -4733,7 +4750,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
args = GETSTACK(-2);
SETCAR(args, prom);
/* make the call */
value = applyClosure(call, fun, args, rho, R_BaseEnv);
value = applyClosure_v(call, fun, args, rho, R_BaseEnv, 0);
break;
default: error(_("bad function"));
}
......@@ -4755,7 +4772,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
SETCAR(args, lhs);
/* make the call */
checkForMissings(args, call);
value = PRIMFUN(fun) (call, fun, args, rho);
value = CALL_PRIMFUN(call, fun, args, rho, 0);
break;
case SPECIALSXP:
/* duplicate arguments and put into stack for GC protection */
......@@ -4766,7 +4783,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
SET_PRVALUE(prom, lhs);
SETCAR(args, prom);
/* make the call */
value = PRIMFUN(fun) (call, fun, args, rho);
value = CALL_PRIMFUN(call, fun, args, rho, 0);
break;
case CLOSXP:
/* replace first argument with evaluated promise for LHS */
......@@ -4775,7 +4792,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
args = GETSTACK(-2);
SETCAR(args, prom);
/* make the call */
value = applyClosure(call, fun, args, rho, R_BaseEnv);
value = applyClosure_v(call, fun, args, rho, R_BaseEnv, 0);
break;
default: error(_("bad function"));
}
......
......@@ -1473,6 +1473,7 @@ static void RunGenCollect(R_size_t size_needed)
FORWARD_NODE(R_EmptyEnv);
FORWARD_NODE(R_Warnings); /* Warnings, if any */
FORWARD_NODE(R_VariantResult); /* Marker for variant result of op */
FORWARD_NODE(R_HandlerStack); /* Condition handler stack */
FORWARD_NODE(R_RestartStack); /* Available restarts stack */
......@@ -3294,7 +3295,7 @@ void attribute_hidden (UNLOCK_BINDING)(SEXP b) {UNLOCK_BINDING(b);}
/* R_FunTab accessors */
int (PRIMVAL)(SEXP x) { return PRIMVAL(x); }
CCODE (PRIMFUN)(SEXP x) { return PRIMFUN(x); }
void (SET_PRIMFUN)(SEXP x, CCODE f) { PRIMFUN(x) = f; }
void (SET_PRIMFUN)(SEXP x, CCODE f) { SET_PRIMFUN(x,f); }
/* for use when testing the write barrier */
int attribute_hidden (IS_BYTES)(SEXP x) { return IS_BYTES(x); }
......
......@@ -59,13 +59,18 @@
* Convention:
* - all start with "do_",
* - all return SEXP.
* - all have argument list
* (SEXP call, SEXP op, SEXP args, SEXP env)
* - have argument list
* (SEXP call, SEXP op, SEXP args, SEXP env)
* or
* (SEXP call, SEXP op, SEXP args, SEXP env, int variant)
*
* offset: the 'op' (offset pointer) above; used for C functions
* which deal with more than one R function...
*
* eval: = XYZ (three digits) --- where e.g. '1' means '001'
* eval: = WXYZ (four digits) --- where e.g. '1' means '0001'
* W=1 says pass a "variant" argument to the c-entry procedure
* (ignored if PPkind is PP_FOREIGN)
* W=0 says don't pass a "variant" argument
* X=1 says that we should force R_Visible off
* X=0 says that we should force R_Visible on
* X=2 says that we should switch R_Visible on but let the C
......@@ -1150,6 +1155,8 @@ void InitNames()
SET_SYMVALUE(R_UnboundValue, R_UnboundValue);
SET_PRINTNAME(R_UnboundValue, R_NilValue);
SET_ATTRIB(R_UnboundValue, R_NilValue);
/* R_VariantResult - anything distinct and inaccessible to users is OK. */
R_VariantResult = CONS(R_NilValue,R_NilValue);
/* R_MissingArg */
R_MissingArg = allocSExp(SYMSXP);
SET_SYMVALUE(R_MissingArg, R_MissingArg);
......@@ -1235,7 +1242,7 @@ SEXP attribute_hidden do_internal(SEXP call, SEXP op, SEXP args, SEXP env)
PROTECT(args);
flag = PRIMPRINT(INTERNAL(fun));
R_Visible = flag != 1;
ans = PRIMFUN(INTERNAL(fun)) (s, INTERNAL(fun), args, env);
ans = CALL_PRIMFUN(s, INTERNAL(fun), args, env, 0);
/* This resetting of R_Visible = FALSE was to fix PR#7397,
now fixed in GEText */
if (flag < 2) R_Visible = flag != 1;
......
......@@ -106,7 +106,7 @@ static SEXP applyMethod(SEXP call, SEXP op, SEXP args, SEXP rho, SEXP newrho)
int save = R_PPStackTop, flag = PRIMPRINT(op);
const void *vmax = vmaxget();
R_Visible = flag != 1;
ans = PRIMFUN(op) (call, op, args, rho);
ans = CALL_PRIMFUN(call, op, args, rho, 0);
if (flag < 2) R_Visible = flag != 1;
check_stack_balance(op, save);
vmaxset(vmax);
......@@ -121,7 +121,7 @@ static SEXP applyMethod(SEXP call, SEXP op, SEXP args, SEXP rho, SEXP newrho)
const void *vmax = vmaxget();
PROTECT(args = evalList(args, rho, call, 0));
R_Visible = flag != 1;
ans = PRIMFUN(op) (call, op, args, rho);
ans = CALL_PRIMFUN(call, op, args, rho, 0);
if (flag < 2) R_Visible = flag != 1;
UNPROTECT(1);
check_stack_balance(op, save);
......
......@@ -1640,7 +1640,7 @@ static SEXP ReadItem (SEXP ref_table, R_inpstream_t stream)
s = R_NilValue; /* keep compiler happy */
error(_("ReadItem: unknown type %i, perhaps written by later version of R"), type);
}
if (type != CHARSXP)
if (type != CHARSXP && type != SPECIALSXP && type != BUILTINSXP)
SETLEVELS(s, levs);
SET_OBJECT(s, objf);
#ifdef USE_ATTRIB_FIELD_FOR_CHARSXP_CACHE_CHAINS
......
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