// // Probe_Core_Debug: C // void Probe_Core_Debug( const char *msg, const char *file, int line, const RELVAL *val ) { if (msg) printf("\n** PROBE_MSG(\"%s\") ", msg); else printf("\n** PROBE() "); printf("tick %d %s:%d\n", cast(int, TG_Do_Count), file, line); fflush(stdout); Debug_Fmt("%r\n", val); }
*/ void Dump_Series(REBSER *series, REBYTE *memo) /* ***********************************************************************/ { if (!series) return; Debug_Fmt( Str_Dump[0], //"%s Series %x %s: Wide: %2d - Bias: %d Tail: %d Rest: %d Size: %6d" memo, series, (SERIES_LABEL(series) ? SERIES_LABEL(series) : "-"), SERIES_WIDE(series), SERIES_BIAS(series), SERIES_TAIL(series), SERIES_REST(series), SERIES_TOTAL(series) ); if (SERIES_WIDE(series) == sizeof(REBVAL)) Dump_Values(BLK_HEAD(series), SERIES_TAIL(series)); else Dump_Bytes(series->data, (SERIES_TAIL(series)+1) * SERIES_WIDE(series)); }
*/ void Debug_Series(const REBSER *ser) /* ***********************************************************************/ { REBINT disabled = GC_Disabled; GC_Disabled = 1; // This routine is also a little catalog of the outlying series // types in terms of sizing, just to know what they are. if (BYTE_SIZE(ser)) Debug_Str(s_cast(BIN_HEAD(ser))); else if (IS_BLOCK_SERIES(ser)) { REBVAL value; // May not actually be a REB_BLOCK, but we put it in a value // container for now saying it is so we can output it. Because // it may be a frame or otherwise, we use a raw VAL_SET VAL_SET(&value, REB_BLOCK); VAL_SERIES(&value) = m_cast(REBSER *, ser); // not actually modifying VAL_INDEX(&value) = 0; Debug_Fmt("%r", &value); } else if (SERIES_WIDE(ser) == sizeof(REBUNI))
*/ void Debug_Series(const REBSER *ser) /* ***********************************************************************/ { REBINT disabled = GC_Disabled; GC_Disabled = 1; // This routine is also a little catalog of the outlying series // types in terms of sizing, just to know what they are. if (BYTE_SIZE(ser)) Debug_Str(s_cast(BIN_HEAD(ser))); else if (Is_Array_Series(ser)) { REBVAL value; // May not actually be a REB_BLOCK, but we put it in a value // container for now saying it is so we can output it. It may be // a frame and we may not want to Manage_Series here, so we use a // raw VAL_SET instead of Val_Init_Block VAL_SET(&value, REB_BLOCK); VAL_SERIES(&value) = m_cast(REBSER *, ser); // not actually modifying VAL_INDEX(&value) = 0; Debug_Fmt("%r", &value); } else if (SERIES_WIDE(ser) == sizeof(REBUNI))
// // Dump_Info: C // void Dump_Info(void) { Debug_Fmt("^/--REBOL Kernel Dump--"); Debug_Fmt("Evaluator:"); Debug_Fmt(" Cycles: %d", cast(REBINT, Eval_Cycles)); Debug_Fmt(" Counter: %d", Eval_Count); Debug_Fmt(" Dose: %d", Eval_Dose); Debug_Fmt(" Signals: %x", Eval_Signals); Debug_Fmt(" Sigmask: %x", Eval_Sigmask); Debug_Fmt(" DSP: %d", DSP); Debug_Fmt("Memory/GC:"); Debug_Fmt(" Ballast: %d", GC_Ballast); Debug_Fmt(" Disable: %d", GC_Disabled); Debug_Fmt(" Guarded Series: %d", SER_LEN(GC_Series_Guard)); Debug_Fmt(" Guarded Values: %d", SER_LEN(GC_Value_Guard)); }
*/ RL_API int RL_Start(REBYTE *bin, REBINT len, REBYTE *script, REBINT script_len, REBCNT flags) /* ** Evaluate the default boot function. ** ** Returns: ** Zero on success, otherwise indicates an error occurred. ** Arguments: ** bin - optional startup code (compressed), can be null ** len - length of above bin ** flags - special flags ** Notes: ** This function completes the startup sequence by calling ** the sys/start function. ** ***********************************************************************/ { REBVAL *val; REBSER *ser; REBOL_STATE state; const REBVAL *error; REBVAL start_result; int result; REBVAL out; if (bin) { ser = Decompress(bin, len, -1, FALSE, FALSE); if (!ser) return 1; val = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_HOST); Val_Init_Binary(val, ser); } if (script && script_len > 4) { /* a 4-byte long payload type at the beginning */ i32 ptype = 0; REBYTE *data = script + sizeof(ptype); script_len -= sizeof(ptype); memcpy(&ptype, script, sizeof(ptype)); if (ptype == 1) {/* COMPRESSed data */ ser = Decompress(data, script_len, -1, FALSE, FALSE); } else { ser = Make_Binary(script_len); if (ser == NULL) { OS_FREE(script); return 1; } memcpy(BIN_HEAD(ser), data, script_len); } OS_FREE(script); val = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_EMBEDDED); Val_Init_Binary(val, ser); } PUSH_UNHALTABLE_TRAP(&error, &state); // The first time through the following code 'error' will be NULL, but... // `raise Error` can longjmp here, so 'error' won't be NULL *if* that happens! if (error) { // Save error for EXPLAIN and return it *Get_System(SYS_STATE, STATE_LAST_ERROR) = *error; Print_Value(error, 1024, FALSE); // !!! Whether or not the Rebol interpreter just throws and quits // in an error case with a bad error code or breaks you into the // console to debug the environment should be controlled by // a command line option. Defaulting to returning an error code // seems better, because kicking into an interactive session can // cause logging systems to hang. For now we throw instead of // just quietly returning a code if the script fails, but add // that option! // For RE_HALT and all other errors we return the error // number. Error numbers are not set in stone (currently), but // are never zero...which is why we can use 0 for success. return VAL_ERR_NUM(error); } if (Do_Sys_Func_Throws(&out, SYS_CTX_FINISH_RL_START, 0)) { #if !defined(NDEBUG) if (LEGACY(OPTIONS_EXIT_FUNCTIONS_ONLY)) raise Error_No_Catch_For_Throw(&out); #endif if ( IS_NATIVE(&out) && ( VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_QUIT_NATIVE) || VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_EXIT_NATIVE) ) ) { int status; CATCH_THROWN(&out, &out); status = Exit_Status_From_Value(&out); DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state); Shutdown_Core(); OS_EXIT(status); DEAD_END; } raise Error_No_Catch_For_Throw(&out); } DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state); // The convention in the API was to return 0 for success. We use the // convention (as for FINISH_INIT_CORE) that any non-UNSET! result from // FINISH_RL_START indicates something went wrong. if (IS_UNSET(&out)) result = 0; else { assert(FALSE); // should not happen (raise an error instead) Debug_Fmt("** finish-rl-start returned non-NONE!:"); Debug_Fmt("%r", &out); result = RE_MISC; } return result; }
// // RL_Start: C // // Evaluate the default boot function. // // Returns: // Zero on success, otherwise indicates an error occurred. // Arguments: // bin - optional startup code (compressed), can be null // len - length of above bin // flags - special flags // Notes: // This function completes the startup sequence by calling // the sys/start function. // RL_API int RL_Start(REBYTE *bin, REBINT len, REBYTE *script, REBINT script_len, REBCNT flags) { REBVAL *val; REBSER *ser; struct Reb_State state; REBCTX *error; int error_num; REBVAL result; VAL_INIT_WRITABLE_DEBUG(&result); if (bin) { ser = Decompress(bin, len, -1, FALSE, FALSE); if (!ser) return 1; val = CTX_VAR(Sys_Context, SYS_CTX_BOOT_HOST); Val_Init_Binary(val, ser); } if (script && script_len > 4) { /* a 4-byte long payload type at the beginning */ i32 ptype = 0; REBYTE *data = script + sizeof(ptype); script_len -= sizeof(ptype); memcpy(&ptype, script, sizeof(ptype)); if (ptype == 1) {/* COMPRESSed data */ ser = Decompress(data, script_len, -1, FALSE, FALSE); } else { ser = Make_Binary(script_len); if (ser == NULL) { OS_FREE(script); return 1; } memcpy(BIN_HEAD(ser), data, script_len); } OS_FREE(script); val = CTX_VAR(Sys_Context, SYS_CTX_BOOT_EMBEDDED); Val_Init_Binary(val, ser); } 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) { // // !!! We are not allowed to ask for a print operation that can take // arbitrarily long without allowing for cancellation via Ctrl-C, // but here we are wanting to print an error. If you're printing // out an error and get a halt, it won't print the halt. // REBCTX *halt_error; // Save error for WHY? // REBVAL *last = Get_System(SYS_STATE, STATE_LAST_ERROR); Val_Init_Error(last, error); PUSH_UNHALTABLE_TRAP(&halt_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 (halt_error) { assert(ERR_NUM(halt_error) == RE_HALT); return ERR_NUM(halt_error); } Print_Value(last, 1024, FALSE); DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state); // !!! When running in a script, whether or not the Rebol interpreter // just exits in an error case with a bad error code or breaks you // into the console to debug the environment should be controlled by // a command line option. Defaulting to returning an error code // seems better, because kicking into an interactive session can // cause logging systems to hang. // For RE_HALT and all other errors we return the error // number. Error numbers are not set in stone (currently), but // are never zero...which is why we can use 0 for success. // return ERR_NUM(error); } if (Apply_Only_Throws( &result, Sys_Func(SYS_CTX_FINISH_RL_START), END_VALUE )) { #if !defined(NDEBUG) if (LEGACY(OPTIONS_EXIT_FUNCTIONS_ONLY)) fail (Error_No_Catch_For_Throw(&result)); #endif if ( IS_FUNCTION_AND(&result, FUNC_CLASS_NATIVE) && ( VAL_FUNC_CODE(&result) == &N_quit || VAL_FUNC_CODE(&result) == &N_exit ) ) { int status; CATCH_THROWN(&result, &result); status = Exit_Status_From_Value(&result); DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state); Shutdown_Core(); OS_EXIT(status); DEAD_END; } fail (Error_No_Catch_For_Throw(&result)); } DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state); // The convention in the API was to return 0 for success. We use the // convention (as for FINISH_INIT_CORE) that any non-UNSET! result from // FINISH_RL_START indicates something went wrong. if (IS_UNSET(&result)) error_num = 0; // no error else { assert(FALSE); // should not happen (raise an error instead) Debug_Fmt("** finish-rl-start returned non-NONE!:"); Debug_Fmt("%r", &result); error_num = RE_MISC; } return error_num; }
*/ REBSER *Make_Object(REBSER *parent, REBVAL value[]) /* ** Create an object from a parent object and a spec block. ** The words within the resultant object are not bound. ** ***********************************************************************/ { REBSER *words; REBSER *object; PG_Reb_Stats->Objects++; if (!value || IS_END(value)) { if (parent) { object = Copy_Array_Core_Managed( parent, 0, SERIES_TAIL(parent), TRUE, TS_CLONE ); } else { object = Make_Frame(0, TRUE); MANAGE_FRAME(object); } } else { words = Collect_Frame(parent, &value[0], BIND_ONLY); // GC safe object = Create_Frame(words, 0); // GC safe if (parent) { if (Reb_Opts->watch_obj_copy) Debug_Fmt(cs_cast(BOOT_STR(RS_WATCH, 2)), SERIES_TAIL(parent) - 1, FRM_WORD_SERIES(object)); // Bitwise copy parent values (will have bits fixed by Clonify) memcpy( FRM_VALUES(object) + 1, FRM_VALUES(parent) + 1, (SERIES_TAIL(parent) - 1) * sizeof(REBVAL) ); // For values we copied that were blocks and strings, replace // their series components with deep copies of themselves: Clonify_Values_Len_Managed( BLK_SKIP(object, 1), SERIES_TAIL(object) - 1, TRUE, TS_CLONE ); // The *word series* might have been reused from the parent, // based on whether any words were added, or we could have gotten // a fresh one back. Force our invariant here (as the screws // tighten...) ENSURE_SERIES_MANAGED(FRM_WORD_SERIES(object)); MANAGE_SERIES(object); } else { MANAGE_FRAME(object); } assert(words == FRM_WORD_SERIES(object)); } ASSERT_SERIES_MANAGED(object); ASSERT_SERIES_MANAGED(FRM_WORD_SERIES(object)); ASSERT_FRAME(object); return object; }
*/ void Assert_Frame_Core(REBSER *frame) /* ***********************************************************************/ { REBINT n; REBVAL *value; REBSER *words; REBVAL *word; REBINT tail; REBVAL *frame_value; // "FRAME!-typed value" at head of "frame" series frame_value = BLK_HEAD(frame); if (!IS_FRAME(frame_value)) Panic_Series(frame); if ((frame == VAL_SERIES(ROOT_ROOT)) || (frame == Task_Series)) { // !!! Currently it is allowed that the root frames not // have a wordlist. This distinct behavior accomodation is // not worth having the variance of behavior, but since // it's there for now... allow it for just those two. if(!FRM_WORD_SERIES(frame)) return; } value = FRM_VALUES(frame); words = FRM_WORD_SERIES(frame); word = FRM_WORDS(frame); tail = SERIES_TAIL(frame); for (n = 0; n < tail; n++, value++, word++) { if (n == 0) { if ( VAL_WORD_SYM(word) != SYM_SELF && VAL_WORD_SYM(word) != SYM_NOT_USED ) { Debug_Fmt("** First slot in frame is not SELF or null symbol"); Panic_Series(frame); } } if (IS_END(word) || IS_END(value)) { Debug_Fmt( "** Early %s end at index: %d", IS_END(word) ? "word" : "value", n ); Panic_Series(frame); } if (!ANY_WORD(word)) { Debug_Fmt("** Non-word in word list, type: %d\n", VAL_TYPE(word)); Panic_Series(words); } if (!VAL_GET_EXT(word, EXT_WORD_TYPED)) { Debug_Fmt("** Frame words contains non-'typed'-word"); Panic_Series(words); } } if (NOT_END(word) || NOT_END(value)) { Debug_Fmt( "** Missing %s end at index: %d type: %d", NOT_END(word) ? "word" : "value", n, VAL_TYPE(word) ); Panic_Series(frame); } }
*/ RL_API void RL_Print_TOS(REBCNT flags, REBYTE *marker) /* ** Print top REBOL stack value to the console. (pending changes) ** ** Returns: ** Nothing ** Arguments: ** flags - special flags (set to zero at this time). ** marker - placed at beginning of line to indicate output. ** Notes: ** This function is used for the main console evaluation ** input loop to print the results of evaluation from stack. ** The REBOL data stack is an abstract structure that can ** change between releases. This function allows the host ** to print the result of processed functions. ** Note that what is printed is actually TOS+1. ** Marker is usually "==" to show output. ** The system/options/result-types determine which values ** are automatically printed. ** ***********************************************************************/ { REBINT dsp = DSP; REBVAL *top = DS_VALUE(dsp+1); REBOL_STATE state; REBVAL *types; if (dsp != 0) Debug_Fmt(Str_Stack_Misaligned, dsp); PUSH_STATE(state, Saved_State); if (SET_JUMP(state)) { POP_STATE(state, Saved_State); Catch_Error(DS_NEXT); // Stores error value here Out_Value(DS_NEXT, 0, FALSE, 0); // error DSP = 0; return; } SET_STATE(state, Saved_State); if (!IS_UNSET(top)) { if (!IS_ERROR(top)) { types = Get_System(SYS_OPTIONS, OPTIONS_RESULT_TYPES); if (IS_TYPESET(types) && TYPE_CHECK(types, VAL_TYPE(top))) { if (marker) Out_Str(marker, 0); Out_Value(top, 500, TRUE, 1); // limit, molded } // else { // Out_Str(Get_Type_Name(top), 1); // } } else { if (VAL_ERR_NUM(top) != RE_HALT) { Out_Value(top, 640, FALSE, 0); // error FORMed // if (VAL_ERR_NUM(top) > RE_THROW_MAX) { // Out_Str("** Note: use WHY? for more about this error", 1); // } } } } POP_STATE(state, Saved_State); DSP = 0; }
// // 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; }