*/ static REBSER *Init_Loop(REBVAL *spec, REBVAL *body_blk, REBSER **fram)
/*
** Initialize standard for loops (copy block, make frame, bind).
** Spec: WORD or [WORD ...]
**
***********************************************************************/
{
REBSER *frame;
REBINT len;
REBVAL *word;
REBVAL *vals;
REBSER *body;
// For :WORD format, get the var's value:
if (IS_GET_WORD(spec)) spec = Get_Var(spec);
// Hand-make a FRAME (done for for speed):
len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1;
if (len == 0) Trap_Arg(spec);
frame = Make_Frame(len);
SET_SELFLESS(frame);
SERIES_TAIL(frame) = len+1;
SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1;
// Setup for loop:
word = FRM_WORD(frame, 1); // skip SELF
vals = BLK_SKIP(frame, 1);
if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec);
// Optimally create the FOREACH frame:
while (len-- > 0) {
if (!IS_WORD(spec) && !IS_SET_WORD(spec)) {
// Prevent inconsistent GC state:
Free_Series(FRM_WORD_SERIES(frame));
Free_Series(frame);
Trap_Arg(spec);
}
VAL_SET(word, VAL_TYPE(spec));
VAL_BIND_SYM(word) = VAL_WORD_SYM(spec);
VAL_BIND_TYPESET(word) = ALL_64;
word++;
SET_NONE(vals);
vals++;
spec++;
}
SET_END(word);
SET_END(vals);
body = Clone_Block_Value(body_blk);
Bind_Block(frame, BLK_HEAD(body), BIND_DEEP);
*fram = frame;
return body;
}
*/ static REBSER *Init_Loop(const REBVAL *spec, REBVAL *body_blk, REBSER **fram)
/*
** Initialize standard for loops (copy block, make frame, bind).
** Spec: WORD or [WORD ...]
**
***********************************************************************/
{
REBSER *frame;
REBINT len;
REBVAL *word;
REBVAL *vals;
REBSER *body;
// For :WORD format, get the var's value:
if (IS_GET_WORD(spec)) spec = GET_VAR(spec);
// Hand-make a FRAME (done for for speed):
len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1;
if (len == 0) raise Error_Invalid_Arg(spec);
frame = Make_Frame(len, FALSE);
SERIES_TAIL(frame) = len+1;
SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1;
// Setup for loop:
word = FRM_WORD(frame, 1); // skip SELF
vals = BLK_SKIP(frame, 1);
if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec);
// Optimally create the FOREACH frame:
while (len-- > 0) {
if (!IS_WORD(spec) && !IS_SET_WORD(spec)) {
// Prevent inconsistent GC state:
Free_Series(FRM_WORD_SERIES(frame));
Free_Series(frame);
raise Error_Invalid_Arg(spec);
}
Val_Init_Word_Typed(word, VAL_TYPE(spec), VAL_WORD_SYM(spec), ALL_64);
word++;
SET_NONE(vals);
vals++;
spec++;
}
SET_END(word);
SET_END(vals);
body = Copy_Array_At_Deep_Managed(
VAL_SERIES(body_blk), VAL_INDEX(body_blk)
);
Bind_Values_Deep(BLK_HEAD(body), frame);
*fram = frame;
return body;
}
*/ void Expand_Hash(REBSER *ser)
/*
** Expand hash series. Clear it but set its tail.
**
***********************************************************************/
{
REBSER oser;
REBSER *nser;
REBINT pnum;
pnum = Get_Hash_Prime(ser->tail+1);
if (!pnum) Trap_Num(RE_SIZE_LIMIT, ser->tail+1);
nser = Make_Series(pnum+1, SERIES_WIDE(ser), TRUE);
LABEL_SERIES(nser, "hash series");
oser = *ser;
*ser = *nser;
ser->info = oser.info;
*nser = oser;
Clear_Series(ser);
ser->tail = pnum;
Free_Series(nser);
}
//
// RL_Do_Binary: C
//
// Evaluate an encoded binary script such as compressed text.
//
// Returns:
// The datatype of the result or zero if error in the encoding.
// Arguments:
// bin - by default, a REBOL compressed UTF-8 (or ASCII) script.
// length - the length of the data.
// flags - special flags (set to zero at this time).
// key - encoding, encryption, or signature key.
// result - value returned from evaluation.
// Notes:
// As of A104, only compressed scripts are supported, however,
// rebin, cloaked, signed, and encrypted formats will be supported.
//
RL_API int RL_Do_Binary(
int *exit_status,
const REBYTE *bin,
REBINT length,
REBCNT flags,
REBCNT key,
RXIARG *out
) {
REBSER *text;
#ifdef DUMP_INIT_SCRIPT
int f;
#endif
int maybe_rxt; // could be REBRXT, or negative number for error :-/
text = Decompress(bin, length, -1, FALSE, FALSE);
if (!text) return 0;
Append_Codepoint_Raw(text, 0);
#ifdef DUMP_INIT_SCRIPT
f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE );
_write(f, BIN_HEAD(text), LEN_BYTES(BIN_HEAD(text)));
_close(f);
#endif
PUSH_GUARD_SERIES(text);
maybe_rxt = RL_Do_String(exit_status, BIN_HEAD(text), flags, out);
DROP_GUARD_SERIES(text);
Free_Series(text);
return maybe_rxt;
}
*/ void Enable_Backtrace(REBFLG on)
/*
***********************************************************************/
{
if (on) {
if (Trace_Limit == 0) {
Trace_Limit = 100000;
Trace_Buffer = Make_Binary(Trace_Limit);
KEEP_SERIES(Trace_Buffer, "trace-buffer"); // !!! use better way
}
}
else {
if (Trace_Limit) Free_Series(Trace_Buffer);
Trace_Limit = 0;
Trace_Buffer = 0;
}
}
*/ static REBSER *Decode_Base2(const REBYTE **src, REBCNT len, REBYTE delim)
/*
***********************************************************************/
{
REBYTE *bp;
const REBYTE *cp;
REBCNT count = 0;
REBINT accum = 0;
REBYTE lex;
REBSER *ser;
ser = Make_Binary(len >> 3);
bp = BIN_HEAD(ser);
cp = *src;
for (; len > 0; cp++, len--) {
if (delim && *cp == delim) break;
lex = Lex_Map[*cp];
if (lex >= LEX_NUMBER) {
if (*cp == '0') accum *= 2;
else if (*cp == '1') accum = (accum * 2) + 1;
else goto err;
if (count++ >= 7) {
*bp++ = (REBYTE)accum;
count = 0;
accum = 0;
}
}
else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
}
if (count) goto err; // improper modulus
*bp = 0;
ser->tail = bp - STR_HEAD(ser);
return ser;
err:
Free_Series(ser);
*src = cp;
return 0;
}
*/ RL_API int RL_Do_Binary(int *exit_status, const REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result)
/*
** Evaluate an encoded binary script such as compressed text.
**
** Returns:
** The datatype of the result or zero if error in the encoding.
** Arguments:
** bin - by default, a REBOL compressed UTF-8 (or ASCII) script.
** length - the length of the data.
** flags - special flags (set to zero at this time).
** key - encoding, encryption, or signature key.
** result - value returned from evaluation.
** Notes:
** As of A104, only compressed scripts are supported, however,
** rebin, cloaked, signed, and encrypted formats will be supported.
**
***********************************************************************/
{
REBSER *text;
#ifdef DUMP_INIT_SCRIPT
int f;
#endif
int do_result;
text = Decompress(bin, length, -1, FALSE, FALSE);
if (!text) return FALSE;
Append_Codepoint_Raw(text, 0);
#ifdef DUMP_INIT_SCRIPT
f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE );
_write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text)));
_close(f);
#endif
PUSH_GUARD_SERIES(text);
do_result = RL_Do_String(exit_status, text->data, flags, result);
DROP_GUARD_SERIES(text);
Free_Series(text);
return do_result;
}
*/ static REBSER *Decode_Base16(const REBYTE **src, REBCNT len, REBYTE delim)
/*
***********************************************************************/
{
REBYTE *bp;
const REBYTE *cp;
REBCNT count = 0;
REBINT accum = 0;
REBYTE lex;
REBINT val;
REBSER *ser;
ser = Make_Binary(len / 2);
bp = STR_HEAD(ser);
cp = *src;
for (; len > 0; cp++, len--) {
if (delim && *cp == delim) break;
lex = Lex_Map[*cp];
if (lex > LEX_WORD) {
val = lex & LEX_VALUE; // char num encoded into lex
if (!val && lex < LEX_NUMBER) goto err; // invalid char (word but no val)
accum = (accum << 4) + val;
if (count++ & 1) *bp++ = (REBYTE)accum;
}
else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
}
if (count & 1) goto err; // improper modulus
*bp = 0;
ser->tail = bp - STR_HEAD(ser);
return ser;
err:
Free_Series(ser);
*src = cp;
return 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;
}
*/ 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;
}
//
// Modify_String: C
//
// Returns new dst_idx.
//
REBCNT Modify_String(
REBCNT action, // INSERT, APPEND, CHANGE
REBSER *dst_ser, // target
REBCNT dst_idx, // position
const REBVAL *src_val, // source
REBFLGS flags, // AN_PART
REBINT dst_len, // length to remove
REBINT dups // dup count
) {
REBSER *src_ser = 0;
REBCNT src_idx = 0;
REBCNT src_len;
REBCNT tail = SER_LEN(dst_ser);
REBINT size; // total to insert
REBOOL needs_free;
REBINT limit;
// For INSERT/PART and APPEND/PART
if (action != SYM_CHANGE && GET_FLAG(flags, AN_PART))
limit = dst_len; // should be non-negative
else
limit = -1;
if (limit == 0 || dups < 0) return (action == SYM_APPEND) ? 0 : dst_idx;
if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail;
// If the src_val is not a string, then we need to create a string:
if (GET_FLAG(flags, AN_SERIES)) { // used to indicate a BINARY series
if (IS_INTEGER(src_val)) {
src_ser = Make_Series_Codepoint(Int8u(src_val));
needs_free = TRUE;
limit = -1;
}
else if (IS_BLOCK(src_val)) {
src_ser = Join_Binary(src_val, limit); // NOTE: it's the shared FORM buffer!
needs_free = FALSE;
limit = -1;
}
else if (IS_CHAR(src_val)) {
//
// "UTF-8 was originally specified to allow codepoints with up to
// 31 bits (or 6 bytes). But with RFC3629, this was reduced to 4
// bytes max. to be more compatible to UTF-16." So depending on
// which RFC you consider "the UTF-8", max size is either 4 or 6.
//
src_ser = Make_Binary(6);
SET_SERIES_LEN(
src_ser,
Encode_UTF8_Char(BIN_HEAD(src_ser), VAL_CHAR(src_val))
);
needs_free = TRUE;
limit = -1;
}
else if (ANY_STRING(src_val)) {
src_len = VAL_LEN_AT(src_val);
if (limit >= 0 && src_len > cast(REBCNT, limit))
src_len = limit;
src_ser = Make_UTF8_From_Any_String(src_val, src_len, 0);
needs_free = TRUE;
limit = -1;
}
else if (!IS_BINARY(src_val))
fail (Error_Invalid_Arg(src_val));
}
else if (IS_CHAR(src_val)) {
src_ser = Make_Series_Codepoint(VAL_CHAR(src_val));
needs_free = TRUE;
}
else if (IS_BLOCK(src_val)) {
src_ser = Form_Tight_Block(src_val);
needs_free = TRUE;
}
else if (!ANY_STRING(src_val) || IS_TAG(src_val)) {
src_ser = Copy_Form_Value(src_val, 0);
needs_free = TRUE;
}
// Use either new src or the one that was passed:
if (src_ser) {
src_len = SER_LEN(src_ser);
}
else {
src_ser = VAL_SERIES(src_val);
src_idx = VAL_INDEX(src_val);
src_len = VAL_LEN_AT(src_val);
needs_free = FALSE;
}
if (limit >= 0) src_len = limit;
// 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 (dst_ser == src_ser) {
assert(!needs_free);
src_ser = Copy_Sequence_At_Len(src_ser, src_idx, src_len);
needs_free = TRUE;
src_idx = 0;
}
// Total to insert:
size = dups * src_len;
if (action != SYM_CHANGE) {
// Always expand dst_ser for INSERT and APPEND actions:
Expand_Series(dst_ser, dst_idx, size);
} else {
if (size > dst_len)
Expand_Series(dst_ser, dst_idx, size - dst_len);
else if (size < dst_len && GET_FLAG(flags, AN_PART))
Remove_Series(dst_ser, dst_idx, dst_len - size);
else if (size + dst_idx > tail) {
EXPAND_SERIES_TAIL(dst_ser, size - (tail - dst_idx));
}
}
// For dup count:
for (; dups > 0; dups--) {
Insert_String(dst_ser, dst_idx, src_ser, src_idx, src_len, TRUE);
dst_idx += src_len;
}
TERM_SEQUENCE(dst_ser);
if (needs_free) {
// If we did not use the series that was passed in, but rather
// created an internal temporary one, we need to free it.
Free_Series(src_ser);
}
return (action == SYM_APPEND) ? 0 : dst_idx;
}
//
// 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,
REBFLGS flags,
REBOOL cased,
REBCNT skip
) {
REBCNT i;
REBINT h = 1; // used for both logic true/false and hash check
REBOOL first_pass = TRUE; // are we in the first pass over the series?
REBSER *out_ser;
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 maximum length of result block. The temporary buffer
// will be allocated at this size, but copied out at the exact size of
// the actual result.
//
i = VAL_LEN_AT(val1);
if (flags & SOP_FLAG_BOTH) i += VAL_LEN_AT(val2);
if (ANY_ARRAY(val1)) {
REBSER *hser = 0; // hash table for series
REBSER *hret; // hash table for return series
// The buffer used for building the return series. Currently it
// reuses BUF_EMIT, because that buffer is not likely to be in
// use (emit doesn't call set operations, nor vice versa). However,
// other routines may get the same idea and start recursing so it
// may be better to use something more similar to the mold stack
// approach of marking off successive ranges in the array.
//
REBSER *buffer = ARR_SERIES(BUF_EMIT);
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 FIND on the value itself w/o the hash.
do {
REBARR *array1 = VAL_ARRAY(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, skip, cased);
// Iterate over first series
//
i = VAL_INDEX(val1);
for (; i < ARR_LEN(array1); i += skip) {
RELVAL *item = ARR_AT(array1, i);
if (flags & SOP_FLAG_CHECK) {
h = Find_Key_Hashed(
VAL_ARRAY(val2),
hser,
item,
VAL_SPECIFIER(val1),
skip,
cased,
1
);
h = (h >= 0);
if (flags & SOP_FLAG_INVERT) h = !h;
}
if (h) {
Find_Key_Hashed(
AS_ARRAY(buffer),
hret,
item,
VAL_SPECIFIER(val1),
skip,
cased,
2
);
}
}
if (i != ARR_LEN(array1)) {
//
// In the current philosophy, the semantics of what to do
// with things like `intersect/skip [1 2 3] [7] 2` is too
// shaky to deal with, so an error is reported if it does
// not work out evenly to the skip size.
//
fail (Error(RE_BLOCK_SKIP_WRONG));
}
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 = ARR_SERIES(Copy_Array_Shallow(AS_ARRAY(buffer), SPECIFIED));
SET_SERIES_LEN(buffer, 0); // required - allow reuse
}
else {
REB_MOLD mo;
CLEARS(&mo);
if (IS_BINARY(val1)) {
//
// All binaries use "case-sensitive" comparison (e.g. each byte
// is treated distinctly)
//
cased = TRUE;
}
// ask mo.series to have at least `i` capacity beyond mo.start
//
mo.opts = MOPT_RESERVE;
mo.reserve = i;
Push_Mold(&mo);
do {
REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass!
REBUNI uc;
// Iterate over first series
//
i = VAL_INDEX(val1);
for (; i < SER_LEN(ser); i += skip) {
uc = GET_ANY_CHAR(ser, i);
if (flags & SOP_FLAG_CHECK) {
h = (NOT_FOUND != Find_Str_Char(
uc,
VAL_SERIES(val2),
0,
VAL_INDEX(val2),
VAL_LEN_HEAD(val2),
skip,
cased ? AM_FIND_CASE : 0
));
if (flags & SOP_FLAG_INVERT) h = !h;
}
if (!h) continue;
if (
NOT_FOUND == Find_Str_Char(
uc, // c2 (the character to find)
mo.series, // ser
mo.start, // head
mo.start, // index
SER_LEN(mo.series), // tail
skip, // skip
cased ? AM_FIND_CASE : 0 // flags
)
) {
Append_String(mo.series, 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 = Pop_Molded_String(&mo);
}
return out_ser;
}
*/ static REB_R File_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
** Internal port handler for files.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *path;
REBREQ *file = 0;
REBCNT args = 0;
REBCNT len;
REBOOL opened = FALSE; // had to be opened (shortcut case)
//Print("FILE ACTION: %r", Get_Action_Word(action));
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
// Validate PORT fields:
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) Trap1_DEAD_END(RE_INVALID_SPEC, spec);
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) Trap1_DEAD_END(RE_INVALID_SPEC, spec);
if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
else if (!IS_FILE(path)) Trap1_DEAD_END(RE_INVALID_SPEC, path);
// Get or setup internal state data:
file = (REBREQ*)Use_Port_State(port, RDI_FILE, sizeof(*file));
switch (action) {
case A_READ:
args = Find_Refines(call_, ALL_READ_REFS);
// Handle the READ %file shortcut case:
if (!IS_OPEN(file)) {
REBCNT nargs = AM_OPEN_READ;
if (args & AM_READ_SEEK) nargs |= AM_OPEN_SEEK;
Setup_File(file, nargs, path);
Open_File_Port(port, file, path);
opened = TRUE;
}
if (args & AM_READ_SEEK) Set_Seek(file, D_ARG(ARG_READ_INDEX));
len = Set_Length(
file, D_REF(ARG_READ_PART) ? VAL_INT64(D_ARG(ARG_READ_LENGTH)) : -1
);
Read_File_Port(D_OUT, port, file, path, args, len);
if (opened) {
OS_DO_DEVICE(file, RDC_CLOSE);
Cleanup_File(file);
}
if (file->error) Trap_Port_DEAD_END(RE_READ_ERROR, port, file->error);
break;
case A_APPEND:
if (!(IS_BINARY(D_ARG(2)) || IS_STRING(D_ARG(2)) || IS_BLOCK(D_ARG(2))))
Trap1_DEAD_END(RE_INVALID_ARG, D_ARG(2));
file->special.file.index = file->special.file.size;
SET_FLAG(file->modes, RFM_RESEEK);
case A_WRITE:
args = Find_Refines(call_, ALL_WRITE_REFS);
spec = D_ARG(2); // data (binary, string, or block)
// Handle the READ %file shortcut case:
if (!IS_OPEN(file)) {
REBCNT nargs = AM_OPEN_WRITE;
if (args & AM_WRITE_SEEK || args & AM_WRITE_APPEND) nargs |= AM_OPEN_SEEK;
else nargs |= AM_OPEN_NEW;
Setup_File(file, nargs, path);
Open_File_Port(port, file, path);
opened = TRUE;
}
else {
if (!GET_FLAG(file->modes, RFM_WRITE)) Trap1_DEAD_END(RE_READ_ONLY, path);
}
// Setup for /append or /seek:
if (args & AM_WRITE_APPEND) {
file->special.file.index = -1; // append
SET_FLAG(file->modes, RFM_RESEEK);
}
if (args & AM_WRITE_SEEK) Set_Seek(file, D_ARG(ARG_WRITE_INDEX));
// Determine length. Clip /PART to size of string if needed.
len = VAL_LEN(spec);
if (args & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LENGTH), 0);
if (n <= len) len = n;
}
Write_File_Port(file, spec, len, args);
if (opened) {
OS_DO_DEVICE(file, RDC_CLOSE);
Cleanup_File(file);
}
if (file->error) Trap1_DEAD_END(RE_WRITE_ERROR, path);
break;
case A_OPEN:
args = Find_Refines(call_, ALL_OPEN_REFS);
// Default file modes if not specified:
if (!(args & (AM_OPEN_READ | AM_OPEN_WRITE))) args |= (AM_OPEN_READ | AM_OPEN_WRITE);
Setup_File(file, args, path);
Open_File_Port(port, file, path); // !!! needs to change file modes to R/O if necessary
break;
case A_COPY:
if (!IS_OPEN(file)) Trap1_DEAD_END(RE_NOT_OPEN, path); //!!!! wrong msg
len = Set_Length(file, D_REF(2) ? VAL_INT64(D_ARG(3)) : -1);
Read_File_Port(D_OUT, port, file, path, args, len);
break;
case A_OPENQ:
if (IS_OPEN(file)) return R_TRUE;
return R_FALSE;
case A_CLOSE:
if (IS_OPEN(file)) {
OS_DO_DEVICE(file, RDC_CLOSE);
Cleanup_File(file);
}
break;
case A_DELETE:
if (IS_OPEN(file)) Trap1_DEAD_END(RE_NO_DELETE, path);
Setup_File(file, 0, path);
if (OS_DO_DEVICE(file, RDC_DELETE) < 0 ) Trap1_DEAD_END(RE_NO_DELETE, path);
break;
case A_RENAME:
if (IS_OPEN(file)) Trap1_DEAD_END(RE_NO_RENAME, path);
else {
REBSER *target;
Setup_File(file, 0, path);
// Convert file name to OS format:
if (!(target = Value_To_OS_Path(D_ARG(2), TRUE)))
Trap1_DEAD_END(RE_BAD_FILE_PATH, D_ARG(2));
file->common.data = BIN_DATA(target);
OS_DO_DEVICE(file, RDC_RENAME);
Free_Series(target);
if (file->error) Trap1_DEAD_END(RE_NO_RENAME, path);
}
break;
case A_CREATE:
// !!! should it leave file open???
if (!IS_OPEN(file)) {
Setup_File(file, AM_OPEN_WRITE | AM_OPEN_NEW, path);
if (OS_DO_DEVICE(file, RDC_CREATE) < 0) Trap_Port_DEAD_END(RE_CANNOT_OPEN, port, file->error);
OS_DO_DEVICE(file, RDC_CLOSE);
}
break;
case A_QUERY:
if (!IS_OPEN(file)) {
Setup_File(file, 0, path);
if (OS_DO_DEVICE(file, RDC_QUERY) < 0) return R_NONE;
}
Ret_Query_File(port, file, D_OUT);
// !!! free file path?
break;
case A_MODIFY:
Set_Mode_Value(file, Get_Mode_Id(D_ARG(2)), D_ARG(3));
if (!IS_OPEN(file)) {
Setup_File(file, 0, path);
if (OS_DO_DEVICE(file, RDC_MODIFY) < 0) return R_NONE;
}
return R_TRUE;
break;
case A_INDEXQ:
SET_INTEGER(D_OUT, file->special.file.index + 1);
break;
case A_LENGTHQ:
SET_INTEGER(D_OUT, file->special.file.size - file->special.file.index); // !clip at zero
break;
case A_HEAD:
file->special.file.index = 0;
goto seeked;
case A_TAIL:
file->special.file.index = file->special.file.size;
goto seeked;
case A_NEXT:
file->special.file.index++;
goto seeked;
case A_BACK:
if (file->special.file.index > 0) file->special.file.index--;
goto seeked;
case A_SKIP:
file->special.file.index += Get_Num_Arg(D_ARG(2));
goto seeked;
case A_HEADQ:
DECIDE(file->special.file.index == 0);
case A_TAILQ:
DECIDE(file->special.file.index >= file->special.file.size);
case A_PASTQ:
DECIDE(file->special.file.index > file->special.file.size);
case A_CLEAR:
// !! check for write enabled?
SET_FLAG(file->modes, RFM_RESEEK);
SET_FLAG(file->modes, RFM_TRUNCATE);
file->length = 0;
if (OS_DO_DEVICE(file, RDC_WRITE) < 0) Trap1_DEAD_END(RE_WRITE_ERROR, path);
break;
/* Not yet implemented:
A_AT, // 38
A_PICK, // 41
A_PATH, // 42
A_PATH_SET, // 43
A_FIND, // 44
A_SELECT, // 45
A_TAKE, // 49
A_INSERT, // 50
A_REMOVE, // 52
A_CHANGE, // 53
A_POKE, // 54
A_QUERY, // 64
A_FLUSH, // 65
*/
default:
Trap_Action_DEAD_END(REB_PORT, action);
}
return R_OUT;
seeked:
SET_FLAG(file->modes, RFM_RESEEK);
return R_ARG1;
is_true:
return R_TRUE;
is_false:
return R_FALSE;
}
*/ static int Dir_Actor(REBVAL *ds, REBSER *port, REBCNT action)
/*
** Internal port handler for file directories.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *path;
REBVAL *state;
REBREQ dir;
REBCNT args = 0;
REBINT result;
REBCNT len;
//REBYTE *flags;
Validate_Port(port, action);
*D_RET = *D_ARG(1);
CLEARS(&dir);
// Validate and fetch relevant PORT fields:
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) Trap1(RE_INVALID_SPEC, spec);
if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
else if (!IS_FILE(path)) Trap1(RE_INVALID_SPEC, path);
state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.
//flags = Security_Policy(SYM_FILE, path);
// Get or setup internal state data:
dir.port = port;
dir.device = RDI_FILE;
switch (action) {
case A_READ:
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(ds, ALL_READ_REFS);
if (!IS_BLOCK(state)) { // !!! ignores /SKIP and /PART, for now
Init_Dir_Path(&dir, path, 1, POL_READ);
Set_Block(state, Make_Block(7)); // initial guess
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
*D_RET = *state;
SET_NONE(state);
} else {
len = VAL_BLK_LEN(state);
// !!? Why does this need to copy the block??
Set_Block(D_RET, Copy_Block_Values(VAL_SERIES(state), 0, len, TS_STRING));
}
break;
case A_CREATE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
create:
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
result = OS_DO_DEVICE(&dir, RDC_CREATE);
///OS_FREE(dir.file.path);
if (result < 0) Trap1(RE_NO_CREATE, path);
if (action == A_CREATE) return R_ARG2;
SET_NONE(state);
break;
case A_RENAME:
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
else {
REBSER *target;
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
// Convert file name to OS format:
if (!(target = Value_To_OS_Path(D_ARG(2)))) Trap1(RE_BAD_FILE_PATH, D_ARG(2));
dir.data = BIN_DATA(target);
OS_DO_DEVICE(&dir, RDC_RENAME);
Free_Series(target);
if (dir.error) Trap1(RE_NO_RENAME, path);
}
break;
case A_DELETE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, 0, POL_WRITE);
// !!! add *.r deletion
// !!! add recursive delete (?)
result = OS_DO_DEVICE(&dir, RDC_DELETE);
///OS_FREE(dir.file.path);
if (result < 0) Trap1(RE_NO_DELETE, path);
return R_ARG2;
case A_OPEN:
// !! If open fails, what if user does a READ w/o checking for error?
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(ds, ALL_OPEN_REFS);
if (args & AM_OPEN_NEW) goto create;
//if (args & ~AM_OPEN_READ) Trap1(RE_INVALID_SPEC, path);
Set_Block(state, Make_Block(7));
Init_Dir_Path(&dir, path, 1, POL_READ);
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
break;
case A_OPENQ:
if (IS_BLOCK(state)) return R_TRUE;
return R_FALSE;
case A_CLOSE:
SET_NONE(state);
break;
case A_QUERY:
//Trap_Security(flags[POL_READ], POL_READ, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
Ret_Query_File(port, &dir, D_RET);
///OS_FREE(dir.file.path);
break;
//-- Port Series Actions (only called if opened as a port)
case A_LENGTHQ:
len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
SET_INTEGER(D_RET, len);
break;
default:
Trap_Action(REB_PORT, action);
}
return R_RET;
}
*/ static REB_R Dir_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
** Internal port handler for file directories.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *path;
REBVAL *state;
REBREQ dir;
REBCNT args = 0;
REBINT result;
REBCNT len;
//REBYTE *flags;
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
CLEARS(&dir);
// Validate and fetch relevant PORT fields:
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) raise Error_1(RE_INVALID_SPEC, spec);
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) raise Error_1(RE_INVALID_SPEC, spec);
if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
else if (!IS_FILE(path)) raise Error_1(RE_INVALID_SPEC, path);
state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.
//flags = Security_Policy(SYM_FILE, path);
// Get or setup internal state data:
dir.port = port;
dir.device = RDI_FILE;
switch (action) {
case A_READ:
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(call_, ALL_READ_REFS);
if (!IS_BLOCK(state)) { // !!! ignores /SKIP and /PART, for now
Init_Dir_Path(&dir, path, 1, POL_READ);
Val_Init_Block(state, Make_Array(7)); // initial guess
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0)
raise Error_On_Port(RE_CANNOT_OPEN, port, dir.error);
*D_OUT = *state;
SET_NONE(state);
}
else {
// !!! This copies the strings in the block, shallowly. What is
// the purpose of doing this? Why copy at all?
Val_Init_Block(
D_OUT,
Copy_Array_Core_Managed(
VAL_SERIES(state),
0,
VAL_BLK_LEN(state),
FALSE, // !deep
TS_STRING
)
);
}
break;
case A_CREATE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
create:
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
result = OS_DO_DEVICE(&dir, RDC_CREATE);
///OS_FREE(dir.file.path);
if (result < 0) raise Error_1(RE_NO_CREATE, path);
if (action == A_CREATE) {
// !!! Used to return R_ARG2, but create is single arity. :-/
return R_ARG1;
}
SET_NONE(state);
break;
case A_RENAME:
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
else {
REBSER *target;
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
// Convert file name to OS format:
if (!(target = Value_To_OS_Path(D_ARG(2), TRUE)))
raise Error_1(RE_BAD_FILE_PATH, D_ARG(2));
dir.common.data = BIN_DATA(target);
OS_DO_DEVICE(&dir, RDC_RENAME);
Free_Series(target);
if (dir.error) raise Error_1(RE_NO_RENAME, path);
}
break;
case A_DELETE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, 0, POL_WRITE);
// !!! add *.r deletion
// !!! add recursive delete (?)
result = OS_DO_DEVICE(&dir, RDC_DELETE);
///OS_FREE(dir.file.path);
if (result < 0) raise Error_1(RE_NO_DELETE, path);
// !!! Returned R_ARG2 before, but there is no second argument :-/
return R_ARG1;
case A_OPEN:
// !! If open fails, what if user does a READ w/o checking for error?
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(call_, ALL_OPEN_REFS);
if (args & AM_OPEN_NEW) goto create;
//if (args & ~AM_OPEN_READ) raise Error_1(RE_INVALID_SPEC, path);
Val_Init_Block(state, Make_Array(7));
Init_Dir_Path(&dir, path, 1, POL_READ);
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) raise Error_On_Port(RE_CANNOT_OPEN, port, dir.error);
break;
case A_OPENQ:
if (IS_BLOCK(state)) return R_TRUE;
return R_FALSE;
case A_CLOSE:
SET_NONE(state);
break;
case A_QUERY:
//Trap_Security(flags[POL_READ], POL_READ, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
Ret_Query_File(port, &dir, D_OUT);
///OS_FREE(dir.file.path);
break;
//-- Port Series Actions (only called if opened as a port)
case A_LENGTH:
len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
SET_INTEGER(D_OUT, len);
break;
default:
raise Error_Illegal_Action(REB_PORT, action);
}
return R_OUT;
}
