//
// VAL_SPECIFIC_Debug: C
//
REBCTX *VAL_SPECIFIC_Debug(const REBVAL *v)
{
REBCTX *specific;
assert(NOT(GET_VAL_FLAG(v, VALUE_FLAG_RELATIVE)));
assert(
ANY_WORD(v)
|| ANY_ARRAY(v)
|| IS_VARARGS(v)
|| IS_FUNCTION(v)
|| ANY_CONTEXT(v)
);
specific = VAL_SPECIFIC_COMMON(v);
if (specific != SPECIFIED) {
//
// Basic sanity check: make sure it's a context at all
//
if (!GET_CTX_FLAG(specific, ARRAY_FLAG_VARLIST)) {
printf("Non-CONTEXT found as specifier in specific value\n");
Panic_Series(cast(REBSER*, specific)); // may not be series either
}
// While an ANY-WORD! can be bound specifically to an arbitrary
// object, an ANY-ARRAY! only becomes bound specifically to frames.
// The keylist for a frame's context should come from a function's
// paramlist, which should have a FUNCTION! value in keylist[0]
//
if (ANY_ARRAY(v))
assert(IS_FUNCTION(CTX_ROOTKEY(specific)));
}
return specific;
}
//
// COPY_VALUE_Debug: C
//
// The implementation of COPY_VALUE_CORE is designed to be fairly optimal
// (since it is being called in lieu of what would have been a memcpy() or
// plain assignment). It is left in its raw form as an inline function to
// to help convey that it is nearly as efficient as an assignment.
//
// This adds some verbose checking in the debug build to help debug cases
// where the relative information bits are incorrect.
//
void COPY_VALUE_Debug(
REBVAL *dest,
const RELVAL *src,
REBCTX *specifier
) {
assert(!IS_END(src));
assert(!IS_TRASH_DEBUG(src));
#ifdef __cplusplus
Assert_Cell_Writable(dest, __FILE__, __LINE__);
#endif
if (IS_RELATIVE(src)) {
assert(ANY_WORD(src) || ANY_ARRAY(src));
if (specifier == SPECIFIED) {
Debug_Fmt("Internal Error: Relative item used with SPECIFIED");
PROBE_MSG(src, "word or array");
PROBE_MSG(FUNC_VALUE(VAL_RELATIVE(src)), "func");
assert(FALSE);
}
else if (
VAL_RELATIVE(src)
!= VAL_FUNC(CTX_FRAME_FUNC_VALUE(specifier))
) {
Debug_Fmt("Internal Error: Function mismatch in specific binding");
PROBE_MSG(src, "word or array");
PROBE_MSG(FUNC_VALUE(VAL_RELATIVE(src)), "expected func");
PROBE_MSG(CTX_FRAME_FUNC_VALUE(specifier), "actual func");
assert(FALSE);
}
}
COPY_VALUE_CORE(dest, src, specifier);
}
//
// Bind_Relative_Inner_Loop: C
//
// Recursive function for relative function word binding. Returns TRUE if
// any relative bindings were made.
//
static void Bind_Relative_Inner_Loop(
struct Reb_Binder *binder,
RELVAL *head,
REBARR *paramlist,
REBU64 bind_types
) {
RELVAL *value = head;
for (; NOT_END(value); value++) {
REBU64 type_bit = FLAGIT_KIND(VAL_TYPE(value));
// The two-pass copy-and-then-bind should have gotten rid of all the
// relative values to other functions during the copy.
//
// !!! Long term, in a single pass copy, this would have to deal
// with relative values and run them through the specification
// process if they were not just getting overwritten.
//
assert(!IS_RELATIVE(value));
if (type_bit & bind_types) {
REBINT n = Try_Get_Binder_Index(binder, VAL_WORD_CANON(value));
if (n != 0) {
//
// Word's canon symbol is in frame. Relatively bind it.
// (clear out existing binding flags first).
//
UNBIND_WORD(value);
SET_VAL_FLAGS(value, WORD_FLAG_BOUND | VALUE_FLAG_RELATIVE);
INIT_WORD_FUNC(value, AS_FUNC(paramlist)); // incomplete func
INIT_WORD_INDEX(value, n);
}
}
else if (ANY_ARRAY(value)) {
Bind_Relative_Inner_Loop(
binder, VAL_ARRAY_AT(value), paramlist, bind_types
);
// Set the bits in the ANY-ARRAY! REBVAL to indicate that it is
// relative to the function.
//
// !!! Technically speaking it is not necessary for an array to
// be marked relative if it doesn't contain any relative words
// under it. However, for uniformity in the near term, it's
// easiest to debug if there is a clear mark on arrays that are
// part of a deep copy of a function body either way.
//
SET_VAL_FLAG(value, VALUE_FLAG_RELATIVE);
INIT_RELATIVE(value, AS_FUNC(paramlist)); // incomplete func
}
}
}
//
// Assert_No_Relative: C
//
// Check to make sure there are no relative values in an array, maybe deeply.
//
// !!! What if you have an ANY-ARRAY! inside your array at a position N,
// but there is a relative value in the VAL_ARRAY() of that value at an
// index earlier than N? This currently considers that an error since it
// checks the whole array...which is more conservative (asserts on more
// cases). But should there be a flag to ask to honor the index?
//
void Assert_No_Relative(REBARR *array, REBOOL deep)
{
RELVAL *item = ARR_HEAD(array);
while (NOT_END(item)) {
if (IS_RELATIVE(item)) {
Debug_Fmt("Array contained relative item and wasn't supposed to.");
PROBE_MSG(item, "relative item");
Panic_Array(array);
}
if (!IS_VOID_OR_SAFE_TRASH(item) && ANY_ARRAY(item) && deep)
Assert_No_Relative(VAL_ARRAY(item), deep);
++item;
}
}
//
// Rebind_Values_Deep: C
//
// Rebind all words that reference src target to dst target.
// Rebind is always deep.
//
void Rebind_Values_Deep(
REBCTX *src,
REBCTX *dst,
RELVAL *head,
struct Reb_Binder *opt_binder
) {
RELVAL *value = head;
for (; NOT_END(value); value++) {
if (ANY_ARRAY(value)) {
Rebind_Values_Deep(src, dst, VAL_ARRAY_AT(value), opt_binder);
}
else if (
ANY_WORD(value)
&& GET_VAL_FLAG(value, WORD_FLAG_BOUND)
&& !GET_VAL_FLAG(value, VALUE_FLAG_RELATIVE)
&& VAL_WORD_CONTEXT(KNOWN(value)) == src
) {
INIT_WORD_CONTEXT(value, dst);
if (opt_binder != NULL) {
INIT_WORD_INDEX(
value,
Try_Get_Binder_Index(opt_binder, VAL_WORD_CANON(value))
);
}
}
else if (IS_FUNCTION(value) && IS_FUNCTION_INTERPRETED(value)) {
//
// !!! Extremely questionable feature--walking into function
// bodies and changing them. This R3-Alpha concept was largely
// broken (didn't work for closures) and created a lot of extra
// garbage (inheriting an object's methods meant making deep
// copies of all that object's method bodies...each time).
// Ren-C has a different idea in the works.
//
Rebind_Values_Deep(
src, dst, VAL_FUNC_BODY(value), opt_binder
);
}
}
}
//
// Unbind_Values_Core: C
//
// Unbind words in a block, optionally unbinding those which are
// bound to a particular target (if target is NULL, then all
// words will be unbound regardless of their VAL_WORD_CONTEXT).
//
void Unbind_Values_Core(RELVAL *head, REBCTX *context, REBOOL deep)
{
RELVAL *value = head;
for (; NOT_END(value); value++) {
if (
ANY_WORD(value)
&& (
!context
|| (
IS_WORD_BOUND(value)
&& !IS_RELATIVE(value)
&& VAL_WORD_CONTEXT(KNOWN(value)) == context
)
)
) {
UNBIND_WORD(value);
}
else if (ANY_ARRAY(value) && deep)
Unbind_Values_Core(VAL_ARRAY_AT(value), context, TRUE);
}
}
//
// MAKE_Tuple: C
//
REB_R MAKE_Tuple(
REBVAL *out,
enum Reb_Kind kind,
const REBVAL *opt_parent,
const REBVAL *arg
){
assert(kind == REB_TUPLE);
if (opt_parent)
fail (Error_Bad_Make_Parent(kind, opt_parent));
if (IS_TUPLE(arg))
return Move_Value(out, arg);
RESET_CELL(out, REB_TUPLE, CELL_MASK_NONE);
REBYTE *vp = VAL_TUPLE(out);
// !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or
// similar URL!s. In Rebol3 these captures come back the same type
// as the input instead of as STRING!, which was a latent bug in the
// network code of the 12-Dec-2012 release:
//
// https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110
//
// All attempts to convert a URL!-flavored IP address failed. Taking
// URL! here fixes it, though there are still open questions.
//
if (IS_TEXT(arg) or IS_URL(arg)) {
REBSIZ size;
const REBYTE *bp
= Analyze_String_For_Scan(&size, arg, MAX_SCAN_TUPLE);
if (Scan_Tuple(out, bp, size) == nullptr)
fail (arg);
return out;
}
if (ANY_ARRAY(arg)) {
REBCNT len = 0;
REBINT n;
RELVAL *item = VAL_ARRAY_AT(arg);
for (; NOT_END(item); ++item, ++vp, ++len) {
if (len >= MAX_TUPLE)
goto bad_make;
if (IS_INTEGER(item)) {
n = Int32(item);
}
else if (IS_CHAR(item)) {
n = VAL_CHAR(item);
}
else
goto bad_make;
if (n > 255 || n < 0)
goto bad_make;
*vp = n;
}
VAL_TUPLE_LEN(out) = len;
for (; len < MAX_TUPLE; len++) *vp++ = 0;
return out;
}
REBCNT alen;
if (IS_ISSUE(arg)) {
REBSTR *spelling = VAL_STRING(arg);
const REBYTE *ap = STR_HEAD(spelling);
size_t size = STR_SIZE(spelling); // UTF-8 len
if (size & 1)
fail (arg); // must have even # of chars
size /= 2;
if (size > MAX_TUPLE)
fail (arg); // valid even for UTF-8
VAL_TUPLE_LEN(out) = size;
for (alen = 0; alen < size; alen++) {
REBYTE decoded;
if ((ap = Scan_Hex2(&decoded, ap)) == NULL)
fail (arg);
*vp++ = decoded;
}
}
else if (IS_BINARY(arg)) {
REBYTE *ap = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
if (len > MAX_TUPLE) len = MAX_TUPLE;
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) *vp++ = *ap++;
}
else
fail (arg);
for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
return out;
bad_make:
fail (Error_Bad_Make(REB_TUPLE, arg));
}
//
// 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;
}
//
// Modify_Array: C
//
// Returns new dst_idx
//
REBCNT Modify_Array(
REBCNT action, // INSERT, APPEND, CHANGE
REBARR *dst_arr, // target
REBCNT dst_idx, // position
const REBVAL *src_val, // source
REBCNT flags, // AN_ONLY, AN_PART
REBINT dst_len, // length to remove
REBINT dups // dup count
) {
REBCNT tail = ARR_LEN(dst_arr);
REBINT ilen = 1; // length to be inserted
const RELVAL *src_rel;
REBCTX *specifier;
if (IS_VOID(src_val) || dups < 0) {
// If they are effectively asking for "no action" then all we have
// to do is return the natural index result for the operation.
// (APPEND will return 0, insert the tail of the insertion...so index)
return (action == SYM_APPEND) ? 0 : dst_idx;
}
if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail;
// Check /PART, compute LEN:
if (!GET_FLAG(flags, AN_ONLY) && ANY_ARRAY(src_val)) {
// Adjust length of insertion if changing /PART:
if (action != SYM_CHANGE && GET_FLAG(flags, AN_PART))
ilen = dst_len;
else
ilen = VAL_LEN_AT(src_val);
// Are we modifying ourselves? If so, copy src_val block first:
if (dst_arr == VAL_ARRAY(src_val)) {
REBARR *copy = Copy_Array_At_Shallow(
VAL_ARRAY(src_val), VAL_INDEX(src_val), VAL_SPECIFIER(src_val)
);
MANAGE_ARRAY(copy); // !!! Review: worth it to not manage and free?
src_rel = ARR_HEAD(copy);
specifier = SPECIFIED; // copy already specified it
}
else {
src_rel = VAL_ARRAY_AT(src_val); // skips by VAL_INDEX values
specifier = VAL_SPECIFIER(src_val);
}
}
else {
// use passed in RELVAL and specifier
src_rel = src_val;
specifier = SPECIFIED; // it's a REBVAL, not a RELVAL, so specified
}
REBINT size = dups * ilen; // total to insert
if (action != SYM_CHANGE) {
// Always expand dst_arr for INSERT and APPEND actions:
Expand_Series(ARR_SERIES(dst_arr), dst_idx, size);
}
else {
if (size > dst_len)
Expand_Series(ARR_SERIES(dst_arr), dst_idx, size-dst_len);
else if (size < dst_len && GET_FLAG(flags, AN_PART))
Remove_Series(ARR_SERIES(dst_arr), dst_idx, dst_len-size);
else if (size + dst_idx > tail) {
EXPAND_SERIES_TAIL(ARR_SERIES(dst_arr), size - (tail - dst_idx));
}
}
tail = (action == SYM_APPEND) ? 0 : size + dst_idx;
#if !defined(NDEBUG)
if (IS_ARRAY_MANAGED(dst_arr)) {
REBINT i;
for (i = 0; i < ilen; ++i)
ASSERT_VALUE_MANAGED(&src_rel[i]);
}
#endif
for (; dups > 0; dups--) {
REBINT index = 0;
for (; index < ilen; ++index, ++dst_idx) {
COPY_VALUE(
SINK(ARR_HEAD(dst_arr) + dst_idx),
src_rel + index,
specifier
);
}
}
TERM_ARRAY_LEN(dst_arr, ARR_LEN(dst_arr));
ASSERT_ARRAY(dst_arr);
return tail;
}
//
// Bind_Values_Inner_Loop: C
//
// Bind_Values_Core() sets up the binding table and then calls
// this recursive routine to do the actual binding.
//
static void Bind_Values_Inner_Loop(
struct Reb_Binder *binder,
RELVAL *head,
REBCTX *context,
REBU64 bind_types, // !!! REVIEW: force word types low enough for 32-bit?
REBU64 add_midstream_types,
REBFLGS flags
) {
RELVAL *value = head;
for (; NOT_END(value); value++) {
REBU64 type_bit = FLAGIT_KIND(VAL_TYPE(value));
if (type_bit & bind_types) {
REBSTR *canon = VAL_WORD_CANON(value);
REBCNT n = Try_Get_Binder_Index(binder, canon);
if (n != 0) {
assert(n <= CTX_LEN(context));
// We're overwriting any previous binding, which may have
// been relative.
//
CLEAR_VAL_FLAG(value, VALUE_FLAG_RELATIVE);
SET_VAL_FLAG(value, WORD_FLAG_BOUND);
INIT_WORD_CONTEXT(value, context);
INIT_WORD_INDEX(value, n);
}
else if (type_bit & add_midstream_types) {
//
// Word is not in context, so add it if option is specified
//
Expand_Context(context, 1);
Append_Context(context, value, 0);
Add_Binder_Index(binder, canon, VAL_WORD_INDEX(value));
}
}
else if (ANY_ARRAY(value) && (flags & BIND_DEEP)) {
Bind_Values_Inner_Loop(
binder,
VAL_ARRAY_AT(value),
context,
bind_types,
add_midstream_types,
flags
);
}
else if (
IS_FUNCTION(value)
&& IS_FUNCTION_INTERPRETED(value)
&& (flags & BIND_FUNC)
) {
// !!! Likely-to-be deprecated functionality--rebinding inside the
// content of an already formed function. :-/
//
Bind_Values_Inner_Loop(
binder,
VAL_FUNC_BODY(value),
context,
bind_types,
add_midstream_types,
flags
);
}
}
}
*/ REBCNT Modify_Array(REBCNT action, REBSER *dst_ser, REBCNT dst_idx, const REBVAL *src_val, REBCNT flags, REBINT dst_len, REBINT dups)
/*
** action: INSERT, APPEND, CHANGE
**
** dst_ser: target
** dst_idx: position
** src_val: source
** flags: AN_ONLY, AN_PART
** dst_len: length to remove
** dups: dup count
**
** return: new dst_idx
**
***********************************************************************/
{
REBCNT tail = SERIES_TAIL(dst_ser);
REBINT ilen = 1; // length to be inserted
REBINT size; // total to insert
#if !defined(NDEBUG)
REBINT index;
#endif
if (IS_UNSET(src_val) || dups < 0) {
// If they are effectively asking for "no action" then all we have
// to do is return the natural index result for the operation.
// (APPEND will return 0, insert the tail of the insertion...so index)
return (action == A_APPEND) ? 0 : dst_idx;
}
if (action == A_APPEND || dst_idx > tail) dst_idx = tail;
// Check /PART, compute LEN:
if (!GET_FLAG(flags, AN_ONLY) && ANY_ARRAY(src_val)) {
// Adjust length of insertion if changing /PART:
if (action != A_CHANGE && GET_FLAG(flags, AN_PART))
ilen = dst_len;
else
ilen = VAL_LEN(src_val);
// Are we modifying ourselves? If so, copy src_val block first:
if (dst_ser == VAL_SERIES(src_val)) {
REBSER *series = Copy_Array_At_Shallow(
VAL_SERIES(src_val), VAL_INDEX(src_val)
);
src_val = BLK_HEAD(series);
}
else
src_val = VAL_BLK_DATA(src_val); // skips by VAL_INDEX values
}
// Total to insert:
size = dups * ilen;
if (action != A_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));
}
}
tail = (action == A_APPEND) ? 0 : size + dst_idx;
#if !defined(NDEBUG)
for (index = 0; index < ilen; index++) {
if (SERIES_GET_FLAG(dst_ser, SER_MANAGED))
ASSERT_VALUE_MANAGED(&src_val[index]);
}
#endif
dst_idx *= SERIES_WIDE(dst_ser); // loop invariant
ilen *= SERIES_WIDE(dst_ser); // loop invariant
for (; dups > 0; dups--) {
memcpy(dst_ser->data + dst_idx, src_val, ilen);
dst_idx += ilen;
}
TERM_ARRAY(dst_ser);
return tail;
}
//
// 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;
}
//
// MAKE_Tuple: C
//
void MAKE_Tuple(REBVAL *out, enum Reb_Kind type, const REBVAL *arg)
{
if (IS_TUPLE(arg)) {
*out = *arg;
return;
}
VAL_RESET_HEADER(out, REB_TUPLE);
REBYTE *vp = VAL_TUPLE(out);
// !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or
// similar URL!s. In Rebol3 these captures come back the same type
// as the input instead of as STRING!, which was a latent bug in the
// network code of the 12-Dec-2012 release:
//
// https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110
//
// All attempts to convert a URL!-flavored IP address failed. Taking
// URL! here fixes it, though there are still open questions.
//
if (IS_STRING(arg) || IS_URL(arg)) {
REBCNT len;
REBYTE *ap = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_TUPLE, &len, FALSE);
if (Scan_Tuple(ap, len, out))
return;
goto bad_arg;
}
if (ANY_ARRAY(arg)) {
REBCNT len = 0;
REBINT n;
RELVAL *item = VAL_ARRAY_AT(arg);
for (; NOT_END(item); ++item, ++vp, ++len) {
if (len >= MAX_TUPLE) goto bad_make;
if (IS_INTEGER(item)) {
n = Int32(item);
}
else if (IS_CHAR(item)) {
n = VAL_CHAR(item);
}
else
goto bad_make;
if (n > 255 || n < 0) goto bad_make;
*vp = n;
}
VAL_TUPLE_LEN(out) = len;
for (; len < MAX_TUPLE; len++) *vp++ = 0;
return;
}
REBCNT alen;
if (IS_ISSUE(arg)) {
REBUNI c;
const REBYTE *ap = VAL_WORD_HEAD(arg);
REBCNT len = LEN_BYTES(ap); // UTF-8 len
if (len & 1) goto bad_arg; // must have even # of chars
len /= 2;
if (len > MAX_TUPLE) goto bad_arg; // valid even for UTF-8
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) {
const REBOOL unicode = FALSE;
if (!Scan_Hex2(ap, &c, unicode)) goto bad_arg;
*vp++ = cast(REBYTE, c);
ap += 2;
}
}
else if (IS_BINARY(arg)) {
REBYTE *ap = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
if (len > MAX_TUPLE) len = MAX_TUPLE;
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) *vp++ = *ap++;
}
else goto bad_arg;
for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
return;
bad_arg:
fail (Error_Invalid_Arg(arg));
bad_make:
fail (Error_Bad_Make(REB_TUPLE, arg));
}
//
// 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;
}
//
// MAKE_Decimal: C
//
void MAKE_Decimal(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
REBDEC d;
switch (VAL_TYPE(arg)) {
case REB_DECIMAL:
d = VAL_DECIMAL(arg);
goto dont_divide_if_percent;
case REB_PERCENT:
d = VAL_DECIMAL(arg);
goto dont_divide_if_percent;
case REB_INTEGER:
d = cast(REBDEC, VAL_INT64(arg));
goto dont_divide_if_percent;
case REB_MONEY:
d = deci_to_decimal(VAL_MONEY_AMOUNT(arg));
goto dont_divide_if_percent;
case REB_LOGIC:
d = VAL_LOGIC(arg) ? 1.0 : 0.0;
goto dont_divide_if_percent;
case REB_CHAR:
d = cast(REBDEC, VAL_CHAR(arg));
goto dont_divide_if_percent;
case REB_TIME:
d = VAL_TIME(arg) * NANO;
break;
case REB_STRING:
{
REBYTE *bp;
REBCNT len;
bp = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_DECIMAL, &len, FALSE);
VAL_RESET_HEADER(out, kind);
if (!Scan_Decimal(
&d, bp, len, LOGICAL(kind != REB_PERCENT)
)) {
goto bad_make;
}
break;
}
case REB_BINARY:
Binary_To_Decimal(arg, out);
VAL_RESET_HEADER(out, kind);
d = VAL_DECIMAL(out);
break;
#ifdef removed
// case REB_ISSUE:
{
REBYTE *bp;
REBCNT len;
bp = Temp_Byte_Chars_May_Fail(arg, MAX_HEX_LEN, &len, FALSE);
if (Scan_Hex(&VAL_INT64(out), bp, len, len) == 0)
fail (Error_Bad_Make(REB_DECIMAL, val));
d = VAL_DECIMAL(out);
break;
}
#endif
default:
if (ANY_ARRAY(arg) && VAL_ARRAY_LEN_AT(arg) == 2) {
RELVAL *item = VAL_ARRAY_AT(arg);
if (IS_INTEGER(item))
d = cast(REBDEC, VAL_INT64(item));
else if (IS_DECIMAL(item) || IS_PERCENT(item))
d = VAL_DECIMAL(item);
else {
REBVAL specific;
COPY_VALUE(&specific, item, VAL_SPECIFIER(arg));
fail (Error_Invalid_Arg(&specific));
}
++item;
REBDEC exp;
if (IS_INTEGER(item))
exp = cast(REBDEC, VAL_INT64(item));
else if (IS_DECIMAL(item) || IS_PERCENT(item))
exp = VAL_DECIMAL(item);
else {
REBVAL specific;
COPY_VALUE(&specific, item, VAL_SPECIFIER(arg));
fail (Error_Invalid_Arg(&specific));
}
while (exp >= 1) {
//
// !!! Comment here said "funky. There must be a better way"
//
--exp;
d *= 10.0;
if (!FINITE(d))
fail (Error(RE_OVERFLOW));
}
while (exp <= -1) {
++exp;
d /= 10.0;
}
}
else
fail (Error_Bad_Make(kind, arg));
}
if (kind == REB_PERCENT)
d /= 100.0;
dont_divide_if_percent:
if (!FINITE(d))
fail (Error(RE_OVERFLOW));
VAL_RESET_HEADER(out, kind);
VAL_DECIMAL(out) = d;
return;
bad_make:
fail (Error_Bad_Make(kind, arg));
}
//
// Make_Time: C
//
// Returns NO_TIME if error.
//
REBI64 Make_Time(REBVAL *val)
{
REBI64 secs = 0;
if (IS_TIME(val)) {
secs = VAL_TIME(val);
}
else if (IS_STRING(val)) {
REBYTE *bp;
REBCNT len;
bp = Temp_Byte_Chars_May_Fail(val, MAX_SCAN_TIME, &len, FALSE);
if (!Scan_Time(bp, len, val)) goto no_time;
secs = VAL_TIME(val);
}
else if (IS_INTEGER(val)) {
if (VAL_INT64(val) < -MAX_SECONDS || VAL_INT64(val) > MAX_SECONDS)
fail (Error_Out_Of_Range(val));
secs = VAL_INT64(val) * SEC_SEC;
}
else if (IS_DECIMAL(val)) {
if (VAL_DECIMAL(val) < (REBDEC)(-MAX_SECONDS) || VAL_DECIMAL(val) > (REBDEC)MAX_SECONDS)
fail (Error_Out_Of_Range(val));
secs = DEC_TO_SECS(VAL_DECIMAL(val));
}
else if (ANY_ARRAY(val) && VAL_BLK_LEN(val) <= 3) {
REBFLG neg = FALSE;
REBI64 i;
val = VAL_BLK_DATA(val);
if (!IS_INTEGER(val)) goto no_time;
i = Int32(val);
if (i < 0) i = -i, neg = TRUE;
secs = i * 3600;
if (secs > MAX_SECONDS) goto no_time;
if (NOT_END(++val)) {
if (!IS_INTEGER(val)) goto no_time;
if ((i = Int32(val)) < 0) goto no_time;
secs += i * 60;
if (secs > MAX_SECONDS) goto no_time;
if (NOT_END(++val)) {
if (IS_INTEGER(val)) {
if ((i = Int32(val)) < 0) goto no_time;
secs += i;
if (secs > MAX_SECONDS) goto no_time;
}
else if (IS_DECIMAL(val)) {
if (secs + (REBI64)VAL_DECIMAL(val) + 1 > MAX_SECONDS) goto no_time;
// added in below
}
else goto no_time;
}
}
secs *= SEC_SEC;
if (IS_DECIMAL(val)) secs += DEC_TO_SECS(VAL_DECIMAL(val));
if (neg) secs = -secs;
}
else
no_time: return NO_TIME;
return secs;
}
