//
// RL_Extend: C
//
// Appends embedded extension to system/catalog/boot-exts.
//
// Returns:
// A pointer to the REBOL library (see reb-lib.h).
// Arguments:
// source - A pointer to a UTF-8 (or ASCII) string that provides
// extension module header, function definitions, and other
// related functions and data.
// call - A pointer to the extension's command dispatcher.
// Notes:
// This function simply adds the embedded extension to the
// boot-exts list. All other processing and initialization
// happens later during startup. Each embedded extension is
// queried and init using LOAD-EXTENSION system native.
// See c:extensions-embedded
//
RL_API void *RL_Extend(const REBYTE *source, RXICAL call)
{
REBVAL *value;
REBARR *array;
value = CTX_VAR(Sys_Context, SYS_CTX_BOOT_EXTS);
if (IS_BLOCK(value))
array = VAL_ARRAY(value);
else {
array = Make_Array(2);
Val_Init_Block(value, array);
}
value = Alloc_Tail_Array(array);
Val_Init_Binary(value, Copy_Bytes(source, -1)); // UTF-8
value = Alloc_Tail_Array(array);
SET_HANDLE_CODE(value, cast(CFUNC*, call));
return Extension_Lib();
}
*/ 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);
}
//
// Destroy_External_Storage: C
//
// Destroy the external storage pointed by `->data` by calling the routine
// `free_func` if it's not NULL
//
// out Result
// ser The series
// free_func A routine to free the storage, if it's NULL, only mark the
// external storage non-accessible
//
REB_R Destroy_External_Storage(REBVAL *out,
REBSER *ser,
REBVAL *free_func)
{
SET_VOID(out);
if (!GET_SER_FLAG(ser, SERIES_FLAG_EXTERNAL)) {
fail (Error(RE_NO_EXTERNAL_STORAGE));
}
if (!GET_SER_FLAG(ser, SERIES_FLAG_ACCESSIBLE)) {
REBVAL i;
SET_INTEGER(&i, cast(REBUPT, SER_DATA_RAW(ser)));
fail (Error(RE_ALREADY_DESTROYED, &i));
}
CLEAR_SER_FLAG(ser, SERIES_FLAG_ACCESSIBLE);
if (free_func) {
REBVAL safe;
REBARR *array;
REBVAL *elem;
REBOOL threw;
array = Make_Array(2);
MANAGE_ARRAY(array);
PUSH_GUARD_ARRAY(array);
elem = Alloc_Tail_Array(array);
*elem = *free_func;
elem = Alloc_Tail_Array(array);
SET_INTEGER(elem, cast(REBUPT, SER_DATA_RAW(ser)));
threw = Do_At_Throws(&safe, array, 0, SPECIFIED); // 2 non-relative val
DROP_GUARD_ARRAY(array);
if (threw) return R_OUT_IS_THROWN;
}
return R_OUT;
}
x*/ void RXI_To_Block(RXIFRM *frm, REBVAL *out) {
/*
***********************************************************************/
REBCNT n;
REBSER *blk;
REBVAL *val;
REBCNT len;
blk = Make_Array(len = RXA_COUNT(frm));
for (n = 1; n <= len; n++) {
val = Alloc_Tail_Array(blk);
RXI_To_Value(val, frm->args[n], RXA_TYPE(frm, n));
}
Val_Init_Block(out, blk);
}
//
// 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
}
*/ RL_API void *RL_Extend(const REBYTE *source, RXICAL call)
/*
** Appends embedded extension to system/catalog/boot-exts.
**
** Returns:
** A pointer to the REBOL library (see reb-lib.h).
** Arguments:
** source - A pointer to a UTF-8 (or ASCII) string that provides
** extension module header, function definitions, and other
** related functions and data.
** call - A pointer to the extension's command dispatcher.
** Notes:
** This function simply adds the embedded extension to the
** boot-exts list. All other processing and initialization
** happens later during startup. Each embedded extension is
** queried and init using LOAD-EXTENSION system native.
** See c:extensions-embedded
**
***********************************************************************/
{
REBVAL *value;
REBSER *ser;
value = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_EXTS);
if (IS_BLOCK(value)) ser = VAL_SERIES(value);
else {
ser = Make_Array(2);
Val_Init_Block(value, ser);
}
value = Alloc_Tail_Array(ser);
Val_Init_Binary(value, Copy_Bytes(source, -1)); // UTF-8
value = Alloc_Tail_Array(ser);
SET_HANDLE_CODE(value, cast(CFUNC*, call));
return Extension_Lib();
}
*/ REBSER *Make_Frame(REBINT len, REBOOL has_self)
/*
** Create a frame of a given size, allocating space for both
** words and values. Normally used for global frames.
**
***********************************************************************/
{
REBSER *frame;
REBSER *words;
REBVAL *value;
words = Make_Array(len + 1); // size + room for SELF
frame = Make_Array(len + 1);
// Note: cannot use Append_Frame for first word.
value = Alloc_Tail_Array(frame);
SET_FRAME(value, 0, words);
value = Alloc_Tail_Array(words);
Val_Init_Word_Typed(
value, REB_WORD, has_self ? SYM_SELF : SYM_NOT_USED, ALL_64
);
return frame;
}
*/ static int Read_Dir(REBREQ *dir, REBSER *files)
/*
** Provide option to get file info too.
** Provide option to prepend dir path.
** Provide option to use wildcards.
**
***********************************************************************/
{
REBINT result;
REBCNT len;
REBSER *fname;
REBSER *name;
REBREQ file;
RESET_TAIL(files);
CLEARS(&file);
// Temporary filename storage:
fname = BUF_OS_STR;
file.special.file.path = cast(REBCHR*, Reset_Buffer(fname, MAX_FILE_NAME));
SET_FLAG(dir->modes, RFM_DIR);
dir->common.data = cast(REBYTE*, &file);
while ((result = OS_DO_DEVICE(dir, RDC_READ)) == 0 && !GET_FLAG(dir->flags, RRF_DONE)) {
len = OS_STRLEN(file.special.file.path);
if (GET_FLAG(file.modes, RFM_DIR)) len++;
name = Copy_OS_Str(file.special.file.path, len);
if (GET_FLAG(file.modes, RFM_DIR))
SET_ANY_CHAR(name, name->tail-1, '/');
Val_Init_File(Alloc_Tail_Array(files), name);
}
if (result < 0 && dir->error != -RFE_OPEN_FAIL
&& (
OS_STRCHR(dir->special.file.path, '*')
|| OS_STRCHR(dir->special.file.path, '?')
)
) {
result = 0; // no matches found, but not an error
}
return result;
}
//
// Init_Typesets: C
//
// Create typeset variables that are defined above.
// For example: NUMBER is both integer and decimal.
// Add the new variables to the system context.
//
void Init_Typesets(void)
{
REBVAL *value;
REBINT n;
Set_Root_Series(ROOT_TYPESETS, ARR_SERIES(Make_Array(40)));
for (n = 0; Typesets[n].sym != SYM_0; n++) {
value = Alloc_Tail_Array(VAL_ARRAY(ROOT_TYPESETS));
// Note: the symbol in the typeset is not the symbol of a word holding
// the typesets, rather an extra data field used when the typeset is
// in a context key slot to identify that field's name
//
Val_Init_Typeset(value, Typesets[n].bits, SYM_0);
*Append_Context(Lib_Context, NULL, Typesets[n].sym) = *value;
}
}
*/ REBSER *Make_Object_Block(REBSER *frame, REBINT mode)
/*
** Return a block containing words, values, or set-word: value
** pairs for the given object. Note: words are bound to original
** object.
**
** Modes:
** 1 for word
** 2 for value
** 3 for words and values
**
***********************************************************************/
{
REBVAL *words = FRM_WORDS(frame);
REBVAL *values = FRM_VALUES(frame);
REBSER *block;
REBVAL *value;
REBCNT n;
n = (mode & 4) ? 0 : 1;
block = Make_Array(SERIES_TAIL(frame) * (n + 1));
for (; n < SERIES_TAIL(frame); n++) {
if (!VAL_GET_EXT(words + n, EXT_WORD_HIDE)) {
if (mode & 1) {
value = Alloc_Tail_Array(block);
if (mode & 2) {
VAL_SET(value, REB_SET_WORD);
VAL_SET_OPT(value, OPT_VALUE_LINE);
}
else VAL_SET(value, REB_WORD); //VAL_TYPE(words+n));
VAL_WORD_SYM(value) = VAL_BIND_SYM(words+n);
VAL_WORD_INDEX(value) = n;
VAL_WORD_FRAME(value) = frame;
}
if (mode & 2) {
Append_Value(block, values+n);
}
}
}
return block;
}
*/ static void Collect_Words_Inner_Loop(REBINT *binds, REBVAL value[], REBCNT modes)
/*
** Used for Collect_Words() after the binds table has
** been set up.
**
***********************************************************************/
{
for (; NOT_END(value); value++) {
if (ANY_WORD(value)
&& !binds[VAL_WORD_CANON(value)]
&& (modes & BIND_ALL || IS_SET_WORD(value))
) {
REBVAL *word;
binds[VAL_WORD_CANON(value)] = 1;
word = Alloc_Tail_Array(BUF_WORDS);
Val_Init_Word_Unbound(word, REB_WORD, VAL_WORD_SYM(value));
}
else if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP))
Collect_Words_Inner_Loop(binds, VAL_BLK_DATA(value), modes);
}
}
//
// Typeset_To_Array: C
//
// Converts typeset value to a block of datatypes.
// No order is specified.
//
REBARR *Typeset_To_Array(REBVAL *tset)
{
REBARR *block;
REBVAL *value;
REBINT n;
REBINT size = 0;
for (n = 0; n < REB_MAX_0; n++) {
if (TYPE_CHECK(tset, KIND_FROM_0(n))) size++;
}
block = Make_Array(size);
// Convert bits to types:
for (n = 0; n < REB_MAX_0; n++) {
if (TYPE_CHECK(tset, KIND_FROM_0(n))) {
value = Alloc_Tail_Array(block);
Val_Init_Datatype(value, KIND_FROM_0(n));
}
}
return block;
}
//
// 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;
}
*/ REBSER *Struct_To_Block(const REBSTU *stu)
/*
** Used by MOLD to create a block.
**
***********************************************************************/
{
REBSER *ser = Make_Array(10);
struct Struct_Field *field = (struct Struct_Field*) SERIES_DATA(stu->fields);
REBCNT i;
// We are building a recursive structure. So if we did not hand each
// sub-series over to the GC then a single Free_Series() would not know
// how to free them all. There would have to be a specialized walk to
// free the resulting structure. Hence, don't invoke the GC until the
// root series being returned is done being used or is safe from GC!
MANAGE_SERIES(ser);
for(i = 0; i < SERIES_TAIL(stu->fields); i ++, field ++) {
REBVAL *val = NULL;
REBVAL *type_blk = NULL;
/* required field name */
val = Alloc_Tail_Array(ser);
Val_Init_Word_Unbound(val, REB_SET_WORD, field->sym);
/* required type */
type_blk = Alloc_Tail_Array(ser);
Val_Init_Block(type_blk, Make_Array(1));
val = Alloc_Tail_Array(VAL_SERIES(type_blk));
if (field->type == STRUCT_TYPE_STRUCT) {
REBVAL *nested = NULL;
DS_PUSH_NONE;
nested = DS_TOP;
Val_Init_Word_Unbound(val, REB_WORD, SYM_STRUCT_TYPE);
get_scalar(stu, field, 0, nested);
val = Alloc_Tail_Array(VAL_SERIES(type_blk));
Val_Init_Block(val, Struct_To_Block(&VAL_STRUCT(nested)));
DS_DROP;
} else
Val_Init_Word_Unbound(val, REB_WORD, type_to_sym[field->type]);
/* optional dimension */
if (field->dimension > 1) {
REBSER *dim = Make_Array(1);
REBVAL *dv = NULL;
val = Alloc_Tail_Array(VAL_SERIES(type_blk));
Val_Init_Block(val, dim);
dv = Alloc_Tail_Array(dim);
SET_INTEGER(dv, field->dimension);
}
/* optional initialization */
if (field->dimension > 1) {
REBSER *dim = Make_Array(1);
REBCNT n = 0;
val = Alloc_Tail_Array(ser);
Val_Init_Block(val, dim);
for (n = 0; n < field->dimension; n ++) {
REBVAL *dv = Alloc_Tail_Array(dim);
get_scalar(stu, field, n, dv);
}
} else {
val = Alloc_Tail_Array(ser);
get_scalar(stu, field, 0, val);
}
}
return 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;
}