*/ 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(); }