*/ 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 REBSER *Init_Loop(REBVAL *spec, REBVAL *body_blk, REBSER **fram)
/*
** Initialize standard for loops (copy block, make frame, bind).
** Spec: WORD or [WORD ...]
**
***********************************************************************/
{
REBSER *frame;
REBINT len;
REBVAL *word;
REBVAL *vals;
REBSER *body;
// For :WORD format, get the var's value:
if (IS_GET_WORD(spec)) spec = Get_Var(spec);
// Hand-make a FRAME (done for for speed):
len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1;
if (len == 0) Trap_Arg(spec);
frame = Make_Frame(len);
SET_SELFLESS(frame);
SERIES_TAIL(frame) = len+1;
SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1;
// Setup for loop:
word = FRM_WORD(frame, 1); // skip SELF
vals = BLK_SKIP(frame, 1);
if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec);
// Optimally create the FOREACH frame:
while (len-- > 0) {
if (!IS_WORD(spec) && !IS_SET_WORD(spec)) {
// Prevent inconsistent GC state:
Free_Series(FRM_WORD_SERIES(frame));
Free_Series(frame);
Trap_Arg(spec);
}
VAL_SET(word, VAL_TYPE(spec));
VAL_BIND_SYM(word) = VAL_WORD_SYM(spec);
VAL_BIND_TYPESET(word) = ALL_64;
word++;
SET_NONE(vals);
vals++;
spec++;
}
SET_END(word);
SET_END(vals);
body = Clone_Block_Value(body_blk);
Bind_Block(frame, BLK_HEAD(body), BIND_DEEP);
*fram = frame;
return body;
}
//
// Collect_Set_Words: C
//
// Scan a block, collecting all of its SET words as a block.
//
REBARR *Collect_Set_Words(REBVAL *val)
{
REBCNT count = 0;
REBVAL *val2 = val;
REBARR *array;
for (; NOT_END(val); val++) if (IS_SET_WORD(val)) count++;
val = val2;
array = Make_Array(count);
val2 = ARR_HEAD(array);
for (; NOT_END(val); val++) {
if (IS_SET_WORD(val))
Val_Init_Word(val2++, REB_WORD, VAL_WORD_SYM(val));
}
SET_END(val2);
SET_ARRAY_LEN(array, count);
return array;
}
*/ static REBSER *Init_Loop(const REBVAL *spec, REBVAL *body_blk, REBSER **fram)
/*
** Initialize standard for loops (copy block, make frame, bind).
** Spec: WORD or [WORD ...]
**
***********************************************************************/
{
REBSER *frame;
REBINT len;
REBVAL *word;
REBVAL *vals;
REBSER *body;
// For :WORD format, get the var's value:
if (IS_GET_WORD(spec)) spec = GET_VAR(spec);
// Hand-make a FRAME (done for for speed):
len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1;
if (len == 0) raise Error_Invalid_Arg(spec);
frame = Make_Frame(len, FALSE);
SERIES_TAIL(frame) = len+1;
SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1;
// Setup for loop:
word = FRM_WORD(frame, 1); // skip SELF
vals = BLK_SKIP(frame, 1);
if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec);
// Optimally create the FOREACH frame:
while (len-- > 0) {
if (!IS_WORD(spec) && !IS_SET_WORD(spec)) {
// Prevent inconsistent GC state:
Free_Series(FRM_WORD_SERIES(frame));
Free_Series(frame);
raise Error_Invalid_Arg(spec);
}
Val_Init_Word_Typed(word, VAL_TYPE(spec), VAL_WORD_SYM(spec), ALL_64);
word++;
SET_NONE(vals);
vals++;
spec++;
}
SET_END(word);
SET_END(vals);
body = Copy_Array_At_Deep_Managed(
VAL_SERIES(body_blk), VAL_INDEX(body_blk)
);
Bind_Values_Deep(BLK_HEAD(body), frame);
*fram = frame;
return body;
}
*/ REBSER *Collect_Set_Words(REBVAL *val)
/*
** Scan a block, collecting all of its SET words as a block.
**
***********************************************************************/
{
REBCNT cnt = 0;
REBVAL *val2 = val;
REBSER *ser;
for (; NOT_END(val); val++) if (IS_SET_WORD(val)) cnt++;
val = val2;
ser = Make_Block(cnt);
val2 = BLK_HEAD(ser);
for (; NOT_END(val); val++) {
if (IS_SET_WORD(val)) Init_Word(val2++, VAL_WORD_SYM(val));
}
SET_END(val2);
SERIES_TAIL(ser) = cnt;
return ser;
}
*/ static void Bind_Block_Words(REBSER *frame, REBVAL *value, REBCNT mode)
/*
** Inner loop of bind block. Modes are:
**
** BIND_ONLY Only bind the words found in the frame.
** BIND_SET Add set-words to the frame during the bind.
** BIND_ALL Add words to the frame during the bind.
** BIND_DEEP Recurse into sub-blocks.
**
** NOTE: BIND_SET must be used carefully, because it does not
** bind prior instances of the word before the set-word. That is
** forward references are not allowed.
**
***********************************************************************/
{
REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
REBCNT n;
REBFLG selfish = !IS_SELFLESS(frame);
for (; NOT_END(value); value++) {
if (ANY_WORD(value)) {
//Print("Word: %s", Get_Sym_Name(VAL_WORD_CANON(value)));
// Is the word found in this frame?
if (NZ(n = binds[VAL_WORD_CANON(value)])) {
if (n == NO_RESULT) n = 0; // SELF word
ASSERT1(n < SERIES_TAIL(frame), RP_BIND_BOUNDS);
// Word is in frame, bind it:
VAL_WORD_INDEX(value) = n;
VAL_WORD_FRAME(value) = frame;
}
else if (selfish && VAL_WORD_CANON(value) == SYM_SELF) {
VAL_WORD_INDEX(value) = 0;
VAL_WORD_FRAME(value) = frame;
}
else {
// Word is not in frame. Add it if option is specified:
if ((mode & BIND_ALL) || ((mode & BIND_SET) && (IS_SET_WORD(value)))) {
Append_Frame(frame, value, 0);
binds[VAL_WORD_CANON(value)] = VAL_WORD_INDEX(value);
}
}
}
else if (ANY_BLOCK(value) && (mode & BIND_DEEP))
Bind_Block_Words(frame, VAL_BLK_DATA(value), mode);
else if ((IS_FUNCTION(value) || IS_CLOSURE(value)) && (mode & BIND_FUNC))
Bind_Block_Words(frame, BLK_HEAD(VAL_FUNC_BODY(value)), mode);
}
}
*/ void Collect_Words(REBVAL *block, REBFLG modes)
/*
** The inner recursive loop used for Collect_Words function below.
**
***********************************************************************/
{
REBINT *binds = WORDS_HEAD(Bind_Table);
REBVAL *word;
REBVAL *value;
for (; NOT_END(block); block++) {
value = block;
//if (modes & BIND_GET && IS_GET_WORD(block)) value = Get_Var(block);
if (ANY_WORD(value)) {
if (!binds[VAL_WORD_CANON(value)]) { // only once per word
if (IS_SET_WORD(value) || modes & BIND_ALL) {
binds[VAL_WORD_CANON(value)] = SERIES_TAIL(BUF_WORDS);
EXPAND_SERIES_TAIL(BUF_WORDS, 1);
word = BLK_LAST(BUF_WORDS);
VAL_SET(word, VAL_TYPE(value));
VAL_SET_OPT(word, OPTS_UNWORD);
VAL_BIND_SYM(word) = VAL_WORD_SYM(value);
// Allow all datatypes (to start):
VAL_BIND_TYPESET(word) = ~((TYPESET(REB_END) | TYPESET(REB_UNSET))); // not END or UNSET
}
} else {
// If word duplicated:
if (modes & BIND_NO_DUP) {
// Reset binding table (note BUF_WORDS may have expanded):
for (word = BLK_HEAD(BUF_WORDS); NOT_END(word); word++)
binds[VAL_WORD_CANON(word)] = 0;
RESET_TAIL(BUF_WORDS); // allow reuse
Trap1(RE_DUP_VARS, value);
}
}
continue;
}
// Recurse into sub-blocks:
if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP))
Collect_Words(VAL_BLK_DATA(value), modes);
// In this mode (foreach native), do not allow non-words:
//else if (modes & BIND_GET) Trap_Arg(value);
}
BLK_TERM(BUF_WORDS);
}
*/ static void Bind_Values_Inner_Loop(REBINT *binds, REBVAL value[], REBSER *frame, REBCNT mode)
/*
** Bind_Values_Core() sets up the binding table and then calls
** this recursive routine to do the actual binding.
**
***********************************************************************/
{
REBFLG selfish = !IS_SELFLESS(frame);
for (; NOT_END(value); value++) {
if (ANY_WORD(value)) {
//Print("Word: %s", Get_Sym_Name(VAL_WORD_CANON(value)));
// Is the word found in this frame?
REBCNT n = binds[VAL_WORD_CANON(value)];
if (n != 0) {
if (n == NO_RESULT) n = 0; // SELF word
assert(n < SERIES_TAIL(frame));
// Word is in frame, bind it:
VAL_WORD_INDEX(value) = n;
VAL_WORD_FRAME(value) = frame;
}
else if (selfish && VAL_WORD_CANON(value) == SYM_SELF) {
VAL_WORD_INDEX(value) = 0;
VAL_WORD_FRAME(value) = frame;
}
else {
// Word is not in frame. Add it if option is specified:
if ((mode & BIND_ALL) || ((mode & BIND_SET) && (IS_SET_WORD(value)))) {
Expand_Frame(frame, 1, 1);
Append_Frame(frame, value, 0);
binds[VAL_WORD_CANON(value)] = VAL_WORD_INDEX(value);
}
}
}
else if (ANY_BLOCK(value) && (mode & BIND_DEEP))
Bind_Values_Inner_Loop(
binds, VAL_BLK_DATA(value), frame, mode
);
else if ((IS_FUNCTION(value) || IS_CLOSURE(value)) && (mode & BIND_FUNC))
Bind_Values_Inner_Loop(
binds, BLK_HEAD(VAL_FUNC_BODY(value)), frame, mode
);
}
}
*/ static void Collect_Frame_Inner_Loop(REBINT *binds, REBVAL value[], REBCNT modes)
/*
** The inner recursive loop used for Collect_Frame function below.
**
***********************************************************************/
{
for (; NOT_END(value); value++) {
if (ANY_WORD(value)) {
if (!binds[VAL_WORD_CANON(value)]) { // only once per word
if (IS_SET_WORD(value) || modes & BIND_ALL) {
REBVAL *word;
binds[VAL_WORD_CANON(value)] = SERIES_TAIL(BUF_WORDS);
EXPAND_SERIES_TAIL(BUF_WORDS, 1);
word = BLK_LAST(BUF_WORDS);
Val_Init_Word_Typed(
word,
VAL_TYPE(value),
VAL_WORD_SYM(value),
// Allow all datatypes but END or UNSET (initially):
~((TYPESET(REB_END) | TYPESET(REB_UNSET)))
);
}
} else {
// If word duplicated:
if (modes & BIND_NO_DUP) {
// Reset binding table (note BUF_WORDS may have expanded):
REBVAL *word;
for (word = BLK_HEAD(BUF_WORDS); NOT_END(word); word++)
binds[VAL_WORD_CANON(word)] = 0;
RESET_TAIL(BUF_WORDS); // allow reuse
raise Error_1(RE_DUP_VARS, value);
}
}
continue;
}
// Recurse into sub-blocks:
if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP))
Collect_Frame_Inner_Loop(binds, VAL_BLK_DATA(value), modes);
// In this mode (foreach native), do not allow non-words:
//else if (modes & BIND_GET) raise Error_Invalid_Arg(value);
}
BLK_TERM(BUF_WORDS);
}
*/ static void Collect_Words_Inner_Loop(REBINT *binds, REBVAL value[], REBCNT modes)
/*
** Used for Collect_Words() after the binds table has
** been set up.
**
***********************************************************************/
{
for (; NOT_END(value); value++) {
if (ANY_WORD(value)
&& !binds[VAL_WORD_CANON(value)]
&& (modes & BIND_ALL || IS_SET_WORD(value))
) {
REBVAL *word;
binds[VAL_WORD_CANON(value)] = 1;
word = Alloc_Tail_Array(BUF_WORDS);
Val_Init_Word_Unbound(word, REB_WORD, VAL_WORD_SYM(value));
}
else if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP))
Collect_Words_Inner_Loop(binds, VAL_BLK_DATA(value), modes);
}
}
//
// Dump_Values: C
//
// Print values in raw hex; If memory is corrupted this still needs to work.
//
void Dump_Values(RELVAL *vp, REBCNT count)
{
REBYTE buf[2048];
REBYTE *cp;
REBCNT l, n;
REBCNT *bp = (REBCNT*)vp;
const REBYTE *type;
cp = buf;
for (l = 0; l < count; l++) {
REBVAL *val = cast(REBVAL*, bp);
cp = Form_Hex_Pad(cp, l, 8);
*cp++ = ':';
*cp++ = ' ';
type = Get_Type_Name((REBVAL*)bp);
for (n = 0; n < 11; n++) {
if (*type) *cp++ = *type++;
else *cp++ = ' ';
}
*cp++ = ' ';
for (n = 0; n < sizeof(REBVAL) / sizeof(REBCNT); n++) {
cp = Form_Hex_Pad(cp, *bp++, 8);
*cp++ = ' ';
}
n = 0;
if (IS_WORD(val) || IS_GET_WORD(val) || IS_SET_WORD(val)) {
const REBYTE *name = STR_HEAD(VAL_WORD_SPELLING(val));
n = snprintf(
s_cast(cp), sizeof(buf) - (cp - buf), " (%s)", cs_cast(name)
);
}
*(cp + n) = 0;
Debug_Str(s_cast(buf));
cp = buf;
}
}
*/ void Collect_Simple_Words(REBVAL *block, REBCNT modes)
/*
** Used for Collect_Block_Words().
**
***********************************************************************/
{
REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
REBVAL *val;
for (; NOT_END(block); block++) {
if (ANY_WORD(block)
&& !binds[VAL_WORD_CANON(block)]
&& (modes & BIND_ALL || IS_SET_WORD(block))
) {
binds[VAL_WORD_CANON(block)] = 1;
val = Append_Value(BUF_WORDS);
Init_Word(val, VAL_WORD_SYM(block));
}
else if (ANY_EVAL_BLOCK(block) && (modes & BIND_DEEP))
Collect_Simple_Words(VAL_BLK_DATA(block), modes);
}
}
*/ 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;
}
*/ 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 void Append_Obj(REBSER *obj, REBVAL *arg)
{
REBCNT i;
REBCNT len = 0;
REBVAL *val;
REBVAL *start = arg;
// Can be a word:
if (ANY_WORD(arg)) {
if (!Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE)) {
if (VAL_WORD_CANON(arg) == SYM_SELF) Trap0(RE_SELF_PROTECTED);
Expand_Frame(obj, 1, 1); // copy word table also
Append_Frame(obj, 0, VAL_WORD_SYM(arg));
// val is UNSET
}
return;
}
if (!IS_BLOCK(arg)) Trap_Arg(arg);
// Verify word/value argument block:
for (arg = VAL_BLK_DATA(arg); NOT_END(arg); arg += 2) {
if (!IS_WORD(arg) && !IS_SET_WORD(arg)) Trap_Arg(arg);
if (NZ(i = Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE))) {
// Just change the value, do not append it.
val = FRM_VALUE(obj, i);
if (GET_FLAGS(VAL_OPTS(FRM_WORD(obj, i)), OPTS_HIDE, OPTS_LOCK)) {
// Back out... reset any prior flags:
for (; arg != VAL_BLK_DATA(start); arg -= 2) VAL_CLR_OPT(arg, OPTS_TEMP);
if (VAL_PROTECTED(FRM_WORD(obj, i))) Trap1(RE_LOCKED_WORD, FRM_WORD(obj, i));
Trap0(RE_HIDDEN);
}
// Problem above: what about prior OPTS_FLAGS? Ok to leave them as is?
if (IS_END(arg+1)) SET_NONE(val);
else *val = arg[1];
VAL_SET_OPT(arg, OPTS_TEMP);
} else {
if (VAL_WORD_CANON(arg) == SYM_SELF) Trap0(RE_SELF_PROTECTED);
len++;
// was: Trap1(RE_DUP_VARS, arg);
}
if (IS_END(arg+1)) break; // fix bug#708
}
// Append new values to end of frame (if necessary):
if (len > 0) {
Expand_Frame(obj, len, 1); // copy word table also
for (arg = VAL_BLK_DATA(start); NOT_END(arg); arg += 2) {
if (VAL_GET_OPT(arg, OPTS_TEMP)) VAL_CLR_OPT(arg, OPTS_TEMP);
else {
val = Append_Frame(obj, 0, VAL_WORD_SYM(arg));
if (IS_END(arg+1)) {
SET_NONE(val);
break;
}
else *val = arg[1];
}
}
}
}
*/ 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;
}
*/ 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;
}
*/ REBFLG MT_Struct(REBVAL *out, REBVAL *data, enum Reb_Kind type)
/*
* Format:
* make struct! [
* field1 [type1]
* field2: [type2] field2-init-value
* field3: [struct [field1 [type1]]]
* field4: [type1[3]]
* ...
* ]
***********************************************************************/
{
//RL_Print("%s\n", __func__);
REBINT max_fields = 16;
VAL_STRUCT_FIELDS(out) = Make_Series(
max_fields, sizeof(struct Struct_Field), MKS_NONE
);
MANAGE_SERIES(VAL_STRUCT_FIELDS(out));
if (IS_BLOCK(data)) {
//if (Reduce_Block_No_Set_Throws(VAL_SERIES(data), 0, NULL))...
//data = DS_POP;
REBVAL *blk = VAL_BLK_DATA(data);
REBINT field_idx = 0; /* for field index */
u64 offset = 0; /* offset in data */
REBCNT eval_idx = 0; /* for spec block evaluation */
REBVAL *init = NULL; /* for result to save in data */
REBOOL expect_init = FALSE;
REBINT raw_size = -1;
REBUPT raw_addr = 0;
REBCNT alignment = 0;
VAL_STRUCT_SPEC(out) = Copy_Array_Shallow(VAL_SERIES(data));
VAL_STRUCT_DATA(out) = Make_Series(
1, sizeof(struct Struct_Data), MKS_NONE
);
EXPAND_SERIES_TAIL(VAL_STRUCT_DATA(out), 1);
VAL_STRUCT_DATA_BIN(out) = Make_Series(max_fields << 2, 1, MKS_NONE);
VAL_STRUCT_OFFSET(out) = 0;
// We tell the GC to manage this series, but it will not cause a
// synchronous garbage collect. Still, when's the right time?
ENSURE_SERIES_MANAGED(VAL_STRUCT_SPEC(out));
MANAGE_SERIES(VAL_STRUCT_DATA(out));
MANAGE_SERIES(VAL_STRUCT_DATA_BIN(out));
/* set type early such that GC will handle it correctly, i.e, not collect series in the struct */
SET_TYPE(out, REB_STRUCT);
if (IS_BLOCK(blk)) {
parse_attr(blk, &raw_size, &raw_addr);
++ blk;
}
while (NOT_END(blk)) {
REBVAL *inner;
struct Struct_Field *field = NULL;
u64 step = 0;
EXPAND_SERIES_TAIL(VAL_STRUCT_FIELDS(out), 1);
DS_PUSH_NONE;
inner = DS_TOP; /* save in stack so that it won't be GC'ed when MT_Struct is recursively called */
field = (struct Struct_Field *)SERIES_SKIP(VAL_STRUCT_FIELDS(out), field_idx);
field->offset = (REBCNT)offset;
if (IS_SET_WORD(blk)) {
field->sym = VAL_WORD_SYM(blk);
expect_init = TRUE;
if (raw_addr) {
/* initialization is not allowed for raw memory struct */
raise Error_Invalid_Arg(blk);
}
} else if (IS_WORD(blk)) {
field->sym = VAL_WORD_SYM(blk);
expect_init = FALSE;
}
else
raise Error_Has_Bad_Type(blk);
++ blk;
if (!IS_BLOCK(blk))
raise Error_Invalid_Arg(blk);
if (!parse_field_type(field, blk, inner, &init)) { return FALSE; }
++ blk;
STATIC_assert(sizeof(field->size) <= 4);
STATIC_assert(sizeof(field->dimension) <= 4);
step = (u64)field->size * (u64)field->dimension;
if (step > VAL_STRUCT_LIMIT)
raise Error_1(RE_SIZE_LIMIT, out);
EXPAND_SERIES_TAIL(VAL_STRUCT_DATA_BIN(out), step);
if (expect_init) {
REBVAL safe; // result of reduce or do (GC saved during eval)
init = &safe;
if (IS_BLOCK(blk)) {
if (Reduce_Block_Throws(init, VAL_SERIES(blk), 0, FALSE))
raise Error_No_Catch_For_Throw(init);
++ blk;
} else {
DO_NEXT_MAY_THROW(
eval_idx,
init,
VAL_SERIES(data),
blk - VAL_BLK_DATA(data)
);
if (eval_idx == THROWN_FLAG)
raise Error_No_Catch_For_Throw(init);
blk = VAL_BLK_SKIP(data, eval_idx);
}
if (field->array) {
if (IS_INTEGER(init)) { /* interpreted as a C pointer */
void *ptr = cast(void *, cast(REBUPT, VAL_INT64(init)));
/* assuming it's an valid pointer and holding enough space */
memcpy(SERIES_SKIP(VAL_STRUCT_DATA_BIN(out), (REBCNT)offset), ptr, field->size * field->dimension);
} else if (IS_BLOCK(init)) {
REBCNT n = 0;
if (VAL_LEN(init) != field->dimension)
raise Error_Invalid_Arg(init);
/* assign */
for (n = 0; n < field->dimension; n ++) {
if (!assign_scalar(&VAL_STRUCT(out), field, n, VAL_BLK_SKIP(init, n))) {
//RL_Print("Failed to assign element value\n");
goto failed;
}
}
}
else
raise Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(blk));
} else {
/* scalar */
if (!assign_scalar(&VAL_STRUCT(out), field, 0, init)) {
//RL_Print("Failed to assign scalar value\n");
goto failed;
}
}
} else if (raw_addr == 0) {
/* parse struct attribute */
static void parse_attr (REBVAL *blk, REBINT *raw_size, REBUPT *raw_addr)
{
REBVAL *attr = VAL_BLK_DATA(blk);
*raw_size = -1;
*raw_addr = 0;
while (NOT_END(attr)) {
if (IS_SET_WORD(attr)) {
switch (VAL_WORD_CANON(attr)) {
case SYM_RAW_SIZE:
++ attr;
if (IS_INTEGER(attr)) {
if (*raw_size > 0) /* duplicate raw-size */
raise Error_Invalid_Arg(attr);
*raw_size = VAL_INT64(attr);
if (*raw_size <= 0)
raise Error_Invalid_Arg(attr);
}
else
raise Error_Invalid_Arg(attr);
break;
case SYM_RAW_MEMORY:
++ attr;
if (IS_INTEGER(attr)) {
if (*raw_addr != 0) /* duplicate raw-memory */
raise Error_Invalid_Arg(attr);
*raw_addr = VAL_UNT64(attr);
if (*raw_addr == 0)
raise Error_Invalid_Arg(attr);
}
else
raise Error_Invalid_Arg(attr);
break;
case SYM_EXTERN:
++ attr;
if (*raw_addr != 0) /* raw-memory is exclusive with extern */
raise Error_Invalid_Arg(attr);
if (!IS_BLOCK(attr)
|| VAL_LEN(attr) != 2) {
raise Error_Invalid_Arg(attr);
}
else {
REBVAL *lib;
REBVAL *sym;
CFUNC *addr;
lib = VAL_BLK_SKIP(attr, 0);
sym = VAL_BLK_SKIP(attr, 1);
if (!IS_LIBRARY(lib))
raise Error_Invalid_Arg(attr);
if (IS_CLOSED_LIB(VAL_LIB_HANDLE(lib)))
raise Error_0(RE_BAD_LIBRARY);
if (!ANY_BINSTR(sym))
raise Error_Invalid_Arg(sym);
addr = OS_FIND_FUNCTION(
LIB_FD(VAL_LIB_HANDLE(lib)), s_cast(VAL_DATA(sym))
);
if (!addr)
raise Error_1(RE_SYMBOL_NOT_FOUND, sym);
*raw_addr = cast(REBUPT, addr);
}
break;
/*
case SYM_ALIGNMENT:
++ attr;
if (IS_INTEGER(attr)) {
alignment = VAL_INT64(attr);
} else {
raise Error_Invalid_Arg(attr);
}
break;
*/
default:
raise Error_Invalid_Arg(attr);
}
}
else
raise Error_Invalid_Arg(attr);
++ attr;
}
}
static void Append_Obj(REBSER *obj, REBVAL *arg)
{
REBCNT i, len;
REBVAL *word, *val;
REBINT *binds; // for binding table
// Can be a word:
if (ANY_WORD(arg)) {
if (!Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE)) {
// bug fix, 'self is protected only in selfish frames
if ((VAL_WORD_CANON(arg) == SYM_SELF) && !IS_SELFLESS(obj))
Trap0(RE_SELF_PROTECTED);
Expand_Frame(obj, 1, 1); // copy word table also
Append_Frame(obj, 0, VAL_WORD_SYM(arg));
// val is UNSET
}
return;
}
if (!IS_BLOCK(arg)) Trap_Arg(arg);
// Process word/value argument block:
arg = VAL_BLK_DATA(arg);
// Use binding table
binds = WORDS_HEAD(Bind_Table);
// Handle selfless
Collect_Start(IS_SELFLESS(obj) ? BIND_NO_SELF | BIND_ALL : BIND_ALL);
// Setup binding table with obj words:
Collect_Object(obj);
// Examine word/value argument block
for (word = arg; NOT_END(word); word += 2) {
if (!IS_WORD(word) && !IS_SET_WORD(word)) {
// release binding table
BLK_TERM(BUF_WORDS);
Collect_End(obj);
Trap_Arg(word);
}
if (NZ(i = binds[VAL_WORD_CANON(word)])) {
// bug fix, 'self is protected only in selfish frames:
if ((VAL_WORD_CANON(word) == SYM_SELF) && !IS_SELFLESS(obj)) {
// release binding table
BLK_TERM(BUF_WORDS);
Collect_End(obj);
Trap0(RE_SELF_PROTECTED);
}
} else {
// collect the word
binds[VAL_WORD_CANON(word)] = SERIES_TAIL(BUF_WORDS);
EXPAND_SERIES_TAIL(BUF_WORDS, 1);
val = BLK_LAST(BUF_WORDS);
*val = *word;
}
if (IS_END(word + 1)) break; // fix bug#708
}
BLK_TERM(BUF_WORDS);
// Append new words to obj
len = SERIES_TAIL(obj);
Expand_Frame(obj, SERIES_TAIL(BUF_WORDS) - len, 1);
for (word = BLK_SKIP(BUF_WORDS, len); NOT_END(word); word++)
Append_Frame(obj, 0, VAL_WORD_SYM(word));
// Set new values to obj words
for (word = arg; NOT_END(word); word += 2) {
i = binds[VAL_WORD_CANON(word)];
val = FRM_VALUE(obj, i);
if (GET_FLAGS(VAL_OPTS(FRM_WORD(obj, i)), OPTS_HIDE, OPTS_LOCK)) {
// release binding table
Collect_End(obj);
if (VAL_PROTECTED(FRM_WORD(obj, i)))
Trap1(RE_LOCKED_WORD, FRM_WORD(obj, i));
Trap0(RE_HIDDEN);
}
if (IS_END(word + 1)) SET_NONE(val);
else *val = word[1];
if (IS_END(word + 1)) break; // fix bug#708
}
// release binding table
Collect_End(obj);
}
*/ 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;
}
