*/ REBSER *Make_Frame(REBINT len)
/*
** Create a frame of a given size, allocating space for both
** words and values. Normally used for global frames.
**
** selfless means do not set SELF word
**
***********************************************************************/
{
REBSER *frame;
REBSER *words;
REBVAL *value;
//DISABLE_GC;
words = Make_Block(len + 1); // size + room for SELF
BARE_SERIES(words);
frame = Make_Block(len + 1);
//ENABLE_GC;
// Note: cannot use Append_Frame for first word.
value = Append_Value(frame);
SET_FRAME(value, 0, words);
value = Append_Value(words);
Init_Frame_Word(value, SYM_SELF); // may get unset by selfless frames
return frame;
}
SEXP SmokeObject::fieldEnv() const {
if (!_fieldEnv) {
_fieldEnv = allocSExp(ENVSXP);
SET_ENCLOS(_fieldEnv, R_EmptyEnv);
SET_FRAME(_fieldEnv, R_NilValue);
R_PreserveObject(_fieldEnv);
}
return _fieldEnv;
}
*/ void Do_Closure(REBVAL *func)
/*
** Do a closure by cloning its body and binding it to
** a new frame of words/values.
**
** This could be made faster by pre-binding the body,
** then using Rebind_Block to rebind the words in it.
**
***********************************************************************/
{
REBSER *body;
REBSER *frame;
REBVAL *result;
REBVAL *ds;
Eval_Functions++;
//DISABLE_GC;
// Clone the body of the function to allow rebinding to it:
body = Clone_Block(VAL_FUNC_BODY(func));
// Copy stack frame args as the closure object (one extra at head)
frame = Copy_Values(BLK_SKIP(DS_Series, DS_ARG_BASE), SERIES_TAIL(VAL_FUNC_ARGS(func)));
SET_FRAME(BLK_HEAD(frame), 0, VAL_FUNC_ARGS(func));
// Rebind the body to the new context (deeply):
//Rebind_Block(VAL_FUNC_ARGS(func), frame, body);
Bind_Block(frame, BLK_HEAD(body), BIND_DEEP); // | BIND_NO_SELF);
ds = DS_RETURN;
SET_OBJECT(ds, body); // keep it GC safe
result = Do_Blk(body, 0); // GC-OK - also, result returned on DS stack
ds = DS_RETURN;
if (IS_ERROR(result) && IS_RETURN(result)) {
// Value below is kept safe from GC because no-allocation is
// done between point of SET_THROW and here.
if (VAL_ERR_VALUE(result))
*ds = *VAL_ERR_VALUE(result);
else
SET_UNSET(ds);
}
else *ds = *result; // Set return value (atomic)
}
*/ REBSER *Create_Frame(REBSER *words, REBSER *spec)
/*
** Create a new frame from a word list.
** The values of the frame are initialized to NONE.
**
***********************************************************************/
{
REBINT len = SERIES_TAIL(words);
REBSER *frame = Make_Block(len);
REBVAL *value = BLK_HEAD(frame);
SET_FRAME(value, spec, words);
SERIES_TAIL(frame) = len;
for (value++, len--; len > 0; len--, value++) SET_NONE(value); // skip first value (self)
SET_END(value);
return frame;
}
*/ REBSER *Make_Frame(REBINT len, REBOOL has_self)
/*
** Create a frame of a given size, allocating space for both
** words and values. Normally used for global frames.
**
***********************************************************************/
{
REBSER *frame;
REBSER *words;
REBVAL *value;
words = Make_Array(len + 1); // size + room for SELF
frame = Make_Array(len + 1);
// Note: cannot use Append_Frame for first word.
value = Alloc_Tail_Array(frame);
SET_FRAME(value, 0, words);
value = Alloc_Tail_Array(words);
Val_Init_Word_Typed(
value, REB_WORD, has_self ? SYM_SELF : SYM_NOT_USED, ALL_64
);
return frame;
}
SEXP attribute_hidden matchPositionalArgsCreateEnv(SEXP formals, SEXP *supplied, int nsupplied, SEXP call, SEXP rho, SEXP* outActuals)
{
SEXP *s;
SEXP f, a;
SEXP actuals = R_NilValue;
SEXP newrho = PROTECT(NewEnvironmentNR(rho));
SEXP *endSupplied = supplied + nsupplied;
for (f = formals, s = supplied, a = actuals ; f != R_NilValue ; f = CDR(f), s++) {
if (TAG(f) == R_DotsSymbol) {
/* pack all remaining arguments into ... */
SEXP *rs = endSupplied - 1;
SEXP dotsContent = R_NilValue;
for(; rs >= s; rs--) {
dotsContent = CONS(*rs, dotsContent); /* FIXME: enabling refcnt? */
}
SEXP dots = CONS_NR(dotsContent, R_NilValue);
SET_TAG(dots, R_DotsSymbol);
if (dotsContent != R_NilValue) {
SET_TYPEOF(dotsContent, DOTSXP);
} else {
SET_MISSING(dots, 1);
}
if (a == R_NilValue) {
PROTECT(actuals = dots);
} else {
SETCDR(a, dots);
ENABLE_REFCNT(a); /* dots are part of a protected list */
}
a = dots;
f = CDR(f);
s = endSupplied;
/* falls through into noMoreSupplied branch below */
}
if (s == endSupplied) {
/* possibly fewer supplied arguments than formals */
SEXP ds;
for(; f != R_NilValue ; f = CDR(f), a = ds) {
ds = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(ds, TAG(f));
if (a == R_NilValue) {
PROTECT(actuals = ds);
} else {
SETCDR(a, ds);
ENABLE_REFCNT(a); /* ds is part of a protected list */
}
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(ds, 2);
SETCAR(ds, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(ds, 1);
}
}
break;
}
/* normal case, the next supplied arg is available */
SEXP arg = CONS_NR(*s, R_NilValue);
SET_TAG(arg, TAG(f));
if (a == R_NilValue) {
PROTECT(actuals = arg);
} else {
SETCDR(a, arg);
ENABLE_REFCNT(a);
}
a = arg;
}
if (s < endSupplied) {
/* some arguments are not used */
SEXP *rs = endSupplied - 1;
SEXP unusedForError = R_NilValue;
for(; rs >= s; rs--) {
SEXP rsValue = *rs;
if (TYPEOF(rsValue) == PROMSXP) {
rsValue = PREXPR(rsValue);
}
unusedForError = CONS(rsValue, unusedForError);
}
PROTECT(unusedForError); /* needed? */
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
UNPROTECT(1);
}
if (a != R_NilValue) {
ENABLE_REFCNT(a);
}
SET_FRAME(newrho, actuals);
ENABLE_REFCNT(newrho);
UNPROTECT(1); /* newrho */
if (actuals != R_NilValue) {
UNPROTECT(1); /* actuals */
}
*outActuals = actuals;
return(newrho);
}
SEXP attribute_hidden matchUnnamedArgsCreateEnv(SEXP formals, SEXP supplied, SEXP call, SEXP rho, SEXP* outActuals)
{
SEXP f, s;
SEXP actuals = PROTECT(supplied);
SEXP newrho = PROTECT(NewEnvironmentNR(rho));
SEXP prevS = R_NilValue;
for (f = formals, s = supplied ; f != R_NilValue ; f = CDR(f), prevS = s, s = CDR(s)) {
if (TAG(f) == R_DotsSymbol) {
/* pack all arguments into ... */
SEXP dots = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(dots, R_DotsSymbol);
if (prevS == R_NilValue) {
UNPROTECT(1); /* old actuals */
PROTECT(actuals = dots);
} else {
SETCDR(prevS, dots);
ENABLE_REFCNT(prevS); /* dots are part of a protected list */
}
if (s != R_NilValue) {
SET_TYPEOF(s, DOTSXP);
SETCAR(dots, s);
s = R_NilValue;
} else {
SET_MISSING(dots, 1);
}
prevS = dots;
f = CDR(f);
/* falls through into s == R_NilValue case */
}
if (s == R_NilValue) {
/* fewer supplied arguments than formals */
SEXP ds;
for(; f != R_NilValue ; f = CDR(f), prevS = ds) {
ds = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(ds, TAG(f));
if (prevS == R_NilValue) {
UNPROTECT(1); /* old actuals */
PROTECT(actuals = ds);
} else {
SETCDR(prevS, ds);
ENABLE_REFCNT(prevS); /* ds is part of a protected list */
}
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(ds, 2);
SETCAR(ds, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(ds, 1);
}
}
break;
}
/* normal case, the next supplied arg is available */
SET_TAG(s, TAG(f));
if (CAR(s) == R_MissingArg) {
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(s, 2);
SETCAR(s, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(s, 1);
}
}
if (prevS != R_NilValue) {
ENABLE_REFCNT(prevS);
}
}
if (s != R_NilValue) {
/* some arguments are not used */
SEXP unusedForError = PROTECT(s);
SETCDR(prevS, R_NilValue); /* make sure they're not in the new environment */
/* show bad arguments in call without evaluating them */
for (; s != R_NilValue; s = CDR(s)) {
SEXP carS = CAR(s);
if (TYPEOF(carS) == PROMSXP) {
SETCAR(s, PREXPR(carS));
}
}
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
UNPROTECT(1);
}
if (prevS != R_NilValue) {
ENABLE_REFCNT(prevS);
}
SET_FRAME(newrho, actuals);
ENABLE_REFCNT(newrho);
UNPROTECT(2); /* newrho, actuals */
*outActuals = actuals;
return(newrho);
}
