*/ void Dump_Stack(REBINT dsf, REBINT dsp)
/*
***********************************************************************/
{
REBINT n;
REBINT m;
REBVAL *args;
if (dsf == 0) {
dsf = DSF;
dsp = DSP;
}
m = dsp - dsf - DSF_SIZE;
Debug_Fmt(BOOT_STR(RS_STACK, 1), dsp, Get_Word_Name(DSF_WORD(dsf)), m, Get_Type_Name(DSF_FUNC(dsf)));
if (dsf > 0) {
if (ANY_FUNC(DSF_FUNC(dsf))) {
args = BLK_HEAD(VAL_FUNC_ARGS(DSF_FUNC(dsf)));
m = SERIES_TAIL(VAL_FUNC_ARGS(DSF_FUNC(dsf)));
for (n = 1; n < m; n++)
Debug_Fmt("\t%s: %72r", Get_Word_Name(args+n), DSF_ARGS(dsf, n));
}
//Debug_Fmt(Str_Stack[2], PRIOR_DSF(dsf));
if (PRIOR_DSF(dsf) > 0) Dump_Stack(PRIOR_DSF(dsf), dsf-1);
}
//for (n = 1; n <= 2; n++) {
// Debug_Fmt(" ARG%d: %s %r", n, Get_Type_Name(DSF_ARGS(dsf, n)), DSF_ARGS(dsf, n));
//}
}
*/ REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def)
/*
***********************************************************************/
{
REBVAL *spec;
REBVAL *body;
REBCNT len;
if (
!IS_BLOCK(def)
|| (len = VAL_LEN(def)) < 2
|| !IS_BLOCK(spec = VAL_BLK(def))
) return FALSE;
body = VAL_BLK_SKIP(def, 1);
VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
if (type != REB_COMMAND) {
if (len != 2 || !IS_BLOCK(body)) return FALSE;
VAL_FUNC_BODY(value) = VAL_SERIES(body);
}
else
Make_Command(value, def);
VAL_SET(value, type);
if (type == REB_FUNCTION || type == REB_CLOSURE)
Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value));
return TRUE;
}
*/ REBFLG Copy_Function(REBVAL *value, REBVAL *args)
/*
***********************************************************************/
{
REBVAL *spec = VAL_BLK(args);
REBVAL *body = VAL_BLK_SKIP(args, 1);
if (IS_END(spec)) body = 0;
else {
// Spec given, must be block or *
if (IS_BLOCK(spec)) {
VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
} else
if (!IS_STAR(spec)) return FALSE;
}
if (body && !IS_END(body)) {
if (!IS_FUNCTION(value) && !IS_CLOSURE(value)) return FALSE;
// Body must be block:
if (!IS_BLOCK(body)) return FALSE;
VAL_FUNC_BODY(value) = VAL_SERIES(body);
}
// No body, use protytpe:
else if (IS_FUNCTION(value) || IS_CLOSURE(value))
VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(value));
// Rebind function words:
if (IS_FUNCTION(value))
Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value), VAL_FUNC_BODY(value));
return TRUE;
}
*/ REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def)
/*
***********************************************************************/
{
REBVAL *spec;
REBVAL *body;
REBCNT len;
if (
!IS_BLOCK(def)
//// || type < REB_CLOSURE // for now
|| (len = VAL_LEN(def)) < 2
|| !IS_BLOCK(spec = VAL_BLK(def))
) return FALSE;
body = VAL_BLK_SKIP(def, 1);
// Print("Make_Func"); //: %s spec %d", Get_Sym_Name(type+1), SERIES_TAIL(spec));
VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
if (type != REB_COMMAND) {
if (len != 2 || !IS_BLOCK(body)) return FALSE;
VAL_FUNC_BODY(value) = VAL_SERIES(body);
}
else
Make_Command(value, def);
VAL_SET(value, type);
if (type == REB_FUNCTION)
Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value), VAL_FUNC_BODY(value));
return TRUE;
}
static REBOOL Same_Func(REBVAL *val, REBVAL *arg)
{
if (VAL_TYPE(val) == VAL_TYPE(arg) &&
VAL_FUNC_SPEC(val) == VAL_FUNC_SPEC(arg) &&
VAL_FUNC_ARGS(val) == VAL_FUNC_ARGS(arg) &&
VAL_FUNC_CODE(val) == VAL_FUNC_CODE(arg)) return TRUE;
return FALSE;
}
*/ void Clone_Function(REBVAL *value, REBVAL *func)
/*
***********************************************************************/
{
VAL_FUNC_SPEC(value) = VAL_FUNC_SPEC(func);
VAL_FUNC_ARGS(value) = VAL_FUNC_ARGS(func);
VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(func));
}
*/ void Clone_Function(REBVAL *value, REBVAL *func)
/*
***********************************************************************/
{
REBSER *src_frame = VAL_FUNC_ARGS(func);
VAL_FUNC_SPEC(value) = VAL_FUNC_SPEC(func);
VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(func));
VAL_FUNC_ARGS(value) = Copy_Block(src_frame, 0);
// VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(func));
VAL_FUNC_BODY(value) = Copy_Block_Values(VAL_FUNC_BODY(func), 0, SERIES_TAIL(VAL_FUNC_BODY(func)), TS_CLONE);
Rebind_Block(src_frame, VAL_FUNC_ARGS(value), BLK_HEAD(VAL_FUNC_BODY(value)), 0);
}
*/ void Do_Command(REBVAL *value)
/*
** Evaluates the arguments for a command function and creates
** a resulting stack frame (struct or object) for command processing.
**
** A command value consists of:
** args - same as other funcs
** spec - same as other funcs
** body - [ext-obj func-index]
**
***********************************************************************/
{
REBVAL *val = BLK_HEAD(VAL_FUNC_BODY(value));
REBEXT *ext;
REBCNT cmd;
REBCNT argc;
REBCNT n;
RXIFRM frm; // args stored here
// All of these were checked above on definition:
val = BLK_HEAD(VAL_FUNC_BODY(value));
cmd = (int)VAL_INT64(val+1);
ext = &Ext_List[VAL_I32(VAL_OBJ_VALUE(val, 1))]; // Handler
// Copy args to command frame (array of args):
RXA_COUNT(&frm) = argc = SERIES_TAIL(VAL_FUNC_ARGS(value))-1; // not self
if (argc > 7) Trap0(RE_BAD_COMMAND);
val = DS_ARG(1);
for (n = 1; n <= argc; n++, val++) {
RXA_TYPE(&frm, n) = Reb_To_RXT[VAL_TYPE(val)];
frm.args[n] = Value_To_RXI(val);
}
// Call the command:
n = ext->call(cmd, &frm, 0);
val = DS_RETURN;
switch (n) {
case RXR_VALUE:
RXI_To_Value(val, frm.args[1], RXA_TYPE(&frm, 1));
break;
case RXR_BLOCK:
RXI_To_Block(&frm, val);
break;
case RXR_UNSET:
SET_UNSET(val);
break;
case RXR_NONE:
SET_NONE(val);
break;
case RXR_TRUE:
SET_TRUE(val);
break;
case RXR_FALSE:
SET_FALSE(val);
break;
case RXR_ERROR:
default:
SET_UNSET(val);
}
}
*/ void Do_Routine(REBVAL *routine)
/*
*/
{
//RL_Print("%s, %d\n", __func__, __LINE__);
REBSER *args = Copy_Values(BLK_SKIP(DS_Series, DS_ARG_BASE + 1), SERIES_TAIL(VAL_FUNC_ARGS(routine)) - 1);
Call_Routine(routine, args, DS_OUT);
}
*/ 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)
}
*/ void Make_Native(REBVAL *value, REBSER *spec, REBFUN func, REBINT type)
/*
***********************************************************************/
{
//Print("Make_Native: %s spec %d", Get_Sym_Name(type+1), SERIES_TAIL(spec));
VAL_FUNC_SPEC(value) = spec;
VAL_FUNC_ARGS(value) = Check_Func_Spec(spec);
VAL_FUNC_CODE(value) = func;
VAL_SET(value, type);
}
*/ void Bind_Stack_Block(REBSER *body, REBSER *block)
/*
***********************************************************************/
{
REBINT dsf = DSF;
// Find body (frame) on stack:
while (body != VAL_WORD_FRAME(DSF_WORD(dsf))) {
dsf = PRIOR_DSF(dsf);
if (dsf <= 0) Trap0(RE_NOT_DEFINED); // better message !!!!
}
if (IS_FUNCTION(DSF_FUNC(dsf))) {
Bind_Relative(VAL_FUNC_ARGS(DSF_FUNC(dsf)), body, block);
}
}
*/ void Make_Command(REBVAL *value, REBVAL *def)
/*
** Assumes prior function has already stored the spec and args
** series. This function validates the body.
**
***********************************************************************/
{
REBVAL *args = BLK_HEAD(VAL_FUNC_ARGS(value));
REBCNT n;
REBVAL *val = VAL_BLK_SKIP(def, 1);
REBEXT *ext;
if (
VAL_LEN(def) != 3
|| !(IS_MODULE(val) || IS_OBJECT(val))
|| !IS_HANDLE(VAL_OBJ_VALUE(val, 1))
|| !IS_INTEGER(val+1)
|| VAL_INT64(val+1) > 0xffff
) Trap1(RE_BAD_FUNC_DEF, def);
val = VAL_OBJ_VALUE(val, 1);
if (
!(ext = &Ext_List[VAL_I32(val)])
|| !(ext->call)
) Trap1(RE_BAD_EXTENSION, def);
// make command! [[arg-spec] handle cmd-index]
VAL_FUNC_BODY(value) = Copy_Block_Len(VAL_SERIES(def), 1, 2);
// Check for valid command arg datatypes:
args++; // skip self
n = 1;
for (; NOT_END(args); args++, n++) {
// If the typeset contains args that are not valid:
// (3 is the default when no args given, for not END and UNSET)
if (3 != ~VAL_TYPESET(args) && (VAL_TYPESET(args) & ~RXT_ALLOWED_TYPES))
Trap1(RE_BAD_FUNC_ARG, args);
}
VAL_SET(value, REB_COMMAND);
}
*/ void Bind_Stack_Word(REBSER *body, REBVAL *word)
/*
***********************************************************************/
{
REBINT dsf = DSF;
REBINT index;
// Find body (frame) on stack:
while (body != VAL_WORD_FRAME(DSF_WORD(dsf))) {
dsf = PRIOR_DSF(dsf);
if (dsf <= 0) Trap1(RE_NOT_IN_CONTEXT, word);
}
if (IS_FUNCTION(DSF_FUNC(dsf))) {
index = Find_Arg_Index(VAL_FUNC_ARGS(DSF_FUNC(dsf)), VAL_WORD_SYM(word));
if (!index) Trap1(RE_NOT_IN_CONTEXT, word);
VAL_WORD_FRAME(word) = body;
VAL_WORD_INDEX(word) = -index;
} else
Crash(9100); // !!! function is not there!
}
*/ void Bind_Frame(REBSER *obj)
/*
** Clone a frame, knowing which types of values need to be
** copied, deep copied, and rebound.
**
***********************************************************************/
{
REBVAL *val;
REBOOL funcs = FALSE;
//DISABLE_GC;
// Copy functions:
for (val = BLK_SKIP(obj, 1); NOT_END(val); val++) {
if (IS_FUNCTION(val)) {
Clone_Function(val, val);
funcs = TRUE;
}
else if (IS_CLOSURE(val)) {
funcs = TRUE;
}
}
// Rebind all values:
Bind_Block(obj, BLK_SKIP(obj, 1), BIND_DEEP | BIND_FUNC);
if (funcs) {
// Rebind functions:
for (val = BLK_SKIP(obj, 1); NOT_END(val); val++) {
if (IS_FUNCTION(val)) {
Bind_Relative(VAL_FUNC_ARGS(val), VAL_FUNC_BODY(val), VAL_FUNC_BODY(val));
}
else if (IS_CLOSURE(val)) {
}
}
}
//ENABLE_GC;
}
*/ void Do_Commands(REBSER *cmds, void *context)
/*
** Evaluate a block of commands as efficiently as possible.
** The arguments to each command must already be reduced or
** use only variable lookup.
**
** Returns the last evaluated value, if provided.
**
***********************************************************************/
{
REBVAL *blk;
REBCNT index = 0;
REBVAL *set_word = 0;
REBVAL *cmd_word;
REBSER *words;
REBVAL *args;
REBVAL *val;
REBVAL *func;
RXIFRM frm; // args stored here
REBCNT n;
REBEXT *ext;
REBCEC *ctx;
if ((ctx = context)) ctx->block = cmds;
blk = BLK_HEAD(cmds);
while (NOT_END(blk)) {
// var: command result
if IS_SET_WORD(blk) {
set_word = blk++;
index++;
};
// get command function
if (IS_WORD(cmd_word = blk)) {
// Optimized var fetch:
n = VAL_WORD_INDEX(blk);
if (n > 0) func = FRM_VALUES(VAL_WORD_FRAME(blk)) + n;
else func = Get_Var(blk); // fallback
} else func = blk;
if (!IS_COMMAND(func)) Trap2(RE_EXPECT_VAL, Get_Type_Word(REB_COMMAND), blk);
// Advance to next value
blk++;
if (ctx) ctx->index = index; // position of function
index++;
// get command arguments and body
words = VAL_FUNC_WORDS(func);
RXA_COUNT(&frm) = SERIES_TAIL(VAL_FUNC_ARGS(func))-1; // not self
// collect each argument (arg list already validated on MAKE)
n = 0;
for (args = BLK_SKIP(words, 1); NOT_END(args); args++) {
//Debug_Type(args);
val = blk++;
index++;
if (IS_END(val)) Trap2(RE_NO_ARG, cmd_word, args);
//Debug_Type(val);
// actual arg is a word, lookup?
if (VAL_TYPE(val) >= REB_WORD) {
if (IS_WORD(val)) {
if (IS_WORD(args)) val = Get_Var(val);
}
else if (IS_PATH(val)) {
if (IS_WORD(args)) val = Get_Any_Var(val); // volatile value!
}
else if (IS_PAREN(val)) {
val = Do_Blk(VAL_SERIES(val), 0); // volatile value!
}
// all others fall through
}
// check datatype
if (!TYPE_CHECK(args, VAL_TYPE(val)))
Trap3(RE_EXPECT_ARG, cmd_word, args, Of_Type(val));
// put arg into command frame
n++;
RXA_TYPE(&frm, n) = Reb_To_RXT[VAL_TYPE(val)];
frm.args[n] = Value_To_RXI(val);
}
// Call the command (also supports different extension modules):
func = BLK_HEAD(VAL_FUNC_BODY(func));
n = (REBCNT)VAL_INT64(func + 1);
ext = &Ext_List[VAL_I32(VAL_OBJ_VALUE(func, 1))]; // Handler
n = ext->call(n, &frm, context);
val = DS_RETURN;
switch (n) {
case RXR_VALUE:
RXI_To_Value(val, frm.args[1], RXA_TYPE(&frm, 1));
break;
case RXR_BLOCK:
RXI_To_Block(&frm, val);
break;
case RXR_UNSET:
SET_UNSET(val);
break;
case RXR_NONE:
SET_NONE(val);
break;
case RXR_TRUE:
SET_TRUE(val);
break;
case RXR_FALSE:
SET_FALSE(val);
break;
case RXR_ERROR:
default:
SET_UNSET(val);
}
if (set_word) {
Set_Var(set_word, val);
set_word = 0;
}
}
}
