//
// Resolve_Path: C
//
// Given a path, return a context and index for its terminal.
//
REBCTX *Resolve_Path(REBVAL *path, REBCNT *index)
{
REBVAL *sel; // selector
const REBVAL *val;
REBARR *blk;
REBCNT i;
if (VAL_LEN_HEAD(path) < 2) return 0;
blk = VAL_ARRAY(path);
sel = ARR_HEAD(blk);
if (!ANY_WORD(sel)) return 0;
val = GET_OPT_VAR_MAY_FAIL(sel);
sel = ARR_AT(blk, 1);
while (TRUE) {
if (!ANY_CONTEXT(val) || !IS_WORD(sel)) return 0;
i = Find_Word_In_Context(VAL_CONTEXT(val), VAL_WORD_SYM(sel), FALSE);
sel++;
if (IS_END(sel)) {
*index = i;
return VAL_CONTEXT(val);
}
}
return 0; // never happens
}
//
// Resolve_Path: C
//
// Given a path, determine if it is ultimately specifying a selection out
// of a context...and if it is, return that context. So `a/obj/key` would
// return the object assocated with obj, while `a/str/1` would return
// NULL if `str` were a string as it's not an object selection.
//
// !!! This routine overlaps the logic of Do_Path, and should potentially
// be a mode of that instead. It is not very complete, considering that it
// does not execute GROUP! (and perhaps shouldn't?) and only supports a
// path that picks contexts out of other contexts, via word selection.
//
REBCTX *Resolve_Path(const REBVAL *path, REBCNT *index_out)
{
RELVAL *selector;
const REBVAL *var;
REBARR *array;
REBCNT i;
array = VAL_ARRAY(path);
selector = ARR_HEAD(array);
if (IS_END(selector) || !ANY_WORD(selector))
return NULL; // !!! only handles heads of paths that are ANY-WORD!
var = GET_OPT_VAR_MAY_FAIL(selector, VAL_SPECIFIER(path));
++selector;
if (IS_END(selector))
return NULL; // !!! does not handle single-element paths
while (ANY_CONTEXT(var) && IS_WORD(selector)) {
i = Find_Canon_In_Context(
VAL_CONTEXT(var), VAL_WORD_CANON(selector), FALSE
);
++selector;
if (IS_END(selector)) {
*index_out = i;
return VAL_CONTEXT(var);
}
var = CTX_VAR(VAL_CONTEXT(var), i);
}
DEAD_END;
}
//
// Get_System: C
//
// Return a second level object field of the system object.
//
REBVAL *Get_System(REBCNT i1, REBCNT i2)
{
REBVAL *obj;
obj = CTX_VAR(VAL_CONTEXT(ROOT_SYSTEM), i1);
if (i2 == 0) return obj;
assert(IS_OBJECT(obj));
return Get_Field(VAL_CONTEXT(obj), i2);
}
//
// Get_Object: C
//
// Get an instance variable from an ANY-CONTEXT! value.
//
REBVAL *Get_Object(const REBVAL *any_context, REBCNT index)
{
REBCTX *context = VAL_CONTEXT(any_context);
assert(GET_ARR_FLAG(CTX_VARLIST(context), ARRAY_FLAG_CONTEXT_VARLIST));
assert(index <= CTX_LEN(context));
return CTX_VAR(context, index);
}
//
// Val_Init_Context: C
//
// Common routine for initializing OBJECT, MODULE!, PORT!, and ERROR!
//
// A fully constructed context can reconstitute the ANY-CONTEXT! REBVAL that
// is its canon form from a single pointer...the REBVAL sitting in the 0 slot
// of the context's varlist.
//
void Val_Init_Context(REBVAL *out, enum Reb_Kind kind, REBCTX *context) {
//
// In a debug build we check to make sure the type of the embedded value
// matches the type of what is intended (so someone who thinks they are
// initializing a REB_OBJECT from a CONTEXT does not accidentally get a
// REB_ERROR, for instance.) It's a point for several other integrity
// checks as well.
//
#if !defined(NDEBUG)
REBVAL *value = CTX_VALUE(context);
assert(ANY_CONTEXT(value));
assert(CTX_TYPE(context) == kind);
assert(VAL_CONTEXT(value) == context);
if (!CTX_KEYLIST(context)) {
Debug_Fmt("Context found with no keylist set");
Panic_Context(context);
}
assert(GET_ARR_FLAG(CTX_VARLIST(context), ARRAY_FLAG_CONTEXT_VARLIST));
// !!! Historically spec is a frame of an object for a "module spec",
// may want to use another word of that and make a block "spec"
//
if (IS_FRAME(CTX_VALUE(context))) {
assert(IS_FUNCTION(FUNC_VALUE(CTX_FRAME_FUNC(context))));
}
else
assert(
NOT(CTX_SPEC(context))
|| ANY_CONTEXT(CTX_VALUE(CTX_SPEC(context)))
);
#endif
// Some contexts (stack frames in particular) start out unmanaged, and
// then check to see if an operation like Val_Init_Context set them to
// managed. If not, they will free the context. This avoids the need
// for the garbage collector to have to deal with the series if there's
// no reason too.
//
// Here is a case of where we mark the context as having an extant usage,
// so that at minimum this value must become unreachable from the root GC
// set before they are GC'd. For another case, see INIT_WORD_CONTEXT(),
// where an ANY-WORD! can mark a context as in use.
//
ENSURE_ARRAY_MANAGED(CTX_VARLIST(context));
// Keylists are different, because they may-or-may-not-be-reused by some
// operations. There needs to be a uniform policy on their management,
// or certain routines would return "sometimes managed, sometimes not"
// keylist series...a bad invariant.
//
ASSERT_ARRAY_MANAGED(CTX_KEYLIST(context));
*out = *CTX_VALUE(context);
}
//
// Uncolor: C
//
// Clear the recusion markers for series and object trees.
//
void Uncolor(RELVAL *v)
{
REBARR *array;
if (ANY_ARRAY_OR_PATH(v))
array = VAL_ARRAY(v);
else if (IS_MAP(v))
array = MAP_PAIRLIST(VAL_MAP(v));
else if (ANY_CONTEXT(v))
array = CTX_VARLIST(VAL_CONTEXT(v));
else {
// Shouldn't have marked recursively any non-array series (no need)
//
assert(
not ANY_SERIES(v)
or Is_Series_White(VAL_SERIES(v))
);
return;
}
Uncolor_Array(array);
}
//
// In_Object: C
//
// Get value from nested list of objects. List is null terminated.
// Returns object value, else returns 0 if not found.
//
REBVAL *In_Object(REBCTX *base, ...)
{
REBVAL *context = NULL;
REBCNT n;
va_list va;
va_start(va, base);
while ((n = va_arg(va, REBCNT))) {
if (n > CTX_LEN(base)) {
va_end(va);
return NULL;
}
context = CTX_VAR(base, n);
if (!ANY_CONTEXT(context)) {
va_end(va);
return NULL;
}
base = VAL_CONTEXT(context);
}
va_end(va);
return context;
}
//
// Do_Breakpoint_Throws: C
//
// A call to Do_Breakpoint_Throws does delegation to a hook in the host, which
// (if registered) will generally start an interactive session for probing the
// environment at the break. The `resume` native cooperates by being able to
// give back a value (or give back code to run to produce a value) that the
// call to breakpoint returns.
//
// RESUME has another feature, which is to be able to actually unwind and
// simulate a return /AT a function *further up the stack*. (This may be
// switched to a feature of a "STEP OUT" command at some point.)
//
REBOOL Do_Breakpoint_Throws(
REBVAL *out,
REBOOL interrupted, // Ctrl-C (as opposed to a BREAKPOINT)
const REBVAL *default_value,
REBOOL do_default
) {
REBVAL *target = NONE_VALUE;
REBVAL temp;
VAL_INIT_WRITABLE_DEBUG(&temp);
if (!PG_Breakpoint_Quitting_Hook) {
//
// Host did not register any breakpoint handler, so raise an error
// about this as early as possible.
//
fail (Error(RE_HOST_NO_BREAKPOINT));
}
// We call the breakpoint hook in a loop, in order to keep running if any
// inadvertent FAILs or THROWs occur during the interactive session.
// Only a conscious call of RESUME speaks the protocol to break the loop.
//
while (TRUE) {
struct Reb_State state;
REBCTX *error;
push_trap:
PUSH_TRAP(&error, &state);
// The host may return a block of code to execute, but cannot
// while evaluating do a THROW or a FAIL that causes an effective
// "resumption". Halt is the exception, hence we PUSH_TRAP and
// not PUSH_UNHALTABLE_TRAP. QUIT is also an exception, but a
// desire to quit is indicated by the return value of the breakpoint
// hook (which may or may not decide to request a quit based on the
// QUIT command being run).
//
// The core doesn't want to get involved in presenting UI, so if
// an error makes it here and wasn't trapped by the host first that
// is a bug in the host. It should have done its own PUSH_TRAP.
//
if (error) {
#if !defined(NDEBUG)
REBVAL error_value;
VAL_INIT_WRITABLE_DEBUG(&error_value);
Val_Init_Error(&error_value, error);
PROBE_MSG(&error_value, "Error not trapped during breakpoint:");
Panic_Array(CTX_VARLIST(error));
#endif
// In release builds, if an error managed to leak out of the
// host's breakpoint hook somehow...just re-push the trap state
// and try it again.
//
goto push_trap;
}
// Call the host's breakpoint hook.
//
if (PG_Breakpoint_Quitting_Hook(&temp, interrupted)) {
//
// If a breakpoint hook returns TRUE that means it wants to quit.
// The value should be the /WITH value (as in QUIT/WITH)
//
assert(!THROWN(&temp));
*out = *ROOT_QUIT_NATIVE;
CONVERT_NAME_TO_THROWN(out, &temp, FALSE);
return TRUE; // TRUE = threw
}
// If a breakpoint handler returns FALSE, then it should have passed
// back a "resume instruction" triggered by a call like:
//
// resume/do [fail "This is how to fail from a breakpoint"]
//
// So now that the handler is done, we will allow any code handed back
// to do whatever FAIL it likes vs. trapping that here in a loop.
//
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
// Decode and process the "resume instruction"
{
struct Reb_Frame *frame;
REBVAL *mode;
REBVAL *payload;
assert(IS_GROUP(&temp));
assert(VAL_LEN_HEAD(&temp) == RESUME_INST_MAX);
mode = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_MODE);
payload = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_PAYLOAD);
target = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_TARGET);
// The first thing we need to do is determine if the target we
// want to return to has another breakpoint sandbox blocking
// us. If so, what we need to do is actually retransmit the
// resume instruction so it can break that wall, vs. transform
// it into an EXIT/FROM that would just get intercepted.
//
if (!IS_NONE(target)) {
#if !defined(NDEBUG)
REBOOL found = FALSE;
#endif
for (frame = FS_TOP; frame != NULL; frame = frame->prior) {
if (frame->mode != CALL_MODE_FUNCTION)
continue;
if (
frame != FS_TOP
&& FUNC_CLASS(frame->func) == FUNC_CLASS_NATIVE
&& (
FUNC_CODE(frame->func) == &N_pause
|| FUNC_CODE(frame->func) == &N_breakpoint
)
) {
// We hit a breakpoint (that wasn't this call to
// breakpoint, at the current FS_TOP) before finding
// the sought after target. Retransmit the resume
// instruction so that level will get it instead.
//
*out = *ROOT_RESUME_NATIVE;
CONVERT_NAME_TO_THROWN(out, &temp, FALSE);
return TRUE; // TRUE = thrown
}
if (IS_FRAME(target)) {
if (NOT(frame->flags & DO_FLAG_FRAME_CONTEXT))
continue;
if (
VAL_CONTEXT(target)
== AS_CONTEXT(frame->data.context)
) {
// Found a closure matching the target before we
// reached a breakpoint, no need to retransmit.
//
#if !defined(NDEBUG)
found = TRUE;
#endif
break;
}
}
else {
assert(IS_FUNCTION(target));
if (frame->flags & DO_FLAG_FRAME_CONTEXT)
continue;
if (VAL_FUNC(target) == frame->func) {
//
// Found a function matching the target before we
// reached a breakpoint, no need to retransmit.
//
#if !defined(NDEBUG)
found = TRUE;
#endif
break;
}
}
}
// RESUME should not have been willing to use a target that
// is not on the stack.
//
#if !defined(NDEBUG)
assert(found);
#endif
}
if (IS_NONE(mode)) {
//
// If the resume instruction had no /DO or /WITH of its own,
// then it doesn't override whatever the breakpoint provided
// as a default. (If neither the breakpoint nor the resume
// provided a /DO or a /WITH, result will be UNSET.)
//
goto return_default; // heeds `target`
}
assert(IS_LOGIC(mode));
if (VAL_LOGIC(mode)) {
if (DO_VAL_ARRAY_AT_THROWS(&temp, payload)) {
//
// Throwing is not compatible with /AT currently.
//
if (!IS_NONE(target))
fail (Error_No_Catch_For_Throw(&temp));
// Just act as if the BREAKPOINT call itself threw
//
*out = temp;
return TRUE; // TRUE = thrown
}
// Ordinary evaluation result...
}
else
temp = *payload;
}
// The resume instruction will be GC'd.
//
goto return_temp;
}
DEAD_END;
return_default:
if (do_default) {
if (DO_VAL_ARRAY_AT_THROWS(&temp, default_value)) {
//
// If the code throws, we're no longer in the sandbox...so we
// bubble it up. Note that breakpoint runs this code at its
// level... so even if you request a higher target, any throws
// will be processed as if they originated at the BREAKPOINT
// frame. To do otherwise would require the EXIT/FROM protocol
// to add support for DO-ing at the receiving point.
//
*out = temp;
return TRUE; // TRUE = thrown
}
}
else
temp = *default_value; // generally UNSET! if no /WITH
return_temp:
// The easy case is that we just want to return from breakpoint
// directly, signaled by the target being NONE!.
//
if (IS_NONE(target)) {
*out = temp;
return FALSE; // FALSE = not thrown
}
// If the target is a function, then we're looking to simulate a return
// from something up the stack. This uses the same mechanic as
// definitional returns--a throw named by the function or closure frame.
//
// !!! There is a weak spot in definitional returns for FUNCTION! that
// they can only return to the most recent invocation; which is a weak
// spot of FUNCTION! in general with stack relative variables. Also,
// natives do not currently respond to definitional returns...though
// they can do so just as well as FUNCTION! can.
//
*out = *target;
CONVERT_NAME_TO_THROWN(out, &temp, TRUE);
return TRUE; // TRUE = thrown
}
//
// Frame_For_Stack_Level: C
//
// Level can be an UNSET!, an INTEGER!, an ANY-FUNCTION!, or a FRAME!. If
// level is UNSET! then it means give whatever the first call found is.
//
// Returns NULL if the given level number does not correspond to a running
// function on the stack.
//
// Can optionally give back the index number of the stack level (counting
// where the most recently pushed stack level is the lowest #)
//
// !!! Unfortunate repetition of logic inside of BACKTRACE; find a way to
// unify the logic for omitting things like breakpoint frames, or either
// considering pending frames or not...
//
struct Reb_Frame *Frame_For_Stack_Level(
REBCNT *number_out,
const REBVAL *level,
REBOOL skip_current
) {
struct Reb_Frame *frame = FS_TOP;
REBOOL first = TRUE;
REBINT num = 0;
if (IS_INTEGER(level)) {
if (VAL_INT32(level) < 0) {
//
// !!! fail() here, or just return NULL?
//
return NULL;
}
}
// We may need to skip some number of frames, if there have been stack
// levels added since the numeric reference point that "level" was
// supposed to refer to has changed. For now that's only allowed to
// be one level, because it's rather fuzzy which stack levels to
// omit otherwise (pending? parens?)
//
if (skip_current)
frame = frame->prior;
for (; frame != NULL; frame = frame->prior) {
if (frame->mode != CALL_MODE_FUNCTION) {
//
// Don't consider pending calls, or GROUP!, or any non-invoked
// function as a candidate to target.
//
// !!! The inability to target a GROUP! by number is an artifact
// of implementation, in that there's no hook in Do_Core() at
// the point of group evaluation to process the return. The
// matter is different with a pending function call, because its
// arguments are only partially processed--hence something
// like a RESUME/AT or an EXIT/FROM would not know which array
// index to pick up running from.
//
continue;
}
if (first) {
if (
IS_FUNCTION_AND(FUNC_VALUE(frame->func), FUNC_CLASS_NATIVE)
&& (
FUNC_CODE(frame->func) == &N_pause
|| FUNC_CODE(frame->func) == N_breakpoint
)
) {
// this is considered the "0". Return it only if 0 was requested
// specifically (you don't "count down to it");
//
if (IS_INTEGER(level) && num == VAL_INT32(level))
goto return_maybe_set_number_out;
else {
first = FALSE;
continue;
}
}
else {
++num; // bump up from 0
}
}
if (IS_INTEGER(level) && num == VAL_INT32(level))
goto return_maybe_set_number_out;
first = FALSE;
if (frame->mode != CALL_MODE_FUNCTION) {
//
// Pending frames don't get numbered
//
continue;
}
if (IS_UNSET(level) || IS_NONE(level)) {
//
// Take first actual frame if unset or none
//
goto return_maybe_set_number_out;
}
else if (IS_INTEGER(level)) {
++num;
if (num == VAL_INT32(level))
goto return_maybe_set_number_out;
}
else if (IS_FRAME(level)) {
if (
(frame->flags & DO_FLAG_FRAME_CONTEXT)
&& frame->data.context == VAL_CONTEXT(level)
) {
goto return_maybe_set_number_out;
}
}
else {
assert(IS_FUNCTION(level));
if (VAL_FUNC(level) == frame->func)
goto return_maybe_set_number_out;
}
}
// Didn't find it...
//
return NULL;
return_maybe_set_number_out:
if (number_out)
*number_out = num;
return frame;
}
//
// RL_Do_String: C
//
// Load a string and evaluate the resulting block.
//
// Returns:
// The datatype of the result if a positive number (or 0 if the
// type has no representation in the "RXT" API). An error code
// if it's a negative number. Two negative numbers are reserved
// for non-error conditions: -1 for halting (e.g. Escape), and
// -2 is reserved for exiting with exit_status set.
//
// Arguments:
// text - A null terminated UTF-8 (or ASCII) string to transcode
// into a block and evaluate.
// flags - set to zero for now
// result - value returned from evaluation, if NULL then result
// will be returned on the top of the stack
//
// Notes:
// This API was from before Rebol's open sourcing and had little
// vetting and few clients. The one client it did have was the
// "sample" console code (which wound up being the "only"
// console code for quite some time).
//
RL_API int RL_Do_String(
int *exit_status,
const REBYTE *text,
REBCNT flags,
RXIARG *out
) {
REBARR *code;
struct Reb_State state;
REBCTX *error;
REBVAL result;
VAL_INIT_WRITABLE_DEBUG(&result);
// assumes it can only be run at the topmost level where
// the data stack is completely empty.
//
assert(DSP == 0);
PUSH_UNHALTABLE_TRAP(&error, &state);
// The first time through the following code 'error' will be NULL, but...
// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
if (error) {
// Save error for WHY?
REBVAL *last = Get_System(SYS_STATE, STATE_LAST_ERROR);
Val_Init_Error(last, error);
if (ERR_NUM(error) == RE_HALT)
return -1; // !!! Revisit hardcoded #
if (out)
Value_To_RXI(out, last);
else
DS_PUSH(last);
return -ERR_NUM(error);
}
code = Scan_Source(text, LEN_BYTES(text));
PUSH_GUARD_ARRAY(code);
// Bind into lib or user spaces?
if (flags) {
// Top words will be added to lib:
Bind_Values_Set_Midstream_Shallow(ARR_HEAD(code), Lib_Context);
Bind_Values_Deep(ARR_HEAD(code), Lib_Context);
}
else {
REBCTX *user = VAL_CONTEXT(Get_System(SYS_CONTEXTS, CTX_USER));
REBVAL vali;
VAL_INIT_WRITABLE_DEBUG(&vali);
SET_INTEGER(&vali, CTX_LEN(user) + 1);
Bind_Values_All_Deep(ARR_HEAD(code), user);
Resolve_Context(user, Lib_Context, &vali, FALSE, FALSE);
}
if (Do_At_Throws(&result, code, 0)) {
DROP_GUARD_ARRAY(code);
if (
IS_FUNCTION_AND(&result, FUNC_CLASS_NATIVE) && (
VAL_FUNC_CODE(&result) == &N_quit
|| VAL_FUNC_CODE(&result) == &N_exit
)
) {
CATCH_THROWN(&result, &result);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
*exit_status = Exit_Status_From_Value(&result);
return -2; // Revisit hardcoded #
}
fail (Error_No_Catch_For_Throw(&result));
}
DROP_GUARD_ARRAY(code);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
if (out)
Value_To_RXI(out, &result);
else
DS_PUSH(&result);
return Reb_To_RXT[VAL_TYPE_0(&result)];
}
//
// Do_String()
//
// This is a version of a routine that was offered by the RL_Api, which has
// been expanded here in order to permit the necessary customizations for
// interesting REPL behavior w.r.t. binding, error handling, and response
// to throws.
//
// !!! Now that this code has been moved into the host, the convoluted
// integer-return-scheme can be eliminated and the code integrated more
// clearly into the surrounding calls.
//
int Do_String(
int *exit_status,
REBVAL *out,
const REBYTE *text,
REBOOL at_breakpoint
) {
struct Reb_State state;
REBCTX *error;
// Breakpoint REPLs are nested, and we may wish to jump out of them to
// the topmost level via a HALT. However, all other errors need to be
// confined, so that if one is doing evaluations during the pause of
// a breakpoint an error doesn't "accidentally resume" by virtue of
// jumping the stack out of the REPL.
//
// The topmost layer REPL, however, needs to catch halts in order to
// keep control and not crash out.
//
if (at_breakpoint)
PUSH_TRAP(&error, &state);
else
PUSH_UNHALTABLE_TRAP(&error, &state);
// The first time through the following code 'error' will be NULL, but...
// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
if (error) {
// Save error for WHY?
REBVAL *last = Get_System(SYS_STATE, STATE_LAST_ERROR);
if (ERR_NUM(error) == RE_HALT) {
assert(!at_breakpoint);
return -1; // !!! Revisit hardcoded #
}
Val_Init_Error(out, error);
*last = *out;
return -cast(REBINT, ERR_NUM(error));
}
REBARR *code = Scan_UTF8_Managed(text, LEN_BYTES(text));
// Where code ends up being bound when loaded at the REPL prompt should
// be more generally configurable. (It may be, for instance, that one
// wants to run something with it not bound at all.) Such choices
// must come from this REPL host...not from the interpreter itself.
{
// First the scanned code is bound into the user context with a
// fallback to the lib context.
//
// !!! This code is very old, and is how the REPL has bound since
// R3-Alpha. It comes from RL_Do_String, but should receive a modern
// review of why it's written exactly this way.
//
REBCTX *user_ctx = VAL_CONTEXT(Get_System(SYS_CONTEXTS, CTX_USER));
REBVAL vali;
SET_INTEGER(&vali, CTX_LEN(user_ctx) + 1);
Bind_Values_All_Deep(ARR_HEAD(code), user_ctx);
Resolve_Context(user_ctx, Lib_Context, &vali, FALSE, FALSE);
// If we're stopped at a breakpoint, the REPL should have a concept
// of what stack level it is inspecting (conveyed by the |#|>> in the
// prompt). This does a binding pass using the function for that
// stack level, just the way a body is bound during Make_Function()
//
if (at_breakpoint) {
REBVAL level;
SET_INTEGER(&level, HG_Stack_Level);
REBFRM *frame = Frame_For_Stack_Level(NULL, &level, FALSE);
assert(frame);
// Need to manage because it may be no words get bound into it,
// and we're not putting it into a FRAME! value, so it might leak
// otherwise if it's reified.
//
REBCTX *frame_ctx = Context_For_Frame_May_Reify_Managed(frame);
Bind_Values_Deep(ARR_HEAD(code), frame_ctx);
}
// !!! This was unused code that used to be in Do_String from
// RL_Api. It was an alternative path under `flags` which said
// "Bind into lib or user spaces?" and then "Top words will be
// added to lib". Is it relevant in any way?
//
/* Bind_Values_Set_Midstream_Shallow(ARR_HEAD(code), Lib_Context);
Bind_Values_Deep(ARR_HEAD(code), Lib_Context); */
}
if (Do_At_Throws(out, code, 0, SPECIFIED)) { // `code` will be GC protected
if (at_breakpoint) {
if (
IS_FUNCTION(out)
&& VAL_FUNC_DISPATCHER(out) == &N_resume
) {
//
// This means we're done with the embedded REPL. We want to
// resume and may be returning a piece of code that will be
// run by the finishing BREAKPOINT command in the target
// environment.
//
// We'll never return a halt, so we reuse -1 (in this very
// temporary scheme built on the very clunky historical REPL,
// which will not last much longer...fingers crossed.)
//
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
CATCH_THROWN(out, out);
*exit_status = -1;
return -1;
}
if (
IS_FUNCTION(out)
&& VAL_FUNC_DISPATCHER(out) == &N_quit
) {
//
// It would be frustrating if the system did not respond to
// a QUIT and forced you to do `resume/with [quit]`. So
// this is *not* caught, rather passed back up with the
// special -2 status code.
//
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
CATCH_THROWN(out, out);
*exit_status = -2;
return -2;
}
}
else {
// We are at the top level REPL, where we catch QUIT and for
// now, also EXIT as meaning you want to leave.
//
if (
IS_FUNCTION(out)
&& (
VAL_FUNC_DISPATCHER(out) == &N_quit
|| VAL_FUNC_DISPATCHER(out) == &N_exit
)
) {
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
CATCH_THROWN(out, out);
*exit_status = Exit_Status_From_Value(out);
return -2; // Revisit hardcoded #
}
}
fail (Error_No_Catch_For_Throw(out));
}
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
return 0;
}
//
// Clonify: C
//
// Clone the series embedded in a value *if* it's in the given set of types
// (and if "cloning" makes sense for them, e.g. they are not simple scalars).
//
// Note: The resulting clones will be managed. The model for lists only
// allows the topmost level to contain unmanaged values...and we *assume* the
// values we are operating on here live inside of an array.
//
void Clonify(
REBVAL *v,
REBFLGS flags,
REBU64 types
){
if (C_STACK_OVERFLOWING(&types))
Fail_Stack_Overflow();
// !!! It may be possible to do this faster/better, the impacts on higher
// quoting levels could be incurring more cost than necessary...but for
// now err on the side of correctness. Unescape the value while cloning
// and then escape it back.
//
REBCNT num_quotes = VAL_NUM_QUOTES(v);
Dequotify(v);
enum Reb_Kind kind = cast(enum Reb_Kind, KIND_BYTE_UNCHECKED(v));
assert(kind < REB_MAX_PLUS_MAX); // we dequoted it (pseudotypes ok)
if (types & FLAGIT_KIND(kind) & TS_SERIES_OBJ) {
//
// Objects and series get shallow copied at minimum
//
REBSER *series;
if (ANY_CONTEXT(v)) {
INIT_VAL_CONTEXT_VARLIST(
v,
CTX_VARLIST(Copy_Context_Shallow_Managed(VAL_CONTEXT(v)))
);
series = SER(CTX_VARLIST(VAL_CONTEXT(v)));
}
else {
if (IS_SER_ARRAY(VAL_SERIES(v))) {
series = SER(
Copy_Array_At_Extra_Shallow(
VAL_ARRAY(v),
0, // !!! what if VAL_INDEX() is nonzero?
VAL_SPECIFIER(v),
0,
NODE_FLAG_MANAGED
)
);
INIT_VAL_NODE(v, series); // copies args
// If it was relative, then copying with a specifier
// means it isn't relative any more.
//
INIT_BINDING(v, UNBOUND);
}
else {
series = Copy_Sequence_Core(
VAL_SERIES(v),
NODE_FLAG_MANAGED
);
INIT_VAL_NODE(v, series);
}
}
// If we're going to copy deeply, we go back over the shallow
// copied series and "clonify" the values in it.
//
if (types & FLAGIT_KIND(kind) & TS_ARRAYS_OBJ) {
REBVAL *sub = KNOWN(ARR_HEAD(ARR(series)));
for (; NOT_END(sub); ++sub)
Clonify(sub, flags, types);
}
}
else if (types & FLAGIT_KIND(kind) & FLAGIT_KIND(REB_ACTION)) {
//
// !!! While Ren-C has abandoned the concept of copying the body
// of functions (they are black boxes which may not *have* a
// body), it would still theoretically be possible to do what
// COPY does and make a function with a new and independently
// hijackable identity. Assume for now it's better that the
// HIJACK of a method for one object will hijack it for all
// objects, and one must filter in the hijacking's body if one
// wants to take more specific action.
//
assert(false);
}
else {
// We're not copying the value, so inherit the const bit from the
// original value's point of view, if applicable.
//
if (NOT_CELL_FLAG(v, EXPLICITLY_MUTABLE))
v->header.bits |= (flags & ARRAY_FLAG_CONST_SHALLOW);
}
Quotify(v, num_quotes);
}
//
// Specialize_Action_Throws: C
//
// Create a new ACTION! value that uses the same implementation as another,
// but just takes fewer arguments or refinements. It does this by storing a
// heap-based "exemplar" FRAME! in the specialized action; this stores the
// values to preload in the stack frame cells when it is invoked.
//
// The caller may provide information on the order in which refinements are
// to be specialized, using the data stack. These refinements should be
// pushed in the *reverse* order of their invocation, so append/dup/part
// has /DUP at DS_TOP, and /PART under it. List stops at lowest_ordered_dsp.
//
bool Specialize_Action_Throws(
REBVAL *out,
REBVAL *specializee,
REBSTR *opt_specializee_name,
REBVAL *opt_def, // !!! REVIEW: binding modified directly (not copied)
REBDSP lowest_ordered_dsp
){
assert(out != specializee);
struct Reb_Binder binder;
if (opt_def)
INIT_BINDER(&binder);
REBACT *unspecialized = VAL_ACTION(specializee);
// This produces a context where partially specialized refinement slots
// will be on the stack (including any we are adding "virtually", from
// the current DSP down to the lowest_ordered_dsp).
//
REBCTX *exemplar = Make_Context_For_Action_Push_Partials(
specializee,
lowest_ordered_dsp,
opt_def ? &binder : nullptr,
CELL_MASK_NON_STACK
);
Manage_Array(CTX_VARLIST(exemplar)); // destined to be managed, guarded
if (opt_def) { // code that fills the frame...fully or partially
//
// Bind all the SET-WORD! in the body that match params in the frame
// into the frame. This means `value: value` can very likely have
// `value:` bound for assignments into the frame while `value` refers
// to whatever value was in the context the specialization is running
// in, but this is likely the more useful behavior.
//
// !!! This binds the actual arg data, not a copy of it--following
// OBJECT!'s lead. However, ordinary functions make a copy of the
// body they are passed before rebinding. Rethink.
// See Bind_Values_Core() for explanations of how the binding works.
Bind_Values_Inner_Loop(
&binder,
VAL_ARRAY_AT(opt_def),
exemplar,
FLAGIT_KIND(REB_SET_WORD), // types to bind (just set-word!)
0, // types to "add midstream" to binding as we go (nothing)
BIND_DEEP
);
// !!! Only one binder can be in effect, and we're calling arbitrary
// code. Must clean up now vs. in loop we do at the end. :-(
//
RELVAL *key = CTX_KEYS_HEAD(exemplar);
REBVAL *var = CTX_VARS_HEAD(exemplar);
for (; NOT_END(key); ++key, ++var) {
if (Is_Param_Unbindable(key))
continue; // !!! is this flag still relevant?
if (Is_Param_Hidden(key)) {
assert(GET_CELL_FLAG(var, ARG_MARKED_CHECKED));
continue;
}
if (GET_CELL_FLAG(var, ARG_MARKED_CHECKED))
continue; // may be refinement from stack, now specialized out
Remove_Binder_Index(&binder, VAL_KEY_CANON(key));
}
SHUTDOWN_BINDER(&binder);
// Run block and ignore result (unless it is thrown)
//
PUSH_GC_GUARD(exemplar);
bool threw = Do_Any_Array_At_Throws(out, opt_def, SPECIFIED);
DROP_GC_GUARD(exemplar);
if (threw) {
DS_DROP_TO(lowest_ordered_dsp);
return true;
}
}
REBVAL *rootkey = CTX_ROOTKEY(exemplar);
// Build up the paramlist for the specialized function on the stack.
// The same walk used for that is used to link and process REB_X_PARTIAL
// arguments for whether they become fully specialized or not.
REBDSP dsp_paramlist = DSP;
Move_Value(DS_PUSH(), ACT_ARCHETYPE(unspecialized));
REBVAL *param = rootkey + 1;
REBVAL *arg = CTX_VARS_HEAD(exemplar);
REBDSP ordered_dsp = lowest_ordered_dsp;
for (; NOT_END(param); ++param, ++arg) {
if (TYPE_CHECK(param, REB_TS_REFINEMENT)) {
if (IS_NULLED(arg)) {
//
// A refinement that is nulled is a candidate for usage at the
// callsite. Hence it must be pre-empted by our ordered
// overrides. -but- the overrides only apply if their slot
// wasn't filled by the user code. Yet these values we are
// putting in disrupt that detection (!), so use another
// flag (PUSH_PARTIAL) to reflect this state.
//
while (ordered_dsp != dsp_paramlist) {
++ordered_dsp;
REBVAL *ordered = DS_AT(ordered_dsp);
if (not IS_WORD_BOUND(ordered)) // specialize 'print/asdf
fail (Error_Bad_Refine_Raw(ordered));
REBVAL *slot = CTX_VAR(exemplar, VAL_WORD_INDEX(ordered));
if (
IS_NULLED(slot) or GET_CELL_FLAG(slot, PUSH_PARTIAL)
){
// It's still partial, so set up the pre-empt.
//
Init_Any_Word_Bound(
arg,
REB_SYM_WORD,
VAL_STORED_CANON(ordered),
exemplar,
VAL_WORD_INDEX(ordered)
);
SET_CELL_FLAG(arg, PUSH_PARTIAL);
goto unspecialized_arg;
}
// Otherwise the user filled it in, so skip to next...
}
goto unspecialized_arg; // ran out...no pre-empt needed
}
if (GET_CELL_FLAG(arg, ARG_MARKED_CHECKED)) {
assert(
IS_BLANK(arg)
or (
IS_REFINEMENT(arg)
and (
VAL_REFINEMENT_SPELLING(arg)
== VAL_PARAM_SPELLING(param)
)
)
);
}
else
Typecheck_Refinement_And_Canonize(param, arg);
goto specialized_arg_no_typecheck;
}
switch (VAL_PARAM_CLASS(param)) {
case REB_P_RETURN:
case REB_P_LOCAL:
assert(IS_NULLED(arg)); // no bindings, you can't set these
goto unspecialized_arg;
default:
break;
}
// It's an argument, either a normal one or a refinement arg.
if (not IS_NULLED(arg))
goto specialized_arg_with_check;
unspecialized_arg:
assert(NOT_CELL_FLAG(arg, ARG_MARKED_CHECKED));
assert(
IS_NULLED(arg)
or (IS_SYM_WORD(arg) and TYPE_CHECK(param, REB_TS_REFINEMENT))
);
Move_Value(DS_PUSH(), param);
continue;
specialized_arg_with_check:
// !!! If argument was previously specialized, should have been type
// checked already... don't type check again (?)
//
if (Is_Param_Variadic(param))
fail ("Cannot currently SPECIALIZE variadic arguments.");
if (TYPE_CHECK(param, REB_TS_DEQUOTE_REQUOTE) and IS_QUOTED(arg)) {
//
// Have to leave the quotes on, but still want to type check.
if (not TYPE_CHECK(param, CELL_KIND(VAL_UNESCAPED(arg))))
fail (arg); // !!! merge w/Error_Invalid_Arg()
}
else if (not TYPE_CHECK(param, VAL_TYPE(arg)))
fail (arg); // !!! merge w/Error_Invalid_Arg()
SET_CELL_FLAG(arg, ARG_MARKED_CHECKED);
specialized_arg_no_typecheck:
// Specialized-out arguments must still be in the parameter list,
// for enumeration in the evaluator to line up with the frame values
// of the underlying function.
assert(GET_CELL_FLAG(arg, ARG_MARKED_CHECKED));
Move_Value(DS_PUSH(), param);
TYPE_SET(DS_TOP, REB_TS_HIDDEN);
continue;
}
REBARR *paramlist = Pop_Stack_Values_Core(
dsp_paramlist,
SERIES_MASK_PARAMLIST
| (SER(unspecialized)->header.bits & PARAMLIST_MASK_INHERIT)
);
Manage_Array(paramlist);
RELVAL *rootparam = ARR_HEAD(paramlist);
VAL_ACT_PARAMLIST_NODE(rootparam) = NOD(paramlist);
// Everything should have balanced out for a valid specialization
//
while (ordered_dsp != DSP) {
++ordered_dsp;
REBVAL *ordered = DS_AT(ordered_dsp);
if (not IS_WORD_BOUND(ordered)) // specialize 'print/asdf
fail (Error_Bad_Refine_Raw(ordered));
REBVAL *slot = CTX_VAR(exemplar, VAL_WORD_INDEX(ordered));
assert(not IS_NULLED(slot) and NOT_CELL_FLAG(slot, PUSH_PARTIAL));
UNUSED(slot);
}
DS_DROP_TO(lowest_ordered_dsp);
// See %sysobj.r for `specialized-meta:` object template
REBVAL *example = Get_System(SYS_STANDARD, STD_SPECIALIZED_META);
REBCTX *meta = Copy_Context_Shallow_Managed(VAL_CONTEXT(example));
Init_Nulled(CTX_VAR(meta, STD_SPECIALIZED_META_DESCRIPTION)); // default
Move_Value(
CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE),
specializee
);
if (not opt_specializee_name)
Init_Nulled(CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME));
else
Init_Word(
CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME),
opt_specializee_name
);
MISC_META_NODE(paramlist) = NOD(meta);
REBACT *specialized = Make_Action(
paramlist,
&Specializer_Dispatcher,
ACT_UNDERLYING(unspecialized), // same underlying action as this
exemplar, // also provide a context of specialization values
1 // details array capacity
);
assert(CTX_KEYLIST(exemplar) == ACT_PARAMLIST(unspecialized));
assert(
GET_ACTION_FLAG(specialized, IS_INVISIBLE)
== GET_ACTION_FLAG(unspecialized, IS_INVISIBLE)
);
// The "body" is the FRAME! value of the specialization. It takes on the
// binding we want to use (which we can't put in the exemplar archetype,
// that binding has to be UNBOUND). It also remembers the original
// action in the phase, so Specializer_Dispatcher() knows what to call.
//
RELVAL *body = ARR_HEAD(ACT_DETAILS(specialized));
Move_Value(body, CTX_ARCHETYPE(exemplar));
INIT_BINDING(body, VAL_BINDING(specializee));
INIT_VAL_CONTEXT_PHASE(body, unspecialized);
Init_Action_Unbound(out, specialized);
return false; // code block did not throw
}
//
// Cmp_Value: C
//
// Compare two values and return the difference.
//
// is_case TRUE for case sensitive compare
//
REBINT Cmp_Value(const RELVAL *s, const RELVAL *t, REBOOL is_case)
{
REBDEC d1, d2;
if (VAL_TYPE(t) != VAL_TYPE(s) && !(ANY_NUMBER(s) && ANY_NUMBER(t)))
return VAL_TYPE(s) - VAL_TYPE(t);
assert(NOT_END(s) && NOT_END(t));
switch(VAL_TYPE(s)) {
case REB_INTEGER:
if (IS_DECIMAL(t)) {
d1 = (REBDEC)VAL_INT64(s);
d2 = VAL_DECIMAL(t);
goto chkDecimal;
}
return THE_SIGN(VAL_INT64(s) - VAL_INT64(t));
case REB_LOGIC:
return VAL_LOGIC(s) - VAL_LOGIC(t);
case REB_CHAR:
if (is_case) return THE_SIGN(VAL_CHAR(s) - VAL_CHAR(t));
return THE_SIGN((REBINT)(UP_CASE(VAL_CHAR(s)) - UP_CASE(VAL_CHAR(t))));
case REB_PERCENT:
case REB_DECIMAL:
case REB_MONEY:
if (IS_MONEY(s))
d1 = deci_to_decimal(VAL_MONEY_AMOUNT(s));
else
d1 = VAL_DECIMAL(s);
if (IS_INTEGER(t))
d2 = cast(REBDEC, VAL_INT64(t));
else if (IS_MONEY(t))
d2 = deci_to_decimal(VAL_MONEY_AMOUNT(t));
else
d2 = VAL_DECIMAL(t);
chkDecimal:
if (Eq_Decimal(d1, d2))
return 0;
if (d1 < d2)
return -1;
return 1;
case REB_PAIR:
return Cmp_Pair(s, t);
case REB_EVENT:
return Cmp_Event(s, t);
case REB_GOB:
return Cmp_Gob(s, t);
case REB_TUPLE:
return Cmp_Tuple(s, t);
case REB_TIME:
return Cmp_Time(s, t);
case REB_DATE:
return Cmp_Date(s, t);
case REB_BLOCK:
case REB_GROUP:
case REB_MAP:
case REB_PATH:
case REB_SET_PATH:
case REB_GET_PATH:
case REB_LIT_PATH:
return Cmp_Array(s, t, is_case);
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
return Compare_String_Vals(s, t, NOT(is_case));
case REB_BITSET:
case REB_BINARY:
case REB_IMAGE:
return Compare_Binary_Vals(s, t);
case REB_VECTOR:
return Compare_Vector(s, t);
case REB_DATATYPE:
return VAL_TYPE_KIND(s) - VAL_TYPE_KIND(t);
case REB_WORD:
case REB_SET_WORD:
case REB_GET_WORD:
case REB_LIT_WORD:
case REB_REFINEMENT:
case REB_ISSUE:
return Compare_Word(s,t,is_case);
case REB_ERROR:
return VAL_ERR_NUM(s) - VAL_ERR_NUM(t);
case REB_OBJECT:
case REB_MODULE:
case REB_PORT:
return VAL_CONTEXT(s) - VAL_CONTEXT(t);
case REB_FUNCTION:
return VAL_FUNC_PARAMLIST(s) - VAL_FUNC_PARAMLIST(t);
case REB_LIBRARY:
return VAL_LIBRARY(s) - VAL_LIBRARY(t);
case REB_STRUCT:
return Cmp_Struct(s, t);
case REB_BLANK:
case REB_MAX_VOID:
default:
break;
}
return 0;
}
