*/ static void Loop_Number(REBVAL *out, REBVAL *var, REBSER* body, REBVAL *start, REBVAL *end, REBVAL *incr)
/*
***********************************************************************/
{
REBDEC s;
REBDEC e;
REBDEC i;
if (IS_INTEGER(start)) s = cast(REBDEC, VAL_INT64(start));
else if (IS_DECIMAL(start) || IS_PERCENT(start)) s = VAL_DECIMAL(start);
else { Trap_Arg(start); DEAD_END_VOID; }
if (IS_INTEGER(end)) e = cast(REBDEC, VAL_INT64(end));
else if (IS_DECIMAL(end) || IS_PERCENT(end)) e = VAL_DECIMAL(end);
else { Trap_Arg(end); DEAD_END_VOID; }
if (IS_INTEGER(incr)) i = cast(REBDEC, VAL_INT64(incr));
else if (IS_DECIMAL(incr) || IS_PERCENT(incr)) i = VAL_DECIMAL(incr);
else { Trap_Arg(incr); DEAD_END_VOID; }
VAL_SET(var, REB_DECIMAL);
SET_NONE(out); // Default result to NONE if the loop does not run
for (; (i > 0.0) ? s <= e : s >= e; s += i) {
VAL_DECIMAL(var) = s;
if (!DO_BLOCK(out, body, 0) && Check_Error(out) >= 0) break;
if (!IS_DECIMAL(var)) Trap_Type(var);
s = VAL_DECIMAL(var);
}
}
*/ static void Loop_Number(REBVAL *var, REBSER* body, REBVAL *start, REBVAL *end, REBVAL *incr)
/*
***********************************************************************/
{
REBVAL *result;
REBDEC s;
REBDEC e;
REBDEC i;
if (IS_INTEGER(start)) s = (REBDEC)VAL_INT64(start);
else if (IS_DECIMAL(start) || IS_PERCENT(start)) s = VAL_DECIMAL(start);
else Trap_Arg(start);
if (IS_INTEGER(end)) e = (REBDEC)VAL_INT64(end);
else if (IS_DECIMAL(end) || IS_PERCENT(end)) e = VAL_DECIMAL(end);
else Trap_Arg(end);
if (IS_INTEGER(incr)) i = (REBDEC)VAL_INT64(incr);
else if (IS_DECIMAL(incr) || IS_PERCENT(incr)) i = VAL_DECIMAL(incr);
else Trap_Arg(incr);
VAL_SET(var, REB_DECIMAL);
for (; (i > 0.0) ? s <= e : s >= e; s += i) {
VAL_DECIMAL(var) = s;
result = Do_Blk(body, 0);
if (THROWN(result) && Check_Error(result) >= 0) break;
if (!IS_DECIMAL(var)) Trap_Type(var);
s = VAL_DECIMAL(var);
}
}
*/ REBINT Min_Max_Pair(REBVAL *ds, REBFLG maxed)
/*
***********************************************************************/
{
REBXYF aa;
REBXYF bb;
REBXYF *cc;
REBVAL *a = D_ARG(1);
REBVAL *b = D_ARG(2);
REBVAL *c = D_RET;
if (IS_PAIR(a)) aa = VAL_PAIR(a);
else if (IS_INTEGER(a)) aa.x = aa.y = (REBD32)VAL_INT64(a);
else Trap_Arg(a);
if (IS_PAIR(b)) bb = VAL_PAIR(b);
else if (IS_INTEGER(b)) bb.x = bb.y = (REBD32)VAL_INT64(b);
else Trap_Arg(b);
cc = &VAL_PAIR(c);
if (maxed) {
cc->x = MAX(aa.x, bb.x);
cc->y = MAX(aa.y, bb.y);
}
else {
cc->x = MIN(aa.x, bb.x);
cc->y = MIN(aa.y, bb.y);
}
SET_TYPE(c, REB_PAIR);
return R_RET;
}
*/ 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;
}
*/ REBINT Get_Num_Arg(REBVAL *val)
/*
** Get the amount to skip or pick.
** Allow multiple types. Throw error if not valid.
** Note that the result is one-based.
**
***********************************************************************/
{
REBINT n;
if (IS_INTEGER(val)) {
if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
Trap_Range(val);
n = VAL_INT32(val);
}
else if (IS_DECIMAL(val) || IS_PERCENT(val)) {
if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
Trap_Range(val);
n = (REBINT)VAL_DECIMAL(val);
}
else if (IS_LOGIC(val)) n = (VAL_LOGIC(val) ? 1 : 2);
else Trap_Arg(val);
return n;
}
*/ static void Sort_String(REBVAL *string, REBFLG ccase, REBVAL *skipv, REBVAL *compv, REBVAL *part, REBFLG all, REBFLG rev)
/*
***********************************************************************/
{
REBCNT len;
REBCNT skip = 1;
REBCNT size = 1;
int (*sfunc)(const void *v1, const void *v2);
// Determine length of sort:
len = Partial(string, 0, part, 0);
if (len <= 1) return;
// Skip factor:
if (!IS_NONE(skipv)) {
skip = Get_Num_Arg(skipv);
if (skip <= 0 || len % skip != 0 || skip > len)
Trap_Arg(skipv);
}
// Use fast quicksort library function:
if (skip > 1) len /= skip, size *= skip;
sfunc = rev ? Compare_Chr_Rev : Compare_Chr;
//!!uni - needs to compare wide chars too
qsort((void *)VAL_DATA(string), len, size * SERIES_WIDE(VAL_SERIES(string)), sfunc);
}
*/ REBDEC Dec64(REBVAL *val)
/*
***********************************************************************/
{
if (IS_DECIMAL(val) || IS_PERCENT(val)) return VAL_DECIMAL(val);
if (IS_INTEGER(val)) return (REBDEC)VAL_INT64(val);
if (IS_MONEY(val)) return deci_to_decimal(VAL_DECI(val));
Trap_Arg(val);
return 0;
}
*/ REBI64 Int64(REBVAL *val)
/*
***********************************************************************/
{
if (IS_INTEGER(val)) return VAL_INT64(val);
if (IS_DECIMAL(val) || IS_PERCENT(val)) return (REBI64)VAL_DECIMAL(val);
if (IS_MONEY(val)) return deci_to_int(VAL_DECI(val));
Trap_Arg(val);
return 0;
}
*/ REBFLG Get_Logic_Arg(REBVAL *arg)
/*
***********************************************************************/
{
if (IS_NONE(arg)) return 0;
if (IS_INTEGER(arg)) return (VAL_INT64(arg) != 0);
if (IS_LOGIC(arg)) return (VAL_LOGIC(arg) != 0);
if (IS_DECIMAL(arg) || IS_PERCENT(arg)) return (VAL_DECIMAL(arg) != 0.0);
Trap_Arg(arg);
DEAD_END;
}
*/ static REBOOL Is_Of_Type(REBVAL *value, REBVAL *types)
/*
** Types can be: word or block. Each element must be either
** a datatype or a typeset.
**
***********************************************************************/
{
REBVAL *val;
val = IS_WORD(types) ? Get_Var(types) : types;
if (IS_DATATYPE(val)) {
return (VAL_DATATYPE(val) == (REBINT)VAL_TYPE(value));
}
if (IS_TYPESET(val)) {
return (TYPE_CHECK(val, VAL_TYPE(value)));
}
if (IS_BLOCK(val)) {
for (types = VAL_BLK_DATA(val); NOT_END(types); types++) {
val = IS_WORD(types) ? Get_Var(types) : types;
if (IS_DATATYPE(val))
if (VAL_DATATYPE(val) == (REBINT)VAL_TYPE(value)) return TRUE;
else if (IS_TYPESET(val))
if (TYPE_CHECK(val, VAL_TYPE(value))) return TRUE;
else
Trap1(RE_INVALID_TYPE, Of_Type(val));
}
return FALSE;
}
Trap_Arg(types);
return 0; // for compiler
}
*/ static void Insert_Gobs(REBGOB *gob, REBVAL *arg, REBCNT index, REBCNT len, REBFLG change)
/*
** Insert one or more gobs into a pane at the given index.
** If index >= tail, an append occurs. Each gob has its parent
** gob field set. (Call Detach_Gobs() before inserting.)
**
***********************************************************************/
{
REBGOB **ptr;
REBCNT n, count;
REBVAL *val, *sarg;
REBINT i;
// Verify they are gobs:
sarg = arg;
for (n = count = 0; n < len; n++, val++) {
val = arg++;
if (IS_WORD(val)) val = Get_Var(val);
if (IS_GOB(val)) {
count++;
if (GOB_PARENT(VAL_GOB(val))) {
// Check if inserting into same parent:
i = -1;
if (GOB_PARENT(VAL_GOB(val)) == gob) {
i = Find_Gob(gob, VAL_GOB(val));
if (i > 0 && i == (REBINT)index-1) { // a no-op
SET_GOB_STATE(VAL_GOB(val), GOBS_NEW);
return;
}
}
Detach_Gob(VAL_GOB(val));
if (i >= 0 && (REBINT)index > i) index--;
}
} else {
Trap_Arg(val);
}
}
arg = sarg;
// Create or expand the pane series:
if (!GOB_PANE(gob)) {
GOB_PANE(gob) = Make_Series(count + 1, sizeof(REBGOB*), 0);
LABEL_SERIES(GOB_PANE(gob), "gob pane");
GOB_TAIL(gob) = count;
index = 0;
}
else {
if (change) {
if (index + count > GOB_TAIL(gob)) {
EXPAND_SERIES_TAIL(GOB_PANE(gob), index + count - GOB_TAIL(gob));
}
} else {
Expand_Series(GOB_PANE(gob), index, count);
if (index >= GOB_TAIL(gob)) index = GOB_TAIL(gob)-1;
}
}
ptr = GOB_SKIP(gob, index);
for (n = 0; n < len; n++) {
val = arg++;
if (IS_WORD(val)) val = Get_Var(val);
if (IS_GOB(val)) {
if GOB_PARENT(VAL_GOB(val)) Trap_Temp();
*ptr++ = VAL_GOB(val);
GOB_PARENT(VAL_GOB(val)) = gob;
SET_GOB_STATE(VAL_GOB(val), GOBS_NEW);
}
}
}
static void No_Nones(REBVAL *arg) {
arg = VAL_BLK_DATA(arg);
for (; NOT_END(arg); arg++) {
if (IS_NONE(arg)) Trap_Arg(arg);
}
}
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 int Event_Actor(REBVAL *ds, REBSER *port, REBCNT action)
/*
***********************************************************************/
{
REBVAL *spec;
REBVAL *state;
REBCNT result;
REBVAL *arg;
REBVAL save_port;
Validate_Port(port, action);
arg = D_ARG(2);
*D_RET = *D_ARG(1);
// Validate and fetch relevant PORT fields:
state = BLK_SKIP(port, STD_PORT_STATE);
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
// Get or setup internal state data:
if (!IS_BLOCK(state)) Set_Block(state, Make_Block(127));
switch (action) {
case A_UPDATE:
return R_NONE;
// Normal block actions done on events:
case A_POKE:
if (!IS_EVENT(D_ARG(3))) Trap_Arg(D_ARG(3));
goto act_blk;
case A_INSERT:
case A_APPEND:
//case A_PATH: // not allowed: port/foo is port object field access
//case A_PATH_SET: // not allowed: above
if (!IS_EVENT(arg)) Trap_Arg(arg);
case A_PICK:
act_blk:
save_port = *D_ARG(1); // save for return
*D_ARG(1) = *state;
result = T_Block(ds, action);
SET_FLAG(Eval_Signals, SIG_EVENT_PORT);
if (action == A_INSERT || action == A_APPEND || action == A_REMOVE) {
*D_RET = save_port;
break;
}
return result; // return condition
case A_CLEAR:
VAL_TAIL(state) = 0;
VAL_BLK_TERM(state);
CLR_FLAG(Eval_Signals, SIG_EVENT_PORT);
break;
case A_LENGTHQ:
SET_INTEGER(D_RET, VAL_TAIL(state));
break;
case A_OPEN:
if (!req) { //!!!
req = OS_MAKE_DEVREQ(RDI_EVENT);
SET_OPEN(req);
OS_DO_DEVICE(req, RDC_CONNECT); // stays queued
}
break;
default:
Trap_Action(REB_PORT, action);
}
return R_RET;
}
*/ void Trap_Reflect(REBCNT type, REBVAL *arg)
/*
***********************************************************************/
{
Trap_Arg(arg);
}
*/ void Make_Error_Object(REBVAL *arg, REBVAL *value)
/*
** Creates an error object from arg and puts it in value.
** The arg can be a string or an object body block.
** This function is called by MAKE ERROR!.
**
***********************************************************************/
{
REBSER *err; // Error object
ERROR_OBJ *error; // Error object values
REBINT code = 0;
// Create a new error object from another object, including any non-standard fields:
if (IS_ERROR(arg) || IS_OBJECT(arg)) {
err = Merge_Frames(VAL_OBJ_FRAME(ROOT_ERROBJ),
IS_ERROR(arg) ? VAL_OBJ_FRAME(arg) : VAL_ERR_OBJECT(arg));
error = ERR_VALUES(err);
// if (!IS_INTEGER(&error->code)) {
if (!Find_Error_Info(error, &code)) code = RE_INVALID_ERROR;
SET_INTEGER(&error->code, code);
// }
SET_ERROR(value, VAL_INT32(&error->code), err);
return;
}
// Make a copy of the error object template:
err = CLONE_OBJECT(VAL_OBJ_FRAME(ROOT_ERROBJ));
error = ERR_VALUES(err);
SET_NONE(&error->id);
SET_ERROR(value, 0, err);
// If block arg, evaluate object values (checking done later):
// If user set error code, use it to setup type and id fields.
if (IS_BLOCK(arg)) {
DISABLE_GC;
Do_Bind_Block(err, arg); // GC-OK (disabled)
ENABLE_GC;
if (IS_INTEGER(&error->code) && VAL_INT64(&error->code)) {
Set_Error_Type(error);
} else {
if (Find_Error_Info(error, &code)) {
SET_INTEGER(&error->code, code);
}
}
// The error code is not valid:
if (IS_NONE(&error->id)) {
SET_INTEGER(&error->code, RE_INVALID_ERROR);
Set_Error_Type(error);
}
if (VAL_INT64(&error->code) < 100 || VAL_INT64(&error->code) > 1000)
Trap_Arg(arg);
}
// If string arg, setup other fields
else if (IS_STRING(arg)) {
SET_INTEGER(&error->code, RE_USER); // user error
Set_String(&error->arg1, Copy_Series_Value(arg));
Set_Error_Type(error);
}
// No longer allowed:
// else if (IS_INTEGER(arg)) {
// error->code = *arg;
// Set_Error_Type(error);
// }
else
Trap_Arg(arg);
if (!(VAL_ERR_NUM(value) = VAL_INT32(&error->code))) {
Trap_Arg(arg);
}
}
*/ REBCNT Modify_String(REBCNT action, REBSER *dst_ser, REBCNT dst_idx, 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(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;
}
*/ static int Loop_All(REBVAL *ds, REBINT mode)
/*
** 0: forall
** 1: forskip
**
***********************************************************************/
{
REBVAL *var;
REBSER *body;
REBCNT bodi;
REBSER *dat;
REBINT idx;
REBINT inc = 1;
REBCNT type;
var = Get_Var(D_ARG(1));
if (IS_NONE(var)) return R_NONE;
// Save the starting var value:
*D_ARG(1) = *var;
SET_NONE(D_RET);
if (mode == 1) inc = Int32(D_ARG(2));
type = VAL_TYPE(var);
body = VAL_SERIES(D_ARG(mode+2));
bodi = VAL_INDEX(D_ARG(mode+2));
// Starting location when past end with negative skip:
if (inc < 0 && VAL_INDEX(var) >= (REBINT)VAL_TAIL(var)) {
VAL_INDEX(var) = (REBINT)VAL_TAIL(var) + inc;
}
// NOTE: This math only works for index in positive ranges!
if (ANY_SERIES(var)) {
while (TRUE) {
dat = VAL_SERIES(var);
idx = (REBINT)VAL_INDEX(var);
if (idx < 0) break;
if (idx >= (REBINT)SERIES_TAIL(dat)) {
if (inc >= 0) break;
idx = (REBINT)SERIES_TAIL(dat) + inc; // negative
if (idx < 0) break;
VAL_INDEX(var) = idx;
}
ds = Do_Blk(body, bodi); // (may move stack)
if (THROWN(ds)) { // Break, throw, continue, error.
if (Check_Error(ds) >= 0) {
*DS_RETURN = *DS_NEXT;
break;
}
}
*DS_RETURN = *ds;
if (VAL_TYPE(var) != type) Trap_Arg(var);
VAL_INDEX(var) += inc;
}
}
else Trap_Arg(var);
// !!!!! ???? allowed to write VAR????
*var = *DS_ARG(1);
return R_RET;
}
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;
}
*/ 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;
}
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];
}
}
}
}
*/ void Make_Block_Type(REBFLG make, REBVAL *value, REBVAL *arg)
/*
** Value can be:
** 1. a datatype (e.g. BLOCK!)
** 2. a value (e.g. [...])
**
** Arg can be:
** 1. integer (length of block)
** 2. block (copy it)
** 3. value (convert to a block)
**
***********************************************************************/
{
REBCNT type;
REBCNT len;
REBSER *ser;
// make block! ...
if (IS_DATATYPE(value))
type = VAL_DATATYPE(value);
else // make [...] ....
type = VAL_TYPE(value);
// make block! [1 2 3]
if (ANY_BLOCK(arg)) {
len = VAL_BLK_LEN(arg);
if (len > 0 && type >= REB_PATH && type <= REB_LIT_PATH)
No_Nones(arg);
ser = Copy_Values(VAL_BLK_DATA(arg), len);
goto done;
}
if (IS_STRING(arg)) {
REBCNT index, len = 0;
VAL_SERIES(arg) = Prep_Bin_Str(arg, &index, &len); // (keeps safe)
ser = Scan_Source(VAL_BIN(arg), VAL_LEN(arg));
goto done;
}
if (IS_BINARY(arg)) {
ser = Scan_Source(VAL_BIN_DATA(arg), VAL_LEN(arg));
goto done;
}
if (IS_MAP(arg)) {
ser = Map_To_Block(VAL_SERIES(arg), 0);
goto done;
}
if (ANY_OBJECT(arg)) {
ser = Make_Object_Block(VAL_OBJ_FRAME(arg), 3);
goto done;
}
if (IS_VECTOR(arg)) {
ser = Make_Vector_Block(arg);
goto done;
}
// if (make && IS_NONE(arg)) {
// ser = Make_Block(0);
// goto done;
// }
// to block! typset
if (!make && IS_TYPESET(arg) && type == REB_BLOCK) {
Set_Block(value, Typeset_To_Block(arg));
return;
}
if (make) {
// make block! 10
if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
len = Int32s(arg, 0);
Set_Series(type, value, Make_Block(len));
return;
}
Trap_Arg(arg);
}
ser = Copy_Values(arg, 1);
done:
Set_Series(type, value, ser);
return;
}
