*/ void Set_Error_Type(ERROR_OBJ *error)
/*
** Sets error type and id fields based on code number.
**
***********************************************************************/
{
REBSER *cats; // Error catalog object
REBSER *cat; // Error category object
REBCNT n; // Word symbol number
REBCNT code;
code = VAL_INT32(&error->code);
// Set error category:
n = code / 100 + 1;
cats = VAL_OBJ_FRAME(Get_System(SYS_CATALOG, CAT_ERRORS));
if (code >= 0 && n < SERIES_TAIL(cats) &&
NZ(cat = VAL_SERIES(BLK_SKIP(cats, n)))
) {
Set_Word(&error->type, FRM_WORD_SYM(cats, n), cats, n);
// Find word related to the error itself:
n = code % 100 + 3;
if (n < SERIES_TAIL(cat))
Set_Word(&error->id, FRM_WORD_SYM(cat, n), cat, n);
}
}
*/ static REBINT Do_Cmd(REBDIA *dia)
/*
** Returns the length of command processed or error. See below.
**
***********************************************************************/
{
REBVAL *fargs;
REBINT size;
REBVAL *val;
REBINT err;
REBINT n;
// Get formal arguments block for this command:
fargs = FRM_VALUES(dia->dialect) + dia->cmd;
if (!IS_BLOCK(fargs)) return -REB_DIALECT_BAD_SPEC;
dia->fargs = VAL_SERIES(fargs);
fargs = VAL_BLK_DATA(fargs);
size = Count_Dia_Args(fargs); // approximate
// Preallocate output block (optimize for large blocks):
if (dia->len > size) size = dia->len;
if (GET_FLAG(dia->flags, RDIA_ALL)) {
Extend_Series(dia->out, size+1);
}
else {
Resize_Series(dia->out, size+1); // tail = 0
CLEAR_SERIES(dia->out); // Be sure it is entirely cleared
}
// Insert command word:
if (!GET_FLAG(dia->flags, RDIA_NO_CMD)) {
val = Append_Value(dia->out);
Set_Word(val, FRM_WORD_SYM(dia->dialect, dia->cmd), dia->dialect, dia->cmd);
if (GET_FLAG(dia->flags, RDIA_LIT_CMD)) VAL_SET(val, REB_LIT_WORD);
dia->outi++;
size++;
}
if (dia->cmd > 1) dia->argi++; // default cmd has no word arg
// Foreach argument provided:
for (n = dia->len; n > 0; n--, dia->argi++) {
val = Eval_Arg(dia);
if (!val)
return -REB_DIALECT_BAD_ARG;
if (IS_END(val)) break;
if (!IS_NONE(val)) {
//Print("n %d len %d argi %d", n, dia->len, dia->argi);
err = Add_Arg(dia, val); // 1: good, 0: no-type, -N: error
if (err == 0) return n; // remainder
if (err < 0) return err;
}
}
// If not enough args, pad with NONE values:
if (dia->cmd > 1) {
for (n = SERIES_TAIL(dia->out); n < size; n++) {
Append_Value(dia->out);
}
}
dia->outi = SERIES_TAIL(dia->out);
return 0;
}
*/ static int Loop_Each(REBVAL *ds, 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;
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_RET);
SET_NONE(DS_NEXT);
// If it's MAP, create result block:
if (mode == 2) {
out = Make_Block(VAL_LEN(value));
Set_Block(D_RET, 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(FRM_WORD(frame, 3));
}
else if (IS_MAP(value)) {
series = VAL_SERIES(value);
index = 0;
//if (frame->tail > 3) Trap_Arg(FRM_WORD(frame, 3));
}
else {
series = VAL_SERIES(value);
index = VAL_INDEX(value);
if (index >= (REBINT)SERIES_TAIL(series)) {
if (mode == 1) {
SET_INTEGER(D_RET, 0);
}
return R_RET;
}
}
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_OPT(BLK_SKIP(out, index), OPTS_HIDE)) {
// Alternate between word and value parts of object:
if (j == 0) {
Set_Word(vars, 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(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(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 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(words);
}
ds = Do_Blk(body, 0);
if (THROWN(ds)) {
if ((err = Check_Error(ds)) >= 0) break;
// else CONTINUE:
if (mode == 1) SET_FALSE(ds); // keep the value (for mode == 1)
} else {
err = 0; // prevent later test against uninitialized value
}
if (mode > 0) {
//if (ANY_OBJECT(value)) Trap_Types(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_FALSE(ds)) {
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(ds)) Append_Val(out, ds); // (mode == 2)
}
skip_hidden: ;
}
// Finish up:
if (mode == 1) {
// Remove hole (updates tail):
if (windex < index) Remove_Series(series, windex, index - windex);
SET_INTEGER(DS_RETURN, index - windex);
return R_RET;
}
// If MAP and not BREAK/RETURN:
if (mode == 2 && err != 2) return R_RET;
return R_TOS1;
}
