//
// Ret_Query_Net: C
//
static void Ret_Query_Net(REBSER *port, REBREQ *sock, REBVAL *ret)
{
REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
REBSER *obj;
if (!info || !IS_OBJECT(info))
fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
obj = Copy_Array_Shallow(VAL_OBJ_FRAME(info));
MANAGE_SERIES(obj);
Val_Init_Object(ret, obj);
Set_Tuple(
OFV(obj, STD_NET_INFO_LOCAL_IP),
cast(REBYTE*, &sock->special.net.local_ip),
4
);
Set_Tuple(
OFV(obj, STD_NET_INFO_REMOTE_IP),
cast(REBYTE*, &sock->special.net.remote_ip),
4
);
SET_INTEGER(OFV(obj, STD_NET_INFO_LOCAL_PORT), sock->special.net.local_port);
SET_INTEGER(OFV(obj, STD_NET_INFO_REMOTE_PORT), sock->special.net.remote_port);
}
//
// Accept_New_Port: C
//
// Clone a listening port as a new accept port.
//
static void Accept_New_Port(REBVAL *out, REBSER *port, REBREQ *sock)
{
REBREQ *nsock;
// Get temp sock struct created by the device:
nsock = sock->common.sock;
if (!nsock) return; // false alarm
sock->common.sock = nsock->next;
nsock->common.data = 0;
nsock->next = 0;
// Create a new port using ACCEPT request passed by sock->common.sock:
port = Copy_Array_Shallow(port);
MANAGE_SERIES(port);
Val_Init_Port(out, port); // Also for GC protect
SET_NONE(OFV(port, STD_PORT_DATA)); // just to be sure.
SET_NONE(OFV(port, STD_PORT_STATE)); // just to be sure.
// Copy over the new sock data:
sock = cast(REBREQ*, Use_Port_State(port, RDI_NET, sizeof(*sock)));
*sock = *nsock;
sock->clen = sizeof(*sock);
sock->port = port;
OS_FREE(nsock); // allocated by dev_net.c (MT issues?)
}
*/ REBSER *Collect_End(REBSER *prior)
/*
** Finish collecting words, and free the Bind_Table for reuse.
**
***********************************************************************/
{
REBVAL *words;
REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
// Reset binding table (note BUF_WORDS may have expanded):
for (words = BLK_HEAD(BUF_WORDS); NOT_END(words); words++)
binds[VAL_WORD_CANON(words)] = 0;
// If no new words, prior frame:
if (prior && SERIES_TAIL(BUF_WORDS) == SERIES_TAIL(prior)) {
RESET_TAIL(BUF_WORDS); // allow reuse
return FRM_WORD_SERIES(prior);
}
prior = Copy_Array_Shallow(BUF_WORDS);
RESET_TAIL(BUF_WORDS); // allow reuse
CHECK_BIND_TABLE;
return prior;
}
*/ REBSER *Make_Module_Spec(REBVAL *spec)
/*
** Create a module spec object. Holds module name, version,
** exports, locals, and more. See system/standard/module.
**
***********************************************************************/
{
// Build standard module header object:
REBSER *obj = VAL_OBJ_FRAME(Get_System(SYS_STANDARD, STD_SCRIPT));
REBSER *frame;
if (spec && IS_BLOCK(spec))
frame = Construct_Object(obj, VAL_BLK_DATA(spec), FALSE);
else
frame = Copy_Array_Shallow(obj);
return frame;
}
*/ REBSER *Split_Lines(REBVAL *val)
/*
** Given a string series, split lines on CR-LF.
** Series can be bytes or Unicode.
**
***********************************************************************/
{
REBSER *ser = BUF_EMIT; // GC protected (because it is emit buffer)
REBSER *str = VAL_SERIES(val);
REBCNT len = VAL_LEN(val);
REBCNT idx = VAL_INDEX(val);
REBCNT start = idx;
REBSER *out;
REBUNI c;
BLK_RESET(ser);
while (idx < len) {
c = GET_ANY_CHAR(str, idx);
if (c == LF || c == CR) {
out = Copy_String(str, start, idx - start);
val = Alloc_Tail_Array(ser);
Val_Init_String(val, out);
VAL_SET_OPT(val, OPT_VALUE_LINE);
idx++;
if (c == CR && GET_ANY_CHAR(str, idx) == LF)
idx++;
start = idx;
}
else idx++;
}
// Possible remainder (no terminator)
if (idx > start) {
out = Copy_String(str, start, idx - start);
val = Alloc_Tail_Array(ser);
Val_Init_String(val, out);
VAL_SET_OPT(val, OPT_VALUE_LINE);
}
return Copy_Array_Shallow(ser);
}
//
// Split_Lines: C
//
// Given a string series, split lines on CR-LF.
// Series can be bytes or Unicode.
//
REBARR *Split_Lines(REBVAL *val)
{
REBARR *array = BUF_EMIT; // GC protected (because it is emit buffer)
REBSER *str = VAL_SERIES(val);
REBCNT len = VAL_LEN_AT(val);
REBCNT idx = VAL_INDEX(val);
REBCNT start = idx;
REBSER *out;
REBUNI c;
RESET_ARRAY(array);
while (idx < len) {
c = GET_ANY_CHAR(str, idx);
if (c == LF || c == CR) {
out = Copy_String_Slimming(str, start, idx - start);
val = Alloc_Tail_Array(array);
Val_Init_String(val, out);
SET_VAL_FLAG(val, VALUE_FLAG_LINE);
idx++;
if (c == CR && GET_ANY_CHAR(str, idx) == LF)
idx++;
start = idx;
}
else idx++;
}
// Possible remainder (no terminator)
if (idx > start) {
out = Copy_String_Slimming(str, start, idx - start);
val = Alloc_Tail_Array(array);
Val_Init_String(val, out);
SET_VAL_FLAG(val, VALUE_FLAG_LINE);
}
return Copy_Array_Shallow(array, SPECIFIED); // no relative values
}
*/ REBFLG MT_Struct(REBVAL *out, REBVAL *data, enum Reb_Kind type)
/*
* Format:
* make struct! [
* field1 [type1]
* field2: [type2] field2-init-value
* field3: [struct [field1 [type1]]]
* field4: [type1[3]]
* ...
* ]
***********************************************************************/
{
//RL_Print("%s\n", __func__);
REBINT max_fields = 16;
VAL_STRUCT_FIELDS(out) = Make_Series(
max_fields, sizeof(struct Struct_Field), MKS_NONE
);
MANAGE_SERIES(VAL_STRUCT_FIELDS(out));
if (IS_BLOCK(data)) {
//if (Reduce_Block_No_Set_Throws(VAL_SERIES(data), 0, NULL))...
//data = DS_POP;
REBVAL *blk = VAL_BLK_DATA(data);
REBINT field_idx = 0; /* for field index */
u64 offset = 0; /* offset in data */
REBCNT eval_idx = 0; /* for spec block evaluation */
REBVAL *init = NULL; /* for result to save in data */
REBOOL expect_init = FALSE;
REBINT raw_size = -1;
REBUPT raw_addr = 0;
REBCNT alignment = 0;
VAL_STRUCT_SPEC(out) = Copy_Array_Shallow(VAL_SERIES(data));
VAL_STRUCT_DATA(out) = Make_Series(
1, sizeof(struct Struct_Data), MKS_NONE
);
EXPAND_SERIES_TAIL(VAL_STRUCT_DATA(out), 1);
VAL_STRUCT_DATA_BIN(out) = Make_Series(max_fields << 2, 1, MKS_NONE);
VAL_STRUCT_OFFSET(out) = 0;
// We tell the GC to manage this series, but it will not cause a
// synchronous garbage collect. Still, when's the right time?
ENSURE_SERIES_MANAGED(VAL_STRUCT_SPEC(out));
MANAGE_SERIES(VAL_STRUCT_DATA(out));
MANAGE_SERIES(VAL_STRUCT_DATA_BIN(out));
/* set type early such that GC will handle it correctly, i.e, not collect series in the struct */
SET_TYPE(out, REB_STRUCT);
if (IS_BLOCK(blk)) {
parse_attr(blk, &raw_size, &raw_addr);
++ blk;
}
while (NOT_END(blk)) {
REBVAL *inner;
struct Struct_Field *field = NULL;
u64 step = 0;
EXPAND_SERIES_TAIL(VAL_STRUCT_FIELDS(out), 1);
DS_PUSH_NONE;
inner = DS_TOP; /* save in stack so that it won't be GC'ed when MT_Struct is recursively called */
field = (struct Struct_Field *)SERIES_SKIP(VAL_STRUCT_FIELDS(out), field_idx);
field->offset = (REBCNT)offset;
if (IS_SET_WORD(blk)) {
field->sym = VAL_WORD_SYM(blk);
expect_init = TRUE;
if (raw_addr) {
/* initialization is not allowed for raw memory struct */
raise Error_Invalid_Arg(blk);
}
} else if (IS_WORD(blk)) {
field->sym = VAL_WORD_SYM(blk);
expect_init = FALSE;
}
else
raise Error_Has_Bad_Type(blk);
++ blk;
if (!IS_BLOCK(blk))
raise Error_Invalid_Arg(blk);
if (!parse_field_type(field, blk, inner, &init)) { return FALSE; }
++ blk;
STATIC_assert(sizeof(field->size) <= 4);
STATIC_assert(sizeof(field->dimension) <= 4);
step = (u64)field->size * (u64)field->dimension;
if (step > VAL_STRUCT_LIMIT)
raise Error_1(RE_SIZE_LIMIT, out);
EXPAND_SERIES_TAIL(VAL_STRUCT_DATA_BIN(out), step);
if (expect_init) {
REBVAL safe; // result of reduce or do (GC saved during eval)
init = &safe;
if (IS_BLOCK(blk)) {
if (Reduce_Block_Throws(init, VAL_SERIES(blk), 0, FALSE))
raise Error_No_Catch_For_Throw(init);
++ blk;
} else {
DO_NEXT_MAY_THROW(
eval_idx,
init,
VAL_SERIES(data),
blk - VAL_BLK_DATA(data)
);
if (eval_idx == THROWN_FLAG)
raise Error_No_Catch_For_Throw(init);
blk = VAL_BLK_SKIP(data, eval_idx);
}
if (field->array) {
if (IS_INTEGER(init)) { /* interpreted as a C pointer */
void *ptr = cast(void *, cast(REBUPT, VAL_INT64(init)));
/* assuming it's an valid pointer and holding enough space */
memcpy(SERIES_SKIP(VAL_STRUCT_DATA_BIN(out), (REBCNT)offset), ptr, field->size * field->dimension);
} else if (IS_BLOCK(init)) {
REBCNT n = 0;
if (VAL_LEN(init) != field->dimension)
raise Error_Invalid_Arg(init);
/* assign */
for (n = 0; n < field->dimension; n ++) {
if (!assign_scalar(&VAL_STRUCT(out), field, n, VAL_BLK_SKIP(init, n))) {
//RL_Print("Failed to assign element value\n");
goto failed;
}
}
}
else
raise Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(blk));
} else {
/* scalar */
if (!assign_scalar(&VAL_STRUCT(out), field, 0, init)) {
//RL_Print("Failed to assign scalar value\n");
goto failed;
}
}
} else if (raw_addr == 0) {
//
// 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;
}
//
// 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;
}
*/ REBSER *Merge_Frames(REBSER *parent1, REBSER *parent2)
/*
** Create a child frame from two parent frames. Merge common fields.
** Values from the second parent take precedence.
**
** Deep copy and rebind the child.
**
***********************************************************************/
{
REBSER *wrds;
REBSER *child;
REBVAL *words;
REBVAL *value;
REBCNT n;
REBINT *binds = WORDS_HEAD(Bind_Table);
// Merge parent1 and parent2 words.
// Keep the binding table.
Collect_Start(BIND_ALL);
// Setup binding table and BUF_WORDS with parent1 words:
Collect_Object(parent1);
// Add parent2 words to binding table and BUF_WORDS:
Collect_Frame_Inner_Loop(
binds, BLK_SKIP(FRM_WORD_SERIES(parent2), 1), BIND_ALL
);
// Allocate child (now that we know the correct size):
wrds = Copy_Array_Shallow(BUF_WORDS);
child = Make_Array(SERIES_TAIL(wrds));
value = Alloc_Tail_Array(child);
VAL_SET(value, REB_FRAME);
VAL_FRM_WORDS(value) = wrds;
VAL_FRM_SPEC(value) = 0;
// Copy parent1 values:
memcpy(
FRM_VALUES(child) + 1,
FRM_VALUES(parent1) + 1,
(SERIES_TAIL(parent1) - 1) * sizeof(REBVAL)
);
// Copy parent2 values:
words = FRM_WORDS(parent2)+1;
value = FRM_VALUES(parent2)+1;
for (; NOT_END(words); words++, value++) {
// no need to search when the binding table is available
n = binds[VAL_WORD_CANON(words)];
BLK_HEAD(child)[n] = *value;
}
// Terminate the child frame:
SERIES_TAIL(child) = SERIES_TAIL(wrds);
BLK_TERM(child);
// Deep copy the child
Clonify_Values_Len_Managed(
BLK_SKIP(child, 1), SERIES_TAIL(child) - 1, TRUE, TS_CLONE
);
// Rebind the child
Rebind_Block(parent1, child, BLK_SKIP(child, 1), REBIND_FUNC);
Rebind_Block(parent2, child, BLK_SKIP(child, 1), REBIND_FUNC | REBIND_TABLE);
// release the bind table
Collect_End(child);
return child;
}
//
// Compose_Any_Array_Throws: C
//
// Compose a block from a block of un-evaluated values and GROUP! arrays that
// are evaluated. This calls into Do_Core, so if 'into' is provided, then its
// series must be protected from garbage collection.
//
// deep - recurse into sub-blocks
// only - parens that return blocks are kept as blocks
//
// Writes result value at address pointed to by out.
//
REBOOL Compose_Any_Array_Throws(
REBVAL *out,
const REBVAL *any_array,
REBOOL deep,
REBOOL only,
REBOOL into
) {
REBDSP dsp_orig = DSP;
Reb_Enumerator e;
PUSH_SAFE_ENUMERATOR(&e, any_array); // evaluating could disrupt any_array
while (NOT_END(e.value)) {
UPDATE_EXPRESSION_START(&e); // informs the error delivery better
if (IS_GROUP(e.value)) {
//
// We evaluate here, but disable lookahead so it only evaluates
// the GROUP! and doesn't trigger errors on what's after it.
//
REBVAL evaluated;
DO_NEXT_REFETCH_MAY_THROW(&evaluated, &e, DO_FLAG_NO_LOOKAHEAD);
if (THROWN(&evaluated)) {
*out = evaluated;
DS_DROP_TO(dsp_orig);
DROP_SAFE_ENUMERATOR(&e);
return TRUE;
}
if (IS_BLOCK(&evaluated) && !only) {
//
// compose [blocks ([a b c]) merge] => [blocks a b c merge]
//
RELVAL *push = VAL_ARRAY_AT(&evaluated);
while (NOT_END(push)) {
//
// `evaluated` is known to be specific, but its specifier
// may be needed to derelativize its children.
//
DS_PUSH_RELVAL(push, VAL_SPECIFIER(&evaluated));
push++;
}
}
else if (!IS_VOID(&evaluated)) {
//
// compose [(1 + 2) inserts as-is] => [3 inserts as-is]
// compose/only [([a b c]) unmerged] => [[a b c] unmerged]
//
DS_PUSH(&evaluated);
}
else {
//
// compose [(print "Voids *vanish*!")] => []
//
}
}
else if (deep) {
if (IS_BLOCK(e.value)) {
//
// compose/deep [does [(1 + 2)] nested] => [does [3] nested]
REBVAL specific;
COPY_VALUE(&specific, e.value, e.specifier);
REBVAL composed;
if (Compose_Any_Array_Throws(
&composed,
&specific,
TRUE,
only,
into
)) {
*out = composed;
DS_DROP_TO(dsp_orig);
DROP_SAFE_ENUMERATOR(&e);
return TRUE;
}
DS_PUSH(&composed);
}
else {
if (ANY_ARRAY(e.value)) {
//
// compose [copy/(orig) (copy)] => [copy/(orig) (copy)]
// !!! path and second group are copies, first group isn't
//
REBARR *copy = Copy_Array_Shallow(
VAL_ARRAY(e.value),
IS_RELATIVE(e.value)
? e.specifier // use parent specifier if relative...
: VAL_SPECIFIER(const_KNOWN(e.value)) // else child's
);
DS_PUSH_TRASH;
Val_Init_Array_Index(
DS_TOP, VAL_TYPE(e.value), copy, VAL_INDEX(e.value)
); // ...manages
}
else
DS_PUSH_RELVAL(e.value, e.specifier);
}
FETCH_NEXT_ONLY_MAYBE_END(&e);
}
else {
//
// compose [[(1 + 2)] (reverse "wollahs")] => [[(1 + 2)] "shallow"]
//
DS_PUSH_RELVAL(e.value, e.specifier);
FETCH_NEXT_ONLY_MAYBE_END(&e);
}
}
if (into)
Pop_Stack_Values_Into(out, dsp_orig);
else
Val_Init_Array(out, VAL_TYPE(any_array), Pop_Stack_Values(dsp_orig));
DROP_SAFE_ENUMERATOR(&e);
return FALSE;
}
