// // 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; }
// // 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 }
// // Copy_Array_At_Max_Shallow: C // // Shallow copy an array from the given index for given maximum // length (clipping if it exceeds the array length) // REBARR *Copy_Array_At_Max_Shallow( REBARR *original, REBCNT index, REBSPC *specifier, REBCNT max ){ const REBFLGS flags = 0; if (index > ARR_LEN(original)) return Make_Array_For_Copy(0, flags, original); if (index + max > ARR_LEN(original)) max = ARR_LEN(original) - index; REBARR *copy = Make_Array_For_Copy(max, flags, original); REBCNT count = 0; const RELVAL *src = ARR_AT(original, index); RELVAL *dest = ARR_HEAD(copy); for (; count < max; ++count, ++src, ++dest) Derelativize(dest, src, specifier); TERM_ARRAY_LEN(copy, max); return copy; }
// // Dump_Series: C // void Dump_Series(REBSER *series, const char *memo) { if (!series) return; Debug_Fmt( "%s Series %x \"%s\":" " wide: %2d" " size: %6d" " bias: %d" " tail: %d" " rest: %d" " flags: %x", memo, series, "-", // !label SER_WIDE(series), SER_TOTAL(series), SER_BIAS(series), SER_LEN(series), SER_REST(series), series->info.bits // flags + width ); if (Is_Array_Series(series)) { Dump_Values(ARR_HEAD(AS_ARRAY(series)), SER_LEN(series)); } else Dump_Bytes( SER_DATA_RAW(series), (SER_LEN(series) + 1) * SER_WIDE(series) ); }
// // Copy_Array_At_Extra_Shallow: C // // Shallow copy an array from the given index thru the tail. // Additional capacity beyond what is required can be added // by giving an `extra` count of how many value cells one needs. // REBARR *Copy_Array_At_Extra_Shallow( REBARR *original, REBCNT index, REBSPC *specifier, REBCNT extra, REBFLGS flags ){ REBCNT len = ARR_LEN(original); if (index > len) return Make_Array_For_Copy(extra, flags, original); len -= index; REBARR *copy = Make_Array_For_Copy(len + extra, flags, original); RELVAL *src = ARR_AT(original, index); RELVAL *dest = ARR_HEAD(copy); REBCNT count = 0; for (; count < len; ++count, ++dest, ++src) Derelativize(dest, src, specifier); TERM_ARRAY_LEN(copy, len); return copy; }
// // Copy_Array_Core_Managed_Inner_Loop: C // // static REBARR *Copy_Array_Core_Managed_Inner_Loop( REBARR *original, REBCNT index, REBSPC *specifier, REBCNT tail, REBCNT extra, // currently no one uses--would it also apply deep (?) REBFLGS flags, REBU64 types ){ assert(index <= tail and tail <= ARR_LEN(original)); assert(flags & NODE_FLAG_MANAGED); REBCNT len = tail - index; // Currently we start by making a shallow copy and then adjust it REBARR *copy = Make_Array_For_Copy(len + extra, flags, original); RELVAL *src = ARR_AT(original, index); RELVAL *dest = ARR_HEAD(copy); REBCNT count = 0; for (; count < len; ++count, ++dest, ++src) { Clonify( Derelativize(dest, src, specifier), flags, types ); } TERM_ARRAY_LEN(copy, len); return copy; }
// // Copy_And_Bind_Relative_Deep_Managed: C // // This routine is called by Make_Function in order to take the raw material // given as a function body, and de-relativize any IS_RELATIVE(value)s that // happen to be in it already (as any Copy does). But it also needs to make // new relative references to ANY-WORD! that are referencing function // parameters, as well as to relativize the copies of ANY-ARRAY! that contain // these relative words...so that they refer to the archetypal function // to which they should be relative. // REBARR *Copy_And_Bind_Relative_Deep_Managed( const REBVAL *body, REBARR *paramlist, // body of function is not actually ready yet REBU64 bind_types ) { // !!! Currently this is done in two phases, because the historical code // would use the generic copying code and then do a bind phase afterward. // Both phases are folded into this routine to make it easier to make // a one-pass version when time permits. // REBARR *copy = COPY_ANY_ARRAY_AT_DEEP_MANAGED(body); struct Reb_Binder binder; INIT_BINDER(&binder); // Setup binding table from the argument word list // REBCNT index = 1; RELVAL *param = ARR_AT(paramlist, 1); // [0] is FUNCTION! value for (; NOT_END(param); param++, index++) Add_Binder_Index(&binder, VAL_KEY_CANON(param), index); Bind_Relative_Inner_Loop(&binder, ARR_HEAD(copy), paramlist, bind_types); // Reset binding table // param = ARR_AT(paramlist, 1); // [0] is FUNCTION! value for (; NOT_END(param); param++) Remove_Binder_Index(&binder, VAL_KEY_CANON(param)); SHUTDOWN_BINDER(&binder); return copy; }
// // Copy_Rerelativized_Array_Deep_Managed: C // // The invariant of copying in general is that when you are done with the // copy, there are no relative values in that copy. One exception to this // is the deep copy required to make a relative function body in the first // place (which it currently does in two passes--a normal deep copy followed // by a relative binding). The other exception is when a relativized // function body is copied to make another relativized function body. // // This is specialized logic for the latter case. It's constrained enough // to be simple (all relative values are known to be relative to the same // function), and the feature is questionable anyway. So it's best not to // further complicate ordinary copying with a parameterization to copy // and change all the relative binding information from one function's // paramlist to another. // REBARR *Copy_Rerelativized_Array_Deep_Managed( REBARR *original, REBACT *before, // references to `before` will be changed to `after` REBACT *after ){ const REBFLGS flags = NODE_FLAG_MANAGED; REBARR *copy = Make_Array_For_Copy(ARR_LEN(original), flags, original); RELVAL *src = ARR_HEAD(original); RELVAL *dest = ARR_HEAD(copy); for (; NOT_END(src); ++src, ++dest) { if (not IS_RELATIVE(src)) { Move_Value(dest, KNOWN(src)); continue; } // All relative values under a sub-block must be relative to the // same function. // assert(VAL_RELATIVE(src) == before); Move_Value_Header(dest, src); if (ANY_ARRAY_OR_PATH(src)) { INIT_VAL_NODE( dest, Copy_Rerelativized_Array_Deep_Managed( VAL_ARRAY(src), before, after ) ); PAYLOAD(Any, dest).second = PAYLOAD(Any, src).second; INIT_BINDING(dest, after); // relative binding } else { assert(ANY_WORD(src)); PAYLOAD(Any, dest) = PAYLOAD(Any, src); INIT_BINDING(dest, after); } } TERM_ARRAY_LEN(copy, ARR_LEN(original)); return copy; }
// // Find_In_Array_Simple: C // // Simple search for a value in an array. Return the index of // the value or the TAIL index if not found. // REBCNT Find_In_Array_Simple(REBARR *array, REBCNT index, const RELVAL *target) { RELVAL *value = ARR_HEAD(array); for (; index < ARR_LEN(array); index++) { if (0 == Cmp_Value(value + index, target, FALSE)) return index; } return ARR_LEN(array); }
// // Specializer_Dispatcher: C // // The evaluator does not do any special "running" of a specialized frame. // All of the contribution that the specialization had to make was taken care // of when Eval_Core() used f->special to fill from the exemplar. So all this // does is change the phase and binding to match the function this layer wa // specializing. // REB_R Specializer_Dispatcher(REBFRM *f) { REBARR *details = ACT_DETAILS(FRM_PHASE(f)); REBVAL *exemplar = KNOWN(ARR_HEAD(details)); assert(IS_FRAME(exemplar)); INIT_FRM_PHASE(f, VAL_PHASE(exemplar)); FRM_BINDING(f) = VAL_BINDING(exemplar); return R_REDO_UNCHECKED; // redo uses the updated phase and binding }
// // Uncolor_Array: C // void Uncolor_Array(REBARR *a) { if (Is_Series_White(SER(a))) return; // avoid loop Flip_Series_To_White(SER(a)); RELVAL *val; for (val = ARR_HEAD(a); NOT_END(val); ++val) if (ANY_ARRAY_OR_PATH(val) or IS_MAP(val) or ANY_CONTEXT(val)) Uncolor(val); }
// // Assert_No_Relative: C // // Check to make sure there are no relative values in an array, maybe deeply. // // !!! What if you have an ANY-ARRAY! inside your array at a position N, // but there is a relative value in the VAL_ARRAY() of that value at an // index earlier than N? This currently considers that an error since it // checks the whole array...which is more conservative (asserts on more // cases). But should there be a flag to ask to honor the index? // void Assert_No_Relative(REBARR *array, REBOOL deep) { RELVAL *item = ARR_HEAD(array); while (NOT_END(item)) { if (IS_RELATIVE(item)) { Debug_Fmt("Array contained relative item and wasn't supposed to."); PROBE_MSG(item, "relative item"); Panic_Array(array); } if (!IS_VOID_OR_SAFE_TRASH(item) && ANY_ARRAY(item) && deep) Assert_No_Relative(VAL_ARRAY(item), deep); ++item; } }
// // RL_Map_Words: C // // Given a block of word values, return an array of word ids. // // Returns: // An array of global word identifiers (integers). The [0] value is the size. // Arguments: // series - block of words as values (from REBOL blocks, not strings.) // Notes: // Word identifiers are persistent, and you can use them anytime. // The block can include any kind of word, including set-words, lit-words, etc. // If the input block contains non-words, they will be skipped. // The array is allocated with OS_ALLOC and you can OS_FREE it any time. // RL_API u32 *RL_Map_Words(REBARR *array) { REBCNT i = 1; u32 *words; REBVAL *val = ARR_HEAD(array); words = OS_ALLOC_N(u32, ARR_LEN(array) + 2); for (; NOT_END(val); val++) { if (ANY_WORD(val)) words[i++] = VAL_WORD_CANON(val); } words[0] = i; words[i] = 0; return words; }
// // Collect_Set_Words: C // // Scan a block, collecting all of its SET words as a block. // REBARR *Collect_Set_Words(REBVAL *val) { REBCNT count = 0; REBVAL *val2 = val; REBARR *array; for (; NOT_END(val); val++) if (IS_SET_WORD(val)) count++; val = val2; array = Make_Array(count); val2 = ARR_HEAD(array); for (; NOT_END(val); val++) { if (IS_SET_WORD(val)) Val_Init_Word(val2++, REB_WORD, VAL_WORD_SYM(val)); } SET_END(val2); SET_ARRAY_LEN(array, count); return array; }
// // Copy_Values_Len_Extra_Shallow_Core: C // // Shallow copy the first 'len' values of `head` into a new series created to // hold that many entries, with an optional bit of extra space at the end. // REBARR *Copy_Values_Len_Extra_Shallow_Core( const RELVAL *head, REBSPC *specifier, REBCNT len, REBCNT extra, REBFLGS flags ){ REBARR *a = Make_Array_Core(len + extra, flags); REBCNT count = 0; const RELVAL *src = head; RELVAL *dest = ARR_HEAD(a); for (; count < len; ++count, ++src, ++dest) { if (KIND_BYTE(src) == REB_NULLED) assert(flags & ARRAY_FLAG_NULLEDS_LEGAL); Derelativize(dest, src, specifier); } TERM_ARRAY_LEN(a, len); return a; }
// // Vector_To_Array: C // // Convert a vector to a block. // REBARR *Vector_To_Array(const REBVAL *vect) { REBCNT len = VAL_LEN_AT(vect); REBYTE *data = SER_DATA_RAW(VAL_SERIES(vect)); REBCNT type = VECT_TYPE(VAL_SERIES(vect)); REBARR *array = NULL; REBCNT n; RELVAL *val; if (len <= 0) fail (Error_Invalid_Arg(vect)); array = Make_Array(len); val = ARR_HEAD(array); for (n = VAL_INDEX(vect); n < VAL_LEN_HEAD(vect); n++, val++) { VAL_RESET_HEADER(val, (type >= VTSF08) ? REB_DECIMAL : REB_INTEGER); VAL_INT64(val) = get_vect(type, data, n); // can be int or decimal } TERM_ARRAY_LEN(array, len); assert(IS_END(val)); return array; }
// // 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 }
// // Make_Where_For_Frame: C // // Each call frame maintains the array it is executing in, the current index // in that array, and the index of where the current expression started. // This can be deduced into a segment of code to display in the debug views // to indicate roughly "what's running" at that stack level. // // Unfortunately, Rebol doesn't formalize this very well. There is no lock // on segments of blocks during their evaluation, and it's possible for // self-modifying code to scramble the blocks being executed. The DO // evaluator is robust in terms of not *crashing*, but the semantics may well // suprise users. // // !!! Should blocks on the stack be locked from modification, at least by // default unless a special setting for self-modifying code unlocks it? // // So long as WHERE information is unreliable, this has to check that // `expr_index` (where the evaluation started) and `index` (where the // evaluation thinks it currently is) aren't out of bounds here. We could // be giving back positions now unrelated to the call...but it won't crash! // REBARR *Make_Where_For_Frame(struct Reb_Frame *frame) { REBCNT start; REBCNT end; REBARR *where; REBOOL pending; if (FRM_IS_VALIST(frame)) { const REBOOL truncated = TRUE; Reify_Va_To_Array_In_Frame(frame, truncated); } // WARNING: MIN is a C macro and repeats its arguments. // start = MIN(ARR_LEN(FRM_ARRAY(frame)), cast(REBCNT, frame->expr_index)); end = MIN(ARR_LEN(FRM_ARRAY(frame)), FRM_INDEX(frame)); assert(end >= start); assert(frame->mode != CALL_MODE_GUARD_ARRAY_ONLY); pending = NOT(frame->mode == CALL_MODE_FUNCTION); // Do a shallow copy so that the WHERE information only includes // the range of the array being executed up to the point of // currently relevant evaluation, not all the way to the tail // of the block (where future potential evaluation would be) { REBCNT n = 0; REBCNT len = 1 // fake function word (compensates for prefetch) + (end - start) // data from expr_index to the current index + (pending ? 1 : 0); // if it's pending we put "..." to show that where = Make_Array(len); // !!! Due to "prefetch" the expr_index will be *past* the invocation // of the function. So this is a lie, as a placeholder for what a // real debug mode would need to actually save the data to show. // If the execution were a path or anything other than a word, this // will lose it. // Val_Init_Word(ARR_AT(where, n), REB_WORD, FRM_LABEL(frame)); ++n; for (n = 1; n < len; ++n) *ARR_AT(where, n) = *ARR_AT(FRM_ARRAY(frame), start + n - 1); SET_ARRAY_LEN(where, len); TERM_ARRAY(where); } // Making a shallow copy offers another advantage, that it's // possible to get rid of the newline marker on the first element, // that would visually disrupt the backtrace for no reason. // if (end - start > 0) CLEAR_VAL_FLAG(ARR_HEAD(where), VALUE_FLAG_LINE); // We add an ellipsis to a pending frame to make it a little bit // clearer what is going on. If someone sees a where that looks // like just `* [print]` the asterisk alone doesn't quite send // home the message that print is not running and it is // argument fulfillment that is why it's not "on the stack" // yet, so `* [print ...]` is an attempt to say that better. // // !!! This is in-band, which can be mixed up with literal usage // of ellipsis. Could there be a better "out-of-band" conveyance? // Might the system use colorization in a value option bit. // if (pending) Val_Init_Word(Alloc_Tail_Array(where), REB_WORD, SYM_ELLIPSIS); return where; }
// // Modify_Array: C // // Returns new dst_idx // REBCNT Modify_Array( REBCNT action, // INSERT, APPEND, CHANGE REBARR *dst_arr, // target REBCNT dst_idx, // position const REBVAL *src_val, // source REBCNT flags, // AN_ONLY, AN_PART REBINT dst_len, // length to remove REBINT dups // dup count ) { REBCNT tail = ARR_LEN(dst_arr); REBINT ilen = 1; // length to be inserted const RELVAL *src_rel; REBCTX *specifier; if (IS_VOID(src_val) || dups < 0) { // If they are effectively asking for "no action" then all we have // to do is return the natural index result for the operation. // (APPEND will return 0, insert the tail of the insertion...so index) return (action == SYM_APPEND) ? 0 : dst_idx; } if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail; // Check /PART, compute LEN: if (!GET_FLAG(flags, AN_ONLY) && ANY_ARRAY(src_val)) { // Adjust length of insertion if changing /PART: if (action != SYM_CHANGE && GET_FLAG(flags, AN_PART)) ilen = dst_len; else ilen = VAL_LEN_AT(src_val); // Are we modifying ourselves? If so, copy src_val block first: if (dst_arr == VAL_ARRAY(src_val)) { REBARR *copy = Copy_Array_At_Shallow( VAL_ARRAY(src_val), VAL_INDEX(src_val), VAL_SPECIFIER(src_val) ); MANAGE_ARRAY(copy); // !!! Review: worth it to not manage and free? src_rel = ARR_HEAD(copy); specifier = SPECIFIED; // copy already specified it } else { src_rel = VAL_ARRAY_AT(src_val); // skips by VAL_INDEX values specifier = VAL_SPECIFIER(src_val); } } else { // use passed in RELVAL and specifier src_rel = src_val; specifier = SPECIFIED; // it's a REBVAL, not a RELVAL, so specified } REBINT size = dups * ilen; // total to insert if (action != SYM_CHANGE) { // Always expand dst_arr for INSERT and APPEND actions: Expand_Series(ARR_SERIES(dst_arr), dst_idx, size); } else { if (size > dst_len) Expand_Series(ARR_SERIES(dst_arr), dst_idx, size-dst_len); else if (size < dst_len && GET_FLAG(flags, AN_PART)) Remove_Series(ARR_SERIES(dst_arr), dst_idx, dst_len-size); else if (size + dst_idx > tail) { EXPAND_SERIES_TAIL(ARR_SERIES(dst_arr), size - (tail - dst_idx)); } } tail = (action == SYM_APPEND) ? 0 : size + dst_idx; #if !defined(NDEBUG) if (IS_ARRAY_MANAGED(dst_arr)) { REBINT i; for (i = 0; i < ilen; ++i) ASSERT_VALUE_MANAGED(&src_rel[i]); } #endif for (; dups > 0; dups--) { REBINT index = 0; for (; index < ilen; ++index, ++dst_idx) { COPY_VALUE( SINK(ARR_HEAD(dst_arr) + dst_idx), src_rel + index, specifier ); } } TERM_ARRAY_LEN(dst_arr, ARR_LEN(dst_arr)); ASSERT_ARRAY(dst_arr); return tail; }
// // Make_Context_For_Action_Push_Partials: C // // This creates a FRAME! context with NULLED cells in the unspecialized slots // that are available to be filled. For partial refinement specializations // in the action, it will push the refinement to the stack. In this way it // retains the ordering information implicit in the partial refinements of an // action's existing specialization. // // It is able to take in more specialized refinements on the stack. These // will be ordered *after* partial specializations in the function already. // The caller passes in the stack pointer of the lowest priority refinement, // which goes up to DSP for the highest of those added specializations. // // Since this is walking the parameters to make the frame already--and since // we don't want to bind to anything specialized out (including the ad-hoc // refinements added on the stack) we go ahead and collect bindings from the // frame if needed. // REBCTX *Make_Context_For_Action_Push_Partials( const REBVAL *action, // need ->binding, so can't just be a REBACT* REBDSP lowest_ordered_dsp, // caller can add refinement specializations struct Reb_Binder *opt_binder, REBFLGS prep // cell formatting mask bits, result managed if non-stack ){ REBDSP highest_ordered_dsp = DSP; REBACT *act = VAL_ACTION(action); REBCNT num_slots = ACT_NUM_PARAMS(act) + 1; // +1 is for CTX_ARCHETYPE() REBARR *varlist = Make_Array_Core(num_slots, SERIES_MASK_VARLIST); REBVAL *rootvar = RESET_CELL( ARR_HEAD(varlist), REB_FRAME, CELL_MASK_CONTEXT ); INIT_VAL_CONTEXT_VARLIST(rootvar, varlist); INIT_VAL_CONTEXT_PHASE(rootvar, VAL_ACTION(action)); INIT_BINDING(rootvar, VAL_BINDING(action)); const REBVAL *param = ACT_PARAMS_HEAD(act); REBVAL *arg = rootvar + 1; const REBVAL *special = ACT_SPECIALTY_HEAD(act); // of exemplar/paramlist REBCNT index = 1; // used to bind REFINEMENT! values to parameter slots REBCTX *exemplar = ACT_EXEMPLAR(act); // may be null if (exemplar) assert(special == CTX_VARS_HEAD(exemplar)); else assert(special == ACT_PARAMS_HEAD(act)); for (; NOT_END(param); ++param, ++arg, ++special, ++index) { arg->header.bits = prep; if (Is_Param_Hidden(param)) { // specialized out assert(GET_CELL_FLAG(special, ARG_MARKED_CHECKED)); Move_Value(arg, special); // doesn't copy ARG_MARKED_CHECKED SET_CELL_FLAG(arg, ARG_MARKED_CHECKED); continue_specialized: assert(not IS_NULLED(arg)); assert(GET_CELL_FLAG(arg, ARG_MARKED_CHECKED)); continue; // Eval_Core() double-checks type in debug build } assert(NOT_CELL_FLAG(special, ARG_MARKED_CHECKED)); REBSTR *canon = VAL_PARAM_CANON(param); // for adding to binding if (not TYPE_CHECK(param, REB_TS_REFINEMENT)) { // nothing to push continue_unspecialized: assert(arg->header.bits == prep); Init_Nulled(arg); if (opt_binder) { if (not Is_Param_Unbindable(param)) Add_Binder_Index(opt_binder, canon, index); } continue; } // Unspecialized refinement slots may have an SYM-WORD! in them that // reflects a partial that needs to be pushed to the stack. (They // are in *reverse* order of use.) assert( (special == param and IS_PARAM(special)) or (IS_SYM_WORD(special) or IS_NULLED(special)) ); if (IS_SYM_WORD(special)) { REBCNT partial_index = VAL_WORD_INDEX(special); Init_Any_Word_Bound( // push a SYM-WORD! to data stack DS_PUSH(), REB_SYM_WORD, VAL_STORED_CANON(special), exemplar, partial_index ); } // Unspecialized or partially specialized refinement. Check the // passed-in refinements on the stack for usage. // REBDSP dsp = highest_ordered_dsp; for (; dsp != lowest_ordered_dsp; --dsp) { REBVAL *ordered = DS_AT(dsp); if (VAL_STORED_CANON(ordered) != canon) continue; // just continuing this loop assert(not IS_WORD_BOUND(ordered)); // we bind only one INIT_BINDING(ordered, varlist); INIT_WORD_INDEX_UNCHECKED(ordered, index); if (not Is_Typeset_Invisible(param)) // needs argument goto continue_unspecialized; // If refinement named on stack takes no arguments, then it can't // be partially specialized...only fully, and won't be bound: // // specialize 'append/only [only: false] ; only not bound // Init_Word(arg, VAL_STORED_CANON(ordered)); Refinify(arg); SET_CELL_FLAG(arg, ARG_MARKED_CHECKED); goto continue_specialized; } goto continue_unspecialized; } TERM_ARRAY_LEN(varlist, num_slots); MISC_META_NODE(varlist) = nullptr; // GC sees this, we must initialize // !!! Can't pass SERIES_FLAG_STACK_LIFETIME into Make_Array_Core(), // because TERM_ARRAY_LEN won't let it set stack array lengths. // if (prep & CELL_FLAG_STACK_LIFETIME) SET_SERIES_FLAG(varlist, STACK_LIFETIME); INIT_CTX_KEYLIST_SHARED(CTX(varlist), ACT_PARAMLIST(act)); return CTX(varlist); }
// // 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); }
// // 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; }
// // 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)]; }