*/ REBSER *Decompress(REBSER *input, REBCNT index, REBINT len, REBCNT limit, REBFLG use_crc) /* ** Decompress a binary (only). ** ***********************************************************************/ { REBCNT size; REBSER *output; REBINT err; if (len < 0 || (index + len > BIN_LEN(input))) len = BIN_LEN(input) - index; // Get the size from the end and make the output buffer that size. if (len <= 4) Trap0(RE_PAST_END); // !!! better msg needed size = Bytes_To_Long(BIN_SKIP(input, len) - 4); if (limit && size > limit) Trap_Num(RE_SIZE_LIMIT, size); output = Make_Binary(size + 20); // (Why 20 extra? -CS) //DISABLE_GC; err = Z_uncompress(BIN_HEAD(output), (uLongf*)&size, BIN_HEAD(input) + index, len, use_crc); if (err) { if (PG_Boot_Phase < 2) return 0; if (err == Z_MEM_ERROR) Trap0(RE_NO_MEMORY); SET_INTEGER(DS_RETURN, err); Trap1(RE_BAD_PRESS, DS_RETURN); //!!!provide error string descriptions } SET_STR_END(output, size); SERIES_TAIL(output) = size; //ENABLE_GC; return output; }
*/ REBDEC Round_Dec(REBDEC dec, REBCNT flags, REBDEC scale) /* ** Identical to ROUND mezzanine function. ** Note: scale arg only valid if RF_TO is set ** ***********************************************************************/ { REBDEC r; int e; REBFLG v; union {REBDEC d; REBI64 i;} m; REBI64 j; if (GET_FLAG(flags, RF_TO)) { if (scale == 0.0) Trap0(RE_ZERO_DIVIDE); scale = fabs(scale); } else scale = 1.0; /* is scale negligible? */ if (scale < ldexp(fabs(dec), -53)) return dec; if ((v = scale >= 1.0)) dec = dec / scale; else { r = frexp(scale, &e); if (e <= -1022) { scale = r; dec = ldexp(dec, e); } else e = 0; scale = 1.0 / scale; dec = dec * scale; } if (flags & RB_DFC) { if (GET_FLAG(flags, RF_FLOOR)) dec = floor(dec); else if (GET_FLAG(flags, RF_DOWN)) dec = Dec_Trunc(dec); else dec = ceil(dec); } else { /* integer-compare fabs(dec) and floor(fabs(dec)) + 0.5, which is equivalent to "tolerant comparison" of the fractional part with 0.5 */ m.d = fabs(dec); j = m.i; m.d = floor(m.d) + 0.5; if (j - m.i < -10) dec = Dec_Trunc(dec); else if (j - m.i > 10) dec = Dec_Away(dec); else if (GET_FLAG(flags, RF_EVEN)) { if (fmod(fabs(dec), 2.0) < 1.0) dec = Dec_Trunc(dec); else dec = Dec_Away(dec); } else if (GET_FLAG(flags, RF_HALF_DOWN)) dec = Dec_Trunc(dec); else if (GET_FLAG(flags, RF_HALF_CEILING)) dec = ceil(dec); else dec = Dec_Away(dec); } if (v) { if (fabs(dec = dec * scale) != HUGE_VAL) return dec; else Trap0(RE_OVERFLOW); } return ldexp(dec / scale, e); }
*/ void Do_Command(REBVAL *value) /* ** Evaluates the arguments for a command function and creates ** a resulting stack frame (struct or object) for command processing. ** ** A command value consists of: ** args - same as other funcs ** spec - same as other funcs ** body - [ext-obj func-index] ** ***********************************************************************/ { REBVAL *val = BLK_HEAD(VAL_FUNC_BODY(value)); REBEXT *ext; REBCNT cmd; REBCNT argc; REBCNT n; RXIFRM frm; // args stored here // All of these were checked above on definition: val = BLK_HEAD(VAL_FUNC_BODY(value)); cmd = (int)VAL_INT64(val+1); ext = &Ext_List[VAL_I32(VAL_OBJ_VALUE(val, 1))]; // Handler // Copy args to command frame (array of args): RXA_COUNT(&frm) = argc = SERIES_TAIL(VAL_FUNC_ARGS(value))-1; // not self if (argc > 7) Trap0(RE_BAD_COMMAND); val = DS_ARG(1); for (n = 1; n <= argc; n++, val++) { RXA_TYPE(&frm, n) = Reb_To_RXT[VAL_TYPE(val)]; frm.args[n] = Value_To_RXI(val); } // Call the command: n = ext->call(cmd, &frm, 0); val = DS_RETURN; switch (n) { case RXR_VALUE: RXI_To_Value(val, frm.args[1], RXA_TYPE(&frm, 1)); break; case RXR_BLOCK: RXI_To_Block(&frm, val); break; case RXR_UNSET: SET_UNSET(val); break; case RXR_NONE: SET_NONE(val); break; case RXR_TRUE: SET_TRUE(val); break; case RXR_FALSE: SET_FALSE(val); break; case RXR_ERROR: default: SET_UNSET(val); } }
*/ int Decode_UTF32(REBUNI *dst, REBYTE *src, REBINT len, REBFLG lee, REBFLG ccr) /* ***********************************************************************/ { Trap0(RE_BAD_DECODE); // not yet supported return 0; }
*/ REBINT Check_Error(REBVAL *val) /* ** Process a loop exceptions. Pass in the TOS value, returns: ** ** 2 - if break/return, change val to that set by break ** 1 - if break ** -1 - if continue, change val to unset ** 0 - if not break or continue ** else: error if not an ERROR value ** ***********************************************************************/ { // It's UNSET, not an error: if (!IS_ERROR(val)) Trap0(RE_NO_RETURN); //!!! change to special msg // If it's a BREAK, check for /return value: if (IS_BREAK(val)) { if (VAL_ERR_VALUE(val)) { *val = *VAL_ERR_VALUE(val); return 2; } else { SET_UNSET(val); return 1; } } if (IS_CONTINUE(val)) { SET_UNSET(val); return -1; } return 0; // Else: Let all other errors return as values. }
*/ void Check_Stack(void) /* ***********************************************************************/ { if ((DSP + 100) > (REBINT)SERIES_REST(DS_Series)) Trap0(RE_STACK_OVERFLOW); }
*/ void Set_Var(REBVAL *word, REBVAL *value) /* ** Set the word (variable) value. (Use macro when possible). ** ***********************************************************************/ { REBINT index = VAL_WORD_INDEX(word); REBINT dsf; REBSER *frm; if (!HAS_FRAME(word)) Trap1(RE_NOT_DEFINED, word); // ASSERT(index, RP_BAD_SET_INDEX); ASSERT(VAL_WORD_FRAME(word), RP_BAD_SET_CONTEXT); // Print("Set %s to %s [frame: %x idx: %d]", Get_Word_Name(word), Get_Type_Name(value), VAL_WORD_FRAME(word), VAL_WORD_INDEX(word)); if (index > 0) { frm = VAL_WORD_FRAME(word); if (VAL_PROTECTED(FRM_WORDS(frm)+index)) Trap1(RE_LOCKED_WORD, word); FRM_VALUES(frm)[index] = *value; return; } if (index == 0) Trap0(RE_SELF_PROTECTED); // Find relative value: dsf = DSF; while (VAL_WORD_FRAME(word) != VAL_WORD_FRAME(DSF_WORD(dsf))) { dsf = PRIOR_DSF(dsf); if (dsf <= 0) Trap1(RE_NOT_DEFINED, word); // change error !!! } *DSF_ARGS(dsf, -index) = *value; }
*/ void Assert_Public_Object(REBVAL *value) /* ***********************************************************************/ { REBVAL *word = BLK_HEAD(VAL_OBJ_WORDS(value)); for (; NOT_END(word); word++) if (VAL_GET_OPT(word, OPTS_HIDE)) Trap0(RE_HIDDEN); }
*/ REBSER *Compress(REBSER *input, REBINT index, REBINT len, REBFLG use_crc) /* ** Compress a binary (only). ** data ** /part ** length ** /crc32 ** ** Note: If the file length is "small", it can't overrun on ** compression too much so we use our magic numbers; otherwise, ** we'll just be safe by a percentage of the file size. This may ** be a bit much, though. ** ***********************************************************************/ { REBCNT size; REBSER *output; REBINT err; REBYTE out_size[4]; if (len < 0) Trap0(RE_PAST_END); // !!! better msg needed size = len + (len > STERLINGS_MAGIC_NUMBER ? len / 10 + 12 : STERLINGS_MAGIC_FIX); output = Make_Binary(size); //DISABLE_GC; // !!! why?? // dest, dest-len, src, src-len, level err = Z_compress2(BIN_HEAD(output), (uLongf*)&size, BIN_HEAD(input) + index, len, use_crc); if (err) { if (err == Z_MEM_ERROR) Trap0(RE_NO_MEMORY); SET_INTEGER(DS_RETURN, err); Trap1(RE_BAD_PRESS, DS_RETURN); //!!!provide error string descriptions } SET_STR_END(output, size); SERIES_TAIL(output) = size; Long_To_Bytes(out_size, (REBCNT)len); // Tag the size to the end. Append_Series(output, (REBYTE*)out_size, 4); if (SERIES_AVAIL(output) > 1024) // Is there wasted space? output = Copy_Series(output); // Trim it down if too big. !!! Revisit this based on mem alloc alg. //ENABLE_GC; return output; }
*/ void Trap_Port(REBCNT errnum, REBSER *port, REBINT err_code) /* ***********************************************************************/ { REBVAL *spec = OFV(port, STD_PORT_SPEC); REBVAL *val; if (!IS_OBJECT(spec)) Trap0(RE_INVALID_PORT); val = Get_Object(spec, STD_PORT_SPEC_HEAD_REF); // most informative if (IS_NONE(val)) val = Get_Object(spec, STD_PORT_SPEC_HEAD_TITLE); DS_PUSH_INTEGER(err_code); Trap2(errnum, val, DS_TOP); }
*/ void Protected(REBVAL *word) /* ** Throw an error if word is protected. ** ***********************************************************************/ { REBSER *frm; REBINT index = VAL_WORD_INDEX(word); if (index > 0) { frm = VAL_WORD_FRAME(word); if (VAL_PROTECTED(FRM_WORDS(frm)+index)) Trap1(RE_LOCKED_WORD, word); } else if (index == 0) Trap0(RE_SELF_PROTECTED); }
*/ void Bind_Stack_Block(REBSER *body, REBSER *block) /* ***********************************************************************/ { REBINT dsf = DSF; // Find body (frame) on stack: while (body != VAL_WORD_FRAME(DSF_WORD(dsf))) { dsf = PRIOR_DSF(dsf); if (dsf <= 0) Trap0(RE_NOT_DEFINED); // better message !!!! } if (IS_FUNCTION(DSF_FUNC(dsf))) { Bind_Relative(VAL_FUNC_ARGS(DSF_FUNC(dsf)), body, block); } }
static REBSER *make_string(REBVAL *arg, REBOOL make) { REBSER *ser = 0; // MAKE <type> 123 if (make && (IS_INTEGER(arg) || IS_DECIMAL(arg))) { ser = Make_Binary(Int32s(arg, 0)); } // MAKE/TO <type> <binary!> else if (IS_BINARY(arg)) { REBYTE *bp = VAL_BIN_DATA(arg); REBCNT len = VAL_LEN(arg); switch (What_UTF(bp, len)) { case 0: break; case 8: // UTF-8 encoded bp += 3; len -= 3; break; default: Trap0(RE_BAD_DECODE); } ser = Decode_UTF_String(bp, len, 8); // UTF-8 } // MAKE/TO <type> <any-string> else if (ANY_BINSTR(arg)) { ser = Copy_String(VAL_SERIES(arg), VAL_INDEX(arg), VAL_LEN(arg)); } // MAKE/TO <type> <any-word> else if (ANY_WORD(arg)) { ser = Copy_Mold_Value(arg, TRUE); //ser = Append_UTF8(0, Get_Word_Name(arg), -1); } // MAKE/TO <type> #"A" else if (IS_CHAR(arg)) { ser = (VAL_CHAR(arg) > 0xff) ? Make_Unicode(2) : Make_Binary(2); Append_Byte(ser, VAL_CHAR(arg)); } // MAKE/TO <type> <any-value> // else if (IS_NONE(arg)) { // ser = Make_Binary(0); // } else ser = Copy_Form_Value(arg, 1<<MOPT_TIGHT); return ser; }
*/ static void Loop_Integer(REBVAL *var, REBSER* body, REBI64 start, REBI64 end, REBI64 incr) /* ***********************************************************************/ { REBVAL *result; VAL_SET(var, REB_INTEGER); while ((incr > 0) ? start <= end : start >= end) { VAL_INT64(var) = start; result = Do_Blk(body, 0); if (THROWN(result) && Check_Error(result) >= 0) break; if (!IS_INTEGER(var)) Trap_Type(var); start = VAL_INT64(var); if (REB_I64_ADD_OF(start, incr, &start)) { Trap0(RE_OVERFLOW); } } }
*/ REBI64 Round_Int(REBI64 num, REBCNT flags, REBI64 scale) /* ** Identical to ROUND mezzanine function. ** Note: scale arg only valid if RF_TO is set ** ***********************************************************************/ { /* using safe unsigned arithmetic */ REBU64 sc, n, r, m, s; if (GET_FLAG(flags, RF_TO)) { if (scale == 0) Trap0(RE_ZERO_DIVIDE); sc = Int_Abs(scale); } else sc = 1; n = Int_Abs(num); r = n % sc; s = sc - r; if (r == 0) return num; if (flags & RB_DFC) { if (GET_FLAG(flags, RF_DOWN)) {Int_Trunc; return num;} if (GET_FLAG(flags, RF_FLOOR)) {Int_Floor; return num;} Int_Ceil; return num; } /* "genuine" rounding */ if (r < s) {Int_Trunc; return num;} else if (r > s) {Int_Away; return num;} /* half */ if (GET_FLAG(flags, RF_EVEN)) { if ((n / sc) & 1) {Int_Away; return num;} else {Int_Trunc; return num;} } if (GET_FLAG(flags, RF_HALF_DOWN)) {Int_Trunc; return num;} if (GET_FLAG(flags, RF_HALF_CEILING)) {Int_Ceil; return num;} Int_Away; return num; /* this is round_half_away */ }
*/ REBDCI Round_Deci(REBDCI num, REBCNT flags, REBDCI scale) /* ** Identical to ROUND mezzanine function. ** Note: scale arg only valid if RF_TO is set ** ***********************************************************************/ { REBDCI deci_one = {1u, 0u, 0u, 0u, 0}; if (GET_FLAG(flags, RF_TO)) { if (deci_is_zero(scale)) Trap0(RE_ZERO_DIVIDE); scale = deci_abs(scale); } else scale = deci_one; if (GET_FLAG(flags, RF_EVEN)) return deci_half_even(num, scale); if (GET_FLAG(flags, RF_DOWN)) return deci_truncate(num, scale); if (GET_FLAG(flags, RF_HALF_DOWN)) return deci_half_truncate(num, scale); if (GET_FLAG(flags, RF_FLOOR)) return deci_floor(num, scale); if (GET_FLAG(flags, RF_CEILING)) return deci_ceil(num, scale); if (GET_FLAG(flags, RF_HALF_CEILING)) return deci_half_ceil(num, scale); return deci_half_away(num, scale); }
*/ 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 REBCNT Parse_Rules_Loop(REBPARSE *parse, REBCNT index, REBVAL *rules, REBCNT depth) /* ***********************************************************************/ { REBSER *series = parse->series; REBVAL *item; // current rule item REBVAL *word; // active word to be set REBCNT start; // recovery restart point REBCNT i; // temp index point REBCNT begin; // point at beginning of match REBINT count; // iterated pattern counter REBINT mincount; // min pattern count REBINT maxcount; // max pattern count REBVAL *item_hold; REBVAL *val; // spare REBCNT rulen; REBSER *ser; REBFLG flags; REBCNT cmd; REBVAL *rule_head = rules; CHECK_STACK(&flags); //if (depth > MAX_PARSE_DEPTH) Trap_Word(RE_LIMIT_HIT, SYM_PARSE, 0); flags = 0; word = 0; mincount = maxcount = 1; start = begin = index; // For each rule in the rule block: while (NOT_END(rules)) { //Print_Parse_Index(parse->type, rules, series, index); if (--Eval_Count <= 0 || Eval_Signals) Do_Signals(); //-------------------------------------------------------------------- // Pre-Rule Processing Section // // For non-iterated rules, including setup for iterated rules. // The input index is not advanced here, but may be changed by // a GET-WORD variable. //-------------------------------------------------------------------- item = rules++; // If word, set-word, or get-word, process it: if (VAL_TYPE(item) >= REB_WORD && VAL_TYPE(item) <= REB_GET_WORD) { // Is it a command word? if (cmd = VAL_CMD(item)) { if (!IS_WORD(item)) Trap1(RE_PARSE_COMMAND, item); // SET or GET not allowed if (cmd <= SYM_BREAK) { // optimization switch (cmd) { case SYM_OR_BAR: return index; // reached it successfully // Note: mincount = maxcount = 1 on entry case SYM_WHILE: SET_FLAG(flags, PF_WHILE); case SYM_ANY: mincount = 0; case SYM_SOME: maxcount = MAX_I32; continue; case SYM_OPT: mincount = 0; continue; case SYM_COPY: SET_FLAG(flags, PF_COPY); case SYM_SET: SET_FLAG(flags, PF_SET); item = rules++; if (!IS_WORD(item)) Trap1(RE_PARSE_VARIABLE, item); if (VAL_CMD(item)) Trap1(RE_PARSE_COMMAND, item); word = item; continue; case SYM_NOT: SET_FLAG(flags, PF_NOT); flags ^= (1<<PF_NOT2); continue; case SYM_AND: SET_FLAG(flags, PF_AND); continue; case SYM_THEN: SET_FLAG(flags, PF_THEN); continue; case SYM_REMOVE: SET_FLAG(flags, PF_REMOVE); continue; case SYM_INSERT: SET_FLAG(flags, PF_INSERT); goto post; case SYM_CHANGE: SET_FLAG(flags, PF_CHANGE); continue; case SYM_RETURN: if (IS_PAREN(rules)) { item = Do_Block_Value_Throw(rules); // might GC Throw_Return_Value(item); } SET_FLAG(flags, PF_RETURN); continue; case SYM_ACCEPT: case SYM_BREAK: parse->result = 1; return index; case SYM_REJECT: parse->result = -1; return index; case SYM_FAIL: index = NOT_FOUND; goto post; case SYM_IF: item = rules++; if (IS_END(item)) goto bad_end; if (!IS_PAREN(item)) Trap1(RE_PARSE_RULE, item); item = Do_Block_Value_Throw(item); // might GC if (IS_TRUE(item)) continue; else { index = NOT_FOUND; goto post; } case SYM_LIMIT: Trap0(RE_NOT_DONE); //val = Get_Parse_Value(rules++); // if (IS_INTEGER(val)) limit = index + Int32(val); // else if (ANY_SERIES(val)) limit = VAL_INDEX(val); // else goto //goto bad_rule; // goto post; case SYM_QQ: Print_Parse_Index(parse->type, rules, series, index); continue; } } // Any other cmd must be a match command, so proceed... } else { // It's not a PARSE command, get or set it: // word: - set a variable to the series at current index if (IS_SET_WORD(item)) { Set_Var_Series(item, parse->type, series, index); continue; } // :word - change the index for the series to a new position if (IS_GET_WORD(item)) { item = Get_Var(item); // CureCode #1263 change //if (parse->type != VAL_TYPE(item) || VAL_SERIES(item) != series) // Trap1(RE_PARSE_SERIES, rules-1); if (!ANY_SERIES(item)) Trap1(RE_PARSE_SERIES, rules-1); index = Set_Parse_Series(parse, item); series = parse->series; continue; } // word - some other variable if (IS_WORD(item)) { item = Get_Var(item); } // item can still be 'word or /word } } else if (ANY_PATH(item)) { item = Do_Parse_Path(item, parse, &index); // index can be modified if (index > series->tail) index = series->tail; if (item == 0) continue; // for SET and GET cases } if (IS_PAREN(item)) { Do_Block_Value_Throw(item); // might GC if (index > series->tail) index = series->tail; continue; } // Counter? 123 if (IS_INTEGER(item)) { // Specify count or range count SET_FLAG(flags, PF_WHILE); mincount = maxcount = Int32s(item, 0); item = Get_Parse_Value(rules++); if (IS_END(item)) Trap1(RE_PARSE_END, rules-2); if (IS_INTEGER(item)) { maxcount = Int32s(item, 0); item = Get_Parse_Value(rules++); if (IS_END(item)) Trap1(RE_PARSE_END, rules-2); } } // else fall through on other values and words //-------------------------------------------------------------------- // Iterated Rule Matching Section: // // Repeats the same rule N times or until the rule fails. // The index is advanced and stored in a temp variable i until // the entire rule has been satisfied. //-------------------------------------------------------------------- item_hold = item; // a command or literal match value if (VAL_TYPE(item) <= REB_UNSET || VAL_TYPE(item) >= REB_NATIVE) goto bad_rule; begin = index; // input at beginning of match section rulen = 0; // rules consumed (do not use rule++ below) i = index; //note: rules var already advanced for (count = 0; count < maxcount;) { item = item_hold; if (IS_WORD(item)) { switch (cmd = VAL_WORD_CANON(item)) { case SYM_SKIP: i = (index < series->tail) ? index+1 : NOT_FOUND; break; case SYM_END: i = (index < series->tail) ? NOT_FOUND : series->tail; break; case SYM_TO: case SYM_THRU: if (IS_END(rules)) goto bad_end; item = Get_Parse_Value(rules); rulen = 1; i = Parse_To(parse, index, item, cmd == SYM_THRU); break; case SYM_QUOTE: if (IS_END(rules)) goto bad_end; rulen = 1; if (IS_PAREN(rules)) { item = Do_Block_Value_Throw(rules); // might GC } else item = rules; i = (0 == Cmp_Value(BLK_SKIP(series, index), item, parse->flags & AM_FIND_CASE)) ? index+1 : NOT_FOUND; break; case SYM_INTO: if (IS_END(rules)) goto bad_end; rulen = 1; item = Get_Parse_Value(rules); // sub-rules if (!IS_BLOCK(item)) goto bad_rule; val = BLK_SKIP(series, index); i = ( (ANY_BINSTR(val) || ANY_BLOCK(val)) && (Parse_Series(val, VAL_BLK_DATA(item), parse->flags, depth+1) == VAL_TAIL(val)) ) ? index+1 : NOT_FOUND; break; case SYM_DO: if (!IS_BLOCK_INPUT(parse)) goto bad_rule; i = Do_Eval_Rule(parse, index, &rules); rulen = 1; break; default: goto bad_rule; } } else if (IS_BLOCK(item)) { item = VAL_BLK_DATA(item); //if (IS_END(rules) && item == rule_head) { // rules = item; // goto top; //} i = Parse_Rules_Loop(parse, index, item, depth+1); if (parse->result) { index = (parse->result > 0) ? i : NOT_FOUND; parse->result = 0; break; } } // Parse according to datatype: else { if (IS_BLOCK_INPUT(parse)) i = Parse_Next_Block(parse, index, item, depth+1); else i = Parse_Next_String(parse, index, item, depth+1); } // Necessary for special cases like: some [to end] // i: indicates new index or failure of the match, but // that does not mean failure of the rule, because optional // matches can still succeed, if if the last match failed. if (i != NOT_FOUND) { count++; // may overflow to negative if (count < 0) count = MAX_I32; // the forever case // If input did not advance: if (i == index && !GET_FLAG(flags, PF_WHILE)) { if (count < mincount) index = NOT_FOUND; // was not enough break; } } //if (i >= series->tail) { // OLD check: no more input else { if (count < mincount) index = NOT_FOUND; // was not enough else if (i != NOT_FOUND) index = i; // else keep index as is. break; } index = i; // A BREAK word stopped us: //if (parse->result) {parse->result = 0; break;} } rules += rulen; //if (index > series->tail && index != NOT_FOUND) index = series->tail; if (index > series->tail) index = NOT_FOUND; //-------------------------------------------------------------------- // Post Match Processing: //-------------------------------------------------------------------- post: // Process special flags: if (flags) { // NOT before all others: if (GET_FLAG(flags, PF_NOT)) { if (GET_FLAG(flags, PF_NOT2) && index != NOT_FOUND) index = NOT_FOUND; else index = begin; } if (index == NOT_FOUND) { // Failure actions: // not decided: if (word) Set_Var_Basic(word, REB_NONE); if (GET_FLAG(flags, PF_THEN)) { SKIP_TO_BAR(rules); if (!IS_END(rules)) rules++; } } else { // Success actions: count = (begin > index) ? 0 : index - begin; // how much we advanced the input if (GET_FLAG(flags, PF_COPY)) { ser = (IS_BLOCK_INPUT(parse)) ? Copy_Block_Len(series, begin, count) : Copy_String(series, begin, count); // condenses Set_Var_Series(word, parse->type, ser, 0); } else if (GET_FLAG(flags, PF_SET)) { if (IS_BLOCK_INPUT(parse)) { item = Get_Var_Safe(word); if (count == 0) SET_NONE(item); else *item = *BLK_SKIP(series, begin); } else { item = Get_Var_Safe(word); if (count == 0) SET_NONE(item); else { i = GET_ANY_CHAR(series, begin); if (parse->type == REB_BINARY) { SET_INTEGER(item, i); } else { SET_CHAR(item, i); } } } } if (GET_FLAG(flags, PF_RETURN)) { ser = (IS_BLOCK_INPUT(parse)) ? Copy_Block_Len(series, begin, count) : Copy_String(series, begin, count); // condenses Throw_Return_Series(parse->type, ser); } if (GET_FLAG(flags, PF_REMOVE)) { if (count) Remove_Series(series, begin, count); index = begin; } if (flags & (1<<PF_INSERT | 1<<PF_CHANGE)) { count = GET_FLAG(flags, PF_INSERT) ? 0 : count; cmd = GET_FLAG(flags, PF_INSERT) ? 0 : (1<<AN_PART); item = rules++; if (IS_END(item)) goto bad_end; // Check for ONLY flag: if (IS_WORD(item) && NZ(cmd = VAL_CMD(item))) { if (cmd != SYM_ONLY) goto bad_rule; cmd |= (1<<AN_ONLY); item = rules++; } // CHECK FOR QUOTE!! item = Get_Parse_Value(item); // new value if (IS_UNSET(item)) Trap1(RE_NO_VALUE, rules-1); if (IS_END(item)) goto bad_end; if (IS_BLOCK_INPUT(parse)) { index = Modify_Block(GET_FLAG(flags, PF_CHANGE) ? A_CHANGE : A_INSERT, series, begin, item, cmd, count, 1); if (IS_LIT_WORD(item)) SET_TYPE(BLK_SKIP(series, index-1), REB_WORD); } else { if (parse->type == REB_BINARY) cmd |= (1<<AN_SERIES); // special flag index = Modify_String(GET_FLAG(flags, PF_CHANGE) ? A_CHANGE : A_INSERT, series, begin, item, cmd, count, 1); } } if (GET_FLAG(flags, PF_AND)) index = begin; } flags = 0; word = 0; } // Goto alternate rule and reset input: if (index == NOT_FOUND) { SKIP_TO_BAR(rules); if (IS_END(rules)) break; rules++; index = begin = start; } begin = index; mincount = maxcount = 1; } return index; bad_rule: Trap1(RE_PARSE_RULE, rules-1); bad_end: Trap1(RE_PARSE_END, rules-1); return 0; }
static void Append_Obj(REBSER *obj, REBVAL *arg) { REBCNT i, len; REBVAL *word, *val; REBINT *binds; // for binding table // Can be a word: if (ANY_WORD(arg)) { if (!Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE)) { // bug fix, 'self is protected only in selfish frames if ((VAL_WORD_CANON(arg) == SYM_SELF) && !IS_SELFLESS(obj)) Trap0(RE_SELF_PROTECTED); Expand_Frame(obj, 1, 1); // copy word table also Append_Frame(obj, 0, VAL_WORD_SYM(arg)); // val is UNSET } return; } if (!IS_BLOCK(arg)) Trap_Arg(arg); // Process word/value argument block: arg = VAL_BLK_DATA(arg); // Use binding table binds = WORDS_HEAD(Bind_Table); // Handle selfless Collect_Start(IS_SELFLESS(obj) ? BIND_NO_SELF | BIND_ALL : BIND_ALL); // Setup binding table with obj words: Collect_Object(obj); // Examine word/value argument block for (word = arg; NOT_END(word); word += 2) { if (!IS_WORD(word) && !IS_SET_WORD(word)) { // release binding table BLK_TERM(BUF_WORDS); Collect_End(obj); Trap_Arg(word); } if (NZ(i = binds[VAL_WORD_CANON(word)])) { // bug fix, 'self is protected only in selfish frames: if ((VAL_WORD_CANON(word) == SYM_SELF) && !IS_SELFLESS(obj)) { // release binding table BLK_TERM(BUF_WORDS); Collect_End(obj); Trap0(RE_SELF_PROTECTED); } } else { // collect the word binds[VAL_WORD_CANON(word)] = SERIES_TAIL(BUF_WORDS); EXPAND_SERIES_TAIL(BUF_WORDS, 1); val = BLK_LAST(BUF_WORDS); *val = *word; } if (IS_END(word + 1)) break; // fix bug#708 } BLK_TERM(BUF_WORDS); // Append new words to obj len = SERIES_TAIL(obj); Expand_Frame(obj, SERIES_TAIL(BUF_WORDS) - len, 1); for (word = BLK_SKIP(BUF_WORDS, len); NOT_END(word); word++) Append_Frame(obj, 0, VAL_WORD_SYM(word)); // Set new values to obj words for (word = arg; NOT_END(word); word += 2) { i = binds[VAL_WORD_CANON(word)]; val = FRM_VALUE(obj, i); if (GET_FLAGS(VAL_OPTS(FRM_WORD(obj, i)), OPTS_HIDE, OPTS_LOCK)) { // release binding table Collect_End(obj); if (VAL_PROTECTED(FRM_WORD(obj, i))) Trap1(RE_LOCKED_WORD, FRM_WORD(obj, i)); Trap0(RE_HIDDEN); } if (IS_END(word + 1)) SET_NONE(val); else *val = word[1]; if (IS_END(word + 1)) break; // fix bug#708 } // release binding table Collect_End(obj); }
static void Append_Obj(REBSER *obj, REBVAL *arg) { REBCNT i; REBCNT len = 0; REBVAL *val; REBVAL *start = arg; // Can be a word: if (ANY_WORD(arg)) { if (!Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE)) { if (VAL_WORD_CANON(arg) == SYM_SELF) Trap0(RE_SELF_PROTECTED); Expand_Frame(obj, 1, 1); // copy word table also Append_Frame(obj, 0, VAL_WORD_SYM(arg)); // val is UNSET } return; } if (!IS_BLOCK(arg)) Trap_Arg(arg); // Verify word/value argument block: for (arg = VAL_BLK_DATA(arg); NOT_END(arg); arg += 2) { if (!IS_WORD(arg) && !IS_SET_WORD(arg)) Trap_Arg(arg); if (NZ(i = Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE))) { // Just change the value, do not append it. val = FRM_VALUE(obj, i); if (GET_FLAGS(VAL_OPTS(FRM_WORD(obj, i)), OPTS_HIDE, OPTS_LOCK)) { // Back out... reset any prior flags: for (; arg != VAL_BLK_DATA(start); arg -= 2) VAL_CLR_OPT(arg, OPTS_TEMP); if (VAL_PROTECTED(FRM_WORD(obj, i))) Trap1(RE_LOCKED_WORD, FRM_WORD(obj, i)); Trap0(RE_HIDDEN); } // Problem above: what about prior OPTS_FLAGS? Ok to leave them as is? if (IS_END(arg+1)) SET_NONE(val); else *val = arg[1]; VAL_SET_OPT(arg, OPTS_TEMP); } else { if (VAL_WORD_CANON(arg) == SYM_SELF) Trap0(RE_SELF_PROTECTED); len++; // was: Trap1(RE_DUP_VARS, arg); } if (IS_END(arg+1)) break; // fix bug#708 } // Append new values to end of frame (if necessary): if (len > 0) { Expand_Frame(obj, len, 1); // copy word table also for (arg = VAL_BLK_DATA(start); NOT_END(arg); arg += 2) { if (VAL_GET_OPT(arg, OPTS_TEMP)) VAL_CLR_OPT(arg, OPTS_TEMP); else { val = Append_Frame(obj, 0, VAL_WORD_SYM(arg)); if (IS_END(arg+1)) { SET_NONE(val); break; } else *val = arg[1]; } } } }
*/ void Trap_Image() /* ***********************************************************************/ { Trap0(RE_BAD_MEDIA); }
*/ REBINT Emit_Decimal(REBYTE *cp, REBDEC d, REBFLG percent, REBYTE point, REBINT digits) /* ***********************************************************************/ { REBYTE out[MAX_NUMCHR]; REBINT len; REBINT n; REBINT i; REBI64 sig; REBINT pt; REBFLG neg; REBYTE *start = cp; *cp = out[0] = 0; // Deal with 0 as special case: if (d == 0.0 || d == -0.0) { *cp++ = '0'; if (!percent) { *cp++ = '.'; *cp++ = '0'; } } else { if (percent) d *= 100.0; if (NZ(neg = (d < 0))) d = -d; if (Convert_Decimal(d, &sig, &pt)) { // Not exp format. len = Form_Integer(out, sig) - out; if (neg) *cp++ = '-'; // Trim un-needed trailing zeros: for (len--; len > 0 && len >= pt; len--) { if (out[len] == '0') out[len] = 0; else break; } // Leading zero, as in 0.1 if (pt <= 0) *cp++ = '0'; // Other leading digits: for (n = 0; out[n] && n < pt; n++) *cp++ = out[n]; if (!percent || n <= len) { // Decimal point: *cp++ = point; // Zeros before first significant digit: for (i = 0; i > pt; i--) *cp++ = '0'; // All remaining digits: for (; n <= len; n++) *cp++ = out[n]; // Force extra zero in 1.0 cases: if (cp[-1] == point) *cp++ = '0'; } } else { REBYTE *pp; // Requires exp format: if (percent) Trap0(RE_OVERFLOW); len = Get_System_Int(SYS_OPTIONS, OPTIONS_DECIMAL_DIGITS, MAX_DIGITS); if (len > MAX_DIGITS) len = MAX_DIGITS; gcvt(d, len, cp); // returns 1.2e123 (also 1e123) pp = strchr(cp, '.'); if (pp && (pp[1] == 'e' || pp[1] == 'E')) { memcpy(pp, pp+1, strlen(pp)); } if (point != '.' && pp) { cp = strchr(cp, '.'); if (cp) *cp = point; } cp = start + LEN_BYTES(start); } } if (percent) *cp++ = '%'; *cp = 0; return cp - start; }
void Trap_Temp(void) { Trap0(501); //!!! temp trap function }