*/ REBINT Cmp_Block(REBVAL *sval, REBVAL *tval, REBFLG is_case) /* ** Compare two blocks and return the difference of the first ** non-matching value. ** ***********************************************************************/ { REBVAL *s = VAL_BLK_DATA(sval); REBVAL *t = VAL_BLK_DATA(tval); REBINT diff; CHECK_STACK(&s); if ((VAL_SERIES(sval)==VAL_SERIES(tval))&& (VAL_INDEX(sval)==VAL_INDEX(tval))) return 0; while (!IS_END(s) && (VAL_TYPE(s) == VAL_TYPE(t) || (IS_NUMBER(s) && IS_NUMBER(t)))) { if ((diff = Cmp_Value(s, t, is_case)) != 0) return diff; s++, t++; } return VAL_TYPE(s) - VAL_TYPE(t); }
*/ static void Sort_Block(REBVAL *block, REBFLG ccase, REBVAL *skipv, REBVAL *compv, REBVAL *part, REBFLG all, REBFLG rev) /* ** series [series!] ** /case {Case sensitive sort} ** /skip {Treat the series as records of fixed size} ** size [integer!] {Size of each record} ** /compare {Comparator offset, block or function} ** comparator [integer! block! function!] ** /part {Sort only part of a series} ** length [number! series!] {Length of series to sort} ** /all {Compare all fields} ** /reverse {Reverse sort order} ** ***********************************************************************/ { REBCNT len; REBCNT skip = 1; REBCNT size = sizeof(REBVAL); // int (*sfunc)(const void *v1, const void *v2); sort_flags.cased = ccase; sort_flags.reverse = rev; sort_flags.compare = 0; sort_flags.offset = 0; if (IS_INTEGER(compv)) sort_flags.offset = Int32(compv)-1; if (ANY_FUNC(compv)) sort_flags.compare = compv; // Determine length of sort: len = Partial1(block, part); if (len <= 1) return; // Skip factor: if (!IS_NONE(skipv)) { skip = Get_Num_Arg(skipv); if (skip <= 0 || len % skip != 0 || skip > len) Trap_Range(skipv); } // Use fast quicksort library function: if (skip > 1) len /= skip, size *= skip; if (sort_flags.compare) qsort((void *)VAL_BLK_DATA(block), len, size, Compare_Call); else qsort((void *)VAL_BLK_DATA(block), len, size, Compare_Val); }
*/ REBFLG MT_Pair(REBVAL *out, REBVAL *data, REBCNT type) /* ***********************************************************************/ { REBD32 x; REBD32 y; if (IS_PAIR(data)) { *out = *data; return TRUE; } if (!IS_BLOCK(data)) return FALSE; data = VAL_BLK_DATA(data); if (IS_INTEGER(data)) x = (REBD32)VAL_INT64(data); else if (IS_DECIMAL(data)) x = (REBD32)VAL_DECIMAL(data); else return FALSE; data++; if (IS_INTEGER(data)) y = (REBD32)VAL_INT64(data); else if (IS_DECIMAL(data)) y = (REBD32)VAL_DECIMAL(data); else return FALSE; VAL_SET(out, REB_PAIR); VAL_PAIR_X(out) = x; VAL_PAIR_Y(out) = y; return TRUE; }
// // Append_Map: C // static void Append_Map(REBSER *ser, REBVAL *arg, REBCNT len) { REBVAL *val; REBCNT n; val = VAL_BLK_DATA(arg); for (n = 0; n < len && NOT_END(val) && NOT_END(val+1); val += 2, n += 2) { Find_Entry(ser, val, val+1); } }
*/ static REBSER *Init_Loop(REBVAL *spec, REBVAL *body_blk, REBSER **fram) /* ** Initialize standard for loops (copy block, make frame, bind). ** Spec: WORD or [WORD ...] ** ***********************************************************************/ { REBSER *frame; REBINT len; REBVAL *word; REBVAL *vals; REBSER *body; // For :WORD format, get the var's value: if (IS_GET_WORD(spec)) spec = Get_Var(spec); // Hand-make a FRAME (done for for speed): len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1; if (len == 0) Trap_Arg(spec); frame = Make_Frame(len); SET_SELFLESS(frame); SERIES_TAIL(frame) = len+1; SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1; // Setup for loop: word = FRM_WORD(frame, 1); // skip SELF vals = BLK_SKIP(frame, 1); if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec); // Optimally create the FOREACH frame: while (len-- > 0) { if (!IS_WORD(spec) && !IS_SET_WORD(spec)) { // Prevent inconsistent GC state: Free_Series(FRM_WORD_SERIES(frame)); Free_Series(frame); Trap_Arg(spec); } VAL_SET(word, VAL_TYPE(spec)); VAL_BIND_SYM(word) = VAL_WORD_SYM(spec); VAL_BIND_TYPESET(word) = ALL_64; word++; SET_NONE(vals); vals++; spec++; } SET_END(word); SET_END(vals); body = Clone_Block_Value(body_blk); Bind_Block(frame, BLK_HEAD(body), BIND_DEEP); *fram = frame; return body; }
*/ static REBSER *Init_Loop(const REBVAL *spec, REBVAL *body_blk, REBSER **fram) /* ** Initialize standard for loops (copy block, make frame, bind). ** Spec: WORD or [WORD ...] ** ***********************************************************************/ { REBSER *frame; REBINT len; REBVAL *word; REBVAL *vals; REBSER *body; // For :WORD format, get the var's value: if (IS_GET_WORD(spec)) spec = GET_VAR(spec); // Hand-make a FRAME (done for for speed): len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1; if (len == 0) raise Error_Invalid_Arg(spec); frame = Make_Frame(len, FALSE); SERIES_TAIL(frame) = len+1; SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1; // Setup for loop: word = FRM_WORD(frame, 1); // skip SELF vals = BLK_SKIP(frame, 1); if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec); // Optimally create the FOREACH frame: while (len-- > 0) { if (!IS_WORD(spec) && !IS_SET_WORD(spec)) { // Prevent inconsistent GC state: Free_Series(FRM_WORD_SERIES(frame)); Free_Series(frame); raise Error_Invalid_Arg(spec); } Val_Init_Word_Typed(word, VAL_TYPE(spec), VAL_WORD_SYM(spec), ALL_64); word++; SET_NONE(vals); vals++; spec++; } SET_END(word); SET_END(vals); body = Copy_Array_At_Deep_Managed( VAL_SERIES(body_blk), VAL_INDEX(body_blk) ); Bind_Values_Deep(BLK_HEAD(body), frame); *fram = frame; return body; }
*/ REBFLG MT_Object(REBVAL *out, REBVAL *data, REBCNT type) /* ***********************************************************************/ { if (!IS_BLOCK(data)) return FALSE; VAL_OBJ_FRAME(out) = Construct_Object(0, VAL_BLK_DATA(data), 0); VAL_SET(out, type); if (type == REB_ERROR) { Make_Error_Object(out, out); } return TRUE; }
*/ REBSER *Form_Tight_Block(REBVAL *blk) /* ***********************************************************************/ { REB_MOLD mo = {0}; REBVAL *val; Reset_Mold(&mo); for (val = VAL_BLK_DATA(blk); NOT_END(val); val++) Mold_Value(&mo, val, 0); return Copy_String(mo.series, 0, -1); }
*/ void Unbind_Block(REBVAL *val, REBCNT deep) /* ***********************************************************************/ { for (; NOT_END(val); val++) { if (ANY_WORD(val)) { UNBIND(val); } if (ANY_BLOCK(val) && deep) { Unbind_Block(VAL_BLK_DATA(val), TRUE); } } }
*/ REBFLG MT_Gob(REBVAL *out, REBVAL *data, REBCNT type) /* ***********************************************************************/ { REBGOB *ngob; if (IS_BLOCK(data)) { ngob = Make_Gob(); Set_GOB_Vars(ngob, VAL_BLK_DATA(data)); SET_GOB(out, ngob); return TRUE; } return FALSE; }
*/ static void Bind_Block_Words(REBSER *frame, REBVAL *value, REBCNT mode) /* ** Inner loop of bind block. Modes are: ** ** BIND_ONLY Only bind the words found in the frame. ** BIND_SET Add set-words to the frame during the bind. ** BIND_ALL Add words to the frame during the bind. ** BIND_DEEP Recurse into sub-blocks. ** ** NOTE: BIND_SET must be used carefully, because it does not ** bind prior instances of the word before the set-word. That is ** forward references are not allowed. ** ***********************************************************************/ { REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here REBCNT n; REBFLG selfish = !IS_SELFLESS(frame); for (; NOT_END(value); value++) { if (ANY_WORD(value)) { //Print("Word: %s", Get_Sym_Name(VAL_WORD_CANON(value))); // Is the word found in this frame? if (NZ(n = binds[VAL_WORD_CANON(value)])) { if (n == NO_RESULT) n = 0; // SELF word ASSERT1(n < SERIES_TAIL(frame), RP_BIND_BOUNDS); // Word is in frame, bind it: VAL_WORD_INDEX(value) = n; VAL_WORD_FRAME(value) = frame; } else if (selfish && VAL_WORD_CANON(value) == SYM_SELF) { VAL_WORD_INDEX(value) = 0; VAL_WORD_FRAME(value) = frame; } else { // Word is not in frame. Add it if option is specified: if ((mode & BIND_ALL) || ((mode & BIND_SET) && (IS_SET_WORD(value)))) { Append_Frame(frame, value, 0); binds[VAL_WORD_CANON(value)] = VAL_WORD_INDEX(value); } } } else if (ANY_BLOCK(value) && (mode & BIND_DEEP)) Bind_Block_Words(frame, VAL_BLK_DATA(value), mode); else if ((IS_FUNCTION(value) || IS_CLOSURE(value)) && (mode & BIND_FUNC)) Bind_Block_Words(frame, BLK_HEAD(VAL_FUNC_BODY(value)), mode); } }
*/ void Unbind_Values_Core(REBVAL value[], REBSER *frame, REBOOL deep) /* ** Unbind words in a block, optionally unbinding those which are ** bound to a particular frame (if frame is NULL, then all ** words will be unbound regardless of their VAL_WORD_FRAME). ** ***********************************************************************/ { for (; NOT_END(value); value++) { if (ANY_WORD(value) && (!frame || VAL_WORD_FRAME(value) == frame)) UNBIND_WORD(value); if (ANY_BLOCK(value) && deep) Unbind_Values_Core(VAL_BLK_DATA(value), frame, TRUE); } }
*/ REBSER *Make_Module_Spec(REBVAL *block) /* ** Create a module spec object. Holds module name, version, ** exports, locals, and more. See system/standard/module. ** ***********************************************************************/ { REBSER *obj; REBSER *frame; // Build standard module header object: obj = VAL_OBJ_FRAME(Get_System(SYS_STANDARD, STD_SCRIPT)); if (block && IS_BLOCK(block)) frame = Construct_Object(obj, VAL_BLK_DATA(block), 0); else frame = CLONE_OBJECT(obj); return frame; }
*/ void Collect_Words(REBVAL *block, REBFLG modes) /* ** The inner recursive loop used for Collect_Words function below. ** ***********************************************************************/ { REBINT *binds = WORDS_HEAD(Bind_Table); REBVAL *word; REBVAL *value; for (; NOT_END(block); block++) { value = block; //if (modes & BIND_GET && IS_GET_WORD(block)) value = Get_Var(block); if (ANY_WORD(value)) { if (!binds[VAL_WORD_CANON(value)]) { // only once per word if (IS_SET_WORD(value) || modes & BIND_ALL) { binds[VAL_WORD_CANON(value)] = SERIES_TAIL(BUF_WORDS); EXPAND_SERIES_TAIL(BUF_WORDS, 1); word = BLK_LAST(BUF_WORDS); VAL_SET(word, VAL_TYPE(value)); VAL_SET_OPT(word, OPTS_UNWORD); VAL_BIND_SYM(word) = VAL_WORD_SYM(value); // Allow all datatypes (to start): VAL_BIND_TYPESET(word) = ~((TYPESET(REB_END) | TYPESET(REB_UNSET))); // not END or UNSET } } else { // If word duplicated: if (modes & BIND_NO_DUP) { // Reset binding table (note BUF_WORDS may have expanded): for (word = BLK_HEAD(BUF_WORDS); NOT_END(word); word++) binds[VAL_WORD_CANON(word)] = 0; RESET_TAIL(BUF_WORDS); // allow reuse Trap1(RE_DUP_VARS, value); } } continue; } // Recurse into sub-blocks: if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP)) Collect_Words(VAL_BLK_DATA(value), modes); // In this mode (foreach native), do not allow non-words: //else if (modes & BIND_GET) Trap_Arg(value); } BLK_TERM(BUF_WORDS); }
*/ REBSER *Make_Module_Spec(REBVAL *spec) /* ** Create a module spec object. Holds module name, version, ** exports, locals, and more. See system/standard/module. ** ***********************************************************************/ { // Build standard module header object: REBSER *obj = VAL_OBJ_FRAME(Get_System(SYS_STANDARD, STD_SCRIPT)); REBSER *frame; if (spec && IS_BLOCK(spec)) frame = Construct_Object(obj, VAL_BLK_DATA(spec), FALSE); else frame = Copy_Array_Shallow(obj); return frame; }
*/ static void Bind_Values_Inner_Loop(REBINT *binds, REBVAL value[], REBSER *frame, REBCNT mode) /* ** Bind_Values_Core() sets up the binding table and then calls ** this recursive routine to do the actual binding. ** ***********************************************************************/ { REBFLG selfish = !IS_SELFLESS(frame); for (; NOT_END(value); value++) { if (ANY_WORD(value)) { //Print("Word: %s", Get_Sym_Name(VAL_WORD_CANON(value))); // Is the word found in this frame? REBCNT n = binds[VAL_WORD_CANON(value)]; if (n != 0) { if (n == NO_RESULT) n = 0; // SELF word assert(n < SERIES_TAIL(frame)); // Word is in frame, bind it: VAL_WORD_INDEX(value) = n; VAL_WORD_FRAME(value) = frame; } else if (selfish && VAL_WORD_CANON(value) == SYM_SELF) { VAL_WORD_INDEX(value) = 0; VAL_WORD_FRAME(value) = frame; } else { // Word is not in frame. Add it if option is specified: if ((mode & BIND_ALL) || ((mode & BIND_SET) && (IS_SET_WORD(value)))) { Expand_Frame(frame, 1, 1); Append_Frame(frame, value, 0); binds[VAL_WORD_CANON(value)] = VAL_WORD_INDEX(value); } } } else if (ANY_BLOCK(value) && (mode & BIND_DEEP)) Bind_Values_Inner_Loop( binds, VAL_BLK_DATA(value), frame, mode ); else if ((IS_FUNCTION(value) || IS_CLOSURE(value)) && (mode & BIND_FUNC)) Bind_Values_Inner_Loop( binds, BLK_HEAD(VAL_FUNC_BODY(value)), frame, mode ); } }
*/ static void Collect_Frame_Inner_Loop(REBINT *binds, REBVAL value[], REBCNT modes) /* ** The inner recursive loop used for Collect_Frame function below. ** ***********************************************************************/ { for (; NOT_END(value); value++) { if (ANY_WORD(value)) { if (!binds[VAL_WORD_CANON(value)]) { // only once per word if (IS_SET_WORD(value) || modes & BIND_ALL) { REBVAL *word; binds[VAL_WORD_CANON(value)] = SERIES_TAIL(BUF_WORDS); EXPAND_SERIES_TAIL(BUF_WORDS, 1); word = BLK_LAST(BUF_WORDS); Val_Init_Word_Typed( word, VAL_TYPE(value), VAL_WORD_SYM(value), // Allow all datatypes but END or UNSET (initially): ~((TYPESET(REB_END) | TYPESET(REB_UNSET))) ); } } else { // If word duplicated: if (modes & BIND_NO_DUP) { // Reset binding table (note BUF_WORDS may have expanded): REBVAL *word; for (word = BLK_HEAD(BUF_WORDS); NOT_END(word); word++) binds[VAL_WORD_CANON(word)] = 0; RESET_TAIL(BUF_WORDS); // allow reuse raise Error_1(RE_DUP_VARS, value); } } continue; } // Recurse into sub-blocks: if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP)) Collect_Frame_Inner_Loop(binds, VAL_BLK_DATA(value), modes); // In this mode (foreach native), do not allow non-words: //else if (modes & BIND_GET) raise Error_Invalid_Arg(value); } BLK_TERM(BUF_WORDS); }
*/ static void Collect_Words_Inner_Loop(REBINT *binds, REBVAL value[], REBCNT modes) /* ** Used for Collect_Words() after the binds table has ** been set up. ** ***********************************************************************/ { for (; NOT_END(value); value++) { if (ANY_WORD(value) && !binds[VAL_WORD_CANON(value)] && (modes & BIND_ALL || IS_SET_WORD(value)) ) { REBVAL *word; binds[VAL_WORD_CANON(value)] = 1; word = Alloc_Tail_Array(BUF_WORDS); Val_Init_Word_Unbound(word, REB_WORD, VAL_WORD_SYM(value)); } else if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP)) Collect_Words_Inner_Loop(binds, VAL_BLK_DATA(value), modes); } }
*/ REBSER *Block_To_String_List(REBVAL *blk) /* ** Convert block of values to a string that holds ** a series of null terminated strings, followed ** by a final terminating string. ** ***********************************************************************/ { REB_MOLD mo = {0}; REBVAL *value; Reset_Mold(&mo); for (value = VAL_BLK_DATA(blk); NOT_END(value); value++) { Mold_Value(&mo, value, 0); Append_Byte(mo.series, 0); } Append_Byte(mo.series, 0); return Copy_Series(mo.series); // Unicode }
*/ 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); } }
*/ void Rebind_Block(REBSER *src_frame, REBSER *dst_frame, REBVAL *data, REBFLG modes) /* ** Rebind all words that reference src frame to dst frame. ** Rebind is always deep. ** ** There are two types of frames: relative frames and normal frames. ** When frame_src type and frame_dst type differ, ** modes must have REBIND_TYPE. ** ***********************************************************************/ { REBINT *binds = WORDS_HEAD(Bind_Table); for (; NOT_END(data); data++) { if (ANY_BLOCK(data)) Rebind_Block(src_frame, dst_frame, VAL_BLK_DATA(data), modes); else if (ANY_WORD(data) && VAL_WORD_FRAME(data) == src_frame) { VAL_WORD_FRAME(data) = dst_frame; if (modes & REBIND_TABLE) VAL_WORD_INDEX(data) = binds[VAL_WORD_CANON(data)]; if (modes & REBIND_TYPE) VAL_WORD_INDEX(data) = - VAL_WORD_INDEX(data); } else if ((modes & REBIND_FUNC) && (IS_FUNCTION(data) || IS_CLOSURE(data))) Rebind_Block(src_frame, dst_frame, BLK_HEAD(VAL_FUNC_BODY(data)), modes); } }
*/ static REBOOL Is_Of_Type(REBVAL *value, REBVAL *types) /* ** Types can be: word or block. Each element must be either ** a datatype or a typeset. ** ***********************************************************************/ { REBVAL *val; val = IS_WORD(types) ? Get_Var(types) : types; if (IS_DATATYPE(val)) { return (VAL_DATATYPE(val) == (REBINT)VAL_TYPE(value)); } if (IS_TYPESET(val)) { return (TYPE_CHECK(val, VAL_TYPE(value))); } if (IS_BLOCK(val)) { for (types = VAL_BLK_DATA(val); NOT_END(types); types++) { val = IS_WORD(types) ? Get_Var(types) : types; if (IS_DATATYPE(val)) if (VAL_DATATYPE(val) == (REBINT)VAL_TYPE(value)) return TRUE; else if (IS_TYPESET(val)) if (TYPE_CHECK(val, VAL_TYPE(value))) return TRUE; else Trap1(RE_INVALID_TYPE, Of_Type(val)); } return FALSE; } Trap_Arg(types); return 0; // for compiler }
STOID Mold_Error(REBVAL *value, REB_MOLD *mold, REBFLG molded) { ERROR_OBJ *err; REBVAL *msg; // Error message block // Protect against recursion. !!!! if (molded) { if (VAL_OBJ_FRAME(value) && VAL_ERR_NUM(value) >= RE_NOTE && VAL_ERR_OBJECT(value)) Mold_Object(value, mold); else { // Happens if throw or return is molded. // make error! 0-3 Pre_Mold(value, mold); Append_Int(mold->series, VAL_ERR_NUM(value)); End_Mold(mold); } return; } // If it is an unprocessed BREAK, THROW, CONTINUE, RETURN: if (VAL_ERR_NUM(value) < RE_NOTE || !VAL_ERR_OBJECT(value)) { VAL_ERR_OBJECT(value) = Make_Error(VAL_ERR_NUM(value), value, 0, 0); // spoofs field } err = VAL_ERR_VALUES(value); // Form: ** <type> Error: Emit(mold, "** WB", &err->type, RS_ERRS+0); // Append: error message ARG1, ARG2, etc. msg = Find_Error_Info(err, 0); if (msg) { if (!IS_BLOCK(msg)) Mold_Value(mold, msg, 0); else { //start = DSP + 1; //Reduce_In_Frame(VAL_ERR_OBJECT(value), VAL_BLK_DATA(msg)); //SERIES_TAIL(DS_Series) = DSP + 1; //Form_Block_Series(DS_Series, start, mold, 0); Form_Block_Series(VAL_SERIES(msg), 0, mold, VAL_ERR_OBJECT(value)); } } else Append_Boot_Str(mold->series, RS_ERRS+1); Append_Byte(mold->series, '\n'); // Form: ** Where: function value = &err->where; if (VAL_TYPE(value) > REB_NONE) { Append_Boot_Str(mold->series, RS_ERRS+2); Mold_Value(mold, value, 0); Append_Byte(mold->series, '\n'); } // Form: ** Near: location value = &err->nearest; if (VAL_TYPE(value) > REB_NONE) { Append_Boot_Str(mold->series, RS_ERRS+3); if (IS_STRING(value)) // special case: source file line number Append_String(mold->series, VAL_SERIES(value), 0, VAL_TAIL(value)); else if (IS_BLOCK(value)) Mold_Simple_Block(mold, VAL_BLK_DATA(value), 60); Append_Byte(mold->series, '\n'); } }
static void Append_Obj(REBSER *obj, REBVAL *arg) { REBCNT i; REBCNT len = 0; REBVAL *val; REBVAL *start = arg; // Can be a word: if (ANY_WORD(arg)) { if (!Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE)) { if (VAL_WORD_CANON(arg) == SYM_SELF) Trap0(RE_SELF_PROTECTED); Expand_Frame(obj, 1, 1); // copy word table also Append_Frame(obj, 0, VAL_WORD_SYM(arg)); // val is UNSET } return; } if (!IS_BLOCK(arg)) Trap_Arg(arg); // Verify word/value argument block: for (arg = VAL_BLK_DATA(arg); NOT_END(arg); arg += 2) { if (!IS_WORD(arg) && !IS_SET_WORD(arg)) Trap_Arg(arg); if (NZ(i = Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE))) { // Just change the value, do not append it. val = FRM_VALUE(obj, i); if (GET_FLAGS(VAL_OPTS(FRM_WORD(obj, i)), OPTS_HIDE, OPTS_LOCK)) { // Back out... reset any prior flags: for (; arg != VAL_BLK_DATA(start); arg -= 2) VAL_CLR_OPT(arg, OPTS_TEMP); if (VAL_PROTECTED(FRM_WORD(obj, i))) Trap1(RE_LOCKED_WORD, FRM_WORD(obj, i)); Trap0(RE_HIDDEN); } // Problem above: what about prior OPTS_FLAGS? Ok to leave them as is? if (IS_END(arg+1)) SET_NONE(val); else *val = arg[1]; VAL_SET_OPT(arg, OPTS_TEMP); } else { if (VAL_WORD_CANON(arg) == SYM_SELF) Trap0(RE_SELF_PROTECTED); len++; // was: Trap1(RE_DUP_VARS, arg); } if (IS_END(arg+1)) break; // fix bug#708 } // Append new values to end of frame (if necessary): if (len > 0) { Expand_Frame(obj, len, 1); // copy word table also for (arg = VAL_BLK_DATA(start); NOT_END(arg); arg += 2) { if (VAL_GET_OPT(arg, OPTS_TEMP)) VAL_CLR_OPT(arg, OPTS_TEMP); else { val = Append_Frame(obj, 0, VAL_WORD_SYM(arg)); if (IS_END(arg+1)) { SET_NONE(val); break; } else *val = arg[1]; } } } }
/* parse struct attribute */ static void parse_attr (REBVAL *blk, REBINT *raw_size, REBUPT *raw_addr) { REBVAL *attr = VAL_BLK_DATA(blk); *raw_size = -1; *raw_addr = 0; while (NOT_END(attr)) { if (IS_SET_WORD(attr)) { switch (VAL_WORD_CANON(attr)) { case SYM_RAW_SIZE: ++ attr; if (IS_INTEGER(attr)) { if (*raw_size > 0) /* duplicate raw-size */ raise Error_Invalid_Arg(attr); *raw_size = VAL_INT64(attr); if (*raw_size <= 0) raise Error_Invalid_Arg(attr); } else raise Error_Invalid_Arg(attr); break; case SYM_RAW_MEMORY: ++ attr; if (IS_INTEGER(attr)) { if (*raw_addr != 0) /* duplicate raw-memory */ raise Error_Invalid_Arg(attr); *raw_addr = VAL_UNT64(attr); if (*raw_addr == 0) raise Error_Invalid_Arg(attr); } else raise Error_Invalid_Arg(attr); break; case SYM_EXTERN: ++ attr; if (*raw_addr != 0) /* raw-memory is exclusive with extern */ raise Error_Invalid_Arg(attr); if (!IS_BLOCK(attr) || VAL_LEN(attr) != 2) { raise Error_Invalid_Arg(attr); } else { REBVAL *lib; REBVAL *sym; CFUNC *addr; lib = VAL_BLK_SKIP(attr, 0); sym = VAL_BLK_SKIP(attr, 1); if (!IS_LIBRARY(lib)) raise Error_Invalid_Arg(attr); if (IS_CLOSED_LIB(VAL_LIB_HANDLE(lib))) raise Error_0(RE_BAD_LIBRARY); if (!ANY_BINSTR(sym)) raise Error_Invalid_Arg(sym); addr = OS_FIND_FUNCTION( LIB_FD(VAL_LIB_HANDLE(lib)), s_cast(VAL_DATA(sym)) ); if (!addr) raise Error_1(RE_SYMBOL_NOT_FOUND, sym); *raw_addr = cast(REBUPT, addr); } break; /* case SYM_ALIGNMENT: ++ attr; if (IS_INTEGER(attr)) { alignment = VAL_INT64(attr); } else { raise Error_Invalid_Arg(attr); } break; */ default: raise Error_Invalid_Arg(attr); } } else raise Error_Invalid_Arg(attr); ++ attr; } }
*/ void Resolve_Context(REBSER *target, REBSER *source, REBVAL *only_words, REBFLG all, REBFLG expand) /* ** Only_words can be a block of words or an index in the target ** (for new words). ** ***********************************************************************/ { REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here REBVAL *words; REBVAL *vals; REBINT n; REBINT m; REBCNT i = 0; CHECK_BIND_TABLE; if (IS_PROTECT_SERIES(target)) Trap0(RE_PROTECTED); if (IS_INTEGER(only_words)) { // Must be: 0 < i <= tail i = VAL_INT32(only_words); // never <= 0 if (i == 0) i = 1; if (i >= target->tail) return; } Collect_Start(BIND_NO_SELF); // DO NOT TRAP IN THIS SECTION n = 0; // If limited resolve, tag the word ids that need to be copied: if (i) { // Only the new words of the target: for (words = FRM_WORD(target, i); NOT_END(words); words++) binds[VAL_BIND_CANON(words)] = -1; n = SERIES_TAIL(target) - 1; } else if (IS_BLOCK(only_words)) { // Limit exports to only these words: for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) { if (IS_WORD(words) || IS_SET_WORD(words)) { binds[VAL_WORD_CANON(words)] = -1; n++; } } } // Expand target as needed: if (expand && n > 0) { // Determine how many new words to add: for (words = FRM_WORD(target, 1); NOT_END(words); words++) if (binds[VAL_BIND_CANON(words)]) n--; // Expand frame by the amount required: if (n > 0) Expand_Frame(target, n, 0); else expand = 0; } // Maps a word to its value index in the source context. // Done by marking all source words (in bind table): words = FRM_WORDS(source)+1; for (n = 1; NOT_END(words); n++, words++) { if (IS_NONE(only_words) || binds[VAL_BIND_CANON(words)]) binds[VAL_WORD_CANON(words)] = n; } // Foreach word in target, copy the correct value from source: n = i ? i : 1; vals = FRM_VALUE(target, n); for (words = FRM_WORD(target, n); NOT_END(words); words++, vals++) { if ((m = binds[VAL_BIND_CANON(words)])) { binds[VAL_BIND_CANON(words)] = 0; // mark it as set if (!VAL_PROTECTED(words) && (all || IS_UNSET(vals))) { if (m < 0) SET_UNSET(vals); // no value in source context else *vals = *FRM_VALUE(source, m); //Debug_Num("type:", VAL_TYPE(vals)); //Debug_Str(Get_Word_Name(words)); } } } // Add any new words and values: if (expand) { REBVAL *val; words = FRM_WORDS(source)+1; for (n = 1; NOT_END(words); n++, words++) { if (binds[VAL_BIND_CANON(words)]) { // Note: no protect check is needed here binds[VAL_BIND_CANON(words)] = 0; val = Append_Frame(target, 0, VAL_BIND_SYM(words)); *val = *FRM_VALUE(source, n); } } } else { // Reset bind table (do not use Collect_End): if (i) { for (words = FRM_WORD(target, i); NOT_END(words); words++) binds[VAL_BIND_CANON(words)] = 0; } else if (IS_BLOCK(only_words)) { for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) { if (IS_WORD(words) || IS_SET_WORD(words)) binds[VAL_WORD_CANON(words)] = 0; } } else { for (words = FRM_WORDS(source)+1; NOT_END(words); words++) binds[VAL_BIND_CANON(words)] = 0; } } CHECK_BIND_TABLE; RESET_TAIL(BUF_WORDS); // allow reuse, trapping ok now }
static REBOOL parse_field_type(struct Struct_Field *field, REBVAL *spec, REBVAL *inner, REBVAL **init) { REBVAL *val = VAL_BLK_DATA(spec); if (IS_WORD(val)){ switch (VAL_WORD_CANON(val)) { case SYM_UINT8: field->type = STRUCT_TYPE_UINT8; field->size = 1; break; case SYM_INT8: field->type = STRUCT_TYPE_INT8; field->size = 1; break; case SYM_UINT16: field->type = STRUCT_TYPE_UINT16; field->size = 2; break; case SYM_INT16: field->type = STRUCT_TYPE_INT16; field->size = 2; break; case SYM_UINT32: field->type = STRUCT_TYPE_UINT32; field->size = 4; break; case SYM_INT32: field->type = STRUCT_TYPE_INT32; field->size = 4; break; case SYM_UINT64: field->type = STRUCT_TYPE_UINT64; field->size = 8; break; case SYM_INT64: field->type = STRUCT_TYPE_INT64; field->size = 8; break; case SYM_FLOAT: field->type = STRUCT_TYPE_FLOAT; field->size = 4; break; case SYM_DOUBLE: field->type = STRUCT_TYPE_DOUBLE; field->size = 8; break; case SYM_POINTER: field->type = STRUCT_TYPE_POINTER; field->size = sizeof(void*); break; case SYM_STRUCT_TYPE: ++ val; if (IS_BLOCK(val)) { REBFLG res; res = MT_Struct(inner, val, REB_STRUCT); if (!res) { //RL_Print("Failed to make nested struct!\n"); return FALSE; } field->size = SERIES_TAIL(VAL_STRUCT_DATA_BIN(inner)); field->type = STRUCT_TYPE_STRUCT; field->fields = VAL_STRUCT_FIELDS(inner); field->spec = VAL_STRUCT_SPEC(inner); *init = inner; /* a shortcut for struct intialization */ } else raise Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(val)); break; case SYM_REBVAL: field->type = STRUCT_TYPE_REBVAL; field->size = sizeof(REBVAL); break; default: raise Error_Has_Bad_Type(val); } } else if (IS_STRUCT(val)) { //[b: [struct-a] val-a] field->size = SERIES_TAIL(VAL_STRUCT_DATA_BIN(val)); field->type = STRUCT_TYPE_STRUCT; field->fields = VAL_STRUCT_FIELDS(val); field->spec = VAL_STRUCT_SPEC(val); *init = val; } else raise Error_Has_Bad_Type(val); ++ val; if (IS_BLOCK(val)) {// make struct! [a: [int32 [2]] [0 0]] REBVAL ret; if (DO_ARRAY_THROWS(&ret, val)) { // !!! Does not check for thrown cases...what should this // do in case of THROW, BREAK, QUIT? raise Error_No_Catch_For_Throw(&ret); } if (!IS_INTEGER(&ret)) raise Error_Unexpected_Type(REB_INTEGER, VAL_TYPE(val)); field->dimension = cast(REBCNT, VAL_INT64(&ret)); field->array = TRUE; ++ val; } else { field->dimension = 1; /* scalar */ field->array = FALSE; } if (NOT_END(val)) raise Error_Has_Bad_Type(val); return TRUE; }
*/ REBINT Find_Max_Bit(REBVAL *val) /* ** Return integer number for the maximum bit number defined by ** the value. Used to determine how much space to allocate. ** ***********************************************************************/ { REBINT maxi = 0; REBINT n; switch (VAL_TYPE(val)) { case REB_CHAR: maxi = VAL_CHAR(val)+1; break; case REB_INTEGER: maxi = Int32s(val, 0); break; case REB_STRING: case REB_FILE: case REB_EMAIL: case REB_URL: case REB_TAG: // case REB_ISSUE: n = VAL_INDEX(val); if (VAL_BYTE_SIZE(val)) { REBYTE *bp = VAL_BIN(val); for (; n < (REBINT)VAL_TAIL(val); n++) if (bp[n] > maxi) maxi = bp[n]; } else { REBUNI *up = VAL_UNI(val); for (; n < (REBINT)VAL_TAIL(val); n++) if (up[n] > maxi) maxi = up[n]; } maxi++; break; case REB_BINARY: maxi = VAL_LEN(val) * 8 - 1; if (maxi < 0) maxi = 0; break; case REB_BLOCK: for (val = VAL_BLK_DATA(val); NOT_END(val); val++) { n = Find_Max_Bit(val); if (n > maxi) maxi = n; } //maxi++; break; case REB_NONE: maxi = 0; break; default: return -1; } return maxi; }
*/ REBI64 Make_Time(REBVAL *val) /* ** Returns NO_TIME if error. ** ***********************************************************************/ { REBI64 secs = 0; if (IS_TIME(val)) { secs = VAL_TIME(val); } else if (IS_STRING(val)) { REBYTE *bp; REBCNT len; bp = Qualify_String(val, 30, &len, FALSE); // can trap, ret diff str if (!Scan_Time(bp, len, val)) goto no_time; secs = VAL_TIME(val); } else if (IS_INTEGER(val)) { if (VAL_INT64(val) < -MAX_SECONDS || VAL_INT64(val) > MAX_SECONDS) Trap_Range_DEAD_END(val); secs = VAL_INT64(val) * SEC_SEC; } else if (IS_DECIMAL(val)) { if (VAL_DECIMAL(val) < (REBDEC)(-MAX_SECONDS) || VAL_DECIMAL(val) > (REBDEC)MAX_SECONDS) Trap_Range_DEAD_END(val); secs = DEC_TO_SECS(VAL_DECIMAL(val)); } else if (ANY_BLOCK(val) && VAL_BLK_LEN(val) <= 3) { REBFLG neg = FALSE; REBI64 i; val = VAL_BLK_DATA(val); if (!IS_INTEGER(val)) goto no_time; i = Int32(val); if (i < 0) i = -i, neg = TRUE; secs = i * 3600; if (secs > MAX_SECONDS) goto no_time; if (NOT_END(++val)) { if (!IS_INTEGER(val)) goto no_time; if ((i = Int32(val)) < 0) goto no_time; secs += i * 60; if (secs > MAX_SECONDS) goto no_time; if (NOT_END(++val)) { if (IS_INTEGER(val)) { if ((i = Int32(val)) < 0) goto no_time; secs += i; if (secs > MAX_SECONDS) goto no_time; } else if (IS_DECIMAL(val)) { if (secs + (REBI64)VAL_DECIMAL(val) + 1 > MAX_SECONDS) goto no_time; // added in below } else goto no_time; } } secs *= SEC_SEC; if (IS_DECIMAL(val)) secs += DEC_TO_SECS(VAL_DECIMAL(val)); if (neg) secs = -secs; } else no_time: return NO_TIME; return secs; }
*/ REBFLG MT_Struct(REBVAL *out, REBVAL *data, enum Reb_Kind type) /* * Format: * make struct! [ * field1 [type1] * field2: [type2] field2-init-value * field3: [struct [field1 [type1]]] * field4: [type1[3]] * ... * ] ***********************************************************************/ { //RL_Print("%s\n", __func__); REBINT max_fields = 16; VAL_STRUCT_FIELDS(out) = Make_Series( max_fields, sizeof(struct Struct_Field), MKS_NONE ); MANAGE_SERIES(VAL_STRUCT_FIELDS(out)); if (IS_BLOCK(data)) { //if (Reduce_Block_No_Set_Throws(VAL_SERIES(data), 0, NULL))... //data = DS_POP; REBVAL *blk = VAL_BLK_DATA(data); REBINT field_idx = 0; /* for field index */ u64 offset = 0; /* offset in data */ REBCNT eval_idx = 0; /* for spec block evaluation */ REBVAL *init = NULL; /* for result to save in data */ REBOOL expect_init = FALSE; REBINT raw_size = -1; REBUPT raw_addr = 0; REBCNT alignment = 0; VAL_STRUCT_SPEC(out) = Copy_Array_Shallow(VAL_SERIES(data)); VAL_STRUCT_DATA(out) = Make_Series( 1, sizeof(struct Struct_Data), MKS_NONE ); EXPAND_SERIES_TAIL(VAL_STRUCT_DATA(out), 1); VAL_STRUCT_DATA_BIN(out) = Make_Series(max_fields << 2, 1, MKS_NONE); VAL_STRUCT_OFFSET(out) = 0; // We tell the GC to manage this series, but it will not cause a // synchronous garbage collect. Still, when's the right time? ENSURE_SERIES_MANAGED(VAL_STRUCT_SPEC(out)); MANAGE_SERIES(VAL_STRUCT_DATA(out)); MANAGE_SERIES(VAL_STRUCT_DATA_BIN(out)); /* set type early such that GC will handle it correctly, i.e, not collect series in the struct */ SET_TYPE(out, REB_STRUCT); if (IS_BLOCK(blk)) { parse_attr(blk, &raw_size, &raw_addr); ++ blk; } while (NOT_END(blk)) { REBVAL *inner; struct Struct_Field *field = NULL; u64 step = 0; EXPAND_SERIES_TAIL(VAL_STRUCT_FIELDS(out), 1); DS_PUSH_NONE; inner = DS_TOP; /* save in stack so that it won't be GC'ed when MT_Struct is recursively called */ field = (struct Struct_Field *)SERIES_SKIP(VAL_STRUCT_FIELDS(out), field_idx); field->offset = (REBCNT)offset; if (IS_SET_WORD(blk)) { field->sym = VAL_WORD_SYM(blk); expect_init = TRUE; if (raw_addr) { /* initialization is not allowed for raw memory struct */ raise Error_Invalid_Arg(blk); } } else if (IS_WORD(blk)) { field->sym = VAL_WORD_SYM(blk); expect_init = FALSE; } else raise Error_Has_Bad_Type(blk); ++ blk; if (!IS_BLOCK(blk)) raise Error_Invalid_Arg(blk); if (!parse_field_type(field, blk, inner, &init)) { return FALSE; } ++ blk; STATIC_assert(sizeof(field->size) <= 4); STATIC_assert(sizeof(field->dimension) <= 4); step = (u64)field->size * (u64)field->dimension; if (step > VAL_STRUCT_LIMIT) raise Error_1(RE_SIZE_LIMIT, out); EXPAND_SERIES_TAIL(VAL_STRUCT_DATA_BIN(out), step); if (expect_init) { REBVAL safe; // result of reduce or do (GC saved during eval) init = &safe; if (IS_BLOCK(blk)) { if (Reduce_Block_Throws(init, VAL_SERIES(blk), 0, FALSE)) raise Error_No_Catch_For_Throw(init); ++ blk; } else { DO_NEXT_MAY_THROW( eval_idx, init, VAL_SERIES(data), blk - VAL_BLK_DATA(data) ); if (eval_idx == THROWN_FLAG) raise Error_No_Catch_For_Throw(init); blk = VAL_BLK_SKIP(data, eval_idx); } if (field->array) { if (IS_INTEGER(init)) { /* interpreted as a C pointer */ void *ptr = cast(void *, cast(REBUPT, VAL_INT64(init))); /* assuming it's an valid pointer and holding enough space */ memcpy(SERIES_SKIP(VAL_STRUCT_DATA_BIN(out), (REBCNT)offset), ptr, field->size * field->dimension); } else if (IS_BLOCK(init)) { REBCNT n = 0; if (VAL_LEN(init) != field->dimension) raise Error_Invalid_Arg(init); /* assign */ for (n = 0; n < field->dimension; n ++) { if (!assign_scalar(&VAL_STRUCT(out), field, n, VAL_BLK_SKIP(init, n))) { //RL_Print("Failed to assign element value\n"); goto failed; } } } else raise Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(blk)); } else { /* scalar */ if (!assign_scalar(&VAL_STRUCT(out), field, 0, init)) { //RL_Print("Failed to assign scalar value\n"); goto failed; } } } else if (raw_addr == 0) {