*/ REBSER *Make_Frame(REBINT len)
/*
** Create a frame of a given size, allocating space for both
** words and values. Normally used for global frames.
**
** selfless means do not set SELF word
**
***********************************************************************/
{
REBSER *frame;
REBSER *words;
REBVAL *value;
//DISABLE_GC;
words = Make_Block(len + 1); // size + room for SELF
BARE_SERIES(words);
frame = Make_Block(len + 1);
//ENABLE_GC;
// Note: cannot use Append_Frame for first word.
value = Append_Value(frame);
SET_FRAME(value, 0, words);
value = Append_Value(words);
Init_Frame_Word(value, SYM_SELF); // may get unset by selfless frames
return frame;
}
*/ static REBSER *String_List_To_Block(REBCHR *str)
/*
** Convert a series of null terminated strings to
** a block of strings separated with '='.
**
***********************************************************************/
{
REBCNT n;
REBCNT len = 0;
REBCHR *start = str;
REBCHR *eq;
REBSER *blk;
while (n = LEN_STR(str)) {
len++;
str += n + 1; // next
}
blk = Make_Block(len*2);
SAVE_SERIES(blk);
str = start;
while (NZ(eq = FIND_CHR(str+1, '=')) && NZ(n = LEN_STR(str))) {
Set_Series(REB_STRING, Append_Value(blk), Copy_OS_Str(str, eq-str));
Set_Series(REB_STRING, Append_Value(blk), Copy_OS_Str(eq+1, n-(eq-str)-1));
str += n + 1; // next
}
Block_As_Map(blk);
UNSAVE_SERIES(blk);
return blk;
}
*/ REBSER *Gob_To_Block(REBGOB *gob)
/*
** Used by MOLD to create a block.
**
***********************************************************************/
{
REBSER *ser = Make_Block(10);
REBVAL *val;
REBINT words[6] = {SYM_OFFSET, SYM_SIZE, SYM_ALPHA, 0};
REBVAL *vals[6];
REBINT n = 0;
REBVAL *val1;
REBCNT sym;
for (n = 0; words[n]; n++) {
val = Append_Value(ser);
Init_Word(val, words[n]);
VAL_SET(val, REB_SET_WORD);
vals[n] = Append_Value(ser);
}
SET_PAIR(vals[0], GOB_X(gob), GOB_Y(gob));
SET_PAIR(vals[1], GOB_W(gob), GOB_H(gob));
SET_INTEGER(vals[2], GOB_ALPHA(gob));
if (!GOB_TYPE(gob)) return ser;
if (GOB_CONTENT(gob)) {
val1 = Append_Value(ser);
val = Append_Value(ser);
switch (GOB_TYPE(gob)) {
case GOBT_COLOR:
sym = SYM_COLOR;
break;
case GOBT_IMAGE:
sym = SYM_IMAGE;
break;
case GOBT_STRING:
case GOBT_TEXT:
sym = SYM_TEXT;
break;
case GOBT_DRAW:
sym = SYM_DRAW;
break;
case GOBT_EFFECT:
sym = SYM_EFFECT;
break;
}
Init_Word(val1, sym);
VAL_SET(val1, REB_SET_WORD);
Get_GOB_Var(gob, val1, val);
}
return ser;
}
*/ REBSER *List_Func_Types(REBVAL *func)
/*
** Return a block of function arg types.
** Note: skips 0th entry.
**
***********************************************************************/
{
REBSER *block;
REBSER *words = VAL_FUNC_WORDS(func);
REBCNT n;
REBVAL *value;
REBVAL *word;
block = Make_Block(SERIES_TAIL(words));
word = BLK_SKIP(words, 1);
for (n = 1; n < SERIES_TAIL(words); word++, n++) {
value = Append_Value(block);
VAL_SET(value, VAL_TYPE(word));
VAL_WORD_SYM(value) = VAL_BIND_SYM(word);
UNBIND(value);
}
return block;
}
*/ static void Return_Gob_Pair(REBVAL *ds, REBGOB *gob, REBD32 x, REBD32 y)
/*
***********************************************************************/
{
REBSER *blk;
REBVAL *val;
blk = Make_Block(2);
Set_Series(REB_BLOCK, ds, blk);
val = Append_Value(blk);
SET_GOB(val, gob);
val = Append_Value(blk);
VAL_SET(val, REB_PAIR);
VAL_PAIR_X(val) = x;
VAL_PAIR_Y(val) = y;
}
*/ REBSER *Merge_Frames(REBSER *parent1, REBSER *parent2)
/*
** Create a child frame from two parent frames. Merge common fields.
** Values from the second parent take precedence.
**
** Deep copy and rebind the child.
**
***********************************************************************/
{
REBSER *wrds;
REBSER *child;
REBVAL *words;
REBVAL *value;
REBCNT n;
REBINT *binds = WORDS_HEAD(Bind_Table);
// Merge parent1 and parent2 words.
// Keep the binding table.
Collect_Start(BIND_ALL);
// Setup binding table and BUF_WORDS with parent1 words:
if (parent1) Collect_Object(parent1);
// Add parent2 words to binding table and BUF_WORDS:
Collect_Words(BLK_SKIP(FRM_WORD_SERIES(parent2), 1), BIND_ALL);
// Allocate child (now that we know the correct size):
wrds = Copy_Series(BUF_WORDS);
child = Make_Block(SERIES_TAIL(wrds));
value = Append_Value(child);
VAL_SET(value, REB_FRAME);
VAL_FRM_WORDS(value) = wrds;
VAL_FRM_SPEC(value) = 0;
// Copy parent1 values:
COPY_VALUES(FRM_VALUES(parent1)+1, FRM_VALUES(child)+1, SERIES_TAIL(parent1)-1);
// Copy parent2 values:
words = FRM_WORDS(parent2)+1;
value = FRM_VALUES(parent2)+1;
for (; NOT_END(words); words++, value++) {
// no need to search when the binding table is available
n = binds[VAL_WORD_CANON(words)];
BLK_HEAD(child)[n] = *value;
}
// Terminate the child frame:
SERIES_TAIL(child) = SERIES_TAIL(wrds);
BLK_TERM(child);
// Deep copy the child
Copy_Deep_Values(child, 1, SERIES_TAIL(child), TS_CLONE);
// Rebind the child
Rebind_Block(parent1, child, BLK_SKIP(child, 1), REBIND_FUNC);
Rebind_Block(parent2, child, BLK_SKIP(child, 1), REBIND_FUNC | REBIND_TABLE);
// release the bind table
Collect_End(wrds);
return child;
}
*/ static REBFLG Get_Struct_Var(REBSTU *stu, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
struct Struct_Field *field = NULL;
REBCNT i = 0;
field = (struct Struct_Field *)SERIES_DATA(stu->fields);
for (i = 0; i < SERIES_TAIL(stu->fields); i ++, field ++) {
if (VAL_WORD_CANON(word) == VAL_SYM_CANON(BLK_SKIP(PG_Word_Table.series, field->sym))) {
if (field->array) {
REBSER *ser = Make_Array(field->dimension);
REBCNT n = 0;
for (n = 0; n < field->dimension; n ++) {
REBVAL elem;
get_scalar(stu, field, n, &elem);
Append_Value(ser, &elem);
}
Val_Init_Block(val, ser);
} else {
get_scalar(stu, field, 0, val);
}
return TRUE;
}
}
return FALSE;
}
*/ void Throw_Return_Value(REBVAL *value)
/*
** Throws a series value using error temp values.
**
***********************************************************************/
{
REBVAL *val;
REBVAL *err;
REBSER *blk = VAL_SERIES(TASK_ERR_TEMPS);
RESET_SERIES(blk);
val = Append_Value(blk);
*val = *value;
err = Append_Value(blk);
SET_THROW(err, RE_RETURN, val);
VAL_ERR_SYM(err) = SYM_RETURN; // indicates it is "virtual" (parse return)
Throw_Break(err);
}
*/ static REBSER *File_List_To_Block(REBCHR *str)
/*
** Convert file directory and file name list to block.
**
***********************************************************************/
{
REBCNT n;
REBCNT len = 0;
REBCHR *start = str;
REBSER *blk;
REBSER *dir;
while (n = LEN_STR(str)) {
len++;
str += n + 1; // next
}
blk = Make_Block(len);
SAVE_SERIES(blk);
// First is a dir path or full file path:
str = start;
n = LEN_STR(str);
if (len == 1) { // First is full file path
dir = To_REBOL_Path(str, n, -1, 0);
Set_Series(REB_FILE, Append_Value(blk), dir);
}
else { // First is dir path for the rest of the files
dir = To_REBOL_Path(str, n, -1, TRUE);
str += n + 1; // next
len = dir->tail;
while (n = LEN_STR(str)) {
dir->tail = len;
Append_Uni_Uni(dir, str, n);
Set_Series(REB_FILE, Append_Value(blk), Copy_String(dir, 0, -1));
str += n + 1; // next
}
}
UNSAVE_SERIES(blk);
return blk;
}
*/ REBSER *Parse_Lines(REBSER *src)
/*
** Convert a string buffer to a block of strings.
** Note that the string must already be converted
** to REBOL LF format (no CRs).
**
***********************************************************************/
{
REBSER *blk;
REBUNI c;
REBCNT i;
REBCNT s;
REBVAL *val;
REBOOL uni = !BYTE_SIZE(src);
REBYTE *bp = BIN_HEAD(src);
REBUNI *up = UNI_HEAD(src);
blk = BUF_EMIT;
RESET_SERIES(blk);
// Scan string, looking for LF and CR terminators:
for (i = s = 0; i < SERIES_TAIL(src); i++) {
c = uni ? up[i] : bp[i];
if (c == LF || c == CR) {
val = Append_Value(blk);
Set_String(val, Copy_String(src, s, i - s));
VAL_SET_LINE(val);
// Skip CRLF if found:
if (c == CR && LF == uni ? up[i] : bp[i]) i++;
s = i;
}
}
// Partial line (no linefeed):
if (s + 1 != i) {
val = Append_Value(blk);
Set_String(val, Copy_String(src, s, i - s));
VAL_SET_LINE(val);
}
return Copy_Block(blk, 0);
}
STOID Mold_Block_Series(REB_MOLD *mold, REBSER *series, REBCNT index, REBYTE *sep)
{
REBSER *out = mold->series;
REBOOL line_flag = FALSE; // newline was part of block
REBOOL had_lines = FALSE;
REBVAL *value = BLK_SKIP(series, index);
if (!sep) sep = "[]";
if (IS_END(value)) {
Append_Bytes(out, sep);
return;
}
// Recursion check: (variation of: Find_Same_Block(MOLD_LOOP, value))
for (value = BLK_HEAD(MOLD_LOOP); NOT_END(value); value++) {
if (VAL_SERIES(value) == series) {
Emit(mold, "C...C", sep[0], sep[1]);
return;
}
}
value = Append_Value(MOLD_LOOP);
Set_Block(value, series);
if (sep[1]) {
Append_Byte(out, sep[0]);
mold->indent++;
}
// else out->tail--; // why?????
value = BLK_SKIP(series, index);
while (NOT_END(value)) {
if (VAL_GET_LINE(value)) {
if (sep[1] || line_flag) New_Indented_Line(mold);
had_lines = TRUE;
}
line_flag = TRUE;
Mold_Value(mold, value, TRUE);
value++;
if (NOT_END(value))
Append_Byte(out, (sep[0] == '/') ? '/' : ' ');
}
if (sep[1]) {
mold->indent--;
if (VAL_GET_LINE(value) || had_lines) New_Indented_Line(mold);
Append_Byte(out, sep[1]);
}
Remove_Last(MOLD_LOOP);
}
//
// RL_Set_Value: C
//
// Set a value in a block.
//
// Returns:
// TRUE if index past end and value was appended to tail of block.
// Arguments:
// series - block series pointer
// index - index of the value in the block (zero based)
// val - new value for field
// type - datatype of value
//
RL_API REBOOL RL_Set_Value(REBARR *array, u32 index, RXIARG val, int type)
{
REBVAL value;
VAL_INIT_WRITABLE_DEBUG(&value);
RXI_To_Value(&value, &val, type);
if (index >= ARR_LEN(array)) {
Append_Value(array, &value);
return TRUE;
}
*ARR_AT(array, index) = value;
return FALSE;
}
x*/ void RXI_To_Block(RXIFRM *frm, REBVAL *out) {
/*
***********************************************************************/
REBCNT n;
REBSER *blk;
REBVAL *val;
REBCNT len;
blk = Make_Block(len = RXA_COUNT(frm));
for (n = 1; n <= len; n++) {
val = Append_Value(blk);
RXI_To_Value(val, frm->args[n], RXA_TYPE(frm, n));
}
Set_Block(out, blk);
}
*/ RL_API void *RL_Extend(REBYTE *source, RXICAL call)
/*
** Appends embedded extension to system/catalog/boot-exts.
**
** Returns:
** A pointer to the REBOL library (see reb-lib.h).
** Arguments:
** source - A pointer to a UTF-8 (or ASCII) string that provides
** extension module header, function definitions, and other
** related functions and data.
** call - A pointer to the extension's command dispatcher.
** Notes:
** This function simply adds the embedded extension to the
** boot-exts list. All other processing and initialization
** happens later during startup. Each embedded extension is
** queried and init using LOAD-EXTENSION system native.
** See c:extensions-embedded
**
***********************************************************************/
{
REBVAL *value;
REBSER *ser;
value = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_EXTS);
if (IS_BLOCK(value)) ser = VAL_SERIES(value);
else {
ser = Make_Block(2);
Set_Block(value, ser);
}
value = Append_Value(ser);
Set_Binary(value, Copy_Bytes(source, -1)); // UTF-8
value = Append_Value(ser);
SET_HANDLE(value, call);
return Extension_Lib();
}
static void Mold_Object(const REBVAL *value, REB_MOLD *mold)
{
REBSER *wser;
REBVAL *words;
REBVAL *vals; // first value is context
REBCNT n;
assert(VAL_OBJ_FRAME(value));
wser = VAL_OBJ_WORDS(value);
// if (wser < 1000)
// Dump_Block_Raw(VAL_OBJ_FRAME(value), 0, 1);
words = BLK_HEAD(wser);
vals = VAL_OBJ_VALUES(value); // first value is context
Pre_Mold(value, mold);
Append_Byte(mold->series, '[');
// Prevent infinite looping:
if (Find_Same_Block(MOLD_LOOP, value) > 0) {
Append_Unencoded(mold->series, "...]");
return;
}
Append_Value(MOLD_LOOP, value);
mold->indent++;
for (n = 1; n < SERIES_TAIL(wser); n++) {
if (
!VAL_GET_OPT(words+n, OPTS_HIDE) &&
((VAL_TYPE(vals+n) > REB_NONE) || !GET_MOPT(mold, MOPT_NO_NONE))
){
New_Indented_Line(mold);
Append_UTF8(mold->series, Get_Sym_Name(VAL_WORD_SYM(words+n)), -1);
//Print("Slot: %s", Get_Sym_Name(VAL_WORD_SYM(words+n)));
Append_Unencoded(mold->series, ": ");
if (IS_WORD(vals+n) && !GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Byte(mold->series, '\'');
Mold_Value(mold, vals+n, TRUE);
}
}
mold->indent--;
New_Indented_Line(mold);
Append_Byte(mold->series, ']');
End_Mold(mold);
Remove_Last(MOLD_LOOP);
}
*/ static REBSER *Flags_To_Block(REBGOB *gob)
/*
***********************************************************************/
{
REBSER *ser;
REBVAL *val;
REBINT i;
ser = Make_Block(3);
for (i = 0; Gob_Flag_Words[i]; i += 2) {
if (GET_GOB_FLAG(gob, Gob_Flag_Words[i+1])) {
val = Append_Value(ser);
Init_Word(val, Gob_Flag_Words[i]);
}
}
return ser;
}
*/ REBSER *Make_Object_Block(REBSER *frame, REBINT mode)
/*
** Return a block containing words, values, or set-word: value
** pairs for the given object. Note: words are bound to original
** object.
**
** Modes:
** 1 for word
** 2 for value
** 3 for words and values
**
***********************************************************************/
{
REBVAL *words = FRM_WORDS(frame);
REBVAL *values = FRM_VALUES(frame);
REBSER *block;
REBVAL *value;
REBCNT n;
n = (mode & 4) ? 0 : 1;
block = Make_Block(SERIES_TAIL(frame) * (n + 1));
for (; n < SERIES_TAIL(frame); n++) {
if (!VAL_GET_OPT(words+n, OPTS_HIDE)) {
if (mode & 1) {
value = Append_Value(block);
if (mode & 2) {
VAL_SET(value, REB_SET_WORD);
VAL_SET_LINE(value);
}
else VAL_SET(value, REB_WORD); //VAL_TYPE(words+n));
VAL_WORD_SYM(value) = VAL_BIND_SYM(words+n);
VAL_WORD_INDEX(value) = n;
VAL_WORD_FRAME(value) = frame;
}
if (mode & 2) {
Append_Val(block, values+n);
}
}
}
return block;
}
*/ REBSER *Make_Backtrace(REBINT start)
/*
** Return a block of backtrace words.
**
***********************************************************************/
{
REBCNT depth = Stack_Depth();
REBSER *blk = Make_Block(depth-start);
REBINT dsf;
REBVAL *val;
for (dsf = DSF; dsf > 0; dsf = PRIOR_DSF(dsf)) {
if (start-- <= 0) {
val = Append_Value(blk);
Init_Word(val, VAL_WORD_SYM(DSF_WORD(dsf)));
}
}
return blk;
}
*/ REBSER *Merge_Frames(REBSER *parent, REBSER *child)
/*
** Create a frame from two frames. Merge common fields.
** Values from the second frame take precedence. No rebinding.
**
***********************************************************************/
{
REBSER *wrds;
REBSER *frame;
REBVAL *words;
REBVAL *value;
REBCNT n;
// Merge parent and child words. This trick works because the
// word list is itself a valid block.
wrds = Collect_Frame(BIND_ALL, parent, BLK_SKIP(FRM_WORD_SERIES(child),1));
// Allocate frame (now that we know the correct size):
frame = Make_Block(SERIES_TAIL(wrds)); // GC!!!
value = Append_Value(frame);
VAL_SET(value, REB_FRAME);
VAL_FRM_WORDS(value) = wrds;
VAL_FRM_SPEC(value) = 0;
// Copy parent values:
COPY_VALUES(FRM_VALUES(parent)+1, FRM_VALUES(frame)+1, SERIES_TAIL(parent)-1);
// Copy new words and values:
words = FRM_WORDS(child)+1;
value = FRM_VALUES(child)+1;
for (; NOT_END(words); words++, value++) {
n = Find_Word_Index(frame, VAL_BIND_SYM(words), FALSE);
if (n) BLK_HEAD(frame)[n] = *value;
}
// Terminate the new frame:
SERIES_TAIL(frame) = SERIES_TAIL(wrds);
BLK_TERM(frame);
return frame;
}
*/ static int Read_Dir(REBREQ *dir, REBSER *files)
/*
** Provide option to get file info too.
** Provide option to prepend dir path.
** Provide option to use wildcards.
**
***********************************************************************/
{
REBINT result;
REBCNT len;
REBSER *fname;
REBSER *name;
REBREQ file;
RESET_TAIL(files);
CLEARS(&file);
// Temporary filename storage:
fname = BUF_OS_STR;
file.file.path = (REBCHR*)Reset_Buffer(fname, MAX_FILE_NAME);
SET_FLAG(dir->modes, RFM_DIR);
dir->data = (REBYTE*)(&file);
while ((result = OS_DO_DEVICE(dir, RDC_READ)) == 0 && !GET_FLAG(dir->flags, RRF_DONE)) {
len = LEN_STR(file.file.path);
if (GET_FLAG(file.modes, RFM_DIR)) len++;
name = Copy_OS_Str(file.file.path, len);
if (GET_FLAG(file.modes, RFM_DIR))
SET_ANY_CHAR(name, name->tail-1, '/');
Set_Series(REB_FILE, Append_Value(files), name);
}
if (result < 0 && dir->error != -RFE_OPEN_FAIL
&& (FIND_CHR(dir->file.path, '*') || FIND_CHR(dir->file.path, '?')))
result = 0; // no matches found, but not an error
return result;
}
*/ 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 void Form_Object(const REBVAL *value, REB_MOLD *mold)
{
REBSER *wser = VAL_OBJ_WORDS(value);
REBVAL *words = BLK_HEAD(wser);
REBVAL *vals = VAL_OBJ_VALUES(value); // first value is context
REBCNT n;
// Prevent endless mold loop:
if (Find_Same_Block(MOLD_LOOP, value) > 0) {
Append_Unencoded(mold->series, "...]");
return;
}
Append_Value(MOLD_LOOP, value);
// Mold all words and their values:
for (n = 1; n < SERIES_TAIL(wser); n++) {
if (!VAL_GET_OPT(words+n, OPTS_HIDE))
Emit(mold, "N: V\n", VAL_WORD_SYM(words+n), vals+n);
}
Remove_Last(mold->series);
Remove_Last(MOLD_LOOP);
}
*/ REBINT Find_Typeset(REBVAL *block)
/*
***********************************************************************/
{
REBVAL value;
REBVAL *val;
REBINT n;
VAL_SET(&value, REB_TYPESET);
Make_Typeset(block, &value, 0);
val = VAL_BLK_SKIP(ROOT_TYPESETS, 1);
for (n = 1; NOT_END(val); val++, n++) {
if (EQUAL_TYPESET(&value, val)){
//Print("FTS: %d", n);
return n;
}
}
// Print("Size Typesets: %d", VAL_TAIL(ROOT_TYPESETS));
Append_Value(VAL_SERIES(ROOT_TYPESETS), &value);
return n;
}
*/ RL_API int RL_Set_Value(REBSER *series, u32 index, RXIARG val, int type)
/*
** Set a value in a block.
**
** Returns:
** TRUE if index past end and value was appended to tail of block.
** Arguments:
** series - block series pointer
** index - index of the value in the block (zero based)
** val - new value for field
** type - datatype of value
**
***********************************************************************/
{
REBVAL value;
CLEARS(&value);
RXI_To_Value(&value, val, type);
if (index >= series->tail) {
Append_Value(series, &value);
return TRUE;
}
*BLK_SKIP(series, index) = value;
return FALSE;
}
static void Mold_Map(const REBVAL *value, REB_MOLD *mold, REBFLG molded)
{
REBSER *mapser = VAL_SERIES(value);
REBVAL *val;
// Prevent endless mold loop:
if (Find_Same_Block(MOLD_LOOP, value) > 0) {
Append_Unencoded(mold->series, "...]");
return;
}
Append_Value(MOLD_LOOP, value);
if (molded) {
Pre_Mold(value, mold);
Append_Byte(mold->series, '[');
}
// Mold all non-none entries
mold->indent++;
for (val = BLK_HEAD(mapser); NOT_END(val) && NOT_END(val+1); val += 2) {
if (!IS_NONE(val+1)) {
if (molded) New_Indented_Line(mold);
Emit(mold, "V V", val, val+1);
if (!molded) Append_Byte(mold->series, '\n');
}
}
mold->indent--;
if (molded) {
New_Indented_Line(mold);
Append_Byte(mold->series, ']');
}
End_Mold(mold);
Remove_Last(MOLD_LOOP);
}
*/ static REB_R Loop_Each(struct Reb_Call *call_, REBINT mode)
/*
** Supports these natives (modes):
** 0: foreach
** 1: remove-each
** 2: map
**
***********************************************************************/
{
REBSER *body;
REBVAL *vars;
REBVAL *words;
REBSER *frame;
REBVAL *value;
REBSER *series;
REBSER *out; // output block (for MAP, mode = 2)
REBINT index; // !!!! should these be REBCNT?
REBINT tail;
REBINT windex; // write
REBINT rindex; // read
REBINT err;
REBCNT i;
REBCNT j;
REBVAL *ds;
assert(mode >= 0 && mode < 3);
value = D_ARG(2); // series
if (IS_NONE(value)) return R_NONE;
body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
SET_OBJECT(D_ARG(1), frame); // keep GC safe
Set_Block(D_ARG(3), body); // keep GC safe
SET_NONE(D_OUT); // Default result to NONE if the loop does not run
// If it's MAP, create result block:
if (mode == 2) {
out = Make_Block(VAL_LEN(value));
SAVE_SERIES(out);
}
// Get series info:
if (ANY_OBJECT(value)) {
series = VAL_OBJ_FRAME(value);
out = FRM_WORD_SERIES(series); // words (the out local reused)
index = 1;
//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
}
else if (IS_MAP(value)) {
series = VAL_SERIES(value);
index = 0;
//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
}
else {
series = VAL_SERIES(value);
index = VAL_INDEX(value);
if (index >= cast(REBINT, SERIES_TAIL(series))) {
if (mode == 1) {
SET_INTEGER(D_OUT, 0);
} else if (mode == 2) {
Set_Block(D_OUT, out);
UNSAVE_SERIES(out);
}
return R_OUT;
}
}
windex = index;
// Iterate over each value in the series block:
while (index < (tail = SERIES_TAIL(series))) {
rindex = index; // remember starting spot
j = 0;
// Set the FOREACH loop variables from the series:
for (i = 1; i < frame->tail; i++) {
vars = FRM_VALUE(frame, i);
words = FRM_WORD(frame, i);
// var spec is WORD
if (IS_WORD(words)) {
if (index < tail) {
if (ANY_BLOCK(value)) {
*vars = *BLK_SKIP(series, index);
}
else if (ANY_OBJECT(value)) {
if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) {
// Alternate between word and value parts of object:
if (j == 0) {
Init_Word(vars, REB_WORD, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index);
if (NOT_END(vars+1)) index--; // reset index for the value part
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
Trap_Arg_DEAD_END(words);
j++;
}
else {
// Do not evaluate this iteration
index++;
goto skip_hidden;
}
}
else if (IS_VECTOR(value)) {
Set_Vector_Value(vars, series, index);
}
else if (IS_MAP(value)) {
REBVAL *val = BLK_SKIP(series, index | 1);
if (!IS_NONE(val)) {
if (j == 0) {
*vars = *BLK_SKIP(series, index & ~1);
if (IS_END(vars+1)) index++; // only words
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
Trap_Arg_DEAD_END(words);
j++;
}
else {
index += 2;
goto skip_hidden;
}
}
else { // A string or binary
if (IS_BINARY(value)) {
SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
}
else if (IS_IMAGE(value)) {
Set_Tuple_Pixel(BIN_SKIP(series, index), vars);
}
else {
VAL_SET(vars, REB_CHAR);
VAL_CHAR(vars) = GET_ANY_CHAR(series, index);
}
}
index++;
}
else SET_NONE(vars);
}
// var spec is SET_WORD:
else if (IS_SET_WORD(words)) {
if (ANY_OBJECT(value) || IS_MAP(value)) {
*vars = *value;
} else {
VAL_SET(vars, REB_BLOCK);
VAL_SERIES(vars) = series;
VAL_INDEX(vars) = index;
}
//if (index < tail) index++; // do not increment block.
}
else Trap_Arg_DEAD_END(words);
}
if (index == rindex) index++; //the word block has only set-words: foreach [a:] [1 2 3][]
if (!DO_BLOCK(D_OUT, body, 0)) {
if ((err = Check_Error(D_OUT)) >= 0) {
index = rindex;
break;
}
// else CONTINUE:
if (mode == 1) SET_FALSE(D_OUT); // keep the value (for mode == 1)
} else {
err = 0; // prevent later test against uninitialized value
}
if (mode > 0) {
//if (ANY_OBJECT(value)) Trap_Types_DEAD_END(words, REB_BLOCK, VAL_TYPE(value)); //check not needed
// If FALSE return, copy values to the write location:
if (mode == 1) { // remove-each
if (IS_CONDITIONAL_FALSE(D_OUT)) {
REBCNT wide = SERIES_WIDE(series);
// memory areas may overlap, so use memmove and not memcpy!
memmove(series->data + (windex * wide), series->data + (rindex * wide), (index - rindex) * wide);
windex += index - rindex;
// old: while (rindex < index) *BLK_SKIP(series, windex++) = *BLK_SKIP(series, rindex++);
}
}
else
if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT); // (mode == 2)
}
skip_hidden: ;
}
// Finish up:
if (mode == 1) {
// Remove hole (updates tail):
if (windex < index) Remove_Series(series, windex, index - windex);
SET_INTEGER(D_OUT, index - windex);
return R_OUT;
}
// If MAP...
if (mode == 2) {
UNSAVE_SERIES(out);
if (err != 2) {
// ...and not BREAK/RETURN:
Set_Block(D_OUT, out);
return R_OUT;
}
}
return R_OUT;
}
*/ static 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 REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
REBVAL *spec;
REBVAL *hndl;
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
return Set_Pair(&(gob->offset), val);
case SYM_SIZE:
return Set_Pair(&gob->size, val);
case SYM_IMAGE:
CLR_GOB_OPAQUE(gob);
if (IS_IMAGE(val)) {
SET_GOB_TYPE(gob, GOBT_IMAGE);
GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val);
GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val);
GOB_CONTENT(gob) = VAL_SERIES(val);
// if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
#ifdef HAS_WIDGET_GOB
case SYM_WIDGET:
//printf("WIDGET GOB\n");
SET_GOB_TYPE(gob, GOBT_WIDGET);
SET_GOB_OPAQUE(gob);
GOB_CONTENT(gob) = Make_Block(4); // [handle type spec data]
hndl = Append_Value(GOB_CONTENT(gob));
Append_Value(GOB_CONTENT(gob)); // used to cache type on host's side
spec = Append_Value(GOB_CONTENT(gob));
Append_Value(GOB_CONTENT(gob)); // used to cache result data
SET_HANDLE(hndl, 0, SYM_WIDGET, 0);
if (IS_WORD(val) || IS_LIT_WORD(val)) {
Set_Block(spec, Make_Block(1));
Append_Val(VAL_SERIES(spec), val);
}
else if (IS_BLOCK(val)) {
Set_Block(spec, VAL_SERIES(val));
}
else return FALSE;
break;
#endif // HAS_WIDGET_GOB
case SYM_DRAW:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_DRAW);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_TEXT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_TEXT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_STRING(val)) {
SET_GOB_TYPE(gob, GOBT_STRING);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_EFFECT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_EFFECT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_COLOR:
CLR_GOB_OPAQUE(gob);
if (IS_TUPLE(val)) {
SET_GOB_TYPE(gob, GOBT_COLOR);
Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val);
if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 255)
SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
break;
case SYM_PANE:
if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob));
if (IS_BLOCK(val))
Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0);
else if (IS_GOB(val))
Insert_Gobs(gob, val, 0, 1, 0);
else if (IS_NONE(val))
gob->pane = 0;
else
return FALSE;
break;
case SYM_ALPHA:
GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255);
break;
case SYM_DATA:
#ifdef HAS_WIDGET_GOB
if (GOB_TYPE(gob) == GOBT_WIDGET) {
OS_SET_WIDGET_DATA(gob, val);
} else {
#endif
SET_GOB_DTYPE(gob, GOBD_NONE);
if (IS_OBJECT(val)) {
SET_GOB_DTYPE(gob, GOBD_OBJECT);
SET_GOB_DATA(gob, VAL_OBJ_FRAME(val));
}
else if (IS_BLOCK(val)) {
SET_GOB_DTYPE(gob, GOBD_BLOCK);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_STRING(val)) {
SET_GOB_DTYPE(gob, GOBD_STRING);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_BINARY(val)) {
SET_GOB_DTYPE(gob, GOBD_BINARY);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_INTEGER(val)) {
SET_GOB_DTYPE(gob, GOBD_INTEGER);
SET_GOB_DATA(gob, (void*)(REBIPT)VAL_INT64(val));
}
else if (IS_NONE(val))
SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
#ifdef HAS_WIDGET_GOB
}
#endif
break;
case SYM_FLAGS:
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
else if (IS_BLOCK(val)) {
gob->flags = 0;
for (val = VAL_BLK(val); NOT_END(val); val++) {
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
}
}
break;
case SYM_OWNER:
if (IS_GOB(val))
GOB_TMP_OWNER(gob) = VAL_GOB(val);
else
return FALSE;
break;
default:
return FALSE;
}
return TRUE;
}
//
// Find_Entry: C
//
// Try to find the entry in the map. If not found
// and val is SET, create the entry and store the key and
// val.
//
// RETURNS: the index to the VALUE or zero if there is none.
//
static REBCNT Find_Entry(REBSER *series, REBVAL *key, REBVAL *val)
{
REBSER *hser = series->extra.series; // can be null
REBCNT *hashes;
REBCNT hash;
REBVAL *v;
REBCNT n;
if (IS_NONE(key)) return 0;
// We may not be large enough yet for the hash table to
// be worthwhile, so just do a linear search:
if (!hser) {
if (series->tail < MIN_DICT*2) {
v = BLK_HEAD(series);
if (ANY_WORD(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (
ANY_WORD(v)
&& SAME_SYM(VAL_WORD_SYM(key), VAL_WORD_SYM(v))
) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else if (ANY_BINSTR(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (VAL_TYPE(key) == VAL_TYPE(v) && 0 == Compare_String_Vals(key, v, (REBOOL)!IS_BINARY(v))) {
if (val)
*++v = *val;
return n/2+1;
}
}
}
else if (IS_INTEGER(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (IS_INTEGER(v) && VAL_INT64(key) == VAL_INT64(v)) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else if (IS_CHAR(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (IS_CHAR(v) && VAL_CHAR(key) == VAL_CHAR(v)) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else
fail (Error_Has_Bad_Type(key));
if (!val) return 0;
Append_Value(series, key);
Append_Value(series, val); // does not copy value, e.g. if string
return series->tail/2;
}
// Add hash table:
//Print("hash added %d", series->tail);
series->extra.series = hser = Make_Hash_Sequence(series->tail);
MANAGE_SERIES(hser);
Rehash_Hash(series);
}
// Get hash table, expand it if needed:
if (series->tail > hser->tail/2) {
Expand_Hash(hser); // modifies size value
Rehash_Hash(series);
}
hash = Find_Key(series, hser, key, 2, 0, 0);
hashes = (REBCNT*)hser->data;
n = hashes[hash];
// Just a GET of value:
if (!val) return n;
// Must set the value:
if (n) { // re-set it:
*BLK_SKIP(series, ((n-1)*2)+1) = *val; // set it
return n;
}
// Create new entry:
Append_Value(series, key);
Append_Value(series, val); // does not copy value, e.g. if string
return (hashes[hash] = series->tail/2);
}
*/ REBSER *Gob_To_Block(REBGOB *gob)
/*
** Used by MOLD to create a block.
**
***********************************************************************/
{
REBSER *ser = Make_Block(10);
REBVAL *val;
REBVAL *val1;
REBCNT sym;
val = Append_Value(ser);
Init_Word(val, SYM_OFFSET);
VAL_SET(val, REB_SET_WORD);
val = Append_Value(ser);
SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
val = Append_Value(ser);
Init_Word(val, SYM_SIZE);
VAL_SET(val, REB_SET_WORD);
val = Append_Value(ser);
SET_PAIR(val, GOB_W(gob), GOB_H(gob));
if (!GET_GOB_FLAG(gob, GOBF_OPAQUE) && GOB_ALPHA(gob) < 255) {
val = Append_Value(ser);
Init_Word(val, SYM_ALPHA);
VAL_SET(val, REB_SET_WORD);
val = Append_Value(ser);
SET_INTEGER(val, 255 - GOB_ALPHA(gob));
}
if (!GOB_TYPE(gob)) return ser;
if (GOB_CONTENT(gob)) {
val1 = Append_Value(ser);
val = Append_Value(ser);
switch (GOB_TYPE(gob)) {
case GOBT_COLOR:
sym = SYM_COLOR;
break;
case GOBT_IMAGE:
sym = SYM_IMAGE;
break;
#ifdef HAS_WIDGET_GOB
case GOBT_WIDGET:
sym = SYM_WIDGET;
break;
#endif
case GOBT_STRING:
case GOBT_TEXT:
sym = SYM_TEXT;
break;
case GOBT_DRAW:
sym = SYM_DRAW;
break;
case GOBT_EFFECT:
sym = SYM_EFFECT;
break;
}
Init_Word(val1, sym);
VAL_SET(val1, REB_SET_WORD);
Get_GOB_Var(gob, val1, val);
}
return ser;
}
