*/ static void Trim_Block(REBSER *ser, REBCNT index, REBCNT flags)
/*
** See Trim_String().
**
***********************************************************************/
{
REBVAL *blk = BLK_HEAD(ser);
REBCNT out = index;
REBCNT end = ser->tail;
if (flags & AM_TRIM_TAIL) {
for (; end >= (index+1); end--) {
if (VAL_TYPE(blk+end-1) > REB_NONE) break;
}
Remove_Series(ser, end, ser->tail - end);
if (!(flags & AM_TRIM_HEAD) || index >= end) return;
}
if (flags & AM_TRIM_HEAD) {
for (; index < end; index++) {
if (VAL_TYPE(blk+index) > REB_NONE) break;
}
Remove_Series(ser, out, index - out);
}
if (flags == 0) {
for (; index < end; index++) {
if (VAL_TYPE(blk+index) > REB_NONE) {
*BLK_SKIP(ser, out) = blk[index];
out++;
}
}
Remove_Series(ser, out, end - out);
}
}
*/ void Sieve_Ports(REBSER *ports)
/*
** Remove all ports not found in the WAKE list.
** ports could be NULL, in which case the WAKE list is cleared.
**
***********************************************************************/
{
REBVAL *port;
REBVAL *waked;
REBVAL *val;
REBCNT n;
port = Get_System(SYS_PORTS, PORTS_SYSTEM);
if (!IS_PORT(port)) return;
waked = VAL_OBJ_VALUE(port, STD_PORT_DATA);
if (!IS_BLOCK(waked)) return;
for (n = 0; ports && n < SERIES_TAIL(ports);) {
val = BLK_SKIP(ports, n);
if (IS_PORT(val)) {
assert(VAL_TAIL(waked) != 0);
if (VAL_TAIL(waked) == Find_Block_Simple(VAL_SERIES(waked), 0, val)) {//not found
Remove_Series(ports, n, 1);
continue;
}
}
n++;
}
//clear waked list
RESET_SERIES(VAL_SERIES(waked));
}
*/ void Debug_String(const void *p, REBCNT len, REBOOL uni, REBINT lines)
/*
***********************************************************************/
{
REBUNI uc;
const REBYTE *bp = uni ? NULL : cast(const REBYTE *, p);
const REBUNI *up = uni ? cast(const REBUNI *, p) : NULL;
if (Trace_Limit > 0) {
if (Trace_Buffer->tail >= Trace_Limit)
Remove_Series(Trace_Buffer, 0, 2000);
if (len == UNKNOWN) len = uni ? Strlen_Uni(up) : LEN_BYTES(bp);
// !!! account for unicode!
for (; len > 0; len--) {
uc = uni ? *up++ : *bp++;
Append_Byte(Trace_Buffer, uc);
}
//Append_Unencoded_Len(Trace_Buffer, bp, len);
for (; lines > 0; lines--) Append_Byte(Trace_Buffer, LF);
}
else {
Prin_OS_String(p, len, uni);
for (; lines > 0; lines--) Print_OS_Line();
}
}
*/ static void Remove_Gobs(REBGOB *gob, REBCNT index, REBCNT len)
/*
** Remove one or more gobs from a pane at the given index.
**
***********************************************************************/
{
REBGOB **ptr;
REBCNT n;
ptr = GOB_SKIP(gob, index);
for (n = 0; n < len; n++, ptr++) {
GOB_PARENT(*ptr) = 0;
}
Remove_Series(GOB_PANE(gob), index, len);
}
*/ static void Detach_Gob(REBGOB *gob)
/*
** Remove a gob value from its parent.
** Done normally in advance of inserting gobs into new parent.
**
***********************************************************************/
{
REBGOB *par;
REBINT i;
par = GOB_PARENT(gob);
if (par && GOB_PANE(par) && (i = Find_Gob(par, gob)) != NOT_FOUND) {
Remove_Series(GOB_PANE(par), i, 1);
}
GOB_PARENT(gob) = 0;
}
//
// Modify_Array: C
//
// Returns new dst_idx
//
REBCNT Modify_Array(
REBCNT action, // INSERT, APPEND, CHANGE
REBARR *dst_arr, // target
REBCNT dst_idx, // position
const REBVAL *src_val, // source
REBCNT flags, // AN_ONLY, AN_PART
REBINT dst_len, // length to remove
REBINT dups // dup count
) {
REBCNT tail = ARR_LEN(dst_arr);
REBINT ilen = 1; // length to be inserted
const RELVAL *src_rel;
REBCTX *specifier;
if (IS_VOID(src_val) || dups < 0) {
// If they are effectively asking for "no action" then all we have
// to do is return the natural index result for the operation.
// (APPEND will return 0, insert the tail of the insertion...so index)
return (action == SYM_APPEND) ? 0 : dst_idx;
}
if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail;
// Check /PART, compute LEN:
if (!GET_FLAG(flags, AN_ONLY) && ANY_ARRAY(src_val)) {
// Adjust length of insertion if changing /PART:
if (action != SYM_CHANGE && GET_FLAG(flags, AN_PART))
ilen = dst_len;
else
ilen = VAL_LEN_AT(src_val);
// Are we modifying ourselves? If so, copy src_val block first:
if (dst_arr == VAL_ARRAY(src_val)) {
REBARR *copy = Copy_Array_At_Shallow(
VAL_ARRAY(src_val), VAL_INDEX(src_val), VAL_SPECIFIER(src_val)
);
MANAGE_ARRAY(copy); // !!! Review: worth it to not manage and free?
src_rel = ARR_HEAD(copy);
specifier = SPECIFIED; // copy already specified it
}
else {
src_rel = VAL_ARRAY_AT(src_val); // skips by VAL_INDEX values
specifier = VAL_SPECIFIER(src_val);
}
}
else {
// use passed in RELVAL and specifier
src_rel = src_val;
specifier = SPECIFIED; // it's a REBVAL, not a RELVAL, so specified
}
REBINT size = dups * ilen; // total to insert
if (action != SYM_CHANGE) {
// Always expand dst_arr for INSERT and APPEND actions:
Expand_Series(ARR_SERIES(dst_arr), dst_idx, size);
}
else {
if (size > dst_len)
Expand_Series(ARR_SERIES(dst_arr), dst_idx, size-dst_len);
else if (size < dst_len && GET_FLAG(flags, AN_PART))
Remove_Series(ARR_SERIES(dst_arr), dst_idx, dst_len-size);
else if (size + dst_idx > tail) {
EXPAND_SERIES_TAIL(ARR_SERIES(dst_arr), size - (tail - dst_idx));
}
}
tail = (action == SYM_APPEND) ? 0 : size + dst_idx;
#if !defined(NDEBUG)
if (IS_ARRAY_MANAGED(dst_arr)) {
REBINT i;
for (i = 0; i < ilen; ++i)
ASSERT_VALUE_MANAGED(&src_rel[i]);
}
#endif
for (; dups > 0; dups--) {
REBINT index = 0;
for (; index < ilen; ++index, ++dst_idx) {
COPY_VALUE(
SINK(ARR_HEAD(dst_arr) + dst_idx),
src_rel + index,
specifier
);
}
}
TERM_ARRAY_LEN(dst_arr, ARR_LEN(dst_arr));
ASSERT_ARRAY(dst_arr);
return tail;
}
//
// Modify_String: C
//
// Returns new dst_idx.
//
REBCNT Modify_String(
REBCNT action, // INSERT, APPEND, CHANGE
REBSER *dst_ser, // target
REBCNT dst_idx, // position
const REBVAL *src_val, // source
REBFLGS flags, // AN_PART
REBINT dst_len, // length to remove
REBINT dups // dup count
) {
REBSER *src_ser = 0;
REBCNT src_idx = 0;
REBCNT src_len;
REBCNT tail = SER_LEN(dst_ser);
REBINT size; // total to insert
REBOOL needs_free;
REBINT limit;
// For INSERT/PART and APPEND/PART
if (action != SYM_CHANGE && GET_FLAG(flags, AN_PART))
limit = dst_len; // should be non-negative
else
limit = -1;
if (limit == 0 || dups < 0) return (action == SYM_APPEND) ? 0 : dst_idx;
if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail;
// If the src_val is not a string, then we need to create a string:
if (GET_FLAG(flags, AN_SERIES)) { // used to indicate a BINARY series
if (IS_INTEGER(src_val)) {
src_ser = Make_Series_Codepoint(Int8u(src_val));
needs_free = TRUE;
limit = -1;
}
else if (IS_BLOCK(src_val)) {
src_ser = Join_Binary(src_val, limit); // NOTE: it's the shared FORM buffer!
needs_free = FALSE;
limit = -1;
}
else if (IS_CHAR(src_val)) {
//
// "UTF-8 was originally specified to allow codepoints with up to
// 31 bits (or 6 bytes). But with RFC3629, this was reduced to 4
// bytes max. to be more compatible to UTF-16." So depending on
// which RFC you consider "the UTF-8", max size is either 4 or 6.
//
src_ser = Make_Binary(6);
SET_SERIES_LEN(
src_ser,
Encode_UTF8_Char(BIN_HEAD(src_ser), VAL_CHAR(src_val))
);
needs_free = TRUE;
limit = -1;
}
else if (ANY_STRING(src_val)) {
src_len = VAL_LEN_AT(src_val);
if (limit >= 0 && src_len > cast(REBCNT, limit))
src_len = limit;
src_ser = Make_UTF8_From_Any_String(src_val, src_len, 0);
needs_free = TRUE;
limit = -1;
}
else if (!IS_BINARY(src_val))
fail (Error_Invalid_Arg(src_val));
}
else if (IS_CHAR(src_val)) {
src_ser = Make_Series_Codepoint(VAL_CHAR(src_val));
needs_free = TRUE;
}
else if (IS_BLOCK(src_val)) {
src_ser = Form_Tight_Block(src_val);
needs_free = TRUE;
}
else if (!ANY_STRING(src_val) || IS_TAG(src_val)) {
src_ser = Copy_Form_Value(src_val, 0);
needs_free = TRUE;
}
// Use either new src or the one that was passed:
if (src_ser) {
src_len = SER_LEN(src_ser);
}
else {
src_ser = VAL_SERIES(src_val);
src_idx = VAL_INDEX(src_val);
src_len = VAL_LEN_AT(src_val);
needs_free = FALSE;
}
if (limit >= 0) src_len = limit;
// If Source == Destination we need to prevent possible conflicts.
// Clone the argument just to be safe.
// (Note: It may be possible to optimize special cases like append !!)
if (dst_ser == src_ser) {
assert(!needs_free);
src_ser = Copy_Sequence_At_Len(src_ser, src_idx, src_len);
needs_free = TRUE;
src_idx = 0;
}
// Total to insert:
size = dups * src_len;
if (action != SYM_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));
}
}
// For dup count:
for (; dups > 0; dups--) {
Insert_String(dst_ser, dst_idx, src_ser, src_idx, src_len, TRUE);
dst_idx += src_len;
}
TERM_SEQUENCE(dst_ser);
if (needs_free) {
// If we did not use the series that was passed in, but rather
// created an internal temporary one, we need to free it.
Free_Series(src_ser);
}
return (action == SYM_APPEND) ? 0 : dst_idx;
}
//
// Series_Common_Action_Returns: C
//
// This routine is called to handle actions on ANY-SERIES! that can be taken
// care of without knowing what specific kind of series it is. So generally
// index manipulation, and things like LENGTH/etc.
//
// The strange name is to convey the result in an if statement, in the same
// spirit as the `if (XXX_Throws(...)) { /* handle throw */ }` pattern.
//
REBOOL Series_Common_Action_Returns(
REB_R *r, // `r_out` would be slightly confusing, considering R_OUT
REBFRM *frame_,
REBSYM action
) {
REBVAL *value = D_ARG(1);
REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
REBINT index = cast(REBINT, VAL_INDEX(value));
REBINT tail = cast(REBINT, VAL_LEN_HEAD(value));
REBINT len = 0;
switch (action) {
//-- Navigation:
case SYM_HEAD:
VAL_INDEX(value) = 0;
break;
case SYM_TAIL:
VAL_INDEX(value) = (REBCNT)tail;
break;
case SYM_HEAD_Q:
*r = (index == 0) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_TAIL_Q:
*r = (index >= tail) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_PAST_Q:
*r = (index > tail) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_NEXT:
if (index < tail) VAL_INDEX(value)++;
break;
case SYM_BACK:
if (index > 0) VAL_INDEX(value)--;
break;
case SYM_SKIP:
case SYM_AT:
len = Get_Num_From_Arg(arg);
{
REBI64 i = (REBI64)index + (REBI64)len;
if (action == SYM_SKIP) {
if (IS_LOGIC(arg)) i--;
} else { // A_AT
if (len > 0) i--;
}
if (i > (REBI64)tail) i = (REBI64)tail;
else if (i < 0) i = 0;
VAL_INDEX(value) = (REBCNT)i;
}
break;
case SYM_INDEX_OF:
SET_INTEGER(D_OUT, cast(REBI64, index) + 1);
*r = R_OUT;
return TRUE; // handled
case SYM_LENGTH:
SET_INTEGER(D_OUT, tail > index ? tail - index : 0);
*r = R_OUT;
return TRUE; // handled
case SYM_REMOVE:
// /PART length
FAIL_IF_LOCKED_SERIES(VAL_SERIES(value));
len = D_REF(2) ? Partial(value, 0, D_ARG(3)) : 1;
index = cast(REBINT, VAL_INDEX(value));
if (index < tail && len != 0)
Remove_Series(VAL_SERIES(value), VAL_INDEX(value), len);
break;
case SYM_ADD: // Join_Strings(value, arg);
case SYM_SUBTRACT: // "test this" - 10
case SYM_MULTIPLY: // "t" * 4 = "tttt"
case SYM_DIVIDE:
case SYM_REMAINDER:
case SYM_POWER:
case SYM_ODD_Q:
case SYM_EVEN_Q:
case SYM_ABSOLUTE:
fail (Error_Illegal_Action(VAL_TYPE(value), action));
default:
return FALSE; // not a common operation, not handled
}
*D_OUT = *value;
*r = R_OUT;
return TRUE; // handled
}
*/ 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 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;
}
*/ REBCNT Modify_Block(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 (dups < 0) 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_BLOCK(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_Block(
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;
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;
}
BLK_TERM(dst_ser);
return tail;
}
*/ REBCNT Modify_String(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_PART
** dst_len: length to remove
** dups: dup count
**
** return: new dst_idx
**
***********************************************************************/
{
REBSER *src_ser = 0;
REBCNT src_idx = 0;
REBCNT src_len;
REBCNT tail = SERIES_TAIL(dst_ser);
REBINT size; // total to insert
if (dups < 0) return (action == A_APPEND) ? 0 : dst_idx;
if (action == A_APPEND || dst_idx > tail) dst_idx = tail;
// If the src_val is not a string, then we need to create a string:
if (GET_FLAG(flags, AN_SERIES)) { // used to indicate a BINARY series
if (IS_INTEGER(src_val)) {
src_ser = Append_Byte(0, Int8u(src_val)); // creates a binary
}
else if (IS_BLOCK(src_val)) {
src_ser = Join_Binary(src_val); // NOTE: it's the shared FORM buffer!
}
else if (IS_CHAR(src_val)) {
src_ser = Make_Binary(6); // (I hate unicode)
src_ser->tail = Encode_UTF8_Char(BIN_HEAD(src_ser), VAL_CHAR(src_val));
}
else if (!ANY_BINSTR(src_val)) Trap_Arg_DEAD_END(src_val);
}
else if (IS_CHAR(src_val)) {
src_ser = Append_Byte(0, VAL_CHAR(src_val)); // unicode ok too
}
else if (IS_BLOCK(src_val)) {
src_ser = Form_Tight_Block(src_val);
}
else if (!ANY_STR(src_val) || IS_TAG(src_val)) {
src_ser = Copy_Form_Value(src_val, 0);
}
// Use either new src or the one that was passed:
if (src_ser) {
src_len = SERIES_TAIL(src_ser);
}
else {
src_ser = VAL_SERIES(src_val);
src_idx = VAL_INDEX(src_val);
src_len = VAL_LEN(src_val);
}
// For INSERT or APPEND with /PART use the dst_len not src_len:
if (action != A_CHANGE && GET_FLAG(flags, AN_PART)) src_len = dst_len;
// If Source == Destination we need to prevent possible conflicts.
// Clone the argument just to be safe.
// (Note: It may be possible to optimize special cases like append !!)
if (dst_ser == src_ser) {
src_ser = Copy_Series_Part(src_ser, src_idx, src_len);
src_idx = 0;
}
// Total to insert:
size = dups * src_len;
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));
}
}
// For dup count:
for (; dups > 0; dups--) {
Insert_String(dst_ser, dst_idx, src_ser, src_idx, src_len, TRUE);
dst_idx += src_len;
}
TERM_SERIES(dst_ser);
return (action == A_APPEND) ? 0 : dst_idx;
}
*/ REBINT Do_Series_Action(REBCNT action, REBVAL *value, REBVAL *arg)
/*
** Common series functions.
**
***********************************************************************/
{
REBINT index;
REBINT tail;
REBINT len = 0;
// Common setup code for all actions:
if (action != A_MAKE && action != A_TO) {
index = (REBINT)VAL_INDEX(value);
tail = (REBINT)VAL_TAIL(value);
} else return -1;
switch (action) {
//-- Navigation:
case A_HEAD:
VAL_INDEX(value) = 0;
break;
case A_TAIL:
VAL_INDEX(value) = (REBCNT)tail;
break;
case A_HEADQ:
DECIDE(index == 0);
case A_TAILQ:
DECIDE(index >= tail);
case A_PASTQ:
DECIDE(index > tail);
case A_NEXT:
if (index < tail) VAL_INDEX(value)++;
break;
case A_BACK:
if (index > 0) VAL_INDEX(value)--;
break;
case A_SKIP:
case A_AT:
len = Get_Num_Arg(arg);
{
REBI64 i = (REBI64)index + (REBI64)len;
if (action == A_SKIP) {
if (IS_LOGIC(arg)) i--;
} else { // A_AT
if (len > 0) i--;
}
if (i > (REBI64)tail) i = (REBI64)tail;
else if (i < 0) i = 0;
VAL_INDEX(value) = (REBCNT)i;
}
break;
/*
case A_ATZ:
len = Get_Num_Arg(arg);
{
REBI64 idx = Add_Max(0, index, len, MAX_I32);
if (idx < 0) idx = 0;
VAL_INDEX(value) = (REBCNT)idx;
}
break;
*/
case A_INDEXQ:
SET_INTEGER(DS_RETURN, ((REBI64)index) + 1);
return R_RET;
case A_LENGTHQ:
SET_INTEGER(DS_RETURN, tail > index ? tail - index : 0);
return R_RET;
case A_REMOVE:
// /PART length
TRAP_PROTECT(VAL_SERIES(value));
len = DS_REF(2) ? Partial(value, 0, DS_ARG(3), 0) : 1;
index = (REBINT)VAL_INDEX(value);
if (index < tail && len != 0)
Remove_Series(VAL_SERIES(value), VAL_INDEX(value), len);
break;
case A_ADD: // Join_Strings(value, arg);
case A_SUBTRACT: // "test this" - 10
case A_MULTIPLY: // "t" * 4 = "tttt"
case A_DIVIDE:
case A_REMAINDER:
case A_POWER:
case A_ODDQ:
case A_EVENQ:
case A_ABSOLUTE:
Trap_Action(VAL_TYPE(value), action);
default:
return -1;
}
DS_RET_VALUE(value);
return R_RET;
is_false:
return R_FALSE;
is_true:
return R_TRUE;
}
*/ 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;
}
x*/ void Modify_StringX(REBCNT action, REBVAL *string, REBVAL *arg)
/*
** Actions: INSERT, APPEND, CHANGE
**
** string [string!] {Series at point to insert}
** value [any-type!] {The value to insert}
** /part {Limits to a given length or position.}
** length [number! series! pair!]
** /only {Inserts a series as a series.}
** /dup {Duplicates the insert a specified number of times.}
** count [number! pair!]
**
***********************************************************************/
{
REBSER *series = VAL_SERIES(string);
REBCNT index = VAL_INDEX(string);
REBCNT tail = VAL_TAIL(string);
REBINT rlen; // length to be removed
REBINT ilen = 1; // length to be inserted
REBINT cnt = 1; // DUP count
REBINT size;
REBVAL *val;
REBSER *arg_ser = 0; // argument series
// Length of target (may modify index): (arg can be anything)
rlen = Partial1((action == A_CHANGE) ? string : arg, DS_ARG(AN_LENGTH));
index = VAL_INDEX(string);
if (action == A_APPEND || index > tail) index = tail;
// If the arg is not a string, then we need to create a string:
if (IS_BINARY(string)) {
if (IS_INTEGER(arg)) {
if (VAL_INT64(arg) > 255 || VAL_INT64(arg) < 0)
Trap_Range(arg);
arg_ser = Make_Binary(1);
Append_Byte(arg_ser, VAL_CHAR(arg)); // check for size!!!
}
else if (!ANY_BINSTR(arg)) Trap_Arg(arg);
}
else if (IS_BLOCK(arg)) {
// MOVE!
REB_MOLD mo = {0};
arg_ser = mo.series = Make_Unicode(VAL_BLK_LEN(arg) * 10); // GC!?
for (val = VAL_BLK_DATA(arg); NOT_END(val); val++)
Mold_Value(&mo, val, 0);
}
else if (IS_CHAR(arg)) {
// Optimize this case !!!
arg_ser = Make_Unicode(1);
Append_Byte(arg_ser, VAL_CHAR(arg));
}
else if (!ANY_STR(arg) || IS_TAG(arg)) {
arg_ser = Copy_Form_Value(arg, 0);
}
if (arg_ser) Set_String(arg, arg_ser);
else arg_ser = VAL_SERIES(arg);
// Length of insertion:
ilen = (action != A_CHANGE && DS_REF(AN_PART)) ? rlen : VAL_LEN(arg);
// If Source == Destination we need to prevent possible conflicts.
// Clone the argument just to be safe.
// (Note: It may be possible to optimize special cases like append !!)
if (series == VAL_SERIES(arg)) {
arg_ser = Copy_Series_Part(arg_ser, VAL_INDEX(arg), ilen); // GC!?
}
// Get /DUP count:
if (DS_REF(AN_DUP)) {
cnt = Int32(DS_ARG(AN_COUNT));
if (cnt <= 0) return; // no changes
}
// Total to insert:
size = cnt * ilen;
if (action != A_CHANGE) {
// Always expand series for INSERT and APPEND actions:
Expand_Series(series, index, size);
} else {
if (size > rlen)
Expand_Series(series, index, size-rlen);
else if (size < rlen && DS_REF(AN_PART))
Remove_Series(series, index, rlen-size);
else if (size + index > tail) {
EXPAND_SERIES_TAIL(series, size - (tail - index));
}
}
// For dup count:
for (; cnt > 0; cnt--) {
Insert_String(series, index, arg_ser, VAL_INDEX(arg), ilen, TRUE);
index += ilen;
}
TERM_SERIES(series);
VAL_INDEX(string) = (action == A_APPEND) ? 0 : index;
}
*/ void Modify_Blockx(REBCNT action, REBVAL *block, REBVAL *arg)
/*
** Actions: INSERT, APPEND, CHANGE
**
** block [block!] {Series at point to insert}
** value [any-type!] {The value to insert}
** /part {Limits to a given length or position.}
** length [number! series! pair!]
** /only {Inserts a series as a series.}
** /dup {Duplicates the insert a specified number of times.}
** count [number! pair!]
**
** Add:
** Handle insert [] () case
** What does insert () [] do?
** /deep option for cloning subcontents?
**
***********************************************************************/
{
REBSER *series = VAL_SERIES(block);
REBCNT index = VAL_INDEX(block);
REBCNT tail = VAL_TAIL(block);
REBFLG only = DS_REF(AN_ONLY);
REBINT rlen; // length to be removed
REBINT ilen = 1; // length to be inserted
REBINT cnt = 1; // DUP count
REBINT size;
REBFLG is_blk = FALSE; // arg is a block not a value
// Length of target (may modify index): (arg can be anything)
rlen = Partial1((action == A_CHANGE) ? block : arg, DS_ARG(AN_LENGTH));
index = VAL_INDEX(block);
if (action == A_APPEND || index > tail) index = tail;
// Check /PART, compute LEN:
if (!only && ANY_BLOCK(arg)) {
is_blk = TRUE; // arg is a block
// Are we modifying ourselves? If so, copy arg block first:
if (series == VAL_SERIES(arg)) {
VAL_SERIES(arg) = Copy_Block(VAL_SERIES(arg), VAL_INDEX(arg));
VAL_INDEX(arg) = 0;
}
// Length of insertion:
ilen = (action != A_CHANGE && DS_REF(AN_PART)) ? rlen : VAL_LEN(arg);
}
// Get /DUP count:
if (DS_REF(AN_DUP)) {
cnt = Int32(DS_ARG(AN_COUNT));
if (cnt <= 0) return; // no changes
}
// Total to insert:
size = cnt * ilen;
if (action != A_CHANGE) {
// Always expand series for INSERT and APPEND actions:
Expand_Series(series, index, size);
} else {
if (size > rlen)
Expand_Series(series, index, size-rlen);
else if (size < rlen && DS_REF(AN_PART))
Remove_Series(series, index, rlen-size);
else if (size + index > tail) {
EXPAND_SERIES_TAIL(series, size - (tail - index));
}
}
if (is_blk) arg = VAL_BLK_DATA(arg);
// For dup count:
VAL_INDEX(block) = (action == A_APPEND) ? 0 : size + index;
index *= SERIES_WIDE(series); // loop invariant
ilen *= SERIES_WIDE(series); // loop invariant
for (; cnt > 0; cnt--) {
memcpy(series->data + index, (REBYTE *)arg, ilen);
index += ilen;
}
BLK_TERM(series);
}
*/ 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;
}
