*/ void Sieve_Ports(REBSER *ports)
/*
** Remove all ports not found in the WAKE list.
** ports could be NULL, in which case the WAKE list is cleared.
**
***********************************************************************/
{
REBVAL *port;
REBVAL *waked;
REBVAL *val;
REBCNT n;
port = Get_System(SYS_PORTS, PORTS_SYSTEM);
if (!IS_PORT(port)) return;
waked = VAL_OBJ_VALUE(port, STD_PORT_DATA);
if (!IS_BLOCK(waked)) return;
for (n = 0; ports && n < SERIES_TAIL(ports);) {
val = BLK_SKIP(ports, n);
if (IS_PORT(val)) {
assert(VAL_TAIL(waked) != 0);
if (VAL_TAIL(waked) == Find_Block_Simple(VAL_SERIES(waked), 0, val)) {//not found
Remove_Series(ports, n, 1);
continue;
}
}
n++;
}
//clear waked list
RESET_SERIES(VAL_SERIES(waked));
}
STOID Mold_File(REBVAL *value, REB_MOLD *mold)
{
REBUNI *dp;
REBCNT n;
REBUNI c;
REBCNT len = VAL_LEN(value);
REBSER *ser = VAL_SERIES(value);
// Compute extra space needed for hex encoded characters:
for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
c = GET_ANY_CHAR(ser, n);
if (IS_FILE_ESC(c)) len += 2;
}
len++; // room for % at start
dp = Prep_Uni_Series(mold, len);
*dp++ = '%';
for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
c = GET_ANY_CHAR(ser, n);
if (IS_FILE_ESC(c)) dp = Form_Hex_Esc_Uni(dp, c); // c => %xx
else *dp++ = c;
}
*dp = 0;
}
*/ static void Loop_Series(REBVAL *out, REBVAL *var, REBSER* body, REBVAL *start, REBINT ei, REBINT ii)
/*
***********************************************************************/
{
REBINT si = VAL_INDEX(start);
REBCNT type = VAL_TYPE(start);
*var = *start;
if (ei >= cast(REBINT, VAL_TAIL(start)))
ei = cast(REBINT, VAL_TAIL(start));
if (ei < 0) ei = 0;
SET_NONE(out); // Default result to NONE if the loop does not run
for (; (ii > 0) ? si <= ei : si >= ei; si += ii) {
VAL_INDEX(var) = si;
if (!DO_BLOCK(out, body, 0) && Check_Error(out) >= 0) break;
if (VAL_TYPE(var) != type) Trap1(RE_INVALID_TYPE, var);
si = VAL_INDEX(var);
}
}
*/ static void Loop_Series(REBVAL *out, REBVAL *var, REBSER* body, REBVAL *start, REBINT ei, REBINT ii)
/*
***********************************************************************/
{
REBINT si = VAL_INDEX(start);
REBCNT type = VAL_TYPE(start);
*var = *start;
if (ei >= cast(REBINT, VAL_TAIL(start)))
ei = cast(REBINT, VAL_TAIL(start));
if (ei < 0) ei = 0;
SET_NONE(out); // Default result to NONE if the loop does not run
for (; (ii > 0) ? si <= ei : si >= ei; si += ii) {
VAL_INDEX(var) = si;
if (Do_Block_Throws(out, body, 0)) {
if (Loop_Throw_Should_Return(out)) break;
}
if (VAL_TYPE(var) != type) raise Error_1(RE_INVALID_TYPE, var);
si = VAL_INDEX(var);
}
}
*/ REBCNT Val_Byte_Len(REBVAL *value)
/*
** Get length of series in bytes.
**
***********************************************************************/
{
if (VAL_INDEX(value) >= VAL_TAIL(value)) return 0;
return (VAL_TAIL(value) - VAL_INDEX(value)) * SERIES_WIDE(VAL_SERIES(value));
}
*/ REBCNT Val_Series_Len(REBVAL *value)
/*
** Get length of series, but avoid negative values.
**
***********************************************************************/
{
if (VAL_INDEX(value) >= VAL_TAIL(value)) return 0;
return VAL_TAIL(value) - VAL_INDEX(value);
}
*/ static REBCNT Set_Parse_Series(REBPARSE *parse, REBVAL *item)
/*
** Change the series and return the new index.
**
***********************************************************************/
{
parse->series = VAL_SERIES(item);
parse->type = VAL_TYPE(item);
if (IS_BINARY(item) || (parse->flags & PF_CASED)) parse->flags |= PF_CASE;
else parse->flags &= ~PF_CASE;
return (VAL_INDEX(item) > VAL_TAIL(item)) ? VAL_TAIL(item) : VAL_INDEX(item);
}
*/ REBINT Awake_System(REBSER *ports, REBINT only)
/*
** Returns:
** -1 for errors
** 0 for nothing to do
** 1 for wait is satisifed
**
***********************************************************************/
{
REBVAL *port;
REBVAL *state;
REBVAL *waked;
REBVAL *awake;
REBVAL tmp;
REBVAL ref_only;
REBINT result;
REBVAL out;
// Get the system port object:
port = Get_System(SYS_PORTS, PORTS_SYSTEM);
if (!IS_PORT(port)) return -10; // verify it is a port object
// Get wait queue block (the state field):
state = VAL_OBJ_VALUE(port, STD_PORT_STATE);
if (!IS_BLOCK(state)) return -10;
//Debug_Num("S", VAL_TAIL(state));
// Get waked queue block:
waked = VAL_OBJ_VALUE(port, STD_PORT_DATA);
if (!IS_BLOCK(waked)) return -10;
// If there is nothing new to do, return now:
if (VAL_TAIL(state) == 0 && VAL_TAIL(waked) == 0) return -1;
//Debug_Num("A", VAL_TAIL(waked));
// Get the system port AWAKE function:
awake = VAL_OBJ_VALUE(port, STD_PORT_AWAKE);
if (!ANY_FUNC(awake)) return -1;
if (ports) Val_Init_Block(&tmp, ports);
else SET_NONE(&tmp);
if (only) SET_TRUE(&ref_only);
else SET_NONE(&ref_only);
// Call the system awake function:
if (Apply_Func_Throws(&out, awake, port, &tmp, &ref_only, 0))
raise Error_No_Catch_For_Throw(&out);
// Awake function returns 1 for end of WAIT:
result = (IS_LOGIC(&out) && VAL_LOGIC(&out)) ? 1 : 0;
return result;
}
*/ REBFLG MT_String(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
REBCNT i;
if (!ANY_BINSTR(data)) return FALSE;
*out = *data++;
VAL_SET(out, type);
i = IS_INTEGER(data) ? Int32(data) - 1 : 0;
if (i > VAL_TAIL(out)) i = VAL_TAIL(out); // clip it
VAL_INDEX(out) = i;
return TRUE;
}
*/ REBINT PD_Block(REBPVS *pvs)
/*
***********************************************************************/
{
REBINT n = 0;
/* Issues!!!
a/1.3
a/not-found: 10 error or append?
a/not-followed: 10 error or append?
*/
if (IS_INTEGER(pvs->select)) {
n = Int32(pvs->select) + VAL_INDEX(pvs->value) - 1;
}
else if (IS_WORD(pvs->select)) {
n = Find_Word(VAL_SERIES(pvs->value), VAL_INDEX(pvs->value), VAL_WORD_CANON(pvs->select));
if (n != NOT_FOUND) n++;
}
else {
// other values:
n = Find_Block_Simple(VAL_SERIES(pvs->value), VAL_INDEX(pvs->value), pvs->select) + 1;
}
if (n < 0 || (REBCNT)n >= VAL_TAIL(pvs->value)) {
if (pvs->setval) return PE_BAD_SELECT;
return PE_NONE;
}
if (pvs->setval) TRAP_PROTECT(VAL_SERIES(pvs->value));
pvs->value = VAL_BLK_SKIP(pvs->value, n);
// if valset - check PROTECT on block
//if (NOT_END(pvs->path+1)) Next_Path(pvs); return PE_OK;
return PE_SET;
}
*/ REBVAL *Append_Event()
/*
** Append an event to the end of the current event port queue.
** Return a pointer to the event value.
**
** Note: this function may be called from out of environment,
** so do NOT extend the event queue here. If it does not have
** space, return 0. (Should it overwrite or wrap???)
**
***********************************************************************/
{
REBVAL *port;
REBVAL *value;
REBVAL *state;
port = Get_System(SYS_PORTS, PORTS_SYSTEM);
if (!IS_PORT(port)) return 0; // verify it is a port object
// Get queue block:
state = VAL_BLK_SKIP(port, STD_PORT_STATE);
if (!IS_BLOCK(state)) return 0;
// Append to tail if room:
if (SERIES_FULL(VAL_SERIES(state))) Crash(RP_MAX_EVENTS);
VAL_TAIL(state)++;
value = VAL_BLK_TAIL(state);
SET_END(value);
value--;
SET_NONE(value);
//Dump_Series(VAL_SERIES(state), "state");
//Print("Tail: %d %d", VAL_TAIL(state), nn++);
return value;
}
*/ REBFLG MT_Block(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
REBCNT i;
if (!ANY_BLOCK(data)) return FALSE;
if (type >= REB_PATH && type <= REB_LIT_PATH)
if (!ANY_WORD(VAL_BLK(data))) return FALSE;
*out = *data++;
VAL_SET(out, type);
i = IS_INTEGER(data) ? Int32(data) - 1 : 0;
if (i > VAL_TAIL(out)) i = VAL_TAIL(out); // clip it
VAL_INDEX(out) = i;
return TRUE;
}
*/ REBINT PD_String(REBPVS *pvs)
/*
***********************************************************************/
{
REBVAL *data = pvs->value;
REBVAL *val = pvs->setval;
REBINT n = 0;
REBCNT i;
REBINT c;
REBSER *ser = VAL_SERIES(data);
if (IS_INTEGER(pvs->select)) {
n = Int32(pvs->select) + VAL_INDEX(data) - 1;
}
else return PE_BAD_SELECT;
if (val == 0) {
if (n < 0 || (REBCNT)n >= SERIES_TAIL(ser)) return PE_NONE;
if (IS_BINARY(data)) {
SET_INTEGER(pvs->store, *BIN_SKIP(ser, n));
} else {
SET_CHAR(pvs->store, GET_ANY_CHAR(ser, n));
}
return PE_USE;
}
if (n < 0 || (REBCNT)n >= SERIES_TAIL(ser)) return PE_BAD_RANGE;
if (IS_CHAR(val)) {
c = VAL_CHAR(val);
if (c > MAX_CHAR) return PE_BAD_SET;
}
else if (IS_INTEGER(val)) {
c = Int32(val);
if (c > MAX_CHAR || c < 0) return PE_BAD_SET;
if (IS_BINARY(data)) { // special case for binary
if (c > 0xff) Trap_Range(val);
BIN_HEAD(ser)[n] = (REBYTE)c;
return PE_OK;
}
}
else if (ANY_BINSTR(val)) {
i = VAL_INDEX(val);
if (i >= VAL_TAIL(val)) return PE_BAD_SET;
c = GET_ANY_CHAR(VAL_SERIES(val), i);
}
else
return PE_BAD_SELECT;
TRAP_PROTECT(ser);
if (BYTE_SIZE(ser) && c > 0xff) Widen_String(ser);
SET_ANY_CHAR(ser, n, c);
return PE_OK;
}
*/ REBVAL *Pick_Block(REBVAL *block, REBVAL *selector)
/*
***********************************************************************/
{
REBINT n = 0;
n = Get_Num_Arg(selector);
n += VAL_INDEX(block) - 1;
if (n < 0 || (REBCNT)n >= VAL_TAIL(block)) return 0;
return VAL_BLK_SKIP(block, n);
}
*/ REBFLG Check_Bit_Str(REBSER *bset, REBVAL *val, REBFLG uncased)
/*
** If uncased is TRUE, try to match either upper or lower case.
**
***********************************************************************/
{
REBCNT n = VAL_INDEX(val);
if (VAL_BYTE_SIZE(val)) {
REBYTE *bp = VAL_BIN(val);
for (; n < VAL_TAIL(val); n++)
if (Check_Bit(bset, bp[n], uncased)) return TRUE;
}
else {
REBUNI *up = VAL_UNI(val);
for (; n < VAL_TAIL(val); n++)
if (Check_Bit(bset, up[n], uncased)) return TRUE;
}
return FALSE;
}
*/ static void Loop_Series(REBVAL *var, REBSER* body, REBVAL *start, REBINT ei, REBINT ii)
/*
***********************************************************************/
{
REBVAL *result;
REBINT si = VAL_INDEX(start);
REBCNT type = VAL_TYPE(start);
*var = *start;
if (ei >= (REBINT)VAL_TAIL(start)) ei = (REBINT)VAL_TAIL(start);
if (ei < 0) ei = 0;
for (; (ii > 0) ? si <= ei : si >= ei; si += ii) {
VAL_INDEX(var) = si;
result = Do_Blk(body, 0);
if (THROWN(result) && Check_Error(result) >= 0) break;
if (VAL_TYPE(var) != type) Trap1(RE_INVALID_TYPE, var);
si = VAL_INDEX(var);
}
}
*/ REBINT Partial1(REBVAL *sval, REBVAL *lval)
/*
** Process the /part (or /skip) and other length modifying
** arguments.
**
***********************************************************************/
{
REBI64 len;
REBINT maxlen;
REBINT is_ser = ANY_SERIES(sval);
// If lval = NONE, use the current len of the target value:
if (IS_NONE(lval)) {
if (!is_ser) return 1;
if (VAL_INDEX(sval) >= VAL_TAIL(sval)) return 0;
return (VAL_TAIL(sval) - VAL_INDEX(sval));
}
if (IS_INTEGER(lval) || IS_DECIMAL(lval)) len = Int32(lval);
else {
if (is_ser && VAL_TYPE(sval) == VAL_TYPE(lval) && VAL_SERIES(sval) == VAL_SERIES(lval))
len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(sval);
else
Trap1(RE_INVALID_PART, lval);
}
if (is_ser) {
// Restrict length to the size available:
if (len >= 0) {
maxlen = (REBINT)VAL_LEN(sval);
if (len > maxlen) len = maxlen;
} else {
len = -len;
if (len > (REBINT)VAL_INDEX(sval)) len = (REBINT)VAL_INDEX(sval);
VAL_INDEX(sval) -= (REBCNT)len;
}
}
return (REBINT)len;
}
static void Mold_Url(const REBVAL *value, REB_MOLD *mold)
{
REBUNI *dp;
REBCNT n;
REBUNI c;
REBCNT len = VAL_LEN(value);
REBSER *ser = VAL_SERIES(value);
// Compute extra space needed for hex encoded characters:
for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
c = GET_ANY_CHAR(ser, n);
if (IS_URL_ESC(c)) len += 2;
}
dp = Prep_Uni_Series(mold, len);
for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
c = GET_ANY_CHAR(ser, n);
if (IS_URL_ESC(c)) dp = Form_Hex_Esc_Uni(dp, c); // c => %xx
else *dp++ = c;
}
*dp = 0;
}
STOID Mold_Issue(REBVAL *value, REB_MOLD *mold)
{
REBUNI *dp;
REBCNT n;
REBUNI c;
REBSER *ser = VAL_SERIES(value);
dp = Prep_Uni_Series(mold, VAL_LEN(value)+1); // '#' extra
*dp++ = '#';
for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
c = GET_ANY_CHAR(ser, n);
if (IS_LEX_DELIMIT(c)) c = '?';
*dp++ = c;
}
*dp = 0;
}
xx*/ void Dump_Block_Raw(REBSER *series, int depth, int max_depth)
/*
***********************************************************************/
{
REBVAL *val;
REBCNT n;
REBYTE *str;
if (!IS_BLOCK_SERIES(series) || depth > max_depth) return;
for (n = 0, val = BLK_HEAD(series); NOT_END(val); val++, n++) {
Debug_Chars(' ', depth * 4);
if (IS_BLOCK(val)) {
Debug_Fmt("%3d: [%s] len: %d", n, Get_Type_Name(val), VAL_TAIL(val));
Dump_Block_Raw(VAL_SERIES(val), depth + 1, max_depth);
} else {
str = "";
if (ANY_WORD(val)) str = Get_Word_Name(val);
Debug_Fmt("%3d: [%s] %s", n, Get_Type_Name(val), str);
}
}
//if (depth == 2) Input_Str();
}
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');
}
}
STOID Mold_Block(REBVAL *value, REB_MOLD *mold)
{
REBYTE *sep;
REBOOL all = GET_MOPT(mold, MOPT_MOLD_ALL);
REBSER *series = mold->series;
REBFLG over = FALSE;
if (SERIES_WIDE(VAL_SERIES(value)) == 0)
Crash(RP_BAD_WIDTH, sizeof(REBVAL), 0, VAL_TYPE(value));
// Optimize when no index needed:
if (VAL_INDEX(value) == 0 && !IS_MAP(value)) // && (VAL_TYPE(value) <= REB_LIT_PATH))
all = FALSE;
// If out of range, do not cause error to avoid error looping.
if (VAL_INDEX(value) >= VAL_TAIL(value)) over = TRUE; // Force it into []
if (all || (over && !IS_BLOCK(value) && !IS_PAREN(value))) {
SET_FLAG(mold->opts, MOPT_MOLD_ALL);
Pre_Mold(value, mold); // #[block! part
//if (over) Append_Bytes(mold->series, "[]");
//else
Mold_Block_Series(mold, VAL_SERIES(value), 0, 0);
Post_Mold(value, mold);
}
else
{
switch(VAL_TYPE(value)) {
case REB_MAP:
Pre_Mold(value, mold);
sep = 0;
case REB_BLOCK:
if (GET_MOPT(mold, MOPT_ONLY)) {
CLR_FLAG(mold->opts, MOPT_ONLY); // only top level
sep = "\000\000";
}
else sep = 0;
break;
case REB_PAREN:
sep = "()";
break;
case REB_GET_PATH:
series = Append_Byte(series, ':');
sep = "/";
break;
case REB_LIT_PATH:
series = Append_Byte(series, '\'');
/* fall through */
case REB_PATH:
case REB_SET_PATH:
sep = "/";
break;
}
if (over) Append_Bytes(mold->series, sep ? sep : (REBYTE*)("[]"));
else Mold_Block_Series(mold, VAL_SERIES(value), VAL_INDEX(value), sep);
if (VAL_TYPE(value) == REB_SET_PATH)
Append_Byte(series, ':');
}
}
STOID Mold_String_Series(REBVAL *value, REB_MOLD *mold)
{
REBCNT len = VAL_LEN(value);
REBSER *ser = VAL_SERIES(value);
REBCNT idx = VAL_INDEX(value);
REB_STRF sf = {0};
REBYTE *bp;
REBUNI *up;
REBUNI *dp;
REBOOL uni = !BYTE_SIZE(ser);
REBCNT n;
REBUNI c;
// Empty string:
if (idx >= VAL_TAIL(value)) {
Append_Bytes(mold->series, "\"\""); //Trap0(RE_PAST_END);
return;
}
Sniff_String(ser, idx, &sf);
if (!GET_MOPT(mold, MOPT_ANSI_ONLY)) sf.paren = 0;
// Source can be 8 or 16 bits:
if (uni) up = UNI_HEAD(ser);
else bp = STR_HEAD(ser);
// If it is a short quoted string, emit it as "string":
if (len <= MAX_QUOTED_STR && sf.quote == 0 && sf.newline < 3) {
dp = Prep_Uni_Series(mold, len + sf.newline + sf.escape + sf.paren + sf.chr1e + 2);
*dp++ = '"';
for (n = idx; n < VAL_TAIL(value); n++) {
c = uni ? up[n] : (REBUNI)(bp[n]);
dp = Emit_Uni_Char(dp, c, (REBOOL)GET_MOPT(mold, MOPT_ANSI_ONLY)); // parened
}
*dp++ = '"';
*dp = 0;
return;
}
// It is a braced string, emit it as {string}:
if (!sf.malign) sf.brace_in = sf.brace_out = 0;
dp = Prep_Uni_Series(mold, len + sf.brace_in + sf.brace_out + sf.escape + sf.paren + sf.chr1e + 2);
*dp++ = '{';
for (n = idx; n < VAL_TAIL(value); n++) {
c = uni ? up[n] : (REBUNI)(bp[n]);
switch (c) {
case '{':
case '}':
if (sf.malign) {
*dp++ = '^';
*dp++ = c;
break;
}
case '\n':
case '"':
*dp++ = c;
break;
default:
dp = Emit_Uni_Char(dp, c, (REBOOL)GET_MOPT(mold, MOPT_ANSI_ONLY)); // parened
}
}
*dp++ = '}';
*dp = 0;
}
//
// Make_Set_Operation_Series: C
//
// Do set operations on a series. Case-sensitive if `cased` is TRUE.
// `skip` is the record size.
//
static REBSER *Make_Set_Operation_Series(const REBVAL *val1, const REBVAL *val2, REBCNT flags, REBCNT cased, REBCNT skip)
{
REBSER *buffer; // buffer for building the return series
REBCNT i;
REBINT h = TRUE;
REBFLG first_pass = TRUE; // are we in the first pass over the series?
REBSER *out_ser;
// This routine should only be called with SERIES! values
assert(ANY_SERIES(val1));
if (val2) {
assert(ANY_SERIES(val2));
if (ANY_ARRAY(val1)) {
if (!ANY_ARRAY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
// As long as they're both arrays, we're willing to do:
//
// >> union quote (a b c) 'b/d/e
// (a b c d e)
//
// The type of the result will match the first value.
}
else if (!IS_BINARY(val1)) {
// We will similarly do any two ANY-STRING! types:
//
// >> union <abc> "bde"
// <abcde>
if (IS_BINARY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
}
else {
// Binaries only operate with other binaries
if (!IS_BINARY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
}
}
// Calculate i as length of result block.
i = VAL_LEN(val1);
if (flags & SOP_FLAG_BOTH) i += VAL_LEN(val2);
if (ANY_ARRAY(val1)) {
REBSER *hser = 0; // hash table for series
REBSER *hret; // hash table for return series
buffer = BUF_EMIT; // use preallocated shared block
Resize_Series(buffer, i);
hret = Make_Hash_Sequence(i); // allocated
// Optimization note: !!
// This code could be optimized for small blocks by not hashing them
// and extending Find_Key to do a FIND on the value itself w/o the hash.
do {
REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass!
// Check what is in series1 but not in series2:
if (flags & SOP_FLAG_CHECK)
hser = Hash_Block(val2, cased);
// Iterate over first series:
i = VAL_INDEX(val1);
for (; i < SERIES_TAIL(ser); i += skip) {
REBVAL *item = BLK_SKIP(ser, i);
if (flags & SOP_FLAG_CHECK) {
h = Find_Key(VAL_SERIES(val2), hser, item, skip, cased, 1);
h = (h >= 0);
if (flags & SOP_FLAG_INVERT) h = !h;
}
if (h) Find_Key(buffer, hret, item, skip, cased, 2);
}
if (flags & SOP_FLAG_CHECK)
Free_Series(hser);
if (!first_pass) break;
first_pass = FALSE;
// Iterate over second series?
if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
const REBVAL *temp = val1;
val1 = val2;
val2 = temp;
}
} while (i);
if (hret)
Free_Series(hret);
out_ser = Copy_Array_Shallow(buffer);
RESET_TAIL(buffer); // required - allow reuse
}
else {
if (IS_BINARY(val1)) {
// All binaries use "case-sensitive" comparison (e.g. each byte
// is treated distinctly)
cased = TRUE;
}
buffer = BUF_MOLD;
Reset_Buffer(buffer, i);
RESET_TAIL(buffer);
do {
REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass!
REBUNI uc;
// Iterate over first series:
i = VAL_INDEX(val1);
for (; i < SERIES_TAIL(ser); i += skip) {
uc = GET_ANY_CHAR(ser, i);
if (flags & SOP_FLAG_CHECK) {
h = (NOT_FOUND != Find_Str_Char(
VAL_SERIES(val2),
0,
VAL_INDEX(val2),
VAL_TAIL(val2),
skip,
uc,
cased ? AM_FIND_CASE : 0
));
if (flags & SOP_FLAG_INVERT) h = !h;
}
if (!h) continue;
if (
NOT_FOUND == Find_Str_Char(
buffer,
0,
0,
SERIES_TAIL(buffer),
skip,
uc,
cased ? AM_FIND_CASE : 0
)
) {
Append_String(buffer, ser, i, skip);
}
}
if (!first_pass) break;
first_pass = FALSE;
// Iterate over second series?
if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
const REBVAL *temp = val1;
val1 = val2;
val2 = temp;
}
} while (i);
out_ser = Copy_String(buffer, 0, -1);
}
return out_ser;
}
*/ 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;
}
*/ static REBINT Do_Set_Operation(struct Reb_Call *call_, REBCNT flags)
/*
** Do set operations on a series.
**
***********************************************************************/
{
REBVAL *val;
REBVAL *val1;
REBVAL *val2 = 0;
REBSER *ser;
REBSER *hser = 0; // hash table for series
REBSER *retser; // return series
REBSER *hret; // hash table for return series
REBCNT i;
REBINT h = TRUE;
REBCNT skip = 1; // record size
REBCNT cased = 0; // case sensitive when TRUE
SET_NONE(D_OUT);
val1 = D_ARG(1);
i = 2;
// Check for second series argument:
if (flags != SET_OP_UNIQUE) {
val2 = D_ARG(i++);
if (VAL_TYPE(val1) != VAL_TYPE(val2))
raise Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2));
}
// Refinements /case and /skip N
cased = D_REF(i++); // cased
if (D_REF(i++)) skip = Int32s(D_ARG(i), 1);
switch (VAL_TYPE(val1)) {
case REB_BLOCK:
i = VAL_LEN(val1);
// Setup result block:
if (GET_FLAG(flags, SOP_BOTH)) i += VAL_LEN(val2);
retser = BUF_EMIT; // use preallocated shared block
Resize_Series(retser, i);
hret = Make_Hash_Sequence(i); // allocated
// Optimization note: !!
// This code could be optimized for small blocks by not hashing them
// and extending Find_Key to do a FIND on the value itself w/o the hash.
do {
// Check what is in series1 but not in series2:
if (GET_FLAG(flags, SOP_CHECK))
hser = Hash_Block(val2, cased);
// Iterate over first series:
ser = VAL_SERIES(val1);
i = VAL_INDEX(val1);
for (; val = BLK_SKIP(ser, i), i < SERIES_TAIL(ser); i += skip) {
if (GET_FLAG(flags, SOP_CHECK)) {
h = Find_Key(VAL_SERIES(val2), hser, val, skip, cased, 1) >= 0;
if (GET_FLAG(flags, SOP_INVERT)) h = !h;
}
if (h) Find_Key(retser, hret, val, skip, cased, 2);
}
// Iterate over second series?
if ((i = GET_FLAG(flags, SOP_BOTH))) {
val = val1;
val1 = val2;
val2 = val;
CLR_FLAG(flags, SOP_BOTH);
}
if (GET_FLAG(flags, SOP_CHECK))
Free_Series(hser);
} while (i);
if (hret)
Free_Series(hret);
Val_Init_Block(D_OUT, Copy_Array_Shallow(retser));
RESET_TAIL(retser); // required - allow reuse
break;
case REB_BINARY:
cased = TRUE;
SET_TYPE(D_OUT, REB_BINARY);
case REB_STRING:
i = VAL_LEN(val1);
// Setup result block:
if (GET_FLAG(flags, SOP_BOTH)) i += VAL_LEN(val2);
retser = BUF_MOLD;
Reset_Buffer(retser, i);
RESET_TAIL(retser);
do {
REBUNI uc;
cased = cased ? AM_FIND_CASE : 0;
// Iterate over first series:
ser = VAL_SERIES(val1);
i = VAL_INDEX(val1);
for (; i < SERIES_TAIL(ser); i += skip) {
uc = GET_ANY_CHAR(ser, i);
if (GET_FLAG(flags, SOP_CHECK)) {
h = Find_Str_Char(VAL_SERIES(val2), 0, VAL_INDEX(val2), VAL_TAIL(val2), skip, uc, cased) != NOT_FOUND;
if (GET_FLAG(flags, SOP_INVERT)) h = !h;
}
if (h && (Find_Str_Char(retser, 0, 0, SERIES_TAIL(retser), skip, uc, cased) == NOT_FOUND)) {
Append_String(retser, ser, i, skip);
}
}
// Iterate over second series?
if ((i = GET_FLAG(flags, SOP_BOTH))) {
val = val1;
val1 = val2;
val2 = val;
CLR_FLAG(flags, SOP_BOTH);
}
} while (i);
ser = Copy_String(retser, 0, -1);
if (IS_BINARY(D_OUT))
Val_Init_Binary(D_OUT, ser);
else
Val_Init_String(D_OUT, ser);
break;
case REB_BITSET:
switch (flags) {
case SET_OP_UNIQUE:
return R_ARG1;
case SET_OP_UNION:
i = A_OR;
break;
case SET_OP_INTERSECT:
i = A_AND;
break;
case SET_OP_DIFFERENCE:
i = A_XOR;
break;
case SET_OP_EXCLUDE:
i = 0; // special case
break;
}
ser = Xandor_Binary(i, val1, val2);
Val_Init_Bitset(D_OUT, ser);
break;
case REB_TYPESET:
switch (flags) {
case SET_OP_UNIQUE:
break;
case SET_OP_UNION:
VAL_TYPESET(val1) |= VAL_TYPESET(val2);
break;
case SET_OP_INTERSECT:
VAL_TYPESET(val1) &= VAL_TYPESET(val2);
break;
case SET_OP_DIFFERENCE:
VAL_TYPESET(val1) ^= VAL_TYPESET(val2);
break;
case SET_OP_EXCLUDE:
VAL_TYPESET(val1) &= ~VAL_TYPESET(val2);
break;
}
return R_ARG1;
default:
raise Error_Invalid_Arg(val1);
}
return R_OUT;
}
x*/ void Modify_StringX(REBCNT action, REBVAL *string, REBVAL *arg)
/*
** Actions: INSERT, APPEND, CHANGE
**
** string [string!] {Series at point to insert}
** value [any-type!] {The value to insert}
** /part {Limits to a given length or position.}
** length [number! series! pair!]
** /only {Inserts a series as a series.}
** /dup {Duplicates the insert a specified number of times.}
** count [number! pair!]
**
***********************************************************************/
{
REBSER *series = VAL_SERIES(string);
REBCNT index = VAL_INDEX(string);
REBCNT tail = VAL_TAIL(string);
REBINT rlen; // length to be removed
REBINT ilen = 1; // length to be inserted
REBINT cnt = 1; // DUP count
REBINT size;
REBVAL *val;
REBSER *arg_ser = 0; // argument series
// Length of target (may modify index): (arg can be anything)
rlen = Partial1((action == A_CHANGE) ? string : arg, DS_ARG(AN_LENGTH));
index = VAL_INDEX(string);
if (action == A_APPEND || index > tail) index = tail;
// If the arg is not a string, then we need to create a string:
if (IS_BINARY(string)) {
if (IS_INTEGER(arg)) {
if (VAL_INT64(arg) > 255 || VAL_INT64(arg) < 0)
Trap_Range(arg);
arg_ser = Make_Binary(1);
Append_Byte(arg_ser, VAL_CHAR(arg)); // check for size!!!
}
else if (!ANY_BINSTR(arg)) Trap_Arg(arg);
}
else if (IS_BLOCK(arg)) {
// MOVE!
REB_MOLD mo = {0};
arg_ser = mo.series = Make_Unicode(VAL_BLK_LEN(arg) * 10); // GC!?
for (val = VAL_BLK_DATA(arg); NOT_END(val); val++)
Mold_Value(&mo, val, 0);
}
else if (IS_CHAR(arg)) {
// Optimize this case !!!
arg_ser = Make_Unicode(1);
Append_Byte(arg_ser, VAL_CHAR(arg));
}
else if (!ANY_STR(arg) || IS_TAG(arg)) {
arg_ser = Copy_Form_Value(arg, 0);
}
if (arg_ser) Set_String(arg, arg_ser);
else arg_ser = VAL_SERIES(arg);
// Length of insertion:
ilen = (action != A_CHANGE && DS_REF(AN_PART)) ? rlen : VAL_LEN(arg);
// If Source == Destination we need to prevent possible conflicts.
// Clone the argument just to be safe.
// (Note: It may be possible to optimize special cases like append !!)
if (series == VAL_SERIES(arg)) {
arg_ser = Copy_Series_Part(arg_ser, VAL_INDEX(arg), ilen); // GC!?
}
// Get /DUP count:
if (DS_REF(AN_DUP)) {
cnt = Int32(DS_ARG(AN_COUNT));
if (cnt <= 0) return; // no changes
}
// Total to insert:
size = cnt * ilen;
if (action != A_CHANGE) {
// Always expand series for INSERT and APPEND actions:
Expand_Series(series, index, size);
} else {
if (size > rlen)
Expand_Series(series, index, size-rlen);
else if (size < rlen && DS_REF(AN_PART))
Remove_Series(series, index, rlen-size);
else if (size + index > tail) {
EXPAND_SERIES_TAIL(series, size - (tail - index));
}
}
// For dup count:
for (; cnt > 0; cnt--) {
Insert_String(series, index, arg_ser, VAL_INDEX(arg), ilen, TRUE);
index += ilen;
}
TERM_SERIES(series);
VAL_INDEX(string) = (action == A_APPEND) ? 0 : index;
}
*/ REBCNT Get_Part_Length(REBVAL *bval, REBVAL *eval)
/*
** Determine the length of a /PART value.
** If /PART value is an integer just use it.
** If it is a series and it is the same series as the first,
** use the difference between the two indices.
**
** If the length ends up negative, back up the index as much
** as possible. If backed up over the head, adjust the length.
**
** Note: This one does not handle list datatypes.
**
***********************************************************************/
{
REBINT len;
REBCNT tail;
if (IS_INTEGER(eval) || IS_DECIMAL(eval)) {
len = Int32(eval);
if (IS_SCALAR(bval) && VAL_TYPE(bval) != REB_PORT)
Trap1(RE_INVALID_PART, bval);
}
else if (
(
// IF normal series and self referencing:
VAL_TYPE(eval) >= REB_STRING &&
VAL_TYPE(eval) <= REB_BLOCK &&
VAL_TYPE(bval) == VAL_TYPE(eval) &&
VAL_SERIES(bval) == VAL_SERIES(eval)
) || (
// OR IF it is a port:
IS_PORT(bval) && IS_PORT(eval) &&
VAL_OBJ_FRAME(bval) == VAL_OBJ_FRAME(eval)
)
)
len = (REBINT)VAL_INDEX(eval) - (REBINT)VAL_INDEX(bval);
else
Trap1(RE_INVALID_PART, eval);
/* !!!!
if (IS_PORT(bval)) {
PORT_STATE_OBJ *port;
port = VAL_PORT(&VAL_PSP(bval)->state);
if (PORT_FLAG(port) & PF_DIRECT)
tail = 0x7fffffff;
else
tail = PORT_TAIL(VAL_PORT(&VAL_PSP(bval)->state));
}
else
*/ tail = VAL_TAIL(bval);
if (len < 0) {
len = -len;
if (len > (REBINT)VAL_INDEX(bval))
len = (REBINT)VAL_INDEX(bval);
VAL_INDEX(bval) -= (REBCNT)len;
}
else if (!IS_INTEGER(eval) && (len + VAL_INDEX(bval)) > tail)
len = (REBINT)(tail - VAL_INDEX(bval));
return (REBCNT)len;
}
*/ REBINT Partial(REBVAL *aval, REBVAL *bval, REBVAL *lval, REBFLG flag)
/*
** Args:
** aval: target value
** bval: argument to modify target (optional)
** lval: length value (or none)
**
** Determine the length of a /PART value. It can be:
** 1. integer or decimal
** 2. relative to A value (bval is null)
** 3. relative to B value
**
** Flag: indicates special treatment for CHANGE. As in:
** CHANGE/part "abcde" "xy" 3 => "xyde"
**
** NOTE: Can modify the value's index!
** The result can be negative. ???
**
***********************************************************************/
{
REBVAL *val;
REBINT len;
REBINT maxlen;
// If lval = NONE, use the current len of the target value:
if (IS_NONE(lval)) {
val = (bval && ANY_SERIES(bval)) ? bval : aval;
if (VAL_INDEX(val) >= VAL_TAIL(val)) return 0;
return (VAL_TAIL(val) - VAL_INDEX(val));
}
if (IS_INTEGER(lval)) {
len = Int32(lval);
val = flag ? aval : bval;
}
else if (IS_DECIMAL(lval)) {
len = Int32(lval);
val = bval;
}
else {
// So, lval must be relative to aval or bval series:
if (VAL_TYPE(aval) == VAL_TYPE(lval) && VAL_SERIES(aval) == VAL_SERIES(lval))
val = aval;
else if (bval && VAL_TYPE(bval) == VAL_TYPE(lval) && VAL_SERIES(bval) == VAL_SERIES(lval))
val = bval;
else
Trap1(RE_INVALID_PART, lval);
len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(val);
}
if (!val) val = aval;
// Restrict length to the size available:
if (len >= 0) {
maxlen = (REBINT)VAL_LEN(val);
if (len > maxlen) len = maxlen;
} else {
len = -len;
if (len > (REBINT)VAL_INDEX(val)) len = (REBINT)VAL_INDEX(val);
VAL_INDEX(val) -= (REBCNT)len;
// if ((-len) > (REBINT)VAL_INDEX(val)) len = -(REBINT)VAL_INDEX(val);
}
return len;
}
static REBSER *make_binary(REBVAL *arg, REBOOL make)
{
REBSER *ser;
// MAKE BINARY! 123
switch (VAL_TYPE(arg)) {
case REB_INTEGER:
case REB_DECIMAL:
if (make) ser = Make_Binary(Int32s(arg, 0));
else ser = Make_Binary_BE64(arg);
break;
// MAKE/TO BINARY! BINARY!
case REB_BINARY:
ser = Copy_Bytes(VAL_BIN_DATA(arg), VAL_LEN(arg));
break;
// MAKE/TO BINARY! <any-string>
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
// case REB_ISSUE:
ser = Encode_UTF8_Value(arg, VAL_LEN(arg), 0);
break;
case REB_BLOCK:
ser = Join_Binary(arg);
break;
// MAKE/TO BINARY! <tuple!>
case REB_TUPLE:
ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg));
break;
// MAKE/TO BINARY! <char!>
case REB_CHAR:
ser = Make_Binary(6);
ser->tail = Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg));
break;
// MAKE/TO BINARY! <bitset!>
case REB_BITSET:
ser = Copy_Bytes(VAL_BIN(arg), VAL_TAIL(arg));
break;
// MAKE/TO BINARY! <image!>
case REB_IMAGE:
ser = Make_Image_Binary(arg);
break;
case REB_MONEY:
ser = Make_Binary(12);
ser->tail = 12;
deci_to_binary(ser->data, VAL_DECI(arg));
ser->data[12] = 0;
break;
default:
ser = 0;
}
return ser;
}