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