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. ...@@ -38,9 +38,31 @@ users, such as cleanups of source code.
12) 12)
13) 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
14) 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) 15)
......
...@@ -104,6 +104,7 @@ checked against the current version of the source code. ...@@ -104,6 +104,7 @@ checked against the current version of the source code.
* Contexts:: * Contexts::
* Argument evaluation:: * Argument evaluation::
* Autoprinting:: * Autoprinting::
* The eval function::
* The write barrier:: * The write barrier::
* Serialization Formats:: * Serialization Formats::
* Encodings for CHARSXPs:: * Encodings for CHARSXPs::
...@@ -382,6 +383,10 @@ that is @code{NA_STRING} or is in the @code{CHARSXP} cache (this is not ...@@ -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 serialized). Only exceptionally is a @code{CHARSXP} not hashed, and
this should never happen in end-user code. 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 @node The 'data', Allocation classes, Rest of header, SEXPs
@subsection The `data' @subsection The `data'
...@@ -401,8 +406,8 @@ union @{ ...@@ -401,8 +406,8 @@ union @{
@end example @end example
@noindent @noindent
All of these alternatives apart from the first (an @code{int}) are three All of these alternatives apart from the first are three pointers, and
pointers, so the union occupies three words. the first should be no larger, so the union should occupy three words.
@cindex vector type @cindex vector type
The vector types are @code{RAWSXP}, @code{CHARSXP}, @code{LGLSXP}, The vector types are @code{RAWSXP}, @code{CHARSXP}, @code{LGLSXP},
...@@ -464,8 +469,10 @@ expression vectors (@code{EXPRSXP}s). ...@@ -464,8 +469,10 @@ expression vectors (@code{EXPRSXP}s).
@item SPECIALSXP @item SPECIALSXP
@itemx BUILTINSXP @itemx BUILTINSXP
An integer giving the offset into the table of An integer (in the gp field) giving the offset into the table of
primitives/@code{.Internal}s. 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 @item CHARSXP
@code{length}, @code{truelength} followed by a block of bytes (allowing @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 ...@@ -1027,7 +1034,7 @@ Special primitives may need to handle @code{...} arguments: see for
example the internal code of @code{switch} in file example the internal code of @code{switch} in file
@file{src/main/builtin.c}. @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 @section Autoprinting
@cindex autoprinting @cindex autoprinting
...@@ -1089,8 +1096,48 @@ Otherwise, if the object bit is set (so the object has a ...@@ -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} for objects without a class the internal code of @code{print.default}
is called. is called.
@node The eval function, The write barrier, Autoprinting, R Internal Structures
@node The write barrier, Serialization Formats, 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 @section The write barrier and the garbage collector
@cindex write barrier @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*); ...@@ -84,7 +84,10 @@ Rcomplex Rf_ComplexFromReal(double, int*);
#define CALLED_FROM_DEFN_H 1 #define CALLED_FROM_DEFN_H 1
#include <Rinternals.h> /*-> Arith.h, Boolean.h, Complex.h, Error.h, #include <Rinternals.h> /*-> Arith.h, Boolean.h, Complex.h, Error.h,
Memory.h, PrtUtil.h, Utils.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 #undef CALLED_FROM_DEFN_H
extern0 SEXP R_CommentSymbol; /* "comment" */ extern0 SEXP R_CommentSymbol; /* "comment" */
extern0 SEXP R_DotEnvSymbol; /* ".Environment" */ extern0 SEXP R_DotEnvSymbol; /* ".Environment" */
extern0 SEXP R_ExactSymbol; /* "exact" */ extern0 SEXP R_ExactSymbol; /* "exact" */
...@@ -305,9 +308,14 @@ extern int putenv(char *string); ...@@ -305,9 +308,14 @@ extern int putenv(char *string);
Was 256 prior to 2.13.0, now just a sanity check. Was 256 prior to 2.13.0, now just a sanity check.
*/ */
/* The type of the do_xxxx functions. */ /* Types for the do_xxxx functions for SPECIAL and BUILTIN operations. */
/* These are the built-in R functions. */
typedef SEXP (*CCODE)(SEXP, SEXP, SEXP, SEXP); 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 */ /* Information for Deparsing Expressions */
typedef enum { typedef enum {
...@@ -365,9 +373,9 @@ typedef struct { ...@@ -365,9 +373,9 @@ typedef struct {
/* This table can be found in ../main/names.c */ /* This table can be found in ../main/names.c */
typedef struct { typedef struct {
char *name; /* print name */ char *name; /* print name */
CCODE cfun; /* c-code address */ void *cfun; /* c-code address */
int code; /* offset within c-code */ int code; /* offset within c-code */
int eval; /* evaluate args? */ int eval; /* evaluate args? (and other info) */
int arity; /* function arity */ int arity; /* function arity */
PPinfo gram; /* pretty-print info */ PPinfo gram; /* pretty-print info */
} FUNTAB; } FUNTAB;
...@@ -378,15 +386,57 @@ typedef struct { ...@@ -378,15 +386,57 @@ typedef struct {
*/ */
/* Primitive Access Macros */ /* Primitive Access Macros */
#define PRIMOFFSET(x) ((x)->u.primsxp.offset)
#define SET_PRIMOFFSET(x,v) (((x)->u.primsxp.offset)=(v)) /* Set offset of primitive in table, and copy some of the information from
#define PRIMFUN(x) (R_FunTab[(x)->u.primsxp.offset].cfun) the table into the primsxp structure for fast access. Note that
#define PRIMNAME(x) (R_FunTab[(x)->u.primsxp.offset].name) primsxp_fast_cfun will (possibly) be set by the slow function, not here. */
#define PRIMVAL(x) (R_FunTab[(x)->u.primsxp.offset].code)
#define PRIMARITY(x) (R_FunTab[(x)->u.primsxp.offset].arity) #define SET_PRIMOFFSET(x,v) do { \
#define PPINFO(x) (R_FunTab[(x)->u.primsxp.offset].gram) SEXP setprim_ptr = (x); \
#define PRIMPRINT(x) (((R_FunTab[(x)->u.primsxp.offset].eval)/100)%10) int setprim_value = (v); \
#define PRIMINTERNAL(x) (((R_FunTab[(x)->u.primsxp.offset].eval)%100)/10) 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 */ /* Promise Access Macros */
#define PRCODE(x) ((x)->u.promsxp.expr) #define PRCODE(x) ((x)->u.promsxp.expr)
......
...@@ -183,8 +183,15 @@ struct vecsxp_struct { ...@@ -183,8 +183,15 @@ struct vecsxp_struct {
R_len_t truelength; R_len_t truelength;
}; };
struct primsxp_struct { struct primsxp_struct { /* table offset of this and other info is in gp */
int offset; 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 { struct symsxp_struct {
...@@ -522,6 +529,7 @@ LibExtern SEXP R_Srcref; /* Current srcref, for debuggers */ ...@@ -522,6 +529,7 @@ LibExtern SEXP R_Srcref; /* Current srcref, for debuggers */
/* Special Values */ /* Special Values */
LibExtern SEXP R_NilValue; /* The nil object */ 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_UnboundValue; /* Unbound marker */
LibExtern SEXP R_MissingArg; /* Missing argument marker */ LibExtern SEXP R_MissingArg; /* Missing argument marker */
#ifdef __MAIN__ #ifdef __MAIN__
...@@ -609,6 +617,7 @@ SEXP Rf_DropDims(SEXP); ...@@ -609,6 +617,7 @@ SEXP Rf_DropDims(SEXP);
SEXP Rf_duplicate(SEXP); SEXP Rf_duplicate(SEXP);
SEXP Rf_duplicated(SEXP, Rboolean); SEXP Rf_duplicated(SEXP, Rboolean);
SEXP Rf_eval(SEXP, SEXP); SEXP Rf_eval(SEXP, SEXP);
SEXP Rf_evalv(SEXP, SEXP, int);
SEXP Rf_findFun(SEXP, SEXP); SEXP Rf_findFun(SEXP, SEXP);
SEXP Rf_findVar(SEXP, SEXP); SEXP Rf_findVar(SEXP, SEXP);
SEXP Rf_findVarInFrame(SEXP, SEXP); SEXP Rf_findVarInFrame(SEXP, SEXP);
...@@ -903,6 +912,7 @@ Rboolean R_compute_identical(SEXP, SEXP, int); ...@@ -903,6 +912,7 @@ Rboolean R_compute_identical(SEXP, SEXP, int);
#define elt Rf_elt #define elt Rf_elt
#define errorcall Rf_errorcall #define errorcall Rf_errorcall
#define eval Rf_eval #define eval Rf_eval
#define evalv Rf_evalv
#define findFun Rf_findFun #define findFun Rf_findFun
#define findVar Rf_findVar #define findVar Rf_findVar
#define findVarInFrame Rf_findVarInFrame #define findVarInFrame Rf_findVarInFrame
......
...@@ -2755,7 +2755,7 @@ void GEplayDisplayList(pGEDevDesc dd) ...@@ -2755,7 +2755,7 @@ void GEplayDisplayList(pGEDevDesc dd)
SEXP theOperation = CAR(theList); SEXP theOperation = CAR(theList);
SEXP op = CAR(theOperation); SEXP op = CAR(theOperation);
SEXP args = CADR(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 /* Check with each graphics system that the plotting went ok
*/ */
if (!GEcheckState(dd)) { if (!GEcheckState(dd)) {
......
...@@ -39,6 +39,7 @@ ...@@ -39,6 +39,7 @@
#define ARGUSED(x) LEVELS(x) #define ARGUSED(x) LEVELS(x)
static SEXP applyClosure_v (SEXP, SEXP, SEXP, SEXP, SEXP, int);
static SEXP bcEval(SEXP, SEXP, Rboolean); static SEXP bcEval(SEXP, SEXP, Rboolean);
/*#define BC_PROFILING*/ /*#define BC_PROFILING*/
...@@ -334,9 +335,18 @@ static SEXP forcePromise(SEXP e) ...@@ -334,9 +335,18 @@ static SEXP forcePromise(SEXP e)
return PRVALUE(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; SEXP op, tmp;
static int evalcount = 0; static int evalcount = 0;
...@@ -469,7 +479,7 @@ SEXP eval(SEXP e, SEXP rho) ...@@ -469,7 +479,7 @@ SEXP eval(SEXP e, SEXP rho)
const void *vmax = vmaxget(); const void *vmax = vmaxget();
PROTECT(CDR(e)); PROTECT(CDR(e));
R_Visible = flag != 1; R_Visible = flag != 1;
tmp = PRIMFUN(op) (e, op, CDR(e), rho); tmp = CALL_PRIMFUN(e, op, CDR(e), rho, variant);
#ifdef CHECK_VISIBILITY #ifdef CHECK_VISIBILITY
if(flag < 2 && R_Visible == flag) { if(flag < 2 && R_Visible == flag) {
char *nm = PRIMNAME(op); char *nm = PRIMNAME(op);
...@@ -495,10 +505,10 @@ SEXP eval(SEXP e, SEXP rho) ...@@ -495,10 +505,10 @@ SEXP eval(SEXP e, SEXP rho)
if (R_Profiling || (PPINFO(op).kind == PP_FOREIGN)) { if (R_Profiling || (PPINFO(op).kind == PP_FOREIGN)) {
begincontext(&cntxt, CTXT_BUILTIN, e, begincontext(&cntxt, CTXT_BUILTIN, e,
R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue); 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); endcontext(&cntxt);
} else { } else {
tmp = PRIMFUN(op) (e, op, tmp, rho); tmp = CALL_PRIMFUN(e, op, tmp, rho, variant);
} }
#ifdef CHECK_VISIBILITY #ifdef CHECK_VISIBILITY
if(flag < 2 && R_Visible == flag) { if(flag < 2 && R_Visible == flag) {
...@@ -513,7 +523,7 @@ SEXP eval(SEXP e, SEXP rho) ...@@ -513,7 +523,7 @@ SEXP eval(SEXP e, SEXP rho)
} }
else if (TYPEOF(op) == CLOSXP) { else if (TYPEOF(op) == CLOSXP) {
PROTECT(tmp = promiseArgs(CDR(e), rho)); 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); UNPROTECT(1);
} }
else else
...@@ -698,7 +708,8 @@ static R_INLINE SEXP getSrcref(SEXP srcrefs, int ind) ...@@ -698,7 +708,8 @@ static R_INLINE SEXP getSrcref(SEXP srcrefs, int ind)
return R_NilValue; 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; SEXP formals, actuals, savedrho;
volatile SEXP body, newrho; volatile SEXP body, newrho;
...@@ -852,13 +863,13 @@ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedenv) ...@@ -852,13 +863,13 @@ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedenv)
if (R_ReturnedValue == R_RestartToken) { if (R_ReturnedValue == R_RestartToken) {
cntxt.callflag = CTXT_RETURN; /* turn restart off */ cntxt.callflag = CTXT_RETURN; /* turn restart off */
R_ReturnedValue = R_NilValue; /* remove restart token */ R_ReturnedValue = R_NilValue; /* remove restart token */
PROTECT(tmp = eval(body, newrho)); PROTECT(tmp = evalv (body, newrho, variant));
} }
else else
PROTECT(tmp = R_ReturnedValue); PROTECT(tmp = R_ReturnedValue);
} }
else { else {
PROTECT(tmp = eval(body, newrho)); PROTECT(tmp = evalv (body, newrho, variant));
} }
endcontext(&cntxt); endcontext(&cntxt);
...@@ -871,6 +882,12 @@ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedenv) ...@@ -871,6 +882,12 @@ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedenv)
return (tmp); 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 /* **** FIXME: This code is factored out of applyClosure. If we keep
**** it we should change applyClosure to run through this routine **** it we should change applyClosure to run through this routine
**** to avoid code drift. */ **** to avoid code drift. */
...@@ -2178,7 +2195,7 @@ SEXP attribute_hidden do_recall(SEXP call, SEXP op, SEXP args, SEXP rho) ...@@ -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)); PROTECT(s = eval(CAR(cptr->call), cptr->sysparent));
if (TYPEOF(s) != CLOSXP) if (TYPEOF(s) != CLOSXP)
error(_("'Recall' called from outside a closure")); 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); UNPROTECT(1);
return ans; return ans;
} }
...@@ -2614,7 +2631,7 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho, ...@@ -2614,7 +2631,7 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
if(isOps) SET_TAG(m, R_NilValue); 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); UNPROTECT(5);
return 1; return 1;
} }
...@@ -4400,17 +4417,17 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4400,17 +4417,17 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
checkForMissings(args, call); checkForMissings(args, call);
flag = PRIMPRINT(fun); flag = PRIMPRINT(fun);
R_Visible = flag != 1; 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; if (flag < 2) R_Visible = flag != 1;
break; break;
case SPECIALSXP: case SPECIALSXP:
flag = PRIMPRINT(fun); flag = PRIMPRINT(fun);
R_Visible = flag != 1; 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; if (flag < 2) R_Visible = flag != 1;
break; break;
case CLOSXP: case CLOSXP:
value = applyClosure(call, fun, args, rho, R_BaseEnv); value = applyClosure_v(call, fun, args, rho, R_BaseEnv, 0);
break; break;
default: error(_("bad function")); default: error(_("bad function"));
} }
...@@ -4430,7 +4447,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4430,7 +4447,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
error(_("not a BUILTIN function")); error(_("not a BUILTIN function"));
flag = PRIMPRINT(fun); flag = PRIMPRINT(fun);
R_Visible = flag != 1; 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; if (flag < 2) R_Visible = flag != 1;
vmaxset(vmax); vmaxset(vmax);
R_BCNodeStackTop -= 2; R_BCNodeStackTop -= 2;
...@@ -4451,7 +4468,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4451,7 +4468,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
BCNPUSH(fun); /* for GC protection */ BCNPUSH(fun); /* for GC protection */
flag = PRIMPRINT(fun); flag = PRIMPRINT(fun);
R_Visible = flag != 1; 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; if (flag < 2) R_Visible = flag != 1;
vmaxset(vmax); vmaxset(vmax);
SETSTACK(-1, value); /* replaces fun on stack */ SETSTACK(-1, value); /* replaces fun on stack */
...@@ -4701,7 +4718,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4701,7 +4718,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
SETCAR(args, lhs); SETCAR(args, lhs);
/* make the call */ /* make the call */
checkForMissings(args, call); checkForMissings(args, call);
value = PRIMFUN(fun) (call, fun, args, rho); value = CALL_PRIMFUN(call, fun, args, rho, 0);
break; break;
case SPECIALSXP: case SPECIALSXP:
/* duplicate arguments and put into stack for GC protection */ /* duplicate arguments and put into stack for GC protection */
...@@ -4719,7 +4736,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4719,7 +4736,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
SET_PRVALUE(prom, rhs); SET_PRVALUE(prom, rhs);
SETCAR(last, prom); SETCAR(last, prom);
/* make the call */ /* make the call */
value = PRIMFUN(fun) (call, fun, args, rho); value = CALL_PRIMFUN(call, fun, args, rho, 0);
break; break;
case CLOSXP: case CLOSXP:
/* push evaluated promise for RHS onto arguments with 'value' tag */ /* push evaluated promise for RHS onto arguments with 'value' tag */
...@@ -4733,7 +4750,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4733,7 +4750,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
args = GETSTACK(-2); args = GETSTACK(-2);
SETCAR(args, prom); SETCAR(args, prom);
/* make the call */ /* make the call */
value = applyClosure(call, fun, args, rho, R_BaseEnv); value = applyClosure_v(call, fun, args, rho, R_BaseEnv, 0);
break; break;
default: error(_("bad function")); default: error(_("bad function"));
} }
...@@ -4755,7 +4772,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4755,7 +4772,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
SETCAR(args, lhs); SETCAR(args, lhs);
/* make the call */ /* make the call */
checkForMissings(args, call); checkForMissings(args, call);
value = PRIMFUN(fun) (call, fun, args, rho); value = CALL_PRIMFUN(call, fun, args, rho, 0);
break; break;
case SPECIALSXP: case SPECIALSXP:
/* duplicate arguments and put into stack for GC protection */ /* duplicate arguments and put into stack for GC protection */
...@@ -4766,7 +4783,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4766,7 +4783,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
SET_PRVALUE(prom, lhs); SET_PRVALUE(prom, lhs);
SETCAR(args, prom); SETCAR(args, prom);
/* make the call */ /* make the call */
value = PRIMFUN(fun) (call, fun, args, rho); value = CALL_PRIMFUN(call, fun, args, rho, 0);
break; break;
case CLOSXP: case CLOSXP:
/* replace first argument with evaluated promise for LHS */ /* replace first argument with evaluated promise for LHS */
...@@ -4775,7 +4792,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache) ...@@ -4775,7 +4792,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
args = GETSTACK(-2); args = GETSTACK(-2);
SETCAR(args, prom); SETCAR(args, prom);
/* make the call */ /* make the call */
value = applyClosure(call, fun, args, rho, R_BaseEnv); value = applyClosure_v(call, fun, args, rho, R_BaseEnv, 0);
break; break;
default: error(_("bad function")); default: error(_("bad function"));
} }
......
...@@ -1473,6 +1473,7 @@ static void RunGenCollect(R_size_t size_needed) ...@@ -1473,6 +1473,7 @@ static void RunGenCollect(R_size_t size_needed)
FORWARD_NODE(R_EmptyEnv); FORWARD_NODE(R_EmptyEnv);
FORWARD_NODE(R_Warnings); /* Warnings, if any */ 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_HandlerStack); /* Condition handler stack */
FORWARD_NODE(R_RestartStack); /* Available restarts stack */ FORWARD_NODE(R_RestartStack); /* Available restarts stack */
...@@ -3294,7 +3295,7 @@ void attribute_hidden (UNLOCK_BINDING)(SEXP b) {UNLOCK_BINDING(b);} ...@@ -3294,7 +3295,7 @@ void attribute_hidden (UNLOCK_BINDING)(SEXP b) {UNLOCK_BINDING(b);}
/* R_FunTab accessors */ /* R_FunTab accessors */
int (PRIMVAL)(SEXP x) { return PRIMVAL(x); } int (PRIMVAL)(SEXP x) { return PRIMVAL(x); }
CCODE (PRIMFUN)(SEXP x) { return PRIMFUN(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 */ /* for use when testing the write barrier */
int attribute_hidden (IS_BYTES)(SEXP x) { return IS_BYTES(x); } int attribute_hidden (IS_BYTES)(SEXP x) { return IS_BYTES(x); }
......
...@@ -59,13 +59,18 @@ ...@@ -59,13 +59,18 @@
* Convention: * Convention: