//
// Copy_And_Bind_Relative_Deep_Managed: C
//
// This routine is called by Make_Function in order to take the raw material
// given as a function body, and de-relativize any IS_RELATIVE(value)s that
// happen to be in it already (as any Copy does). But it also needs to make
// new relative references to ANY-WORD! that are referencing function
// parameters, as well as to relativize the copies of ANY-ARRAY! that contain
// these relative words...so that they refer to the archetypal function
// to which they should be relative.
//
REBARR *Copy_And_Bind_Relative_Deep_Managed(
const REBVAL *body,
REBARR *paramlist, // body of function is not actually ready yet
REBU64 bind_types
) {
// !!! Currently this is done in two phases, because the historical code
// would use the generic copying code and then do a bind phase afterward.
// Both phases are folded into this routine to make it easier to make
// a one-pass version when time permits.
//
REBARR *copy = COPY_ANY_ARRAY_AT_DEEP_MANAGED(body);
struct Reb_Binder binder;
INIT_BINDER(&binder);
// Setup binding table from the argument word list
//
REBCNT index = 1;
RELVAL *param = ARR_AT(paramlist, 1); // [0] is FUNCTION! value
for (; NOT_END(param); param++, index++)
Add_Binder_Index(&binder, VAL_KEY_CANON(param), index);
Bind_Relative_Inner_Loop(&binder, ARR_HEAD(copy), paramlist, bind_types);
// Reset binding table
//
param = ARR_AT(paramlist, 1); // [0] is FUNCTION! value
for (; NOT_END(param); param++)
Remove_Binder_Index(&binder, VAL_KEY_CANON(param));
SHUTDOWN_BINDER(&binder);
return copy;
}
//
// Resolve_Path: C
//
// Given a path, return a context and index for its terminal.
//
REBCTX *Resolve_Path(REBVAL *path, REBCNT *index)
{
REBVAL *sel; // selector
const REBVAL *val;
REBARR *blk;
REBCNT i;
if (VAL_LEN_HEAD(path) < 2) return 0;
blk = VAL_ARRAY(path);
sel = ARR_HEAD(blk);
if (!ANY_WORD(sel)) return 0;
val = GET_OPT_VAR_MAY_FAIL(sel);
sel = ARR_AT(blk, 1);
while (TRUE) {
if (!ANY_CONTEXT(val) || !IS_WORD(sel)) return 0;
i = Find_Word_In_Context(VAL_CONTEXT(val), VAL_WORD_SYM(sel), FALSE);
sel++;
if (IS_END(sel)) {
*index = i;
return VAL_CONTEXT(val);
}
}
return 0; // never happens
}
//
// Copy_Array_At_Max_Shallow: C
//
// Shallow copy an array from the given index for given maximum
// length (clipping if it exceeds the array length)
//
REBARR *Copy_Array_At_Max_Shallow(
REBARR *original,
REBCNT index,
REBSPC *specifier,
REBCNT max
){
const REBFLGS flags = 0;
if (index > ARR_LEN(original))
return Make_Array_For_Copy(0, flags, original);
if (index + max > ARR_LEN(original))
max = ARR_LEN(original) - index;
REBARR *copy = Make_Array_For_Copy(max, flags, original);
REBCNT count = 0;
const RELVAL *src = ARR_AT(original, index);
RELVAL *dest = ARR_HEAD(copy);
for (; count < max; ++count, ++src, ++dest)
Derelativize(dest, src, specifier);
TERM_ARRAY_LEN(copy, max);
return copy;
}
//
// Copy_Array_At_Extra_Shallow: C
//
// Shallow copy an array from the given index thru the tail.
// Additional capacity beyond what is required can be added
// by giving an `extra` count of how many value cells one needs.
//
REBARR *Copy_Array_At_Extra_Shallow(
REBARR *original,
REBCNT index,
REBSPC *specifier,
REBCNT extra,
REBFLGS flags
){
REBCNT len = ARR_LEN(original);
if (index > len)
return Make_Array_For_Copy(extra, flags, original);
len -= index;
REBARR *copy = Make_Array_For_Copy(len + extra, flags, original);
RELVAL *src = ARR_AT(original, index);
RELVAL *dest = ARR_HEAD(copy);
REBCNT count = 0;
for (; count < len; ++count, ++dest, ++src)
Derelativize(dest, src, specifier);
TERM_ARRAY_LEN(copy, len);
return copy;
}
//
// Copy_Array_Core_Managed_Inner_Loop: C
//
//
static REBARR *Copy_Array_Core_Managed_Inner_Loop(
REBARR *original,
REBCNT index,
REBSPC *specifier,
REBCNT tail,
REBCNT extra, // currently no one uses--would it also apply deep (?)
REBFLGS flags,
REBU64 types
){
assert(index <= tail and tail <= ARR_LEN(original));
assert(flags & NODE_FLAG_MANAGED);
REBCNT len = tail - index;
// Currently we start by making a shallow copy and then adjust it
REBARR *copy = Make_Array_For_Copy(len + extra, flags, original);
RELVAL *src = ARR_AT(original, index);
RELVAL *dest = ARR_HEAD(copy);
REBCNT count = 0;
for (; count < len; ++count, ++dest, ++src) {
Clonify(
Derelativize(dest, src, specifier),
flags,
types
);
}
TERM_ARRAY_LEN(copy, len);
return copy;
}
//
// Do_Array_At_Core: C
//
// Most common case of evaluator invocation in Rebol: the data lives in an
// array series. Generic routine takes flags and may act as either a DO
// or a DO/NEXT at the position given. Option to provide an element that
// may not be resident in the array to kick off the execution.
//
REBIXO Do_Array_At_Core(
REBVAL *out,
const REBVAL *opt_first,
REBARR *array,
REBCNT index,
REBFLGS flags
) {
struct Reb_Frame f;
if (opt_first) {
f.value = opt_first;
f.indexor = index;
}
else {
// Do_Core() requires caller pre-seed first value, always
//
f.value = ARR_AT(array, index);
f.indexor = index + 1;
}
if (IS_END(f.value)) {
SET_UNSET(out);
return END_FLAG;
}
f.out = out;
f.source.array = array;
f.flags = flags;
f.mode = CALL_MODE_GUARD_ARRAY_ONLY;
Do_Core(&f);
return f.indexor;
}
//
// RL_Get_Value: C
//
// Get a value from a block.
//
// Returns:
// Datatype of value or zero if index is past tail.
// Arguments:
// series - block series pointer
// index - index of the value in the block (zero based)
// result - set to the value of the field
//
RL_API int RL_Get_Value(REBARR *array, u32 index, RXIARG *result)
{
REBVAL *value;
if (index >= ARR_LEN(array)) return 0;
value = ARR_AT(array, index);
Value_To_RXI(result, value);
return Reb_To_RXT[VAL_TYPE_0(value)];
}
//
// RL_Word_String: C
//
// Return a string related to a given global word identifier.
//
// Returns:
// A copy of the word string, null terminated.
// Arguments:
// word - a global word identifier
// Notes:
// The result is a null terminated copy of the name for your own use.
// The string is always UTF-8 encoded (chars > 127 are encoded.)
// In this API, word identifiers are always canonical. Therefore,
// the returned string may have different spelling/casing than expected.
// The string is allocated with OS_ALLOC and you can OS_FREE it any time.
//
RL_API REBYTE *RL_Word_String(u32 word)
{
REBYTE *s1, *s2;
// !!This code should use a function from c-words.c (but nothing perfect yet.)
if (word == 0 || word >= ARR_LEN(PG_Word_Table.array)) return 0;
s1 = VAL_SYM_NAME(ARR_AT(PG_Word_Table.array, word));
s2 = OS_ALLOC_N(REBYTE, LEN_BYTES(s1) + 1);
COPY_BYTES(s2, s1, LEN_BYTES(s1) + 1);
return s2;
}
//
// Update_Typeset_Bits_Core: C
//
// This sets the bits in a bitset according to a block of datatypes. There
// is special handling by which BAR! will set the "variadic" bit on the
// typeset, which is heeded by functions only.
//
// !!! R3-Alpha supported fixed word symbols for datatypes and typesets.
// Confusingly, this means that if you have said `word!: integer!` and use
// WORD!, you will get the integer type... but if WORD! is unbound then it
// will act as WORD!. Also, is essentially having "keywords" and should be
// reviewed to see if anything actually used it.
//
REBOOL Update_Typeset_Bits_Core(
REBVAL *typeset,
const REBVAL *head,
REBOOL trap // if TRUE, then return FALSE instead of failing
) {
const REBVAL *item = head;
REBARR *types = VAL_ARRAY(ROOT_TYPESETS);
assert(IS_TYPESET(typeset));
VAL_TYPESET_BITS(typeset) = 0;
for (; NOT_END(item); item++) {
const REBVAL *var = NULL;
if (IS_BAR(item)) {
SET_VAL_FLAG(typeset, TYPESET_FLAG_VARIADIC);
continue;
}
if (IS_WORD(item) && !(var = TRY_GET_OPT_VAR(item))) {
REBSYM sym = VAL_WORD_SYM(item);
// See notes: if a word doesn't look up to a variable, then its
// symbol is checked as a second chance.
//
if (IS_KIND_SYM(sym)) {
TYPE_SET(typeset, KIND_FROM_SYM(sym));
continue;
}
else if (sym >= SYM_ANY_NOTHING_X && sym < SYM_DATATYPES)
var = ARR_AT(types, sym - SYM_ANY_NOTHING_X);
}
if (!var) var = item;
if (IS_DATATYPE(var)) {
TYPE_SET(typeset, VAL_TYPE_KIND(var));
}
else if (IS_TYPESET(var)) {
VAL_TYPESET_BITS(typeset) |= VAL_TYPESET_BITS(var);
}
else {
if (trap) return FALSE;
fail (Error_Invalid_Arg(item));
}
}
return TRUE;
}
//
// RL_Set_Value: C
//
// Set a value in a block.
//
// Returns:
// TRUE if index past end and value was appended to tail of block.
// Arguments:
// series - block series pointer
// index - index of the value in the block (zero based)
// val - new value for field
// type - datatype of value
//
RL_API REBOOL RL_Set_Value(REBARR *array, u32 index, RXIARG val, int type)
{
REBVAL value;
VAL_INIT_WRITABLE_DEBUG(&value);
RXI_To_Value(&value, &val, type);
if (index >= ARR_LEN(array)) {
Append_Value(array, &value);
return TRUE;
}
*ARR_AT(array, index) = value;
return FALSE;
}
//
// Make_Where_For_Frame: C
//
// Each call frame maintains the array it is executing in, the current index
// in that array, and the index of where the current expression started.
// This can be deduced into a segment of code to display in the debug views
// to indicate roughly "what's running" at that stack level.
//
// Unfortunately, Rebol doesn't formalize this very well. There is no lock
// on segments of blocks during their evaluation, and it's possible for
// self-modifying code to scramble the blocks being executed. The DO
// evaluator is robust in terms of not *crashing*, but the semantics may well
// suprise users.
//
// !!! Should blocks on the stack be locked from modification, at least by
// default unless a special setting for self-modifying code unlocks it?
//
// So long as WHERE information is unreliable, this has to check that
// `expr_index` (where the evaluation started) and `index` (where the
// evaluation thinks it currently is) aren't out of bounds here. We could
// be giving back positions now unrelated to the call...but it won't crash!
//
REBARR *Make_Where_For_Frame(struct Reb_Frame *frame)
{
REBCNT start;
REBCNT end;
REBARR *where;
REBOOL pending;
if (FRM_IS_VALIST(frame)) {
const REBOOL truncated = TRUE;
Reify_Va_To_Array_In_Frame(frame, truncated);
}
// WARNING: MIN is a C macro and repeats its arguments.
//
start = MIN(ARR_LEN(FRM_ARRAY(frame)), cast(REBCNT, frame->expr_index));
end = MIN(ARR_LEN(FRM_ARRAY(frame)), FRM_INDEX(frame));
assert(end >= start);
assert(frame->mode != CALL_MODE_GUARD_ARRAY_ONLY);
pending = NOT(frame->mode == CALL_MODE_FUNCTION);
// Do a shallow copy so that the WHERE information only includes
// the range of the array being executed up to the point of
// currently relevant evaluation, not all the way to the tail
// of the block (where future potential evaluation would be)
{
REBCNT n = 0;
REBCNT len =
1 // fake function word (compensates for prefetch)
+ (end - start) // data from expr_index to the current index
+ (pending ? 1 : 0); // if it's pending we put "..." to show that
where = Make_Array(len);
// !!! Due to "prefetch" the expr_index will be *past* the invocation
// of the function. So this is a lie, as a placeholder for what a
// real debug mode would need to actually save the data to show.
// If the execution were a path or anything other than a word, this
// will lose it.
//
Val_Init_Word(ARR_AT(where, n), REB_WORD, FRM_LABEL(frame));
++n;
for (n = 1; n < len; ++n)
*ARR_AT(where, n) = *ARR_AT(FRM_ARRAY(frame), start + n - 1);
SET_ARRAY_LEN(where, len);
TERM_ARRAY(where);
}
// Making a shallow copy offers another advantage, that it's
// possible to get rid of the newline marker on the first element,
// that would visually disrupt the backtrace for no reason.
//
if (end - start > 0)
CLEAR_VAL_FLAG(ARR_HEAD(where), VALUE_FLAG_LINE);
// We add an ellipsis to a pending frame to make it a little bit
// clearer what is going on. If someone sees a where that looks
// like just `* [print]` the asterisk alone doesn't quite send
// home the message that print is not running and it is
// argument fulfillment that is why it's not "on the stack"
// yet, so `* [print ...]` is an attempt to say that better.
//
// !!! This is in-band, which can be mixed up with literal usage
// of ellipsis. Could there be a better "out-of-band" conveyance?
// Might the system use colorization in a value option bit.
//
if (pending)
Val_Init_Word(Alloc_Tail_Array(where), REB_WORD, SYM_ELLIPSIS);
return where;
}
//
// 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;
}
