*/ static REBSER *String_List_To_Block(REBCHR *str) /* ** Convert a series of null terminated strings to ** a block of strings separated with '='. ** ***********************************************************************/ { REBCNT n; REBCNT len = 0; REBCHR *start = str; REBCHR *eq; REBSER *blk; while (n = LEN_STR(str)) { len++; str += n + 1; // next } blk = Make_Block(len*2); SAVE_SERIES(blk); str = start; while (NZ(eq = FIND_CHR(str+1, '=')) && NZ(n = LEN_STR(str))) { Set_Series(REB_STRING, Append_Value(blk), Copy_OS_Str(str, eq-str)); Set_Series(REB_STRING, Append_Value(blk), Copy_OS_Str(eq+1, n-(eq-str)-1)); str += n + 1; // next } Block_As_Map(blk); UNSAVE_SERIES(blk); return blk; }
xx*/ void Print_Dump_Value(REBVAL *value, REBYTE *label) /* ** Dump a value's contents for debugging purposes. ** ***********************************************************************/ { REBSER *series; series = Copy_Bytes(label, -1); SAVE_SERIES(series); series = Dump_Value(value, series); Debug_Str(STR_HEAD(series)); UNSAVE_SERIES(series); }
*/ RL_API int RL_Do_Binary(REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result) /* ** Evaluate an encoded binary script such as compressed text. ** ** Returns: ** The datatype of the result or zero if error in the encoding. ** Arguments: ** bin - by default, a REBOL compressed UTF-8 (or ASCII) script. ** length - the length of the data. ** flags - special flags (set to zero at this time). ** key - encoding, encryption, or signature key. ** result - value returned from evaluation. ** Notes: ** As of A104, only compressed scripts are supported, however, ** rebin, cloaked, signed, and encrypted formats will be supported. ** ***********************************************************************/ { REBSER spec = {0}; REBSER *text; REBVAL *val; #ifdef DUMP_INIT_SCRIPT int f; #endif //Cloak(TRUE, code, NAT_SPEC_SIZE, &key[0], 20, TRUE); spec.data = bin; spec.tail = length; text = Decompress(&spec, 0, -1, 10000000, 0); if (!text) return FALSE; Append_Byte(text, 0); #ifdef DUMP_INIT_SCRIPT f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE ); _write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text))); _close(f); #endif SAVE_SERIES(text); val = Do_String(text->data, flags); UNSAVE_SERIES(text); if (IS_ERROR(val)) // && (VAL_ERR_NUM(val) != RE_QUIT)) { Print_Value(val, 1000, FALSE); if (result) { *result = Value_To_RXI(val); return Reb_To_RXT[VAL_TYPE(val)]; } return 0; }
*/ static REBSER *File_List_To_Block(REBCHR *str) /* ** Convert file directory and file name list to block. ** ***********************************************************************/ { REBCNT n; REBCNT len = 0; REBCHR *start = str; REBSER *blk; REBSER *dir; while (n = LEN_STR(str)) { len++; str += n + 1; // next } blk = Make_Block(len); SAVE_SERIES(blk); // First is a dir path or full file path: str = start; n = LEN_STR(str); if (len == 1) { // First is full file path dir = To_REBOL_Path(str, n, -1, 0); Set_Series(REB_FILE, Append_Value(blk), dir); } else { // First is dir path for the rest of the files dir = To_REBOL_Path(str, n, -1, TRUE); str += n + 1; // next len = dir->tail; while (n = LEN_STR(str)) { dir->tail = len; Append_Uni_Uni(dir, str, n); Set_Series(REB_FILE, Append_Value(blk), Copy_String(dir, 0, -1)); str += n + 1; // next } } UNSAVE_SERIES(blk); return blk; }
*/ 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; }
*/ static REBCNT Do_Eval_Rule(REBPARSE *parse, REBCNT index, REBVAL **rule) /* ** Evaluate the input as a code block. Advance input if ** rule succeeds. Return new index or failure. ** ** Examples: ** do skip ** do end ** do "abc" ** do 'abc ** do [...] ** do variable ** do datatype! ** do quote 123 ** do into [...] ** ** Problem: cannot write: set var do datatype! ** ***********************************************************************/ { REBVAL value; REBVAL *item = *rule; REBCNT n; REBPARSE newparse; // First, check for end of input: if (index >= parse->series->tail) { if (IS_WORD(item) && VAL_CMD(item) == SYM_END) return index; else return NOT_FOUND; } // Evaluate next N input values: index = Do_Next(parse->series, index, FALSE); // Value is on top of stack (volatile!): value = *DS_POP; if (THROWN(&value)) Throw_Break(&value); // Get variable or command: if (IS_WORD(item)) { n = VAL_CMD(item); if (n == SYM_SKIP) return (IS_SET(&value)) ? index : NOT_FOUND; if (n == SYM_QUOTE) { item = item + 1; (*rule)++; if (IS_END(item)) Trap1(RE_PARSE_END, item-2); if (IS_PAREN(item)) { item = Do_Block_Value_Throw(item); // might GC } } else if (n == SYM_INTO) { item = item + 1; (*rule)++; if (IS_END(item)) Trap1(RE_PARSE_END, item-2); item = Get_Parse_Value(item); // sub-rules if (!IS_BLOCK(item)) Trap1(RE_PARSE_RULE, item-2); if (!ANY_BINSTR(&value) && !ANY_BLOCK(&value)) return NOT_FOUND; return (Parse_Series(&value, VAL_BLK_DATA(item), parse->flags, 0) == VAL_TAIL(&value)) ? index : NOT_FOUND; } else if (n > 0) Trap1(RE_PARSE_RULE, item); else item = Get_Parse_Value(item); // variable } else if (IS_PATH(item)) { item = Get_Parse_Value(item); // variable } else if (IS_SET_WORD(item) || IS_GET_WORD(item) || IS_SET_PATH(item) || IS_GET_PATH(item)) Trap1(RE_PARSE_RULE, item); if (IS_NONE(item)) { return (VAL_TYPE(&value) > REB_NONE) ? NOT_FOUND : index; } // Copy the value into its own block: newparse.series = Make_Block(1); SAVE_SERIES(newparse.series); Append_Val(newparse.series, &value); newparse.type = REB_BLOCK; newparse.flags = parse->flags; newparse.result = 0; n = (Parse_Next_Block(&newparse, 0, item, 0) != NOT_FOUND) ? index : NOT_FOUND; UNSAVE_SERIES(newparse.series); return n; }
*/ REBSER *Parse_String(REBSER *series, REBCNT index, REBVAL *rules, REBCNT flags) /* ***********************************************************************/ { REBCNT tail = series->tail; REBSER *blk; REBSER *set; REBCNT begin; REBCNT end; REBOOL skip_spaces = !(flags & PF_ALL); REBUNI uc; blk = BUF_EMIT; // shared series RESET_SERIES(blk); // String of delimiters or single character: if (IS_STRING(rules) || IS_CHAR(rules)) { begin = Find_Max_Bit(rules); if (begin <= ' ') begin = ' ' + 1; set = Make_Bitset(begin); Set_Bits(set, rules, TRUE); } // None, so use defaults ",;": else { set = Make_Bitset(1+MAX(',',';')); Set_Bit(set, ',', TRUE); Set_Bit(set, ';', TRUE); } SAVE_SERIES(set); // If required, make space delimiters too: if (skip_spaces) { for (uc = 1; uc <= ' '; uc++) Set_Bit(set, uc, TRUE); } while (index < tail) { if (--Eval_Count <= 0 || Eval_Signals) Do_Signals(); // Skip whitespace if not /all refinement: if (skip_spaces) { uc = 0; for (; index < tail; index++) { uc = GET_ANY_CHAR(series, index); if (!IS_WHITE(uc)) break; } } else uc = GET_ANY_CHAR(series, index); // prefetch if (index < tail) { // Handle quoted strings (in a simple way): if (uc == '"') { begin = ++index; // eat quote for (; index < tail; index++) { uc = GET_ANY_CHAR(series, index); if (uc == '"') break; } end = index; if (index < tail) index++; } // All other tokens: else { begin = index; for (; index < tail; index++) { if (Check_Bit(set, GET_ANY_CHAR(series, index), !(flags & PF_CASE))) break; } end = index; } // Skip trailing spaces: if (skip_spaces) for (; index < tail; index++) { uc = GET_ANY_CHAR(series, index); if (!IS_WHITE(uc)) break; } // Check for and remove separator: if (Check_Bit(set, GET_ANY_CHAR(series, index), !(flags & PF_CASE))) index++; // Append new string: Set_String(Append_Value(blk), Copy_String(series, begin, end - begin)); } } UNSAVE_SERIES(set); return Copy_Block(blk, 0); }
*/ 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; }