RL_API void *RL_Make_Block(u32 size)
/*
** Allocate a new block.
**
** Returns:
** A pointer to a block series.
** Arguments:
** size - the length of the block. The system will add one extra
** for the end-of-block marker.
** Notes:
** Blocks are allocated with REBOL's internal memory manager.
** Internal structures may change, so NO assumptions should be made!
** Blocks are automatically garbage collected if there are
** no references to them from REBOL code (C code does nothing.)
** However, you can lock blocks to prevent deallocation. (?? default)
*/
{
return Make_Block(size);
}
*/ 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);
dir = To_REBOL_Path(str, n, -1, 0);
if (len == 1) {
Set_Series(REB_FILE, Append_Value(blk), dir);
}
else {
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 *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;
}
*/ void Init_Typesets(void)
/*
** Create typeset variables that are defined above.
** For example: NUMBER is both integer and decimal.
** Add the new variables to the system context.
**
***********************************************************************/
{
REBVAL *value;
REBINT n;
Set_Root_Series(ROOT_TYPESETS, Make_Block(40), "typeset presets");
for (n = 0; Typesets[n]; n += 2) {
value = Alloc_Tail_Blk(VAL_SERIES(ROOT_TYPESETS));
VAL_SET(value, REB_TYPESET);
VAL_TYPESET(value) = Typesets[n+1];
if (Typesets[n] > 1)
*Append_Frame(Lib_Context, 0, (REBCNT)(Typesets[n])) = *value;
}
}
*/ void Init_Stacks(REBCNT size)
/*
***********************************************************************/
{
// We always keep one call stack chunk frame around for the first
// call frame push. The first frame allocated out of it is
// saved as CS_Root.
struct Reb_Chunk *chunk = ALLOC(struct Reb_Chunk);
#if !defined(NDEBUG)
memset(chunk, 0xBD, sizeof(struct Reb_Chunk));
#endif
chunk->next = NULL;
CS_Root = cast(struct Reb_Call*, &chunk->payload);
CS_Top = NULL;
CS_Running = NULL;
DS_Series = Make_Block(size);
Set_Root_Series(TASK_STACK, DS_Series, "data stack"); // uses special GC
}
*/ 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 REBSER *Pane_To_Block(REBGOB *gob, REBCNT index, REBINT len)
/*
** Convert pane list of gob pointers to a block of GOB!s.
**
***********************************************************************/
{
REBSER *ser;
REBGOB **gp;
REBVAL *val;
if (len == -1 || (len + index) > GOB_TAIL(gob)) len = GOB_TAIL(gob) - index;
if (len < 0) len = 0;
ser = Make_Block(len);
ser->tail = len;
val = BLK_HEAD(ser);
gp = GOB_HEAD(gob);
for (; len > 0; len--, val++, gp++) {
SET_GOB(val, *gp);
}
SET_END(val);
return ser;
}
*/ 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 REBFLG Get_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
break;
case SYM_SIZE:
SET_PAIR(val, GOB_W(gob), GOB_H(gob));
break;
case SYM_IMAGE:
if (GOB_TYPE(gob) == GOBT_IMAGE) {
// image
}
else goto is_none;
break;
case SYM_DRAW:
if (GOB_TYPE(gob) == GOBT_DRAW) {
Set_Block(val, GOB_CONTENT(gob)); // Note: compiler optimizes SET_BLOCKs below
}
else goto is_none;
break;
case SYM_TEXT:
if (GOB_TYPE(gob) == GOBT_TEXT) {
Set_Block(val, GOB_CONTENT(gob));
}
else if (GOB_TYPE(gob) == GOBT_STRING) {
Set_String(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_EFFECT:
if (GOB_TYPE(gob) == GOBT_EFFECT) {
Set_Block(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_COLOR:
if (GOB_TYPE(gob) == GOBT_COLOR) {
Set_Tuple_Pixel((REBYTE*)&GOB_CONTENT(gob), val);
}
else goto is_none;
break;
case SYM_ALPHA:
SET_INTEGER(val, GOB_ALPHA(gob));
break;
case SYM_PANE:
if (GOB_PANE(gob))
Set_Block(val, Pane_To_Block(gob, 0, -1));
else
Set_Block(val, Make_Block(0));
break;
case SYM_PARENT:
if (GOB_PARENT(gob)) {
SET_GOB(val, GOB_PARENT(gob));
}
else
is_none:
SET_NONE(val);
break;
case SYM_DATA:
if (GOB_DTYPE(gob) == GOBD_OBJECT) {
SET_OBJECT(val, GOB_DATA(gob));
}
else if (GOB_DTYPE(gob) == GOBD_BLOCK) {
Set_Block(val, GOB_DATA(gob));
}
else if (GOB_DTYPE(gob) == GOBD_STRING) {
Set_String(val, GOB_DATA(gob));
}
else if (GOB_DTYPE(gob) == GOBD_BINARY) {
SET_BINARY(val, GOB_DATA(gob));
}
else if (GOB_DTYPE(gob) == GOBD_INTEGER) {
SET_INTEGER(val, (REBIPT)GOB_DATA(gob));
}
else goto is_none;
break;
case SYM_FLAGS:
Set_Block(val, Flags_To_Block(gob));
break;
default:
return FALSE;
}
return TRUE;
}
*/ 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;
}
*/ static REBFLG Get_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
REBSER *data;
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
break;
case SYM_SIZE:
SET_PAIR(val, GOB_W(gob), GOB_H(gob));
break;
case SYM_IMAGE:
if (GOB_TYPE(gob) == GOBT_IMAGE) {
// image
}
else goto is_none;
break;
#ifdef HAS_WIDGET_GOB
case SYM_WIDGET:
data = VAL_SERIES(GOB_WIDGET_SPEC(gob));
Init_Word(val, VAL_WORD_CANON(BLK_HEAD(data)));
VAL_SET(val, REB_LIT_WORD);
break;
#endif
case SYM_DRAW:
if (GOB_TYPE(gob) == GOBT_DRAW) {
Set_Block(val, GOB_CONTENT(gob)); // Note: compiler optimizes SET_BLOCKs below
}
else goto is_none;
break;
case SYM_TEXT:
if (GOB_TYPE(gob) == GOBT_TEXT) {
Set_Block(val, GOB_CONTENT(gob));
}
else if (GOB_TYPE(gob) == GOBT_STRING) {
Set_String(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_EFFECT:
if (GOB_TYPE(gob) == GOBT_EFFECT) {
Set_Block(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_COLOR:
if (GOB_TYPE(gob) == GOBT_COLOR) {
Set_Tuple_Pixel((REBYTE*)&GOB_CONTENT(gob), val);
}
else goto is_none;
break;
case SYM_ALPHA:
SET_INTEGER(val, GOB_ALPHA(gob));
break;
case SYM_PANE:
if (GOB_PANE(gob))
Set_Block(val, Pane_To_Block(gob, 0, -1));
else
Set_Block(val, Make_Block(0));
break;
case SYM_PARENT:
if (GOB_PARENT(gob)) {
SET_GOB(val, GOB_PARENT(gob));
}
else
is_none:
SET_NONE(val);
break;
case SYM_DATA:
#ifdef HAS_WIDGET_GOB
if (GOB_TYPE(gob) == GOBT_WIDGET) {
return OS_GET_WIDGET_DATA(gob, val);
}
#endif
data = GOB_DATA(gob);
if (GOB_DTYPE(gob) == GOBD_OBJECT) {
SET_OBJECT(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_BLOCK) {
Set_Block(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_STRING) {
Set_String(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_BINARY) {
SET_BINARY(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_INTEGER) {
SET_INTEGER(val, (REBIPT)data);
}
else goto is_none;
break;
case SYM_FLAGS:
Set_Block(val, Flags_To_Block(gob));
break;
default:
return FALSE;
}
return TRUE;
}
*/ 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;
}
*/ 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;
}
*/ 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 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 int Dir_Actor(REBVAL *ds, REBSER *port, REBCNT action)
/*
** Internal port handler for file directories.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *path;
REBVAL *state;
REBREQ dir;
REBCNT args = 0;
REBINT result;
REBCNT len;
//REBYTE *flags;
Validate_Port(port, action);
*D_RET = *D_ARG(1);
CLEARS(&dir);
// Validate and fetch relevant PORT fields:
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) Trap1(RE_INVALID_SPEC, spec);
if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
else if (!IS_FILE(path)) Trap1(RE_INVALID_SPEC, path);
state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.
//flags = Security_Policy(SYM_FILE, path);
// Get or setup internal state data:
dir.port = port;
dir.device = RDI_FILE;
switch (action) {
case A_READ:
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(ds, ALL_READ_REFS);
if (!IS_BLOCK(state)) { // !!! ignores /SKIP and /PART, for now
Init_Dir_Path(&dir, path, 1, POL_READ);
Set_Block(state, Make_Block(7)); // initial guess
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
*D_RET = *state;
SET_NONE(state);
} else {
len = VAL_BLK_LEN(state);
// !!? Why does this need to copy the block??
Set_Block(D_RET, Copy_Block_Values(VAL_SERIES(state), 0, len, TS_STRING));
}
break;
case A_CREATE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
create:
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
result = OS_DO_DEVICE(&dir, RDC_CREATE);
///OS_FREE(dir.file.path);
if (result < 0) Trap1(RE_NO_CREATE, path);
if (action == A_CREATE) return R_ARG2;
SET_NONE(state);
break;
case A_RENAME:
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
else {
REBSER *target;
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
// Convert file name to OS format:
if (!(target = Value_To_OS_Path(D_ARG(2)))) Trap1(RE_BAD_FILE_PATH, D_ARG(2));
dir.data = BIN_DATA(target);
OS_DO_DEVICE(&dir, RDC_RENAME);
Free_Series(target);
if (dir.error) Trap1(RE_NO_RENAME, path);
}
break;
case A_DELETE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, 0, POL_WRITE);
// !!! add *.r deletion
// !!! add recursive delete (?)
result = OS_DO_DEVICE(&dir, RDC_DELETE);
///OS_FREE(dir.file.path);
if (result < 0) Trap1(RE_NO_DELETE, path);
return R_ARG2;
case A_OPEN:
// !! If open fails, what if user does a READ w/o checking for error?
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(ds, ALL_OPEN_REFS);
if (args & AM_OPEN_NEW) goto create;
//if (args & ~AM_OPEN_READ) Trap1(RE_INVALID_SPEC, path);
Set_Block(state, Make_Block(7));
Init_Dir_Path(&dir, path, 1, POL_READ);
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
break;
case A_OPENQ:
if (IS_BLOCK(state)) return R_TRUE;
return R_FALSE;
case A_CLOSE:
SET_NONE(state);
break;
case A_QUERY:
//Trap_Security(flags[POL_READ], POL_READ, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
Ret_Query_File(port, &dir, D_RET);
///OS_FREE(dir.file.path);
break;
//-- Port Series Actions (only called if opened as a port)
case A_LENGTHQ:
len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
SET_INTEGER(D_RET, len);
break;
default:
Trap_Action(REB_PORT, action);
}
return R_RET;
}
*/ 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;
}
*/ static REB_R Event_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
** Internal port handler for events.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *state;
REB_R result;
REBVAL *arg;
REBVAL save_port;
Validate_Port(port, action);
arg = D_ARG(2);
*D_OUT = *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_DEAD_END(RE_INVALID_SPEC, spec);
// Get or setup internal state data:
if (!IS_BLOCK(state)) Set_Block(state, Make_Block(EVENTS_CHUNK - 1));
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_DEAD_END(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_DEAD_END(arg);
case A_PICK:
act_blk:
save_port = *D_ARG(1); // save for return
*D_ARG(1) = *state;
result = T_Block(call_, action);
SET_SIGNAL(SIG_EVENT_PORT);
if (action == A_INSERT || action == A_APPEND || action == A_REMOVE) {
*D_OUT = save_port;
break;
}
return result; // return condition
case A_CLEAR:
VAL_TAIL(state) = 0;
VAL_BLK_TERM(state);
CLR_SIGNAL(SIG_EVENT_PORT);
break;
case A_LENGTHQ:
SET_INTEGER(D_OUT, VAL_TAIL(state));
break;
case A_OPEN:
if (!req) { //!!!
req = OS_MAKE_DEVREQ(RDI_EVENT);
if (req) {
SET_OPEN(req);
OS_DO_DEVICE(req, RDC_CONNECT); // stays queued
}
}
break;
case A_CLOSE:
OS_ABORT_DEVICE(req);
OS_DO_DEVICE(req, RDC_CLOSE);
// free req!!!
SET_CLOSED(req);
req = 0;
break;
case A_FIND: // add it
default:
Trap_Action_DEAD_END(REB_PORT, action);
}
return R_OUT;
}
