*/ RL_API void RL_Print_TOS(REBOOL mold, const REBYTE *marker) /* ** Print top REBOL stack value to the console. ** ** Returns: ** Nothing ** Arguments: ** mold - should value be MOLDed instead of FORMed. ** 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. ** Marker is usually "==" to show output. ** The system/options/result-types determine which values ** are automatically printed. ** ***********************************************************************/ { if (DSP != 0) Debug_Fmt(Str_Stack_Misaligned, DSP); // We shouldn't get any THROWN() values exposed to the client assert(!THROWN(DS_TOP)); if (!IS_UNSET(DS_TOP)) { if (marker) Out_Str(marker, 0); Out_Value(DS_TOP, 500, mold, 1); // limit print length } }
*/ int main(int argc, char **argv) /* ***********************************************************************/ { char *cmd; // Parse command line arguments. Done early. May affect REBOL boot. Parse_Args(argc, argv, &Main_Args); Print_Str("REBOL 3.0\n"); REBOL_Init(&Main_Args); // Evaluate user input: while (TRUE) { cmd = Prompt_User(); REBOL_Do_String(cmd); if (!IS_UNSET(DS_TOP)) { //if (DSP > 0) { if (!IS_ERROR(DS_TOP)) { Prin("== "); Print_Value(DS_TOP, 0, TRUE); } else Print_Value(DS_TOP, 0, FALSE); //} } //DS_DROP; // result } return 0; }
// // Partial1: C // // Process the /part (or /skip) and other length modifying // arguments. // REBINT Partial1(REBVAL *sval, REBVAL *lval) { REBI64 len; REBINT maxlen; REBINT is_ser = ANY_SERIES(sval); // If lval is not set or is BAR!, use the current len of the target value: if (IS_UNSET(lval) || IS_BAR(lval)) { if (!is_ser) return 1; if (VAL_INDEX(sval) >= VAL_LEN_HEAD(sval)) return 0; return (VAL_LEN_HEAD(sval) - VAL_INDEX(sval)); } if (IS_INTEGER(lval) || IS_DECIMAL(lval)) len = Int32(lval); else { if (is_ser && VAL_TYPE(sval) == VAL_TYPE(lval) && VAL_SERIES(sval) == VAL_SERIES(lval)) len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(sval); else fail (Error(RE_INVALID_PART, lval)); } if (is_ser) { // Restrict length to the size available: if (len >= 0) { maxlen = (REBINT)VAL_LEN_AT(sval); if (len > maxlen) len = maxlen; } else { len = -len; if (len > (REBINT)VAL_INDEX(sval)) len = (REBINT)VAL_INDEX(sval); VAL_INDEX(sval) -= (REBCNT)len; } } return (REBINT)len; }
// // Next_Path_Throws: C // // Evaluate next part of a path. // REBOOL Next_Path_Throws(REBPVS *pvs) { REBPEF dispatcher; REBVAL temp; VAL_INIT_WRITABLE_DEBUG(&temp); // Path must have dispatcher, else return: dispatcher = Path_Dispatch[VAL_TYPE_0(pvs->value)]; if (!dispatcher) return FALSE; // unwind, then check for errors pvs->item++; //Debug_Fmt("Next_Path: %r/%r", pvs->path-1, pvs->path); // object/:field case: if (IS_GET_WORD(pvs->item)) { pvs->selector = GET_MUTABLE_VAR_MAY_FAIL(pvs->item); if (IS_UNSET(pvs->selector)) fail (Error(RE_NO_VALUE, pvs->item)); } // object/(expr) case: else if (IS_GROUP(pvs->item)) { if (DO_VAL_ARRAY_AT_THROWS(&temp, pvs->item)) { *pvs->value = temp; return TRUE; } pvs->selector = &temp; } else // object/word and object/value case: pvs->selector = pvs->item; 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_NONE(pvs->store); case PE_USE_STORE: pvs->value = pvs->store; break; default: assert(FALSE); } if (NOT_END(pvs->item + 1)) return Next_Path_Throws(pvs); return FALSE; }
// // Partial: C // // Args: // aval: target value // bval: argument to modify target (optional) // lval: length value (or none) // // Determine the length of a /PART value. It can be: // 1. integer or decimal // 2. relative to A value (bval is null) // 3. relative to B value // // NOTE: Can modify the value's index! // The result can be negative. ??? // REBINT Partial(REBVAL *aval, REBVAL *bval, REBVAL *lval) { REBVAL *val; REBINT len; REBINT maxlen; // If lval is unset, use the current len of the target value: if (IS_UNSET(lval)) { val = (bval && ANY_SERIES(bval)) ? bval : aval; if (VAL_INDEX(val) >= VAL_LEN_HEAD(val)) return 0; return (VAL_LEN_HEAD(val) - VAL_INDEX(val)); } if (IS_INTEGER(lval) || IS_DECIMAL(lval)) { len = Int32(lval); val = bval; } else { // So, lval must be relative to aval or bval series: if ( VAL_TYPE(aval) == VAL_TYPE(lval) && VAL_SERIES(aval) == VAL_SERIES(lval) ) { val = aval; } else if ( bval && VAL_TYPE(bval) == VAL_TYPE(lval) && VAL_SERIES(bval) == VAL_SERIES(lval) ) { val = bval; } else fail (Error(RE_INVALID_PART, lval)); len = cast(REBINT, VAL_INDEX(lval)) - cast(REBINT, VAL_INDEX(val)); } if (!val) val = aval; // Restrict length to the size available // if (len >= 0) { maxlen = (REBINT)VAL_LEN_AT(val); if (len > maxlen) len = maxlen; } else { len = -len; if (len > cast(REBINT, VAL_INDEX(val))) len = cast(REBINT, VAL_INDEX(val)); VAL_INDEX(val) -= (REBCNT)len; } return len; }
*/ static void Set_GOB_Vars(REBGOB *gob, REBVAL *blk) /* ***********************************************************************/ { REBVAL *var; REBVAL *val; while (NOT_END(blk)) { var = blk++; val = blk++; if (!IS_SET_WORD(var)) Trap2(RE_EXPECT_VAL, Get_Type(REB_SET_WORD), Of_Type(var)); if (IS_END(val) || IS_UNSET(val) || IS_SET_WORD(val)) Trap1(RE_NEED_VALUE, var); val = Get_Simple_Value(val); if (!Set_GOB_Var(gob, var, val)) Trap2(RE_BAD_FIELD_SET, var, Of_Type(val)); } }
static REBFLG Print_Native_Modifying_Throws( REBVAL *value, // Value may be modified. Contents must be GC-safe! REBOOL newline ) { if (IS_UNSET(value)) { #if !defined(NDEBUG) if (LEGACY(OPTIONS_PRINT_FORMS_EVERYTHING)) goto form_it; #endif // No effect (not even a newline). Previously this also was the // behavior for NONE, but now that none is considered "reified" it // does not opt out from rendering. } else if (IS_BINARY(value)) { #if !defined(NDEBUG) if (LEGACY(OPTIONS_PRINT_FORMS_EVERYTHING)) goto form_it; #endif // Send raw bytes to the console. CGI+ANSI+VT100 etc. require it // for full 8-bit byte transport (UTF-8 is by definition not good // enough...some bytes are illegal to occur in UTF-8 at all). // // Given that PRINT is not a general-purpose PROBE tool (it has // never output values purely "as is", evaluating blocks for // instance) it's worth doing a "strange" thing (though no stranger // than WRITE) to be able to access the facility. Prin_OS_String(VAL_BIN_DATA(value), VAL_LEN(value), OPT_ENC_RAW); // !!! Binary print should never output a newline. This would seem // more natural if PRINT's decision to output newlines was guided // by whether it was given a block or not (under consideration). } else if (IS_BLOCK(value)) { // !!! Pending plan for PRINT of BLOCK! is to do something like // COMBINE where NONE! is elided, single characters are not spaced out, // nested blocks are recursed, etc. So: // // print ["A" newline "B" if 1 > 2 [newline] if 1 < 2 ["C"]]] // // Would output the following (where _ is space): // // A // B_C // // As opposed to historical output, which is: // // A_ // B_none_C // // Currently it effectively FORM REDUCEs the output. if (Reduce_Block_Throws( value, VAL_SERIES(value), VAL_INDEX(value), FALSE )) { return TRUE; } Prin_Value(value, 0, 0); if (newline) Print_OS_Line(); } else { #if !defined(NDEBUG) form_it: // used only by OPTIONS_PRINT_FORMS_EVERYTHING #endif // !!! Full behavior review needed for all types. Prin_Value(value, 0, 0); if (newline) Print_OS_Line(); } return FALSE; }
*/ REBCNT Modify_Array(REBCNT action, REBSER *dst_ser, REBCNT dst_idx, const REBVAL *src_val, REBCNT flags, REBINT dst_len, REBINT dups) /* ** action: INSERT, APPEND, CHANGE ** ** dst_ser: target ** dst_idx: position ** src_val: source ** flags: AN_ONLY, AN_PART ** dst_len: length to remove ** dups: dup count ** ** return: new dst_idx ** ***********************************************************************/ { REBCNT tail = SERIES_TAIL(dst_ser); REBINT ilen = 1; // length to be inserted REBINT size; // total to insert #if !defined(NDEBUG) REBINT index; #endif if (IS_UNSET(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 == A_APPEND) ? 0 : dst_idx; } if (action == A_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 != A_CHANGE && GET_FLAG(flags, AN_PART)) ilen = dst_len; else ilen = VAL_LEN(src_val); // Are we modifying ourselves? If so, copy src_val block first: if (dst_ser == VAL_SERIES(src_val)) { REBSER *series = Copy_Array_At_Shallow( VAL_SERIES(src_val), VAL_INDEX(src_val) ); src_val = BLK_HEAD(series); } else src_val = VAL_BLK_DATA(src_val); // skips by VAL_INDEX values } // Total to insert: size = dups * ilen; if (action != A_CHANGE) { // Always expand dst_ser for INSERT and APPEND actions: Expand_Series(dst_ser, dst_idx, size); } else { if (size > dst_len) Expand_Series(dst_ser, dst_idx, size-dst_len); else if (size < dst_len && GET_FLAG(flags, AN_PART)) Remove_Series(dst_ser, dst_idx, dst_len-size); else if (size + dst_idx > tail) { EXPAND_SERIES_TAIL(dst_ser, size - (tail - dst_idx)); } } tail = (action == A_APPEND) ? 0 : size + dst_idx; #if !defined(NDEBUG) for (index = 0; index < ilen; index++) { if (SERIES_GET_FLAG(dst_ser, SER_MANAGED)) ASSERT_VALUE_MANAGED(&src_val[index]); } #endif dst_idx *= SERIES_WIDE(dst_ser); // loop invariant ilen *= SERIES_WIDE(dst_ser); // loop invariant for (; dups > 0; dups--) { memcpy(dst_ser->data + dst_idx, src_val, ilen); dst_idx += ilen; } TERM_ARRAY(dst_ser); return tail; }
*/ static REBCNT Parse_Rules_Loop(REBPARSE *parse, REBCNT index, REBVAL *rules, REBCNT depth) /* ***********************************************************************/ { REBSER *series = parse->series; REBVAL *item; // current rule item REBVAL *word; // active word to be set REBCNT start; // recovery restart point REBCNT i; // temp index point REBCNT begin; // point at beginning of match REBINT count; // iterated pattern counter REBINT mincount; // min pattern count REBINT maxcount; // max pattern count REBVAL *item_hold; REBVAL *val; // spare REBCNT rulen; REBSER *ser; REBFLG flags; REBCNT cmd; REBVAL *rule_head = rules; CHECK_STACK(&flags); //if (depth > MAX_PARSE_DEPTH) Trap_Word(RE_LIMIT_HIT, SYM_PARSE, 0); flags = 0; word = 0; mincount = maxcount = 1; start = begin = index; // For each rule in the rule block: while (NOT_END(rules)) { //Print_Parse_Index(parse->type, rules, series, index); if (--Eval_Count <= 0 || Eval_Signals) Do_Signals(); //-------------------------------------------------------------------- // Pre-Rule Processing Section // // For non-iterated rules, including setup for iterated rules. // The input index is not advanced here, but may be changed by // a GET-WORD variable. //-------------------------------------------------------------------- item = rules++; // If word, set-word, or get-word, process it: if (VAL_TYPE(item) >= REB_WORD && VAL_TYPE(item) <= REB_GET_WORD) { // Is it a command word? if (cmd = VAL_CMD(item)) { if (!IS_WORD(item)) Trap1(RE_PARSE_COMMAND, item); // SET or GET not allowed if (cmd <= SYM_BREAK) { // optimization switch (cmd) { case SYM_OR_BAR: return index; // reached it successfully // Note: mincount = maxcount = 1 on entry case SYM_WHILE: SET_FLAG(flags, PF_WHILE); case SYM_ANY: mincount = 0; case SYM_SOME: maxcount = MAX_I32; continue; case SYM_OPT: mincount = 0; continue; case SYM_COPY: SET_FLAG(flags, PF_COPY); case SYM_SET: SET_FLAG(flags, PF_SET); item = rules++; if (!IS_WORD(item)) Trap1(RE_PARSE_VARIABLE, item); if (VAL_CMD(item)) Trap1(RE_PARSE_COMMAND, item); word = item; continue; case SYM_NOT: SET_FLAG(flags, PF_NOT); flags ^= (1<<PF_NOT2); continue; case SYM_AND: SET_FLAG(flags, PF_AND); continue; case SYM_THEN: SET_FLAG(flags, PF_THEN); continue; case SYM_REMOVE: SET_FLAG(flags, PF_REMOVE); continue; case SYM_INSERT: SET_FLAG(flags, PF_INSERT); goto post; case SYM_CHANGE: SET_FLAG(flags, PF_CHANGE); continue; case SYM_RETURN: if (IS_PAREN(rules)) { item = Do_Block_Value_Throw(rules); // might GC Throw_Return_Value(item); } SET_FLAG(flags, PF_RETURN); continue; case SYM_ACCEPT: case SYM_BREAK: parse->result = 1; return index; case SYM_REJECT: parse->result = -1; return index; case SYM_FAIL: index = NOT_FOUND; goto post; case SYM_IF: item = rules++; if (IS_END(item)) goto bad_end; if (!IS_PAREN(item)) Trap1(RE_PARSE_RULE, item); item = Do_Block_Value_Throw(item); // might GC if (IS_TRUE(item)) continue; else { index = NOT_FOUND; goto post; } case SYM_LIMIT: Trap0(RE_NOT_DONE); //val = Get_Parse_Value(rules++); // if (IS_INTEGER(val)) limit = index + Int32(val); // else if (ANY_SERIES(val)) limit = VAL_INDEX(val); // else goto //goto bad_rule; // goto post; case SYM_QQ: Print_Parse_Index(parse->type, rules, series, index); continue; } } // Any other cmd must be a match command, so proceed... } else { // It's not a PARSE command, get or set it: // word: - set a variable to the series at current index if (IS_SET_WORD(item)) { Set_Var_Series(item, parse->type, series, index); continue; } // :word - change the index for the series to a new position if (IS_GET_WORD(item)) { item = Get_Var(item); // CureCode #1263 change //if (parse->type != VAL_TYPE(item) || VAL_SERIES(item) != series) // Trap1(RE_PARSE_SERIES, rules-1); if (!ANY_SERIES(item)) Trap1(RE_PARSE_SERIES, rules-1); index = Set_Parse_Series(parse, item); series = parse->series; continue; } // word - some other variable if (IS_WORD(item)) { item = Get_Var(item); } // item can still be 'word or /word } } else if (ANY_PATH(item)) { item = Do_Parse_Path(item, parse, &index); // index can be modified if (index > series->tail) index = series->tail; if (item == 0) continue; // for SET and GET cases } if (IS_PAREN(item)) { Do_Block_Value_Throw(item); // might GC if (index > series->tail) index = series->tail; continue; } // Counter? 123 if (IS_INTEGER(item)) { // Specify count or range count SET_FLAG(flags, PF_WHILE); mincount = maxcount = Int32s(item, 0); item = Get_Parse_Value(rules++); if (IS_END(item)) Trap1(RE_PARSE_END, rules-2); if (IS_INTEGER(item)) { maxcount = Int32s(item, 0); item = Get_Parse_Value(rules++); if (IS_END(item)) Trap1(RE_PARSE_END, rules-2); } } // else fall through on other values and words //-------------------------------------------------------------------- // Iterated Rule Matching Section: // // Repeats the same rule N times or until the rule fails. // The index is advanced and stored in a temp variable i until // the entire rule has been satisfied. //-------------------------------------------------------------------- item_hold = item; // a command or literal match value if (VAL_TYPE(item) <= REB_UNSET || VAL_TYPE(item) >= REB_NATIVE) goto bad_rule; begin = index; // input at beginning of match section rulen = 0; // rules consumed (do not use rule++ below) i = index; //note: rules var already advanced for (count = 0; count < maxcount;) { item = item_hold; if (IS_WORD(item)) { switch (cmd = VAL_WORD_CANON(item)) { case SYM_SKIP: i = (index < series->tail) ? index+1 : NOT_FOUND; break; case SYM_END: i = (index < series->tail) ? NOT_FOUND : series->tail; break; case SYM_TO: case SYM_THRU: if (IS_END(rules)) goto bad_end; item = Get_Parse_Value(rules); rulen = 1; i = Parse_To(parse, index, item, cmd == SYM_THRU); break; case SYM_QUOTE: if (IS_END(rules)) goto bad_end; rulen = 1; if (IS_PAREN(rules)) { item = Do_Block_Value_Throw(rules); // might GC } else item = rules; i = (0 == Cmp_Value(BLK_SKIP(series, index), item, parse->flags & AM_FIND_CASE)) ? index+1 : NOT_FOUND; break; case SYM_INTO: if (IS_END(rules)) goto bad_end; rulen = 1; item = Get_Parse_Value(rules); // sub-rules if (!IS_BLOCK(item)) goto bad_rule; val = BLK_SKIP(series, index); i = ( (ANY_BINSTR(val) || ANY_BLOCK(val)) && (Parse_Series(val, VAL_BLK_DATA(item), parse->flags, depth+1) == VAL_TAIL(val)) ) ? index+1 : NOT_FOUND; break; case SYM_DO: if (!IS_BLOCK_INPUT(parse)) goto bad_rule; i = Do_Eval_Rule(parse, index, &rules); rulen = 1; break; default: goto bad_rule; } } else if (IS_BLOCK(item)) { item = VAL_BLK_DATA(item); //if (IS_END(rules) && item == rule_head) { // rules = item; // goto top; //} i = Parse_Rules_Loop(parse, index, item, depth+1); if (parse->result) { index = (parse->result > 0) ? i : NOT_FOUND; parse->result = 0; break; } } // Parse according to datatype: else { if (IS_BLOCK_INPUT(parse)) i = Parse_Next_Block(parse, index, item, depth+1); else i = Parse_Next_String(parse, index, item, depth+1); } // Necessary for special cases like: some [to end] // i: indicates new index or failure of the match, but // that does not mean failure of the rule, because optional // matches can still succeed, if if the last match failed. if (i != NOT_FOUND) { count++; // may overflow to negative if (count < 0) count = MAX_I32; // the forever case // If input did not advance: if (i == index && !GET_FLAG(flags, PF_WHILE)) { if (count < mincount) index = NOT_FOUND; // was not enough break; } } //if (i >= series->tail) { // OLD check: no more input else { if (count < mincount) index = NOT_FOUND; // was not enough else if (i != NOT_FOUND) index = i; // else keep index as is. break; } index = i; // A BREAK word stopped us: //if (parse->result) {parse->result = 0; break;} } rules += rulen; //if (index > series->tail && index != NOT_FOUND) index = series->tail; if (index > series->tail) index = NOT_FOUND; //-------------------------------------------------------------------- // Post Match Processing: //-------------------------------------------------------------------- post: // Process special flags: if (flags) { // NOT before all others: if (GET_FLAG(flags, PF_NOT)) { if (GET_FLAG(flags, PF_NOT2) && index != NOT_FOUND) index = NOT_FOUND; else index = begin; } if (index == NOT_FOUND) { // Failure actions: // not decided: if (word) Set_Var_Basic(word, REB_NONE); if (GET_FLAG(flags, PF_THEN)) { SKIP_TO_BAR(rules); if (!IS_END(rules)) rules++; } } else { // Success actions: count = (begin > index) ? 0 : index - begin; // how much we advanced the input if (GET_FLAG(flags, PF_COPY)) { ser = (IS_BLOCK_INPUT(parse)) ? Copy_Block_Len(series, begin, count) : Copy_String(series, begin, count); // condenses Set_Var_Series(word, parse->type, ser, 0); } else if (GET_FLAG(flags, PF_SET)) { if (IS_BLOCK_INPUT(parse)) { item = Get_Var_Safe(word); if (count == 0) SET_NONE(item); else *item = *BLK_SKIP(series, begin); } else { item = Get_Var_Safe(word); if (count == 0) SET_NONE(item); else { i = GET_ANY_CHAR(series, begin); if (parse->type == REB_BINARY) { SET_INTEGER(item, i); } else { SET_CHAR(item, i); } } } } if (GET_FLAG(flags, PF_RETURN)) { ser = (IS_BLOCK_INPUT(parse)) ? Copy_Block_Len(series, begin, count) : Copy_String(series, begin, count); // condenses Throw_Return_Series(parse->type, ser); } if (GET_FLAG(flags, PF_REMOVE)) { if (count) Remove_Series(series, begin, count); index = begin; } if (flags & (1<<PF_INSERT | 1<<PF_CHANGE)) { count = GET_FLAG(flags, PF_INSERT) ? 0 : count; cmd = GET_FLAG(flags, PF_INSERT) ? 0 : (1<<AN_PART); item = rules++; if (IS_END(item)) goto bad_end; // Check for ONLY flag: if (IS_WORD(item) && NZ(cmd = VAL_CMD(item))) { if (cmd != SYM_ONLY) goto bad_rule; cmd |= (1<<AN_ONLY); item = rules++; } // CHECK FOR QUOTE!! item = Get_Parse_Value(item); // new value if (IS_UNSET(item)) Trap1(RE_NO_VALUE, rules-1); if (IS_END(item)) goto bad_end; if (IS_BLOCK_INPUT(parse)) { index = Modify_Block(GET_FLAG(flags, PF_CHANGE) ? A_CHANGE : A_INSERT, series, begin, item, cmd, count, 1); if (IS_LIT_WORD(item)) SET_TYPE(BLK_SKIP(series, index-1), REB_WORD); } else { if (parse->type == REB_BINARY) cmd |= (1<<AN_SERIES); // special flag index = Modify_String(GET_FLAG(flags, PF_CHANGE) ? A_CHANGE : A_INSERT, series, begin, item, cmd, count, 1); } } if (GET_FLAG(flags, PF_AND)) index = begin; } flags = 0; word = 0; } // Goto alternate rule and reset input: if (index == NOT_FOUND) { SKIP_TO_BAR(rules); if (IS_END(rules)) break; rules++; index = begin = start; } begin = index; mincount = maxcount = 1; } return index; bad_rule: Trap1(RE_PARSE_RULE, rules-1); bad_end: Trap1(RE_PARSE_END, rules-1); return 0; }
*/ 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; }
// // Do_Path_Throws: 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( REBVAL *out, REBSYM *label_sym, const REBVAL *path, 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(out)); assert(!IN_DATA_STACK(path)); assert(!opt_setval || !IN_DATA_STACK(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! // 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); if (IS_UNSET(pvs.value)) fail (Error(RE_NO_VALUE, pvs.item)); } else { // !!! Ideally there would be some way to protect pvs.value during // successive path dispatches to make sure it does not get written. // This is semi-dangerously giving pvs.value a reference into the // input path, which should not be modified! pvs.value = VAL_ARRAY_AT(pvs.orig); } // 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_0(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: fail (Error(RE_INVALID_PATH, pvs.orig, pvs.item)); } } else if (!IS_FUNCTION(pvs.value)) fail (Error(RE_BAD_PATH_TYPE, pvs.orig, 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) *pvs.store = *pvs.value; 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_sym) { REBVAL refinement; VAL_INIT_WRITABLE_DEBUG(&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_sym = VAL_WORD_SYM(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_sym = 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_NONE(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_VAL_ARRAY_AT_THROWS(&refinement, pvs.item)) { *out = refinement; DS_DROP_TO(dsp_orig); return TRUE; } if (IS_NONE(&refinement)) continue; DS_PUSH(&refinement); } else if (IS_GET_WORD(pvs.item)) { DS_PUSH_TRASH; *DS_TOP = *GET_OPT_VAR_MAY_FAIL(pvs.item); if (IS_NONE(DS_TOP)) { DS_DROP; continue; } } else DS_PUSH(pvs.item); // 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_SYM(DS_TOP, SYMBOL_TO_CANON(VAL_WORD_SYM(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; }
// // 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; }
*/ 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; }
// // Frame_For_Stack_Level: C // // Level can be an UNSET!, an INTEGER!, an ANY-FUNCTION!, or a FRAME!. If // level is UNSET! then it means give whatever the first call found is. // // Returns NULL if the given level number does not correspond to a running // function on the stack. // // Can optionally give back the index number of the stack level (counting // where the most recently pushed stack level is the lowest #) // // !!! Unfortunate repetition of logic inside of BACKTRACE; find a way to // unify the logic for omitting things like breakpoint frames, or either // considering pending frames or not... // struct Reb_Frame *Frame_For_Stack_Level( REBCNT *number_out, const REBVAL *level, REBOOL skip_current ) { struct Reb_Frame *frame = FS_TOP; REBOOL first = TRUE; REBINT num = 0; if (IS_INTEGER(level)) { if (VAL_INT32(level) < 0) { // // !!! fail() here, or just return NULL? // return NULL; } } // We may need to skip some number of frames, if there have been stack // levels added since the numeric reference point that "level" was // supposed to refer to has changed. For now that's only allowed to // be one level, because it's rather fuzzy which stack levels to // omit otherwise (pending? parens?) // if (skip_current) frame = frame->prior; for (; frame != NULL; frame = frame->prior) { if (frame->mode != CALL_MODE_FUNCTION) { // // Don't consider pending calls, or GROUP!, or any non-invoked // function as a candidate to target. // // !!! The inability to target a GROUP! by number is an artifact // of implementation, in that there's no hook in Do_Core() at // the point of group evaluation to process the return. The // matter is different with a pending function call, because its // arguments are only partially processed--hence something // like a RESUME/AT or an EXIT/FROM would not know which array // index to pick up running from. // continue; } if (first) { if ( IS_FUNCTION_AND(FUNC_VALUE(frame->func), FUNC_CLASS_NATIVE) && ( FUNC_CODE(frame->func) == &N_pause || FUNC_CODE(frame->func) == N_breakpoint ) ) { // this is considered the "0". Return it only if 0 was requested // specifically (you don't "count down to it"); // if (IS_INTEGER(level) && num == VAL_INT32(level)) goto return_maybe_set_number_out; else { first = FALSE; continue; } } else { ++num; // bump up from 0 } } if (IS_INTEGER(level) && num == VAL_INT32(level)) goto return_maybe_set_number_out; first = FALSE; if (frame->mode != CALL_MODE_FUNCTION) { // // Pending frames don't get numbered // continue; } if (IS_UNSET(level) || IS_NONE(level)) { // // Take first actual frame if unset or none // goto return_maybe_set_number_out; } else if (IS_INTEGER(level)) { ++num; if (num == VAL_INT32(level)) goto return_maybe_set_number_out; } else if (IS_FRAME(level)) { if ( (frame->flags & DO_FLAG_FRAME_CONTEXT) && frame->data.context == VAL_CONTEXT(level) ) { goto return_maybe_set_number_out; } } else { assert(IS_FUNCTION(level)); if (VAL_FUNC(level) == frame->func) goto return_maybe_set_number_out; } } // Didn't find it... // return NULL; return_maybe_set_number_out: if (number_out) *number_out = num; return frame; }
*/ static REB_R Loop_Each(struct Reb_Call *call_, REBINT mode) /* ** Supports these natives (modes): ** 0: foreach ** 1: remove-each ** 2: map ** ***********************************************************************/ { REBSER *body; REBVAL *vars; REBVAL *words; REBSER *frame; REBVAL *value; REBSER *series; REBSER *out; // output block (for MAP, mode = 2) REBINT index; // !!!! should these be REBCNT? REBINT tail; REBINT windex; // write REBINT rindex; // read REBINT err; REBCNT i; REBCNT j; REBVAL *ds; assert(mode >= 0 && mode < 3); value = D_ARG(2); // series if (IS_NONE(value)) return R_NONE; body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body SET_OBJECT(D_ARG(1), frame); // keep GC safe Set_Block(D_ARG(3), body); // keep GC safe SET_NONE(D_OUT); // Default result to NONE if the loop does not run // If it's MAP, create result block: if (mode == 2) { out = Make_Block(VAL_LEN(value)); SAVE_SERIES(out); } // Get series info: if (ANY_OBJECT(value)) { series = VAL_OBJ_FRAME(value); out = FRM_WORD_SERIES(series); // words (the out local reused) index = 1; //if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3)); } else if (IS_MAP(value)) { series = VAL_SERIES(value); index = 0; //if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3)); } else { series = VAL_SERIES(value); index = VAL_INDEX(value); if (index >= cast(REBINT, SERIES_TAIL(series))) { if (mode == 1) { SET_INTEGER(D_OUT, 0); } else if (mode == 2) { Set_Block(D_OUT, out); UNSAVE_SERIES(out); } return R_OUT; } } windex = index; // Iterate over each value in the series block: while (index < (tail = SERIES_TAIL(series))) { rindex = index; // remember starting spot j = 0; // Set the FOREACH loop variables from the series: for (i = 1; i < frame->tail; i++) { vars = FRM_VALUE(frame, i); words = FRM_WORD(frame, i); // var spec is WORD if (IS_WORD(words)) { if (index < tail) { if (ANY_BLOCK(value)) { *vars = *BLK_SKIP(series, index); } else if (ANY_OBJECT(value)) { if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) { // Alternate between word and value parts of object: if (j == 0) { Init_Word(vars, REB_WORD, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index); if (NOT_END(vars+1)) index--; // reset index for the value part } else if (j == 1) *vars = *BLK_SKIP(series, index); else Trap_Arg_DEAD_END(words); j++; } else { // Do not evaluate this iteration index++; goto skip_hidden; } } else if (IS_VECTOR(value)) { Set_Vector_Value(vars, series, index); } else if (IS_MAP(value)) { REBVAL *val = BLK_SKIP(series, index | 1); if (!IS_NONE(val)) { if (j == 0) { *vars = *BLK_SKIP(series, index & ~1); if (IS_END(vars+1)) index++; // only words } else if (j == 1) *vars = *BLK_SKIP(series, index); else Trap_Arg_DEAD_END(words); j++; } else { index += 2; goto skip_hidden; } } else { // A string or binary if (IS_BINARY(value)) { SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index])); } else if (IS_IMAGE(value)) { Set_Tuple_Pixel(BIN_SKIP(series, index), vars); } else { VAL_SET(vars, REB_CHAR); VAL_CHAR(vars) = GET_ANY_CHAR(series, index); } } index++; } else SET_NONE(vars); } // var spec is SET_WORD: else if (IS_SET_WORD(words)) { if (ANY_OBJECT(value) || IS_MAP(value)) { *vars = *value; } else { VAL_SET(vars, REB_BLOCK); VAL_SERIES(vars) = series; VAL_INDEX(vars) = index; } //if (index < tail) index++; // do not increment block. } else Trap_Arg_DEAD_END(words); } if (index == rindex) index++; //the word block has only set-words: foreach [a:] [1 2 3][] if (!DO_BLOCK(D_OUT, body, 0)) { if ((err = Check_Error(D_OUT)) >= 0) { index = rindex; break; } // else CONTINUE: if (mode == 1) SET_FALSE(D_OUT); // keep the value (for mode == 1) } else { err = 0; // prevent later test against uninitialized value } if (mode > 0) { //if (ANY_OBJECT(value)) Trap_Types_DEAD_END(words, REB_BLOCK, VAL_TYPE(value)); //check not needed // If FALSE return, copy values to the write location: if (mode == 1) { // remove-each if (IS_CONDITIONAL_FALSE(D_OUT)) { REBCNT wide = SERIES_WIDE(series); // memory areas may overlap, so use memmove and not memcpy! memmove(series->data + (windex * wide), series->data + (rindex * wide), (index - rindex) * wide); windex += index - rindex; // old: while (rindex < index) *BLK_SKIP(series, windex++) = *BLK_SKIP(series, rindex++); } } else if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT); // (mode == 2) } skip_hidden: ; } // Finish up: if (mode == 1) { // Remove hole (updates tail): if (windex < index) Remove_Series(series, windex, index - windex); SET_INTEGER(D_OUT, index - windex); return R_OUT; } // If MAP... if (mode == 2) { UNSAVE_SERIES(out); if (err != 2) { // ...and not BREAK/RETURN: Set_Block(D_OUT, out); return R_OUT; } } return R_OUT; }
*/ void Resolve_Context(REBSER *target, REBSER *source, REBVAL *only_words, REBFLG all, REBFLG expand) /* ** Only_words can be a block of words or an index in the target ** (for new words). ** ***********************************************************************/ { REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here REBVAL *words; REBVAL *vals; REBINT n; REBINT m; REBCNT i = 0; CHECK_BIND_TABLE; if (IS_PROTECT_SERIES(target)) Trap0(RE_PROTECTED); if (IS_INTEGER(only_words)) { // Must be: 0 < i <= tail i = VAL_INT32(only_words); // never <= 0 if (i == 0) i = 1; if (i >= target->tail) return; } Collect_Start(BIND_NO_SELF); // DO NOT TRAP IN THIS SECTION n = 0; // If limited resolve, tag the word ids that need to be copied: if (i) { // Only the new words of the target: for (words = FRM_WORD(target, i); NOT_END(words); words++) binds[VAL_BIND_CANON(words)] = -1; n = SERIES_TAIL(target) - 1; } else if (IS_BLOCK(only_words)) { // Limit exports to only these words: for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) { if (IS_WORD(words) || IS_SET_WORD(words)) { binds[VAL_WORD_CANON(words)] = -1; n++; } } } // Expand target as needed: if (expand && n > 0) { // Determine how many new words to add: for (words = FRM_WORD(target, 1); NOT_END(words); words++) if (binds[VAL_BIND_CANON(words)]) n--; // Expand frame by the amount required: if (n > 0) Expand_Frame(target, n, 0); else expand = 0; } // Maps a word to its value index in the source context. // Done by marking all source words (in bind table): words = FRM_WORDS(source)+1; for (n = 1; NOT_END(words); n++, words++) { if (IS_NONE(only_words) || binds[VAL_BIND_CANON(words)]) binds[VAL_WORD_CANON(words)] = n; } // Foreach word in target, copy the correct value from source: n = i ? i : 1; vals = FRM_VALUE(target, n); for (words = FRM_WORD(target, n); NOT_END(words); words++, vals++) { if ((m = binds[VAL_BIND_CANON(words)])) { binds[VAL_BIND_CANON(words)] = 0; // mark it as set if (!VAL_PROTECTED(words) && (all || IS_UNSET(vals))) { if (m < 0) SET_UNSET(vals); // no value in source context else *vals = *FRM_VALUE(source, m); //Debug_Num("type:", VAL_TYPE(vals)); //Debug_Str(Get_Word_Name(words)); } } } // Add any new words and values: if (expand) { REBVAL *val; words = FRM_WORDS(source)+1; for (n = 1; NOT_END(words); n++, words++) { if (binds[VAL_BIND_CANON(words)]) { // Note: no protect check is needed here binds[VAL_BIND_CANON(words)] = 0; val = Append_Frame(target, 0, VAL_BIND_SYM(words)); *val = *FRM_VALUE(source, n); } } } else { // Reset bind table (do not use Collect_End): if (i) { for (words = FRM_WORD(target, i); NOT_END(words); words++) binds[VAL_BIND_CANON(words)] = 0; } else if (IS_BLOCK(only_words)) { for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) { if (IS_WORD(words) || IS_SET_WORD(words)) binds[VAL_WORD_CANON(words)] = 0; } } else { for (words = FRM_WORDS(source)+1; NOT_END(words); words++) binds[VAL_BIND_CANON(words)] = 0; } } CHECK_BIND_TABLE; RESET_TAIL(BUF_WORDS); // allow reuse, trapping ok now }
*/ static REB_R Loop_Each(struct Reb_Call *call_, LOOP_MODE mode) /* ** Common implementation code of FOR-EACH, REMOVE-EACH, MAP-EACH, ** and EVERY. ** ***********************************************************************/ { REBSER *body; REBVAL *vars; REBVAL *words; REBSER *frame; // `data` is the series/object/map/etc. being iterated over // Note: `data_is_object` flag is optimized out, but hints static analyzer REBVAL *data = D_ARG(2); REBSER *series; const REBOOL data_is_object = ANY_OBJECT(data); REBSER *out; // output block (needed for MAP-EACH) REBINT index; // !!!! should these be REBCNT? REBINT tail; REBINT windex; // write REBINT rindex; // read REBOOL break_with = FALSE; REBOOL every_true = TRUE; REBCNT i; REBCNT j; REBVAL *ds; if (IS_NONE(data)) return R_NONE; body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body Val_Init_Object(D_ARG(1), frame); // keep GC safe Val_Init_Block(D_ARG(3), body); // keep GC safe SET_NONE(D_OUT); // Default result to NONE if the loop does not run if (mode == LOOP_MAP_EACH) { // Must be managed *and* saved...because we are accumulating results // into it, and those results must be protected from GC // !!! This means we cannot Free_Series in case of a BREAK, we // have to leave it to the GC. Should there be a variant which // lets a series be a GC root for a temporary time even if it is // not SER_KEEP? out = Make_Array(VAL_LEN(data)); MANAGE_SERIES(out); SAVE_SERIES(out); } // Get series info: if (data_is_object) { series = VAL_OBJ_FRAME(data); out = FRM_WORD_SERIES(series); // words (the out local reused) index = 1; //if (frame->tail > 3) raise Error_Invalid_Arg(FRM_WORD(frame, 3)); } else if (IS_MAP(data)) { series = VAL_SERIES(data); index = 0; //if (frame->tail > 3) raise Error_Invalid_Arg(FRM_WORD(frame, 3)); } else { series = VAL_SERIES(data); index = VAL_INDEX(data); if (index >= cast(REBINT, SERIES_TAIL(series))) { if (mode == LOOP_REMOVE_EACH) { SET_INTEGER(D_OUT, 0); } else if (mode == LOOP_MAP_EACH) { UNSAVE_SERIES(out); Val_Init_Block(D_OUT, out); } return R_OUT; } } windex = index; // Iterate over each value in the data series block: while (index < (tail = SERIES_TAIL(series))) { rindex = index; // remember starting spot j = 0; // Set the FOREACH loop variables from the series: for (i = 1; i < frame->tail; i++) { vars = FRM_VALUE(frame, i); words = FRM_WORD(frame, i); // var spec is WORD if (IS_WORD(words)) { if (index < tail) { if (ANY_BLOCK(data)) { *vars = *BLK_SKIP(series, index); } else if (data_is_object) { if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) { // Alternate between word and value parts of object: if (j == 0) { Val_Init_Word(vars, REB_WORD, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index); if (NOT_END(vars+1)) index--; // reset index for the value part } else if (j == 1) *vars = *BLK_SKIP(series, index); else raise Error_Invalid_Arg(words); j++; } else { // Do not evaluate this iteration index++; goto skip_hidden; } } else if (IS_VECTOR(data)) { Set_Vector_Value(vars, series, index); } else if (IS_MAP(data)) { REBVAL *val = BLK_SKIP(series, index | 1); if (!IS_NONE(val)) { if (j == 0) { *vars = *BLK_SKIP(series, index & ~1); if (IS_END(vars+1)) index++; // only words } else if (j == 1) *vars = *BLK_SKIP(series, index); else raise Error_Invalid_Arg(words); j++; } else { index += 2; goto skip_hidden; } } else { // A string or binary if (IS_BINARY(data)) { SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index])); } else if (IS_IMAGE(data)) { Set_Tuple_Pixel(BIN_SKIP(series, index), vars); } else { VAL_SET(vars, REB_CHAR); VAL_CHAR(vars) = GET_ANY_CHAR(series, index); } } index++; } else SET_NONE(vars); } // var spec is SET_WORD: else if (IS_SET_WORD(words)) { if (ANY_OBJECT(data) || IS_MAP(data)) *vars = *data; else Val_Init_Block_Index(vars, series, index); //if (index < tail) index++; // do not increment block. } else raise Error_Invalid_Arg(words); } if (index == rindex) { // the word block has only set-words: for-each [a:] [1 2 3][] index++; } if (Do_Block_Throws(D_OUT, body, 0)) { if (IS_WORD(D_OUT) && VAL_WORD_SYM(D_OUT) == SYM_CONTINUE) { if (mode == LOOP_REMOVE_EACH) { // signal the post-body-execution processing that we // *do not* want to remove the element on a CONTINUE SET_FALSE(D_OUT); } else { // CONTINUE otherwise acts "as if" the loop body execution // returned an UNSET! SET_UNSET(D_OUT); } } else if (IS_WORD(D_OUT) && VAL_WORD_SYM(D_OUT) == SYM_BREAK) { // If it's a BREAK, get the /WITH value (UNSET! if no /WITH) // Though technically this doesn't really tell us if a // BREAK/WITH happened, as you can BREAK/WITH an UNSET! TAKE_THROWN_ARG(D_OUT, D_OUT); if (!IS_UNSET(D_OUT)) break_with = TRUE; index = rindex; break; } else { // Any other kind of throw, with a WORD! name or otherwise... index = rindex; break; } } switch (mode) { case LOOP_FOR_EACH: // no action needed after body is run break; case LOOP_REMOVE_EACH: // If FALSE return, copy values to the write location // !!! Should UNSET! also act as conditional false here? Error? if (IS_CONDITIONAL_FALSE(D_OUT)) { REBYTE wide = SERIES_WIDE(series); // memory areas may overlap, so use memmove and not memcpy! // !!! This seems a slow way to do it, but there's probably // not a lot that can be done as the series is expected to // be in a good state for the next iteration of the body. :-/ memmove( series->data + (windex * wide), series->data + (rindex * wide), (index - rindex) * wide ); windex += index - rindex; } break; case LOOP_MAP_EACH: // anything that's not an UNSET! will be added to the result if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT); break; case LOOP_EVERY: if (every_true) { // !!! This currently treats UNSET! as true, which ALL // effectively does right now. That's likely a bad idea. // When ALL changes, so should this. // every_true = IS_CONDITIONAL_TRUE(D_OUT); } break; default: assert(FALSE); } skip_hidden: ; } switch (mode) { case LOOP_FOR_EACH: // Nothing to do but return last result (will be UNSET! if an // ordinary BREAK was used, the /WITH if a BREAK/WITH was used, // and an UNSET! if the last loop iteration did a CONTINUE.) return R_OUT; case LOOP_REMOVE_EACH: // Remove hole (updates tail): if (windex < index) Remove_Series(series, windex, index - windex); SET_INTEGER(D_OUT, index - windex); return R_OUT; case LOOP_MAP_EACH: UNSAVE_SERIES(out); if (break_with) { // If BREAK is given a /WITH parameter that is not an UNSET!, it // is assumed that you want to override the accumulated mapped // data so far and return the /WITH value. (which will be in // D_OUT when the loop above is `break`-ed) // !!! Would be nice if we could Free_Series(out), but it is owned // by GC (we had to make it that way to use SAVE_SERIES on it) return R_OUT; } // If you BREAK/WITH an UNSET! (or just use a BREAK that has no // /WITH, which is indistinguishable in the thrown value) then it // returns the accumulated results so far up to the break. Val_Init_Block(D_OUT, out); return R_OUT; case LOOP_EVERY: // Result is the cumulative TRUE? state of all the input (with any // unsets taken out of the consideration). The last TRUE? input // if all valid and NONE! otherwise. (Like ALL.) If the loop // never runs, `every_true` will be TRUE *but* D_OUT will be NONE! if (!every_true) SET_NONE(D_OUT); return R_OUT; } DEAD_END; }