*/ void Insert_String(REBSER *dst, REBCNT idx, const REBSER *src, REBCNT pos, REBCNT len, REBFLG no_expand)
/*
** Insert a non-encoded string into a series at given index.
** Source and/or destination can be 1 or 2 bytes wide.
** If destination is not wide enough, it will be widened.
**
***********************************************************************/
{
REBUNI *up;
REBYTE *bp;
REBCNT n;
if (idx > dst->tail) idx = dst->tail;
if (!no_expand) Expand_Series(dst, idx, len); // tail changed too
// Src and dst have same width (8 or 16):
if (SERIES_WIDE(dst) == SERIES_WIDE(src)) {
cp_same:
if (BYTE_SIZE(dst))
memcpy(BIN_SKIP(dst, idx), BIN_SKIP(src, pos), len);
else
memcpy(UNI_SKIP(dst, idx), UNI_SKIP(src, pos), sizeof(REBUNI) * len);
return;
}
// Src is 8 and dst is 16:
if (!BYTE_SIZE(dst)) {
bp = BIN_SKIP(src, pos);
up = UNI_SKIP(dst, idx);
for (n = 0; n < len; n++) up[n] = (REBUNI)bp[n];
return;
}
// Src is 16 and dst is 8:
bp = BIN_SKIP(dst, idx);
up = UNI_SKIP(src, pos);
for (n = 0; n < len; n++) {
if (up[n] > 0xFF) {
//Debug_Num("##Widen-series because char value is:", up[n]);
// Expand dst and restart:
idx += n;
pos += n;
len -= n;
Widen_String(dst, TRUE);
goto cp_same;
}
bp[n] = (REBYTE)up[n];
}
}
*/ void Display_Backtrace(REBCNT lines)
/*
***********************************************************************/
{
REBCNT tail;
REBCNT i;
if (Trace_Limit > 0) {
tail = Trace_Buffer->tail;
i = tail - 1;
for (lines++ ;lines > 0; lines--, i--) {
i = Find_Str_Char(Trace_Buffer, 0, i, tail, -1, LF, 0);
if (i == NOT_FOUND || i == 0) {
i = 0;
break;
}
}
if (lines == 0) i += 2; // start of next line
Prin_OS_String(BIN_SKIP(Trace_Buffer, i), tail-i, 0);
//RESET_SERIES(Trace_Buffer);
}
else {
Out_Str(cb_cast("backtrace not enabled"), 1);
}
}
*/ REBSER *Decompress(REBSER *input, REBCNT index, REBINT len, REBCNT limit, REBFLG use_crc)
/*
** Decompress a binary (only).
**
***********************************************************************/
{
REBCNT size;
REBSER *output;
REBINT err;
if (len < 0 || (index + len > BIN_LEN(input))) len = BIN_LEN(input) - index;
// Get the size from the end and make the output buffer that size.
if (len <= 4) Trap0(RE_PAST_END); // !!! better msg needed
size = Bytes_To_Long(BIN_SKIP(input, len) - 4);
if (limit && size > limit) Trap_Num(RE_SIZE_LIMIT, size);
output = Make_Binary(size + 20); // (Why 20 extra? -CS)
//DISABLE_GC;
err = Z_uncompress(BIN_HEAD(output), (uLongf*)&size, BIN_HEAD(input) + index, len, use_crc);
if (err) {
if (PG_Boot_Phase < 2) return 0;
if (err == Z_MEM_ERROR) Trap0(RE_NO_MEMORY);
SET_INTEGER(DS_RETURN, err);
Trap1(RE_BAD_PRESS, DS_RETURN); //!!!provide error string descriptions
}
SET_STR_END(output, size);
SERIES_TAIL(output) = size;
//ENABLE_GC;
return output;
}
*/ RL_API int RL_Get_String(REBSER *series, u32 index, void **str)
/*
** Obtain a pointer into a string (bytes or unicode).
**
** Returns:
** The length and type of string. When len > 0, string is unicode.
** When len < 0, string is bytes.
** Arguments:
** series - string series pointer
** index - index from beginning (zero-based)
** str - pointer to first character
** Notes:
** If the len is less than zero, then the string is optimized to
** codepoints (chars) 255 or less for ASCII and LATIN-1 charsets.
** Strings are allowed to move in memory. Therefore, you will want
** to make a copy of the string if needed.
**
***********************************************************************/
{ // ret: len or -len
int len = (index >= series->tail) ? 0 : series->tail - index;
if (BYTE_SIZE(series)) {
*str = BIN_SKIP(series, index);
len = -len;
}
else {
*str = UNI_SKIP(series, index);
}
return len;
}
*/ void Enline_Bytes(REBSER *ser, REBCNT idx, REBCNT len)
/*
***********************************************************************/
{
REBCNT cnt = 0;
REBYTE *bp;
REBYTE c = 0;
REBCNT tail;
// Calculate the size difference by counting the number of LF's
// that have no CR's in front of them.
bp = BIN_SKIP(ser, idx);
for (; len > 0; len--) {
if (*bp == LF && c != CR) cnt++;
c = *bp++;
}
if (cnt == 0) return;
// Extend series:
len = SERIES_TAIL(ser); // before expansion
EXPAND_SERIES_TAIL(ser, cnt);
tail = SERIES_TAIL(ser); // after expansion
bp = BIN_HEAD(ser); // expand may change it
// Add missing CRs:
while (cnt > 0) {
bp[tail--] = bp[len]; // Copy src to dst.
if (bp[len] == LF && (len == 0 || bp[len - 1] != CR)) {
bp[tail--] = CR;
cnt--;
}
len--;
}
}
*/ REBCNT Find_Byte_Str(REBSER *series, REBCNT index, REBYTE *b2, REBCNT l2, REBFLG uncase, REBFLG match)
/*
** Find a byte string within a byte string. Optimized for speed.
**
** Returns starting position or NOT_FOUND.
**
** Uncase: compare is case-insensitive.
** Match: compare to first position only.
**
** NOTE: Series tail must be > index.
**
***********************************************************************/
{
REBYTE *b1;
REBYTE *e1;
REBCNT l1;
REBYTE c;
REBCNT n;
// The pattern empty or is longer than the target:
if (l2 == 0 || (l2 + index) > SERIES_TAIL(series)) return NOT_FOUND;
b1 = BIN_SKIP(series, index);
l1 = SERIES_TAIL(series) - index;
e1 = b1 + (match ? 1 : l1 - (l2 - 1));
c = *b2; // first char
if (!uncase) {
while (b1 != e1) {
if (*b1 == c) { // matched first char
for (n = 1; n < l2; n++) {
if (b1[n] != b2[n]) break;
}
if (n == l2) return (b1 - BIN_HEAD(series));
}
b1++;
}
} else {
c = (REBYTE)LO_CASE(c); // OK! (never > 255)
while (b1 != e1) {
if (LO_CASE(*b1) == c) { // matched first char
for (n = 1; n < l2; n++) {
if (LO_CASE(b1[n]) != LO_CASE(b2[n])) break;
}
if (n == l2) return (b1 - BIN_HEAD(series));
}
b1++;
}
}
return NOT_FOUND;
}
*/ REBOOL Cloak(REBOOL decode, REBYTE *cp, REBCNT dlen, REBYTE *kp, REBCNT klen, REBFLG as_is)
/*
** Simple data scrambler. Quality depends on the key length.
** Result is made in place (data string).
**
** The key (kp) is passed as a REBVAL or REBYTE (when klen is !0).
**
***********************************************************************/
{
REBCNT i, n;
REBYTE src[20];
REBYTE dst[20];
if (dlen == 0) return TRUE;
// Decode KEY as VALUE field (binary, string, or integer)
if (klen == 0) {
REBVAL *val = (REBVAL*)kp;
REBSER *ser;
switch (VAL_TYPE(val)) {
case REB_BINARY:
kp = VAL_BIN_DATA(val);
klen = VAL_LEN(val);
break;
case REB_STRING:
ser = Temp_Bin_Str_Managed(val, &i, &klen);
kp = BIN_SKIP(ser, i);
break;
case REB_INTEGER:
INT_TO_STR(VAL_INT64(val), dst);
klen = LEN_BYTES(dst);
as_is = FALSE;
break;
}
if (klen == 0) return FALSE;
}
if (!as_is) {
for (i = 0; i < 20; i++) src[i] = kp[i % klen];
SHA1(src, 20, dst);
klen = 20;
kp = dst;
}
if (decode)
for (i = dlen-1; i > 0; i--) cp[i] ^= cp[i-1] ^ kp[i % klen];
// Change starting byte based all other bytes.
n = 0xa5;
for (i = 1; i < dlen; i++) n += cp[i];
cp[0] ^= (REBYTE)n;
if (!decode)
for (i = 1; i < dlen; i++) cp[i] ^= cp[i-1] ^ kp[i % klen];
return TRUE;
}
*/ REBINT PD_String(REBPVS *pvs)
/*
***********************************************************************/
{
REBVAL *data = pvs->value;
REBVAL *val = pvs->setval;
REBINT n = 0;
REBCNT i;
REBINT c;
REBSER *ser = VAL_SERIES(data);
if (IS_INTEGER(pvs->select)) {
n = Int32(pvs->select) + VAL_INDEX(data) - 1;
}
else return PE_BAD_SELECT;
if (val == 0) {
if (n < 0 || (REBCNT)n >= SERIES_TAIL(ser)) return PE_NONE;
if (IS_BINARY(data)) {
SET_INTEGER(pvs->store, *BIN_SKIP(ser, n));
} else {
SET_CHAR(pvs->store, GET_ANY_CHAR(ser, n));
}
return PE_USE;
}
if (n < 0 || (REBCNT)n >= SERIES_TAIL(ser)) return PE_BAD_RANGE;
if (IS_CHAR(val)) {
c = VAL_CHAR(val);
if (c > MAX_CHAR) return PE_BAD_SET;
}
else if (IS_INTEGER(val)) {
c = Int32(val);
if (c > MAX_CHAR || c < 0) return PE_BAD_SET;
if (IS_BINARY(data)) { // special case for binary
if (c > 0xff) Trap_Range(val);
BIN_HEAD(ser)[n] = (REBYTE)c;
return PE_OK;
}
}
else if (ANY_BINSTR(val)) {
i = VAL_INDEX(val);
if (i >= VAL_TAIL(val)) return PE_BAD_SET;
c = GET_ANY_CHAR(VAL_SERIES(val), i);
}
else
return PE_BAD_SELECT;
TRAP_PROTECT(ser);
if (BYTE_SIZE(ser) && c > 0xff) Widen_String(ser);
SET_ANY_CHAR(ser, n, c);
return PE_OK;
}
*/ void Trim_Tail(REBSER *src, REBYTE chr)
/*
** Used to trim off hanging spaces during FORM and MOLD.
**
***********************************************************************/
{
REBOOL is_uni = !BYTE_SIZE(src);
REBCNT tail;
REBUNI c;
assert(!Is_Array_Series(src));
for (tail = SERIES_TAIL(src); tail > 0; tail--) {
c = is_uni ? *UNI_SKIP(src, tail - 1) : *BIN_SKIP(src, tail - 1);
if (c != chr) break;
}
SERIES_TAIL(src) = tail;
TERM_SEQUENCE(src);
}
*/ int Encode_UTF8_Line(REBSER *dst, REBSER *src, REBCNT idx)
/*
** Encode a unicode source buffer into a binary line of UTF8.
** Include the LF terminator in the result.
** Return the length of the line buffer.
**
***********************************************************************/
{
REBUNI *up = UNI_HEAD(src);
REBCNT len = SERIES_TAIL(src);
REBCNT tail;
REBUNI c;
REBINT n;
REBYTE buf[8];
tail = RESET_TAIL(dst);
while (idx < len) {
if ((c = up[idx]) < 0x80) {
EXPAND_SERIES_TAIL(dst, 1);
BIN_HEAD(dst)[tail++] = (REBYTE)c;
}
else {
n = Encode_UTF8_Char(buf, c);
EXPAND_SERIES_TAIL(dst, n);
memcpy(BIN_SKIP(dst, tail), buf, n);
tail += n;
}
idx++;
if (c == LF) break;
}
BIN_HEAD(dst)[tail] = 0;
SERIES_TAIL(dst) = tail;
return idx;
}
*/ 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 To_Thru(REBPARSE *parse, REBCNT index, REBVAL *block, REBFLG is_thru)
/*
***********************************************************************/
{
REBSER *series = parse->series;
REBCNT type = parse->type;
REBVAL *blk;
REBVAL *item;
REBCNT cmd;
REBCNT i;
REBCNT len;
for (; index <= series->tail; index++) {
for (blk = VAL_BLK(block); NOT_END(blk); blk++) {
item = blk;
// Deal with words and commands
if (IS_WORD(item)) {
if (cmd = VAL_CMD(item)) {
if (cmd == SYM_END) {
if (index >= series->tail) {
index = series->tail;
goto found;
}
goto next;
}
else if (cmd == SYM_QUOTE) {
item = ++blk; // next item is the quoted value
if (IS_END(item)) goto bad_target;
if (IS_PAREN(item)) {
item = Do_Block_Value_Throw(item); // might GC
}
}
else goto bad_target;
}
else {
item = Get_Var(item);
}
}
else if (IS_PATH(item)) {
item = Get_Parse_Value(item);
}
// Try to match it:
if (type >= REB_BLOCK) {
if (ANY_BLOCK(item)) goto bad_target;
i = Parse_Next_Block(parse, index, item, 0);
if (i != NOT_FOUND) {
if (!is_thru) i--;
index = i;
goto found;
}
}
else if (type == REB_BINARY) {
REBYTE ch1 = *BIN_SKIP(series, index);
// Handle special string types:
if (IS_CHAR(item)) {
if (VAL_CHAR(item) > 0xff) goto bad_target;
if (ch1 == VAL_CHAR(item)) goto found1;
}
else if (IS_BINARY(item)) {
if (ch1 == *VAL_BIN_DATA(item)) {
len = VAL_LEN(item);
if (len == 1) goto found1;
if (0 == Compare_Bytes(BIN_SKIP(series, index), VAL_BIN_DATA(item), len, 0)) {
if (is_thru) index += len;
goto found;
}
}
}
else if (IS_INTEGER(item)) {
if (VAL_INT64(item) > 0xff) goto bad_target;
if (ch1 == VAL_INT32(item)) goto found1;
}
else goto bad_target;
}
else { // String
REBCNT ch1 = GET_ANY_CHAR(series, index);
REBCNT ch2;
if (!HAS_CASE(parse)) ch1 = UP_CASE(ch1);
// Handle special string types:
if (IS_CHAR(item)) {
ch2 = VAL_CHAR(item);
if (!HAS_CASE(parse)) ch2 = UP_CASE(ch2);
if (ch1 == ch2) goto found1;
}
else if (ANY_STR(item)) {
ch2 = VAL_ANY_CHAR(item);
if (!HAS_CASE(parse)) ch2 = UP_CASE(ch2);
if (ch1 == ch2) {
len = VAL_LEN(item);
if (len == 1) goto found1;
i = Find_Str_Str(series, 0, index, SERIES_TAIL(series), 1, VAL_SERIES(item), VAL_INDEX(item), len, AM_FIND_MATCH | parse->flags);
if (i != NOT_FOUND) {
if (is_thru) i += len;
index = i;
goto found;
}
}
}
else if (IS_INTEGER(item)) {
ch1 = GET_ANY_CHAR(series, index); // No casing!
if (ch1 == (REBCNT)VAL_INT32(item)) goto found1;
}
else goto bad_target;
}
next: // Check for | (required if not end)
blk++;
if (IS_PAREN(blk)) blk++;
if (IS_END(blk)) break;
if (!IS_OR_BAR(blk)) {
item = blk;
goto bad_target;
}
}
}
return NOT_FOUND;
found:
if (IS_PAREN(blk+1)) Do_Block_Value_Throw(blk+1);
return index;
found1:
if (IS_PAREN(blk+1)) Do_Block_Value_Throw(blk+1);
return index + (is_thru ? 1 : 0);
bad_target:
Trap1(RE_PARSE_RULE, item);
return 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;
}
