// // 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; }