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; }