// // 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 }
// // Update_Typeset_Bits_Core: C // // This sets the bits in a bitset according to a block of datatypes. There // is special handling by which BAR! will set the "variadic" bit on the // typeset, which is heeded by functions only. // // !!! R3-Alpha supported fixed word symbols for datatypes and typesets. // Confusingly, this means that if you have said `word!: integer!` and use // WORD!, you will get the integer type... but if WORD! is unbound then it // will act as WORD!. Also, is essentially having "keywords" and should be // reviewed to see if anything actually used it. // REBOOL Update_Typeset_Bits_Core( REBVAL *typeset, const REBVAL *head, REBOOL trap // if TRUE, then return FALSE instead of failing ) { const REBVAL *item = head; REBARR *types = VAL_ARRAY(ROOT_TYPESETS); assert(IS_TYPESET(typeset)); VAL_TYPESET_BITS(typeset) = 0; for (; NOT_END(item); item++) { const REBVAL *var = NULL; if (IS_BAR(item)) { SET_VAL_FLAG(typeset, TYPESET_FLAG_VARIADIC); continue; } if (IS_WORD(item) && !(var = TRY_GET_OPT_VAR(item))) { REBSYM sym = VAL_WORD_SYM(item); // See notes: if a word doesn't look up to a variable, then its // symbol is checked as a second chance. // if (IS_KIND_SYM(sym)) { TYPE_SET(typeset, KIND_FROM_SYM(sym)); continue; } else if (sym >= SYM_ANY_NOTHING_X && sym < SYM_DATATYPES) var = ARR_AT(types, sym - SYM_ANY_NOTHING_X); } if (!var) var = item; if (IS_DATATYPE(var)) { TYPE_SET(typeset, VAL_TYPE_KIND(var)); } else if (IS_TYPESET(var)) { VAL_TYPESET_BITS(typeset) |= VAL_TYPESET_BITS(var); } else { if (trap) return FALSE; fail (Error_Invalid_Arg(item)); } } return TRUE; }
// // 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; } }
// // 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; }
// // Init_Typesets: C // // Create typeset variables that are defined above. // For example: NUMBER is both integer and decimal. // Add the new variables to the system context. // void Init_Typesets(void) { REBVAL *value; REBINT n; Set_Root_Series(ROOT_TYPESETS, ARR_SERIES(Make_Array(40))); for (n = 0; Typesets[n].sym != SYM_0; n++) { value = Alloc_Tail_Array(VAL_ARRAY(ROOT_TYPESETS)); // Note: the symbol in the typeset is not the symbol of a word holding // the typesets, rather an extra data field used when the typeset is // in a context key slot to identify that field's name // Val_Init_Typeset(value, Typesets[n].bits, SYM_0); *Append_Context(Lib_Context, NULL, Typesets[n].sym) = *value; } }
// // RL_Extend: C // // Appends embedded extension to system/catalog/boot-exts. // // Returns: // A pointer to the REBOL library (see reb-lib.h). // Arguments: // source - A pointer to a UTF-8 (or ASCII) string that provides // extension module header, function definitions, and other // related functions and data. // call - A pointer to the extension's command dispatcher. // Notes: // This function simply adds the embedded extension to the // boot-exts list. All other processing and initialization // happens later during startup. Each embedded extension is // queried and init using LOAD-EXTENSION system native. // See c:extensions-embedded // RL_API void *RL_Extend(const REBYTE *source, RXICAL call) { REBVAL *value; REBARR *array; value = CTX_VAR(Sys_Context, SYS_CTX_BOOT_EXTS); if (IS_BLOCK(value)) array = VAL_ARRAY(value); else { array = Make_Array(2); Val_Init_Block(value, array); } value = Alloc_Tail_Array(array); Val_Init_Binary(value, Copy_Bytes(source, -1)); // UTF-8 value = Alloc_Tail_Array(array); SET_HANDLE_CODE(value, cast(CFUNC*, call)); return Extension_Lib(); }
// // 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); }
// // 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_Set_Operation_Series: C // // Do set operations on a series. Case-sensitive if `cased` is TRUE. // `skip` is the record size. // static REBSER *Make_Set_Operation_Series( const REBVAL *val1, const REBVAL *val2, REBFLGS flags, REBOOL cased, REBCNT skip ) { REBCNT i; REBINT h = 1; // used for both logic true/false and hash check REBOOL first_pass = TRUE; // are we in the first pass over the series? REBSER *out_ser; assert(ANY_SERIES(val1)); if (val2) { assert(ANY_SERIES(val2)); if (ANY_ARRAY(val1)) { if (!ANY_ARRAY(val2)) fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2))); // As long as they're both arrays, we're willing to do: // // >> union quote (a b c) 'b/d/e // (a b c d e) // // The type of the result will match the first value. } else if (!IS_BINARY(val1)) { // We will similarly do any two ANY-STRING! types: // // >> union <abc> "bde" // <abcde> if (IS_BINARY(val2)) fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2))); } else { // Binaries only operate with other binaries if (!IS_BINARY(val2)) fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2))); } } // Calculate `i` as maximum length of result block. The temporary buffer // will be allocated at this size, but copied out at the exact size of // the actual result. // i = VAL_LEN_AT(val1); if (flags & SOP_FLAG_BOTH) i += VAL_LEN_AT(val2); if (ANY_ARRAY(val1)) { REBSER *hser = 0; // hash table for series REBSER *hret; // hash table for return series // The buffer used for building the return series. Currently it // reuses BUF_EMIT, because that buffer is not likely to be in // use (emit doesn't call set operations, nor vice versa). However, // other routines may get the same idea and start recursing so it // may be better to use something more similar to the mold stack // approach of marking off successive ranges in the array. // REBSER *buffer = ARR_SERIES(BUF_EMIT); Resize_Series(buffer, i); hret = Make_Hash_Sequence(i); // allocated // Optimization note: !! // This code could be optimized for small blocks by not hashing them // and extending Find_Key to FIND on the value itself w/o the hash. do { REBARR *array1 = VAL_ARRAY(val1); // val1 and val2 swapped 2nd pass! // Check what is in series1 but not in series2 // if (flags & SOP_FLAG_CHECK) hser = Hash_Block(val2, skip, cased); // Iterate over first series // i = VAL_INDEX(val1); for (; i < ARR_LEN(array1); i += skip) { RELVAL *item = ARR_AT(array1, i); if (flags & SOP_FLAG_CHECK) { h = Find_Key_Hashed( VAL_ARRAY(val2), hser, item, VAL_SPECIFIER(val1), skip, cased, 1 ); h = (h >= 0); if (flags & SOP_FLAG_INVERT) h = !h; } if (h) { Find_Key_Hashed( AS_ARRAY(buffer), hret, item, VAL_SPECIFIER(val1), skip, cased, 2 ); } } if (i != ARR_LEN(array1)) { // // In the current philosophy, the semantics of what to do // with things like `intersect/skip [1 2 3] [7] 2` is too // shaky to deal with, so an error is reported if it does // not work out evenly to the skip size. // fail (Error(RE_BLOCK_SKIP_WRONG)); } if (flags & SOP_FLAG_CHECK) Free_Series(hser); if (!first_pass) break; first_pass = FALSE; // Iterate over second series? // if ((i = ((flags & SOP_FLAG_BOTH) != 0))) { const REBVAL *temp = val1; val1 = val2; val2 = temp; } } while (i); if (hret) Free_Series(hret); out_ser = ARR_SERIES(Copy_Array_Shallow(AS_ARRAY(buffer), SPECIFIED)); SET_SERIES_LEN(buffer, 0); // required - allow reuse } else { REB_MOLD mo; CLEARS(&mo); if (IS_BINARY(val1)) { // // All binaries use "case-sensitive" comparison (e.g. each byte // is treated distinctly) // cased = TRUE; } // ask mo.series to have at least `i` capacity beyond mo.start // mo.opts = MOPT_RESERVE; mo.reserve = i; Push_Mold(&mo); do { REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass! REBUNI uc; // Iterate over first series // i = VAL_INDEX(val1); for (; i < SER_LEN(ser); i += skip) { uc = GET_ANY_CHAR(ser, i); if (flags & SOP_FLAG_CHECK) { h = (NOT_FOUND != Find_Str_Char( uc, VAL_SERIES(val2), 0, VAL_INDEX(val2), VAL_LEN_HEAD(val2), skip, cased ? AM_FIND_CASE : 0 )); if (flags & SOP_FLAG_INVERT) h = !h; } if (!h) continue; if ( NOT_FOUND == Find_Str_Char( uc, // c2 (the character to find) mo.series, // ser mo.start, // head mo.start, // index SER_LEN(mo.series), // tail skip, // skip cased ? AM_FIND_CASE : 0 // flags ) ) { Append_String(mo.series, ser, i, skip); } } if (!first_pass) break; first_pass = FALSE; // Iterate over second series? // if ((i = ((flags & SOP_FLAG_BOTH) != 0))) { const REBVAL *temp = val1; val1 = val2; val2 = temp; } } while (i); out_ser = Pop_Molded_String(&mo); } return out_ser; }
// // 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); }
// // Compose_Any_Array_Throws: C // // Compose a block from a block of un-evaluated values and GROUP! arrays that // are evaluated. This calls into Do_Core, so if 'into' is provided, then its // series must be protected from garbage collection. // // deep - recurse into sub-blocks // only - parens that return blocks are kept as blocks // // Writes result value at address pointed to by out. // REBOOL Compose_Any_Array_Throws( REBVAL *out, const REBVAL *any_array, REBOOL deep, REBOOL only, REBOOL into ) { REBDSP dsp_orig = DSP; Reb_Enumerator e; PUSH_SAFE_ENUMERATOR(&e, any_array); // evaluating could disrupt any_array while (NOT_END(e.value)) { UPDATE_EXPRESSION_START(&e); // informs the error delivery better if (IS_GROUP(e.value)) { // // We evaluate here, but disable lookahead so it only evaluates // the GROUP! and doesn't trigger errors on what's after it. // REBVAL evaluated; DO_NEXT_REFETCH_MAY_THROW(&evaluated, &e, DO_FLAG_NO_LOOKAHEAD); if (THROWN(&evaluated)) { *out = evaluated; DS_DROP_TO(dsp_orig); DROP_SAFE_ENUMERATOR(&e); return TRUE; } if (IS_BLOCK(&evaluated) && !only) { // // compose [blocks ([a b c]) merge] => [blocks a b c merge] // RELVAL *push = VAL_ARRAY_AT(&evaluated); while (NOT_END(push)) { // // `evaluated` is known to be specific, but its specifier // may be needed to derelativize its children. // DS_PUSH_RELVAL(push, VAL_SPECIFIER(&evaluated)); push++; } } else if (!IS_VOID(&evaluated)) { // // compose [(1 + 2) inserts as-is] => [3 inserts as-is] // compose/only [([a b c]) unmerged] => [[a b c] unmerged] // DS_PUSH(&evaluated); } else { // // compose [(print "Voids *vanish*!")] => [] // } } else if (deep) { if (IS_BLOCK(e.value)) { // // compose/deep [does [(1 + 2)] nested] => [does [3] nested] REBVAL specific; COPY_VALUE(&specific, e.value, e.specifier); REBVAL composed; if (Compose_Any_Array_Throws( &composed, &specific, TRUE, only, into )) { *out = composed; DS_DROP_TO(dsp_orig); DROP_SAFE_ENUMERATOR(&e); return TRUE; } DS_PUSH(&composed); } else { if (ANY_ARRAY(e.value)) { // // compose [copy/(orig) (copy)] => [copy/(orig) (copy)] // !!! path and second group are copies, first group isn't // REBARR *copy = Copy_Array_Shallow( VAL_ARRAY(e.value), IS_RELATIVE(e.value) ? e.specifier // use parent specifier if relative... : VAL_SPECIFIER(const_KNOWN(e.value)) // else child's ); DS_PUSH_TRASH; Val_Init_Array_Index( DS_TOP, VAL_TYPE(e.value), copy, VAL_INDEX(e.value) ); // ...manages } else DS_PUSH_RELVAL(e.value, e.specifier); } FETCH_NEXT_ONLY_MAYBE_END(&e); } else { // // compose [[(1 + 2)] (reverse "wollahs")] => [[(1 + 2)] "shallow"] // DS_PUSH_RELVAL(e.value, e.specifier); FETCH_NEXT_ONLY_MAYBE_END(&e); } } if (into) Pop_Stack_Values_Into(out, dsp_orig); else Val_Init_Array(out, VAL_TYPE(any_array), Pop_Stack_Values(dsp_orig)); DROP_SAFE_ENUMERATOR(&e); return FALSE; }
// // Next_Path_Throws: C // // Evaluate next part of a path. // REBOOL Next_Path_Throws(REBPVS *pvs) { REBPEF dispatcher; // Path must have dispatcher, else return: dispatcher = Path_Dispatch[VAL_TYPE(pvs->value)]; if (!dispatcher) return FALSE; // unwind, then check for errors pvs->item++; //Debug_Fmt("Next_Path: %r/%r", pvs->path-1, pvs->path); // Determine the "selector". See notes on pvs->selector_temp for why // a local variable can't be used for the temporary space. // if (IS_GET_WORD(pvs->item)) { // e.g. object/:field pvs->selector = GET_MUTABLE_VAR_MAY_FAIL(pvs->item, pvs->item_specifier); if (IS_VOID(pvs->selector)) fail (Error_No_Value_Core(pvs->item, pvs->item_specifier)); SET_TRASH_IF_DEBUG(&pvs->selector_temp); } // object/(expr) case: else if (IS_GROUP(pvs->item)) { if (Do_At_Throws( &pvs->selector_temp, VAL_ARRAY(pvs->item), VAL_INDEX(pvs->item), IS_RELATIVE(pvs->item) ? pvs->item_specifier // if relative, use parent specifier... : VAL_SPECIFIER(const_KNOWN(pvs->item)) // ...else use child's )) { *pvs->store = pvs->selector_temp; return TRUE; } pvs->selector = &pvs->selector_temp; } else { // object/word and object/value case: // COPY_VALUE(&pvs->selector_temp, pvs->item, pvs->item_specifier); pvs->selector = &pvs->selector_temp; } switch (dispatcher(pvs)) { case PE_OK: break; case PE_SET_IF_END: if (pvs->opt_setval && IS_END(pvs->item + 1)) { *pvs->value = *pvs->opt_setval; pvs->opt_setval = NULL; } break; case PE_NONE: SET_BLANK(pvs->store); case PE_USE_STORE: pvs->value = pvs->store; pvs->value_specifier = SPECIFIED; break; default: assert(FALSE); } if (NOT_END(pvs->item + 1)) return Next_Path_Throws(pvs); return FALSE; }
// // Do_Path_Throws_Core: C // // Evaluate an ANY_PATH! REBVAL, starting from the index position of that // path value and continuing to the end. // // The evaluator may throw because GROUP! is evaluated, e.g. `foo/(throw 1020)` // // If label_sym is passed in as being non-null, then the caller is implying // readiness to process a path which may be a function with refinements. // These refinements will be left in order on the data stack in the case // that `out` comes back as IS_FUNCTION(). // // If `opt_setval` is given, the path operation will be done as a "SET-PATH!" // if the path evaluation did not throw or error. HOWEVER the set value // is NOT put into `out`. This provides more flexibility on performance in // the evaluator, which may already have the `val` where it wants it, and // so the extra assignment would just be overhead. // // !!! Path evaluation is one of the parts of R3-Alpha that has not been // vetted very heavily by Ren-C, and needs a review and overhaul. // REBOOL Do_Path_Throws_Core( REBVAL *out, REBSTR **label_out, const RELVAL *path, REBCTX *specifier, REBVAL *opt_setval ) { REBPVS pvs; REBDSP dsp_orig = DSP; assert(ANY_PATH(path)); // !!! There is a bug in the dispatch such that if you are running a // set path, it does not always assign the output, because it "thinks you // aren't going to look at it". This presumably originated from before // parens were allowed in paths, and neglects cases like: // // foo/(throw 1020): value // // We always have to check to see if a throw occurred. Until this is // streamlined, we have to at minimum set it to something that is *not* // thrown so that we aren't testing uninitialized memory. A safe trash // will do, which is unset in release builds. // if (opt_setval) SET_TRASH_SAFE(out); // None of the values passed in can live on the data stack, because // they might be relocated during the path evaluation process. // assert(!IN_DATA_STACK_DEBUG(out)); assert(!IN_DATA_STACK_DEBUG(path)); assert(!opt_setval || !IN_DATA_STACK_DEBUG(opt_setval)); // Not currently robust for reusing passed in path or value as the output assert(out != path && out != opt_setval); assert(!opt_setval || !THROWN(opt_setval)); // Initialize REBPVS -- see notes in %sys-do.h // pvs.opt_setval = opt_setval; pvs.store = out; pvs.orig = path; pvs.item = VAL_ARRAY_AT(pvs.orig); // may not be starting at head of PATH! // The path value that's coming in may be relative (in which case it // needs to use the specifier passed in). Or it may be specific already, // in which case we should use the specifier in the value to process // its array contents. // if (IS_RELATIVE(path)) { #if !defined(NDEBUG) assert(specifier != SPECIFIED); if (VAL_RELATIVE(path) != VAL_FUNC(CTX_FRAME_FUNC_VALUE(specifier))) { Debug_Fmt("Specificity mismatch found in path dispatch"); PROBE_MSG(path, "the path being evaluated"); PROBE_MSG(FUNC_VALUE(VAL_RELATIVE(path)), "expected func"); PROBE_MSG(CTX_FRAME_FUNC_VALUE(specifier), "actual func"); assert(FALSE); } #endif pvs.item_specifier = specifier; } else pvs.item_specifier = VAL_SPECIFIER(const_KNOWN(path)); // Seed the path evaluation process by looking up the first item (to // get a datatype to dispatch on for the later path items) // if (IS_WORD(pvs.item)) { pvs.value = GET_MUTABLE_VAR_MAY_FAIL(pvs.item, pvs.item_specifier); pvs.value_specifier = SPECIFIED; if (IS_VOID(pvs.value)) fail (Error_No_Value_Core(pvs.item, pvs.item_specifier)); } else { // !!! Ideally there would be some way to deal with writes to // temporary locations, like this pvs.value...if a set-path sets // it, then it will be discarded. COPY_VALUE(pvs.store, VAL_ARRAY_AT(pvs.orig), pvs.item_specifier); pvs.value = pvs.store; pvs.value_specifier = SPECIFIED; } // Start evaluation of path: if (IS_END(pvs.item + 1)) { // If it was a single element path, return the value rather than // try to dispatch it (would cause a crash at time of writing) // // !!! Is this the desired behavior, or should it be an error? } else if (Path_Dispatch[VAL_TYPE(pvs.value)]) { REBOOL threw = Next_Path_Throws(&pvs); // !!! See comments about why the initialization of out is necessary. // Without it this assertion can change on some things: // // t: now // t/time: 10:20:03 // // (It thinks pvs.value has its THROWN bit set when it completed // successfully. It was a PE_USE_STORE case where pvs.value was reset to // pvs.store, and pvs.store has its thrown bit set. Valgrind does not // catch any uninitialized variables.) // // There are other cases that do trip valgrind when omitting the // initialization, though not as clearly reproducible. // assert(threw == THROWN(pvs.value)); if (threw) return TRUE; // Check for errors: if (NOT_END(pvs.item + 1) && !IS_FUNCTION(pvs.value)) { // // Only function refinements should get by this line: REBVAL specified_orig; COPY_VALUE(&specified_orig, pvs.orig, specifier); REBVAL specified_item; COPY_VALUE(&specified_item, pvs.item, specifier); fail (Error(RE_INVALID_PATH, &specified_orig, &specified_item)); } } else if (!IS_FUNCTION(pvs.value)) { REBVAL specified; COPY_VALUE(&specified, pvs.orig, specifier); fail (Error(RE_BAD_PATH_TYPE, &specified, Type_Of(pvs.value))); } if (opt_setval) { // If SET then we don't return anything assert(IS_END(pvs.item) + 1); return FALSE; } // If storage was not used, then copy final value back to it: if (pvs.value != pvs.store) COPY_VALUE(pvs.store, pvs.value, pvs.value_specifier); assert(!THROWN(out)); // Return 0 if not function or is :path/word... if (!IS_FUNCTION(pvs.value)) { assert(IS_END(pvs.item) + 1); return FALSE; } if (label_out) { REBVAL refinement; // When a function is hit, path processing stops as soon as the // processed sub-path resolves to a function. The path is still sitting // on the position of the last component of that sub-path. Usually, // this last component in the sub-path is a word naming the function. // if (IS_WORD(pvs.item)) { *label_out = VAL_WORD_SPELLING(pvs.item); } else { // In rarer cases, the final component (completing the sub-path to // the function to call) is not a word. Such as when you use a path // to pick by index out of a block of functions: // // functions: reduce [:add :subtract] // functions/1 10 20 // // Or when you have an immediate function value in a path with a // refinement. Tricky to make, but possible: // // do reduce [ // to-path reduce [:append 'only] [a] [b] // ] // // !!! When a function was not invoked through looking up a word // (or a word in a path) to use as a label, there were once three // different alternate labels used. One was SYM__APPLY_, another // was ROOT_NONAME, and another was to be the type of the function // being executed. None are fantastic, we do the type for now. *label_out = Canon(SYM_FROM_KIND(VAL_TYPE(pvs.value))); } // Move on to the refinements (if any) ++pvs.item; // !!! Currently, the mainline path evaluation "punts" on refinements. // When it finds a function, it stops the path evaluation and leaves // the position pvs.path before the list of refinements. // // A more elegant solution would be able to process and notice (for // instance) that `:APPEND/ONLY` should yield a function value that // has been specialized with a refinement. Path chaining should thus // be able to effectively do this and give the refined function object // back to the evaluator or other client. // // If a label_sym is passed in, we recognize that a function dispatch // is going to be happening. We do not want to pay to generate the // new series that would be needed to make a temporary function that // will be invoked and immediately GC'd So we gather the refinements // on the data stack. // // This code simulates that path-processing-to-data-stack, but it // should really be something in dispatch iself. In any case, we put // refinements on the data stack...and caller knows refinements are // from dsp_orig to DSP (thanks to accounting, all other operations // should balance!) for (; NOT_END(pvs.item); ++pvs.item) { // "the refinements" if (IS_VOID(pvs.item)) continue; if (IS_GROUP(pvs.item)) { // // Note it is not legal to use the data stack directly as the // output location for a DO (might be resized) if (Do_At_Throws( &refinement, VAL_ARRAY(pvs.item), VAL_INDEX(pvs.item), IS_RELATIVE(pvs.item) ? pvs.item_specifier // if relative, use parent's : VAL_SPECIFIER(const_KNOWN(pvs.item)) // else embedded )) { *out = refinement; DS_DROP_TO(dsp_orig); return TRUE; } if (IS_VOID(&refinement)) continue; DS_PUSH(&refinement); } else if (IS_GET_WORD(pvs.item)) { DS_PUSH_TRASH; *DS_TOP = *GET_OPT_VAR_MAY_FAIL(pvs.item, pvs.item_specifier); if (IS_VOID(DS_TOP)) { DS_DROP; continue; } } else DS_PUSH_RELVAL(pvs.item, pvs.item_specifier); // Whatever we were trying to use as a refinement should now be // on the top of the data stack, and only words are legal ATM // if (!IS_WORD(DS_TOP)) { fail (Error(RE_BAD_REFINE, DS_TOP)); } // Go ahead and canonize the word symbol so we don't have to // do it each time in order to get a case-insenstive compare // INIT_WORD_SPELLING(DS_TOP, VAL_WORD_CANON(DS_TOP)); } // To make things easier for processing, reverse the refinements on // the data stack (we needed to evaluate them in forward order). // This way we can just pop them as we go, and know if they weren't // all consumed if it doesn't get back to `dsp_orig` by the end. if (dsp_orig != DSP) { REBVAL *bottom = DS_AT(dsp_orig + 1); REBVAL *top = DS_TOP; while (top > bottom) { refinement = *bottom; *bottom = *top; *top = refinement; top--; bottom++; } } } else { // !!! Historically this just ignores a result indicating this is a // function with refinements, e.g. ':append/only'. However that // ignoring seems unwise. It should presumably create a modified // function in that case which acts as if it has the refinement. // // If the caller did not pass in a label pointer we assume they are // likely not ready to process any refinements. // if (NOT_END(pvs.item + 1)) fail (Error(RE_TOO_LONG)); // !!! Better error or add feature } return FALSE; }