*/ REBFLG Copy_Function(REBVAL *value, REBVAL *args)
/*
***********************************************************************/
{
REBVAL *spec = VAL_BLK(args);
REBVAL *body = VAL_BLK_SKIP(args, 1);
if (IS_END(spec)) body = 0;
else {
// Spec given, must be block or *
if (IS_BLOCK(spec)) {
VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
} else
if (!IS_STAR(spec)) return FALSE;
}
if (body && !IS_END(body)) {
if (!IS_FUNCTION(value) && !IS_CLOSURE(value)) return FALSE;
// Body must be block:
if (!IS_BLOCK(body)) return FALSE;
VAL_FUNC_BODY(value) = VAL_SERIES(body);
}
// No body, use protytpe:
else if (IS_FUNCTION(value) || IS_CLOSURE(value))
VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(value));
// Rebind function words:
if (IS_FUNCTION(value))
Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value), VAL_FUNC_BODY(value));
return TRUE;
}
*/ REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def)
/*
***********************************************************************/
{
REBVAL *spec;
REBVAL *body;
REBCNT len;
if (
!IS_BLOCK(def)
//// || type < REB_CLOSURE // for now
|| (len = VAL_LEN(def)) < 2
|| !IS_BLOCK(spec = VAL_BLK(def))
) return FALSE;
body = VAL_BLK_SKIP(def, 1);
// Print("Make_Func"); //: %s spec %d", Get_Sym_Name(type+1), SERIES_TAIL(spec));
VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
if (type != REB_COMMAND) {
if (len != 2 || !IS_BLOCK(body)) return FALSE;
VAL_FUNC_BODY(value) = VAL_SERIES(body);
}
else
Make_Command(value, def);
VAL_SET(value, type);
if (type == REB_FUNCTION)
Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value), VAL_FUNC_BODY(value));
return TRUE;
}
*/ REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def)
/*
***********************************************************************/
{
REBVAL *spec;
REBVAL *body;
REBCNT len;
if (
!IS_BLOCK(def)
|| (len = VAL_LEN(def)) < 2
|| !IS_BLOCK(spec = VAL_BLK(def))
) return FALSE;
body = VAL_BLK_SKIP(def, 1);
VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
if (type != REB_COMMAND) {
if (len != 2 || !IS_BLOCK(body)) return FALSE;
VAL_FUNC_BODY(value) = VAL_SERIES(body);
}
else
Make_Command(value, def);
VAL_SET(value, type);
if (type == REB_FUNCTION || type == REB_CLOSURE)
Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value));
return TRUE;
}
//
// MAKE_Function: C
//
// For REB_FUNCTION and "make spec", there is a function spec block and then
// a block of Rebol code implementing that function. In that case we expect
// that `def` should be:
//
// [[spec] [body]]
//
// With REB_COMMAND, the code is implemented via a C DLL, under a system of
// APIs that pre-date Rebol's open sourcing and hence Ren/C:
//
// [[spec] extension command-num]
//
// See notes in Make_Command() regarding that mechanism and meaning.
//
void MAKE_Function(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
assert(kind == REB_FUNCTION);
if (
!IS_BLOCK(arg)
|| VAL_LEN_AT(arg) != 2
|| !IS_BLOCK(VAL_ARRAY_AT(arg))
|| !IS_BLOCK(VAL_ARRAY_AT(arg) + 1)
){
fail (Error_Bad_Make(kind, arg));
}
REBVAL spec;
COPY_VALUE(&spec, VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg));
REBVAL body;
COPY_VALUE(&body, VAL_ARRAY_AT(arg) + 1, VAL_SPECIFIER(arg));
// Spec-constructed functions do *not* have definitional returns
// added automatically. They are part of the generators. So the
// behavior comes--as with any other generator--from the projected
// code (though round-tripping it via text is not possible in
// general in any case due to loss of bindings.)
//
REBFUN *fun = Make_Interpreted_Function_May_Fail(
&spec, &body, MKF_ANY_VALUE
);
*out = *FUNC_VALUE(fun);
}
*/ 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;
}
*/ REBINT Awake_System(REBSER *ports, REBINT only)
/*
** Returns:
** -1 for errors
** 0 for nothing to do
** 1 for wait is satisifed
**
***********************************************************************/
{
REBVAL *port;
REBVAL *state;
REBVAL *waked;
REBVAL *awake;
REBVAL tmp;
REBVAL ref_only;
REBINT result;
REBVAL out;
// Get the system port object:
port = Get_System(SYS_PORTS, PORTS_SYSTEM);
if (!IS_PORT(port)) return -10; // verify it is a port object
// Get wait queue block (the state field):
state = VAL_OBJ_VALUE(port, STD_PORT_STATE);
if (!IS_BLOCK(state)) return -10;
//Debug_Num("S", VAL_TAIL(state));
// Get waked queue block:
waked = VAL_OBJ_VALUE(port, STD_PORT_DATA);
if (!IS_BLOCK(waked)) return -10;
// If there is nothing new to do, return now:
if (VAL_TAIL(state) == 0 && VAL_TAIL(waked) == 0) return -1;
//Debug_Num("A", VAL_TAIL(waked));
// Get the system port AWAKE function:
awake = VAL_OBJ_VALUE(port, STD_PORT_AWAKE);
if (!ANY_FUNC(awake)) return -1;
if (ports) Val_Init_Block(&tmp, ports);
else SET_NONE(&tmp);
if (only) SET_TRUE(&ref_only);
else SET_NONE(&ref_only);
// Call the system awake function:
if (Apply_Func_Throws(&out, awake, port, &tmp, &ref_only, 0))
raise Error_No_Catch_For_Throw(&out);
// Awake function returns 1 for end of WAIT:
result = (IS_LOGIC(&out) && VAL_LOGIC(&out)) ? 1 : 0;
return result;
}
//
// Is_Type_Of: C
//
// Types can be: word or block. Each element must be either
// a datatype or a typeset.
//
static REBOOL Is_Type_Of(const REBVAL *value, REBVAL *types)
{
const REBVAL *val;
val = IS_WORD(types) ? GET_OPT_VAR_MAY_FAIL(types) : types;
if (IS_DATATYPE(val))
return LOGICAL(VAL_TYPE_KIND(val) == VAL_TYPE(value));
if (IS_TYPESET(val))
return LOGICAL(TYPE_CHECK(val, VAL_TYPE(value)));
if (IS_BLOCK(val)) {
for (types = VAL_ARRAY_AT(val); NOT_END(types); types++) {
val = IS_WORD(types) ? GET_OPT_VAR_MAY_FAIL(types) : types;
if (IS_DATATYPE(val)) {
if (VAL_TYPE_KIND(val) == VAL_TYPE(value)) return TRUE;
}
else if (IS_TYPESET(val)) {
if (TYPE_CHECK(val, VAL_TYPE(value))) return TRUE;
}
else
fail (Error(RE_INVALID_TYPE, Type_Of(val)));
}
return FALSE;
}
fail (Error_Invalid_Arg(types));
}
*/ REBVAL *Find_Last_Event (REBINT model, REBINT type)
/*
** Find the last event in the queue by the model
** Check its type, if it matches, then return the event or NULL
**
**
***********************************************************************/
{
REBVAL *port;
REBVAL *value;
REBVAL *state;
port = Get_System(SYS_PORTS, PORTS_SYSTEM);
if (!IS_PORT(port)) return NULL; // verify it is a port object
// Get queue block:
state = VAL_OBJ_VALUE(port, STD_PORT_STATE);
if (!IS_BLOCK(state)) return NULL;
for (value = VAL_BLK_TAIL(state) - 1; value >= VAL_BLK(state); -- value) {
if (VAL_EVENT_MODEL(value) == model) {
if (VAL_EVENT_TYPE(value) == type) {
return value;
} else {
return NULL;
}
}
}
return NULL;
}
*/ REBVAL *Append_Event()
/*
** Append an event to the end of the current event port queue.
** Return a pointer to the event value.
**
** Note: this function may be called from out of environment,
** so do NOT extend the event queue here. If it does not have
** space, return 0. (Should it overwrite or wrap???)
**
***********************************************************************/
{
REBVAL *port;
REBVAL *value;
REBVAL *state;
port = Get_System(SYS_PORTS, PORTS_SYSTEM);
if (!IS_PORT(port)) return 0; // verify it is a port object
// Get queue block:
state = VAL_BLK_SKIP(port, STD_PORT_STATE);
if (!IS_BLOCK(state)) return 0;
// Append to tail if room:
if (SERIES_FULL(VAL_SERIES(state))) Crash(RP_MAX_EVENTS);
VAL_TAIL(state)++;
value = VAL_BLK_TAIL(state);
SET_END(value);
value--;
SET_NONE(value);
//Dump_Series(VAL_SERIES(state), "state");
//Print("Tail: %d %d", VAL_TAIL(state), nn++);
return value;
}
*/ void Sieve_Ports(REBSER *ports)
/*
** Remove all ports not found in the WAKE list.
** ports could be NULL, in which case the WAKE list is cleared.
**
***********************************************************************/
{
REBVAL *port;
REBVAL *waked;
REBVAL *val;
REBCNT n;
port = Get_System(SYS_PORTS, PORTS_SYSTEM);
if (!IS_PORT(port)) return;
waked = VAL_OBJ_VALUE(port, STD_PORT_DATA);
if (!IS_BLOCK(waked)) return;
for (n = 0; ports && n < SERIES_TAIL(ports);) {
val = BLK_SKIP(ports, n);
if (IS_PORT(val)) {
assert(VAL_TAIL(waked) != 0);
if (VAL_TAIL(waked) == Find_Block_Simple(VAL_SERIES(waked), 0, val)) {//not found
Remove_Series(ports, n, 1);
continue;
}
}
n++;
}
//clear waked list
RESET_SERIES(VAL_SERIES(waked));
}
*/ REBFLG MT_Pair(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
REBD32 x;
REBD32 y;
if (IS_PAIR(data)) {
*out = *data;
return TRUE;
}
if (!IS_BLOCK(data)) return FALSE;
data = VAL_BLK_DATA(data);
if (IS_INTEGER(data)) x = (REBD32)VAL_INT64(data);
else if (IS_DECIMAL(data)) x = (REBD32)VAL_DECIMAL(data);
else return FALSE;
data++;
if (IS_INTEGER(data)) y = (REBD32)VAL_INT64(data);
else if (IS_DECIMAL(data)) y = (REBD32)VAL_DECIMAL(data);
else return FALSE;
VAL_SET(out, REB_PAIR);
VAL_PAIR_X(out) = x;
VAL_PAIR_Y(out) = y;
return TRUE;
}
double sem_cov_ab(VARIOGRAM *v, DPOINT *a, DPOINT *b, int sem)
/*
* return Cov(a,b) or Sem(a,b),
* taking care of IS_BLOCK(a) and IS_BLOCK(b):
*/
{
static DATA *Discr_a = NULL, *Discr_b = NULL;
static DPOINT *block_p = NULL;
DPOINT *tmp;
if (block_p == NULL)
block_p = get_block_p();
if (a == b) {
if (IS_POINT(a))
return sem_cov_blocks(v, NULL, NULL, sem);
Discr_a = block_discr(Discr_a, block_p, a);
return sem_cov_blocks(v, Discr_a, Discr_a, sem);
}
/*
* if one of them IS_BLOCK, make sure it's a:
* (because block_discr() will otherwise store block
* discretisations in both Discr_a and Discr_b)
*/
if (IS_POINT(a) && IS_BLOCK(b)) {
tmp = a; a = b; b = tmp; /* swap a and b */
}
Discr_a = block_discr(Discr_a, block_p, a);
Discr_b = block_discr(Discr_b, block_p, b);
return sem_cov_blocks(v, Discr_a, Discr_b, sem);
}
//
// MT_Pair: C
//
REBFLG MT_Pair(REBVAL *out, REBVAL *data, enum Reb_Kind type)
{
REBD32 x;
REBD32 y;
if (IS_PAIR(data)) {
*out = *data;
return TRUE;
}
if (!IS_BLOCK(data)) return FALSE;
data = VAL_ARRAY_AT(data);
if (IS_INTEGER(data)) x = (REBD32)VAL_INT64(data);
else if (IS_DECIMAL(data)) x = (REBD32)VAL_DECIMAL(data);
else return FALSE;
data++;
if (IS_END(data))
return FALSE;
if (IS_INTEGER(data)) y = (REBD32)VAL_INT64(data);
else if (IS_DECIMAL(data)) y = (REBD32)VAL_DECIMAL(data);
else return FALSE;
VAL_RESET_HEADER(out, REB_PAIR);
VAL_PAIR_X(out) = x;
VAL_PAIR_Y(out) = y;
return TRUE;
}
*/ static void Write_File_Port(REBREQ *file, REBVAL *data, REBCNT len, REBCNT args)
/*
***********************************************************************/
{
REBSER *ser;
if (IS_BLOCK(data)) {
// Form the values of the block
// !! Could be made more efficient if we broke the FORM
// into 32K chunks for writing.
REB_MOLD mo;
CLEARS(&mo);
Reset_Mold(&mo);
if (args & AM_WRITE_LINES) {
mo.opts = 1 << MOPT_LINES;
}
Mold_Value(&mo, data, 0);
Set_String(data, mo.series); // fall into next section
len = SERIES_TAIL(mo.series);
}
// Auto convert string to UTF-8
if (IS_STRING(data)) {
ser = Encode_UTF8_Value(data, len, ENCF_OS_CRLF);
file->common.data = ser? BIN_HEAD(ser) : VAL_BIN_DATA(data); // No encoding may be needed
len = SERIES_TAIL(ser);
}
else {
file->common.data = VAL_BIN_DATA(data);
}
file->length = len;
OS_DO_DEVICE(file, RDC_WRITE);
}
//
// TO_Vector: C
//
void TO_Vector(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
if (IS_BLOCK(arg)) {
if (Make_Vector_Spec(VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg), out))
return;
}
fail (Error_Bad_Make(kind, arg));
}
//
// MAKE_String: C
//
void MAKE_String(REBVAL *out, enum Reb_Kind kind, const REBVAL *def) {
REBSER *ser; // goto would cross initialization
if (IS_INTEGER(def)) {
//
// !!! R3-Alpha tolerated decimal, e.g. `make string! 3.14`, which
// is semantically nebulous (round up, down?) and generally bad.
//
ser = Make_Binary(Int32s(def, 0));
Val_Init_Series(out, kind, ser);
return;
}
else if (IS_BLOCK(def)) {
//
// The construction syntax for making strings or binaries that are
// preloaded with an offset into the data is #[binary [#{0001} 2]].
// In R3-Alpha make definitions didn't have to be a single value
// (they are for compatibility between construction syntax and MAKE
// in Ren-C). So the positional syntax was #[binary! #{0001} 2]...
// while #[binary [#{0001} 2]] would join the pieces together in order
// to produce #{000102}. That behavior is not available in Ren-C.
if (VAL_ARRAY_LEN_AT(def) != 2)
goto bad_make;
RELVAL *any_binstr = VAL_ARRAY_AT(def);
if (!ANY_BINSTR(any_binstr))
goto bad_make;
if (IS_BINARY(any_binstr) != LOGICAL(kind == REB_BINARY))
goto bad_make;
RELVAL *index = VAL_ARRAY_AT(def) + 1;
if (!IS_INTEGER(index))
goto bad_make;
REBINT i = Int32(index) - 1 + VAL_INDEX(any_binstr);
if (i < 0 || i > cast(REBINT, VAL_LEN_AT(any_binstr)))
goto bad_make;
Val_Init_Series_Index(out, kind, VAL_SERIES(any_binstr), i);
return;
}
if (kind == REB_BINARY)
ser = make_binary(def, TRUE);
else
ser = MAKE_TO_String_Common(def);
if (!ser)
goto bad_make;
Val_Init_Series_Index(out, kind, ser, 0);
return;
bad_make:
fail (Error_Bad_Make(kind, def));
}
void modify (value *fp, value val)
{
value old = *(fp);
*(fp) = val;
if (Is_in_heap (fp)) {
if (gc_phase == Phase_mark) {
darken(old);
}
if (IS_BLOCK(val) && Is_young (val)
&& ! (IS_BLOCK(old) && Is_young (old))) {
*ref_table_ptr++ = (fp);
if (ref_table_ptr >= ref_table_limit) {
assert (ref_table_ptr == ref_table_limit);
realloc_ref_table();
}
}
}
}
/* [initialize] never calls the GC, so you may call it while an object is
unfinished (i.e. just after a call to [alloc_shr].) */
void initialize (value * fp, value val)
{
*fp = val;
assert (Is_in_heap (fp));
if (IS_BLOCK(val) && Is_young (val)){
*ref_table_ptr++ = fp;
if (ref_table_ptr >= ref_table_limit){
realloc_ref_table ();
}
}
}
*/ REBFLG MT_Typeset(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
if (!IS_BLOCK(data)) return FALSE;
if (!Make_Typeset(VAL_BLK(data), out, TRUE)) return FALSE;
VAL_SET(out, REB_TYPESET);
return TRUE;
}
*/ REBFLG MT_Object(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
if (!IS_BLOCK(data)) return FALSE;
VAL_OBJ_FRAME(out) = Construct_Object(0, VAL_BLK_DATA(data), 0);
VAL_SET(out, type);
if (type == REB_ERROR) {
Make_Error_Object(out, out);
}
return TRUE;
}
*/ REBFLG MT_Gob(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
REBGOB *ngob;
if (IS_BLOCK(data)) {
ngob = Make_Gob();
Set_GOB_Vars(ngob, VAL_BLK_DATA(data));
SET_GOB(out, ngob);
return TRUE;
}
return FALSE;
}
xx*/ REBVAL *Prior_Func_Frame(void)
/*
***********************************************************************/
{
REBCNT dsf = DSF;
REBVAL *val;
for (dsf = DSF; dsf > 0; dsf = PRIOR_DSF(dsf)) {
val = DSF_BACK(dsf);
if (IS_BLOCK(val) && VAL_SERIES(val))
return val;
}
return 0;
}
//
// MT_Typeset: C
//
REBOOL MT_Typeset(REBVAL *out, REBVAL *data, enum Reb_Kind type)
{
if (!IS_BLOCK(data)) return FALSE;
VAL_RESET_HEADER(out, REB_TYPESET);
if (!Update_Typeset_Bits_Core(
out,
VAL_ARRAY_HEAD(data),
TRUE // `trap`: true means to return FALSE instead of fail() on error
)) {
return FALSE;
}
return TRUE;
}
*/ REBSER *Make_Module_Spec(REBVAL *block)
/*
** Create a module spec object. Holds module name, version,
** exports, locals, and more. See system/standard/module.
**
***********************************************************************/
{
REBSER *obj;
REBSER *frame;
// Build standard module header object:
obj = VAL_OBJ_FRAME(Get_System(SYS_STANDARD, STD_SCRIPT));
if (block && IS_BLOCK(block)) frame = Construct_Object(obj, VAL_BLK_DATA(block), 0);
else frame = CLONE_OBJECT(obj);
return frame;
}
REB_R N_debug(REBFRM *frame_) {
PARAM(1, value);
REBVAL *value = ARG(value);
if (IS_VOID(value)) {
//
// e.g. just `>> debug` and [enter] in the console. Ideally this
// would shift the REPL into a mode where all commands issued were
// assumed to be in the debug dialect, similar to Ren Garden's
// modalities like `debug>>`.
//
Debug_Fmt("Sorry, there is no debug>> 'mode' yet in the console.");
goto modify_with_confidence;
}
if (IS_INTEGER(value) || IS_FRAME(value) || IS_FUNCTION(value)) {
REBFRM *frame;
// We pass TRUE here to account for an extra stack level... the one
// added by DEBUG itself, which presumably should not count.
//
if (!(frame = Frame_For_Stack_Level(&HG_Stack_Level, value, TRUE)))
fail (Error_Invalid_Arg(value));
Val_Init_Block(D_OUT, Make_Where_For_Frame(frame));
return R_OUT;
}
assert(IS_BLOCK(value));
Debug_Fmt(
"Sorry, but the `debug [...]` dialect is not defined yet.\n"
"Change the stack level (integer!, frame!, function!)\n"
"Or try out these commands:\n"
"\n"
" BREAKPOINT, RESUME, BACKTRACE\n"
);
modify_with_confidence:
Debug_Fmt(
"(Note: Ren-C is 'modify-with-confidence'...so just because a debug\n"
"feature you want isn't implemented doesn't mean you can't add it!)\n"
);
return R_BLANK;
}
*/ 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;
}
static void oldify (value *p, value v)
{
value result;
mlsize_t i;
tail_call:
if (IS_BLOCK(v) && Is_young (v)){
assert (Hp_val (v) < young_ptr);
if (Is_blue_val (v)){ /* Already forwarded ? */
*p = Field (v, 0); /* Then the forward pointer is the first field. */
}else if (Tag_val (v) >= No_scan_tag){
result = alloc_shr (Wosize_val (v), Tag_val (v));
bcopy (Bp_val (v), Bp_val (result), Bosize_val (v));
Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */
Field (v, 0) = result; /* And the forward pointer. */
*p = result;
}else{
/* We can do recursive calls before all the fields are filled, because
we will not be calling the major GC. */
value field0 = Field (v, 0);
mlsize_t sz = Wosize_val (v);
result = alloc_shr (sz, Tag_val (v));
*p = result;
Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */
Field (v, 0) = result; /* And the forward pointer. */
if (sz == 1){
p = &Field (result, 0);
v = field0;
goto tail_call;
}else{
oldify (&Field (result, 0), field0);
for (i = 1; i < sz - 1; i++){
oldify (&Field (result, i), Field (v, i));
}
p = &Field (result, i);
v = Field (v, i);
goto tail_call;
}
}
}else{
*p = v;
}
}
//
// MT_Bitset: C
//
REBOOL MT_Bitset(REBVAL *out, REBVAL *data, enum Reb_Kind type)
{
REBOOL is_not = FALSE;
if (IS_BLOCK(data)) {
REBINT len = Find_Max_Bit(data);
REBSER *ser;
if (len < 0 || len > 0xFFFFFF) fail (Error_Invalid_Arg(data));
ser = Make_Bitset(len);
Set_Bits(ser, data, TRUE);
Val_Init_Bitset(out, ser);
return TRUE;
}
if (!IS_BINARY(data)) return FALSE;
Val_Init_Bitset(out, Copy_Sequence_At_Position(data));
BITS_NOT(VAL_SERIES(out)) = FALSE;
return TRUE;
}
//
// 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();
}
